| 1 | ! ================================================================================================================================= |
|---|
| 2 | ! MODULE : stomate_lcchange_fh |
|---|
| 3 | ! |
|---|
| 4 | ! CONTACT : orchidee-help _at_ ipsl.jussieu.fr |
|---|
| 5 | ! |
|---|
| 6 | ! LICENCE : IPSL (2006) |
|---|
| 7 | ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC |
|---|
| 8 | ! |
|---|
| 9 | !>\BRIEF This module is a copy of stomate_lcchange. It includes the forestry |
|---|
| 10 | ! harvest. |
|---|
| 11 | !! |
|---|
| 12 | !!\n DESCRIPTION: None |
|---|
| 13 | !! |
|---|
| 14 | !! RECENT CHANGE(S): Including permafrost carbon |
|---|
| 15 | !! |
|---|
| 16 | !! REFERENCE(S) : None |
|---|
| 17 | !! |
|---|
| 18 | !! SVN : |
|---|
| 19 | !! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/perso/albert.jornet/ORCHIDEE-MICT/src_stomate/stomate_lcchange.f90 $ |
|---|
| 20 | !! $Date: 2015-07-30 15:38:45 +0200 (Thu, 30 Jul 2015) $ |
|---|
| 21 | !! $Revision: 2847 $ |
|---|
| 22 | !! \n |
|---|
| 23 | !_ ================================================================================================================================ |
|---|
| 24 | |
|---|
| 25 | |
|---|
| 26 | MODULE stomate_glcchange_fh |
|---|
| 27 | |
|---|
| 28 | ! modules used: |
|---|
| 29 | |
|---|
| 30 | USE ioipsl_para |
|---|
| 31 | USE stomate_data |
|---|
| 32 | USE pft_parameters |
|---|
| 33 | USE constantes |
|---|
| 34 | USE constantes_soil_var |
|---|
| 35 | |
|---|
| 36 | IMPLICIT NONE |
|---|
| 37 | |
|---|
| 38 | PRIVATE |
|---|
| 39 | PUBLIC gross_glcc_firstday_fh, gross_glcchange_fh, age_class_distr |
|---|
| 40 | |
|---|
| 41 | CONTAINS |
|---|
| 42 | |
|---|
| 43 | ! ================================================================================================================================ |
|---|
| 44 | !! SUBROUTINE : age_class_distr |
|---|
| 45 | !! |
|---|
| 46 | !>\BRIEF Redistribute biomass, litter, soilcarbon and water across |
|---|
| 47 | !! the age classes |
|---|
| 48 | !! |
|---|
| 49 | !! DESCRIPTION : Following growth, the trees from an age class may have become |
|---|
| 50 | !! too big to belong to this age class. The biomass, litter, soilcarbon and |
|---|
| 51 | !! soil water then need to be moved from one age class to the next age class. |
|---|
| 52 | !! |
|---|
| 53 | !! RECENT CHANGE(S) : |
|---|
| 54 | !! |
|---|
| 55 | !! MAIN OUTPUT VARIABLE(S) : |
|---|
| 56 | !! |
|---|
| 57 | !! REFERENCES : None |
|---|
| 58 | !! |
|---|
| 59 | !! FLOWCHART : |
|---|
| 60 | !! \n |
|---|
| 61 | !_ ================================================================================================================================ |
|---|
| 62 | |
|---|
| 63 | SUBROUTINE age_class_distr(npts, lalo, resolution, bound_spa, & |
|---|
| 64 | biomass, veget_max, ind, & |
|---|
| 65 | lm_lastyearmax, leaf_frac, co2_to_bm, & |
|---|
| 66 | fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 67 | everywhere, litter_above, litter_below, carbon, carbon_32l, & |
|---|
| 68 | lignin_struc_above, lignin_struc_below, & |
|---|
| 69 | deepC_a, deepC_s, deepC_p, & |
|---|
| 70 | bm_to_litter, PFTpresent, when_growthinit,& |
|---|
| 71 | senescence, npp_longterm, gpp_daily, leaf_age, & |
|---|
| 72 | gdd_from_growthinit, gdd_midwinter, time_hum_min, gdd_m5_dormance, & |
|---|
| 73 | ncd_dormance, moiavail_month, moiavail_week, ngd_minus5, & |
|---|
| 74 | gpp_week, resp_maint, resp_growth, npp_daily) |
|---|
| 75 | |
|---|
| 76 | IMPLICIT NONE |
|---|
| 77 | |
|---|
| 78 | !! 0. Variable and parameter declaration |
|---|
| 79 | |
|---|
| 80 | !! 0.1 Input variables |
|---|
| 81 | |
|---|
| 82 | INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 83 | REAL(r_std),DIMENSION(npts,2),INTENT(in) :: lalo !! Geographical coordinates (latitude,longitude) |
|---|
| 84 | !! for pixels (degrees) |
|---|
| 85 | REAL(r_std), DIMENSION(npts,2), INTENT(in) :: resolution !! Resolution at each grid point (m) |
|---|
| 86 | !! [1=E-W, 2=N-S] |
|---|
| 87 | |
|---|
| 88 | !! 0.2 Output variables |
|---|
| 89 | |
|---|
| 90 | |
|---|
| 91 | !! 0.3 Modified variables |
|---|
| 92 | |
|---|
| 93 | LOGICAL, DIMENSION(:,:), INTENT(inout) :: PFTpresent !! Tab indicating which PFTs are present in |
|---|
| 94 | !! each pixel |
|---|
| 95 | LOGICAL, DIMENSION(:,:), INTENT(inout) :: senescence !! Flag for setting senescence stage (only |
|---|
| 96 | !! for deciduous trees) |
|---|
| 97 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_month !! "Monthly" moisture availability (0 to 1, |
|---|
| 98 | !! unitless) |
|---|
| 99 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_week !! "Weekly" moisture availability |
|---|
| 100 | !! (0 to 1, unitless) |
|---|
| 101 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_week !! Mean weekly gross primary productivity |
|---|
| 102 | !! @tex $(gC m^{-2} day^{-1})$ @endtex |
|---|
| 103 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ngd_minus5 !! Number of growing days (days), threshold |
|---|
| 104 | !! -5 deg C (for phenology) |
|---|
| 105 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_maint !! Maintenance respiration |
|---|
| 106 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 107 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_growth !! Growth respiration |
|---|
| 108 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 109 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_daily !! Net primary productivity |
|---|
| 110 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 111 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: when_growthinit !! How many days ago was the beginning of |
|---|
| 112 | !! the growing season (days) |
|---|
| 113 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_longterm !! "Long term" mean yearly primary productivity |
|---|
| 114 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ind !! Number of individuals at the stand level |
|---|
| 115 | !! @tex $(m^{-2})$ @endtex |
|---|
| 116 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: veget_max !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 117 | !! May sum to |
|---|
| 118 | !! less than unity if the pixel has |
|---|
| 119 | !! nobio area. (unitless, 0-1) |
|---|
| 120 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: lm_lastyearmax !! last year's maximum leaf mass for each PFT |
|---|
| 121 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 122 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: everywhere !! is the PFT everywhere in the grid box or |
|---|
| 123 | !! very localized (after its introduction) (?) |
|---|
| 124 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: co2_to_bm !! CO2 taken from the atmosphere to get C to create |
|---|
| 125 | !! the seedlings @tex (gC.m^{-2}dt^{-1})$ @endtex |
|---|
| 126 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_daily !! Daily gross primary productivity |
|---|
| 127 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 128 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: time_hum_min !! Time elapsed since strongest moisture |
|---|
| 129 | !! availability (days) |
|---|
| 130 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_midwinter !! Growing degree days (K), since midwinter |
|---|
| 131 | !! (for phenology) - this is written to the |
|---|
| 132 | !! history files |
|---|
| 133 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_from_growthinit !! growing degree days, since growthinit |
|---|
| 134 | !! for crops |
|---|
| 135 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_m5_dormance !! Growing degree days (K), threshold -5 deg |
|---|
| 136 | !! C (for phenology) |
|---|
| 137 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ncd_dormance !! Number of chilling days (days), since |
|---|
| 138 | !! leaves were lost (for phenology) |
|---|
| 139 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: lignin_struc !! ratio Lignine/Carbon in structural litter, |
|---|
| 140 | ! !! above and below ground |
|---|
| 141 | REAL(r_std), DIMENSION(npts,nvm), INTENT(inout) :: lignin_struc_above !! Ratio of Lignin/Carbon in structural |
|---|
| 142 | !! litter, above ground, |
|---|
| 143 | !! @tex $(gC m^{-2})$ @endtex |
|---|
| 144 | REAL(r_std), DIMENSION(npts,nvm,ndeep), INTENT(inout) :: lignin_struc_below !! Ratio of Lignin/Carbon in structural |
|---|
| 145 | !! litter, below ground, |
|---|
| 146 | |
|---|
| 147 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: carbon !! carbon pool: active, slow, or passive |
|---|
| 148 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 149 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: carbon_32l !! Soil carbon pools: active, slow, or passive, \f$(gC m^{2})$\f |
|---|
| 150 | |
|---|
| 151 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_a !! Permafrost soil carbon (g/m**3) active |
|---|
| 152 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_s !! Permafrost soil carbon (g/m**3) slow |
|---|
| 153 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_p !! Permafrost soil carbon (g/m**3) passive |
|---|
| 154 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_frac !! fraction of leaves in leaf age class (unitless;0-1) |
|---|
| 155 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_age !! Leaf age (days) |
|---|
| 156 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: bm_to_litter !! Transfer of biomass to litter |
|---|
| 157 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 158 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: biomass !! Stand level biomass @tex $(gC.m^{-2})$ @endtex |
|---|
| 159 | REAL(r_std), DIMENSION(:,:,:,:,:) :: litter(npts,nlitt,nvm,nlevs,nelements) !! metabolic and structural litter, above and |
|---|
| 160 | !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 161 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: litter_above !! metabolic and structural litter, above and |
|---|
| 162 | !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 163 | REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: litter_below !! metabolic and structural litter, above and |
|---|
| 164 | !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 165 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1hr |
|---|
| 166 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_10hr |
|---|
| 167 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_100hr |
|---|
| 168 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1000hr |
|---|
| 169 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: bound_spa !! Spatial age class boundaries. |
|---|
| 170 | |
|---|
| 171 | !! 0.4 Local variables |
|---|
| 172 | |
|---|
| 173 | INTEGER(i_std) :: ipts,ivm,igroup !! Indeces(unitless) |
|---|
| 174 | INTEGER(i_std) :: iele,ipar,ipft !! Indeces(unitless) |
|---|
| 175 | INTEGER(i_std) :: iagec,imbc,icirc !! Indeces(unitless) |
|---|
| 176 | INTEGER(i_std) :: ilit,ilev,icarb !! Indeces(unitless) |
|---|
| 177 | INTEGER(i_std) :: ivma !! Indeces(unitless) |
|---|
| 178 | REAL(r_std) :: share_expanded !! Share of the veget_max of the existing vegetation |
|---|
| 179 | !! within a PFT over the total veget_max following |
|---|
| 180 | !! expansion of that PFT (unitless, 0-1) |
|---|
| 181 | !! @tex $(ind m^{-2})$ @endtex |
|---|
| 182 | REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements) :: check_intern !! Contains the components of the internal |
|---|
| 183 | !! mass balance chech for this routine |
|---|
| 184 | !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex |
|---|
| 185 | REAL(r_std), DIMENSION(npts,nvm,nelements) :: closure_intern !! Check closure of internal mass balance |
|---|
| 186 | !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex |
|---|
| 187 | REAL(r_std), DIMENSION(npts,nvm,nelements) :: pool_start !! Start and end pool of this routine |
|---|
| 188 | !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex |
|---|
| 189 | REAL(r_std), DIMENSION(npts,nvm,nelements) :: pool_end !! Start and end pool of this routine |
|---|
| 190 | !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex |
|---|
| 191 | REAL(r_std), DIMENSION(nelements) :: temp_start !! Start and end pool of this routine |
|---|
| 192 | !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex |
|---|
| 193 | REAL(r_std), DIMENSION(nelements) :: temp_end !! Start and end pool of this routine |
|---|
| 194 | !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex |
|---|
| 195 | REAL(r_std), DIMENSION(nlitt,nlevs) :: litter_weight_expanded !! The fraction of litter on the expanded |
|---|
| 196 | !! PFT. |
|---|
| 197 | !! @tex $-$ @endtex |
|---|
| 198 | REAL(r_std), DIMENSION(npts,nvm) :: woodmass !! Woodmass of individuals (gC) |
|---|
| 199 | REAL(r_std), DIMENSION(npts,nvm) :: soilcarbon !! |
|---|
| 200 | REAL(r_std), DIMENSION(npts,nvm) :: agec_indicator !! |
|---|
| 201 | CHARACTER(LEN=80) :: data_filename |
|---|
| 202 | |
|---|
| 203 | !_ ================================================================================================================================ |
|---|
| 204 | |
|---|
| 205 | IF (printlev.GE.3) WRITE(numout,*) 'Entering age class distribution' |
|---|
| 206 | |
|---|
| 207 | !CALL getin_p('AgeC_Threshold_File',data_filename) |
|---|
| 208 | !CALL slowproc_read_data(npts, lalo, resolution, bound_spa, data_filename, 'matrix') |
|---|
| 209 | |
|---|
| 210 | IF (.NOT. use_bound_spa) THEN |
|---|
| 211 | DO ipts = 1,npts |
|---|
| 212 | bound_spa(ipts,:) = age_class_bound(:) |
|---|
| 213 | ENDDO |
|---|
| 214 | ENDIF |
|---|
| 215 | |
|---|
| 216 | !! 1. Initialize |
|---|
| 217 | |
|---|
| 218 | woodmass(:,:) = biomass(:,:,isapabove,icarbon)+biomass(:,:,isapbelow,icarbon) & |
|---|
| 219 | +biomass(:,:,iheartabove,icarbon)+biomass(:,:,iheartbelow,icarbon) |
|---|
| 220 | soilcarbon(:,:) = -1 *SUM(SUM(carbon_32l(:,:,:,:),DIM=2),DIM=3) + & |
|---|
| 221 | SUM(SUM(litter_below(:,:,:,:,icarbon),DIM=2),DIM=3)+SUM(litter_above(:,:,:,icarbon),DIM=2) |
|---|
| 222 | |
|---|
| 223 | !! 1.2 Initialize check for mass balance closure |
|---|
| 224 | ! The mass balance is calculated at the end of this routine |
|---|
| 225 | ! in section 3. Initial biomass and harvest pool all other |
|---|
| 226 | ! relevant pools were just set to zero. |
|---|
| 227 | pool_start(:,:,:) = zero |
|---|
| 228 | DO iele = 1,nelements |
|---|
| 229 | |
|---|
| 230 | ! co2_to_bm |
|---|
| 231 | pool_start(:,:,iele) = pool_start(:,:,iele) + co2_to_bm(:,:) |
|---|
| 232 | |
|---|
| 233 | ! Biomass pool + bm_to_litter |
|---|
| 234 | DO ipar = 1,nparts |
|---|
| 235 | pool_start(:,:,iele) = pool_start(:,:,iele) + & |
|---|
| 236 | (biomass(:,:,ipar,iele) + bm_to_litter(:,:,ipar,iele)) * & |
|---|
| 237 | veget_max(:,:) |
|---|
| 238 | ENDDO |
|---|
| 239 | ! |
|---|
| 240 | !!SIMON added merge |
|---|
| 241 | ! Litter pool (gC m-2) * (m2 m-2) |
|---|
| 242 | ! DO ilit = 1,nlitt |
|---|
| 243 | ! DO ilev = 1,nlevs |
|---|
| 244 | ! pool_start(:,:,iele) = pool_start(:,:,iele) + & |
|---|
| 245 | ! litter(:,ilit,:,ilev,iele) * veget_max(:,:) |
|---|
| 246 | ! ENDDO |
|---|
| 247 | ! ENDDO |
|---|
| 248 | ! |
|---|
| 249 | DO ilit = 1,nlitt |
|---|
| 250 | pool_start(:,:,iele) = pool_start(:,:,iele) + & |
|---|
| 251 | litter_above(:,ilit,:,iele) * veget_max(:,:) |
|---|
| 252 | ENDDO |
|---|
| 253 | |
|---|
| 254 | DO ilit = 1,nlitt |
|---|
| 255 | DO ilev = 1,ndeep |
|---|
| 256 | pool_start(:,:,iele) = pool_start(:,:,iele) + & |
|---|
| 257 | litter_below(:,ilit,:,ilev,iele) * veget_max(:,:) |
|---|
| 258 | ENDDO |
|---|
| 259 | ENDDO |
|---|
| 260 | |
|---|
| 261 | |
|---|
| 262 | ! Soil carbon (gC m-2) * (m2 m-2) |
|---|
| 263 | DO icarb = 1,ncarb |
|---|
| 264 | DO ilev = 1,ndeep |
|---|
| 265 | pool_start(:,:,iele) = pool_start(:,:,iele) + & |
|---|
| 266 | carbon_32l(:,icarb,:,ilev) * veget_max(:,:) |
|---|
| 267 | ENDDO |
|---|
| 268 | |
|---|
| 269 | ENDDO |
|---|
| 270 | |
|---|
| 271 | |
|---|
| 272 | !! 2. Handle the merge of PFTs when one age class moves to the next one. |
|---|
| 273 | |
|---|
| 274 | ! Following growth, the value of age-class indicator variable |
|---|
| 275 | ! from an age class may have become too big to stay |
|---|
| 276 | ! in this age class. The biomass, litter, soilcarbon and soil |
|---|
| 277 | ! water then need to be moved from one age class to the next age class. |
|---|
| 278 | DO ipts = 1,npts |
|---|
| 279 | ! This loops over all the MTCs that we have ignoring age classes |
|---|
| 280 | DO ivma=1,nvmap |
|---|
| 281 | ivm=start_index(ivma) |
|---|
| 282 | |
|---|
| 283 | ! If we only have a single age class for this |
|---|
| 284 | ! PFT, we can skip it. |
|---|
| 285 | IF(nagec_pft(ivma) .EQ. 1)CYCLE |
|---|
| 286 | |
|---|
| 287 | IF(is_tree(ivm)) THEN |
|---|
| 288 | agec_indicator(:,:) = woodmass(:,:) |
|---|
| 289 | ELSE |
|---|
| 290 | agec_indicator(:,:) = soilcarbon(:,:) |
|---|
| 291 | ENDIF ! is_tree(ivm) |
|---|
| 292 | |
|---|
| 293 | CALL check_merge_same_MTC(ipts, ivma, woodmass, bound_spa, & |
|---|
| 294 | biomass, veget_max, ind, & |
|---|
| 295 | lm_lastyearmax, leaf_frac, co2_to_bm, & |
|---|
| 296 | fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 297 | everywhere, litter_above, litter_below, carbon, carbon_32l, & |
|---|
| 298 | lignin_struc_above, lignin_struc_below, & |
|---|
| 299 | deepC_a, deepC_s, deepC_p, & |
|---|
| 300 | bm_to_litter, PFTpresent, when_growthinit,& |
|---|
| 301 | senescence, npp_longterm, gpp_daily, leaf_age, & |
|---|
| 302 | gdd_from_growthinit, gdd_midwinter, time_hum_min, gdd_m5_dormance, & |
|---|
| 303 | ncd_dormance, moiavail_month, moiavail_week, ngd_minus5, & |
|---|
| 304 | gpp_week, resp_maint, resp_growth, npp_daily) |
|---|
| 305 | |
|---|
| 306 | ENDDO ! Looping over MTCs |
|---|
| 307 | ENDDO ! loop over #pixels - domain size |
|---|
| 308 | ENDDO ! iele 1,nelements? |
|---|
| 309 | |
|---|
| 310 | !! 3. Mass balance closure |
|---|
| 311 | |
|---|
| 312 | !! 3.1 Calculate components of the mass balance |
|---|
| 313 | pool_end(:,:,:) = zero |
|---|
| 314 | |
|---|
| 315 | DO iele = 1,nelements |
|---|
| 316 | |
|---|
| 317 | ! co2_to_bm |
|---|
| 318 | pool_end(:,:,iele) = pool_end(:,:,iele) + co2_to_bm(:,:) |
|---|
| 319 | |
|---|
| 320 | ! Biomass pool + bm_to_litter |
|---|
| 321 | DO ipar = 1,nparts |
|---|
| 322 | pool_end(:,:,iele) = pool_end(:,:,iele) + & |
|---|
| 323 | (biomass(:,:,ipar,iele) + bm_to_litter(:,:,ipar,iele)) * & |
|---|
| 324 | veget_max(:,:) |
|---|
| 325 | ENDDO |
|---|
| 326 | |
|---|
| 327 | ! Litter pool (gC m-2) * (m2 m-2) |
|---|
| 328 | ! ! DO ilit = 1,nlitt |
|---|
| 329 | ! DO ilev = 1,nlevs |
|---|
| 330 | ! pool_end(:,:,iele) = pool_end(:,:,iele) + & |
|---|
| 331 | ! litter(:,ilit,:,ilev,iele) * veget_max(:,:) |
|---|
| 332 | ! ENDDO |
|---|
| 333 | ! ENDDO |
|---|
| 334 | ! |
|---|
| 335 | DO ilit = 1,nlitt |
|---|
| 336 | pool_start(:,:,iele) = pool_start(:,:,iele) + & |
|---|
| 337 | litter_above(:,ilit,:,iele) * veget_max(:,:) |
|---|
| 338 | ENDDO |
|---|
| 339 | |
|---|
| 340 | DO ilit = 1,nlitt |
|---|
| 341 | DO ilev = 1,ndeep |
|---|
| 342 | pool_start(:,:,iele) = pool_start(:,:,iele) + & |
|---|
| 343 | litter_below(:,ilit,:,ilev,iele) * veget_max(:,:) |
|---|
| 344 | ENDDO |
|---|
| 345 | ENDDO |
|---|
| 346 | |
|---|
| 347 | |
|---|
| 348 | |
|---|
| 349 | ! Soil carbon (gC m-2) * (m2 m-2) |
|---|
| 350 | DO icarb = 1,ncarb |
|---|
| 351 | pool_end(:,:,iele) = pool_end(:,:,iele) + & |
|---|
| 352 | carbon(:,icarb,:) * veget_max(:,:) |
|---|
| 353 | ENDDO |
|---|
| 354 | ENDDO |
|---|
| 355 | |
|---|
| 356 | !! 3.2 Calculate mass balance |
|---|
| 357 | check_intern(:,:,iatm2land,icarbon) = zero |
|---|
| 358 | check_intern(:,:,iland2atm,icarbon) = -un * zero |
|---|
| 359 | check_intern(:,:,ilat2out,icarbon) = zero |
|---|
| 360 | check_intern(:,:,ilat2in,icarbon) = -un * zero |
|---|
| 361 | check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - pool_start(:,:,icarbon)) |
|---|
| 362 | closure_intern = zero |
|---|
| 363 | DO imbc = 1,nmbcomp |
|---|
| 364 | closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + check_intern(:,:,imbc,icarbon) |
|---|
| 365 | ENDDO |
|---|
| 366 | |
|---|
| 367 | !! 3.3 Write outcome of the check |
|---|
| 368 | ! Sum over ivm because of age class redistribution |
|---|
| 369 | DO ipts = 1,npts |
|---|
| 370 | IF (SUM(closure_intern(ipts,:,icarbon)) .LT. min_stomate .AND. & |
|---|
| 371 | SUM(closure_intern(ipts,:,icarbon)) .GT. -min_stomate) THEN |
|---|
| 372 | IF (ld_massbal) WRITE(numout,*) 'Mass balance closure: age_class_distr', ipts |
|---|
| 373 | ELSE |
|---|
| 374 | WRITE(numout,*) 'Error: mass balance is not closed in age_class_distr' |
|---|
| 375 | WRITE(numout,*) ' Difference, ipts, ', ipts, SUM(closure_intern(ipts,:,icarbon)) |
|---|
| 376 | ENDIF |
|---|
| 377 | ENDDO |
|---|
| 378 | |
|---|
| 379 | IF (printlev.GE.4) WRITE(numout,*) 'Leaving age class distribution' |
|---|
| 380 | |
|---|
| 381 | END SUBROUTINE age_class_distr |
|---|
| 382 | |
|---|
| 383 | |
|---|
| 384 | |
|---|
| 385 | |
|---|
| 386 | SUBROUTINE check_merge_same_MTC(ipts, ivma, woodmass, bound_spa, & |
|---|
| 387 | biomass, veget_max, ind, & |
|---|
| 388 | lm_lastyearmax, leaf_frac, co2_to_bm, & |
|---|
| 389 | fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 390 | everywhere, litter_above, litter_below, carbon, carbon_32l, & |
|---|
| 391 | lignin_struc_above, lignin_struc_below, & |
|---|
| 392 | deepC_a, deepC_s, deepC_p, & |
|---|
| 393 | bm_to_litter, PFTpresent, when_growthinit,& |
|---|
| 394 | senescence, npp_longterm, gpp_daily, leaf_age, & |
|---|
| 395 | gdd_from_growthinit, gdd_midwinter, time_hum_min, gdd_m5_dormance, & |
|---|
| 396 | ncd_dormance, moiavail_month, moiavail_week, ngd_minus5, & |
|---|
| 397 | gpp_week, resp_maint, resp_growth, npp_daily) |
|---|
| 398 | |
|---|
| 399 | IMPLICIT NONE |
|---|
| 400 | |
|---|
| 401 | !! 0. Variable and parameter declaration |
|---|
| 402 | |
|---|
| 403 | !! 0.1 Input variables |
|---|
| 404 | |
|---|
| 405 | INTEGER, INTENT(in) :: ipts !! Domain size - number of pixels (unitless) |
|---|
| 406 | INTEGER, INTENT(in) :: ivma !! |
|---|
| 407 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: woodmass !! Woodmass of individuals (gC) |
|---|
| 408 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: bound_spa !! |
|---|
| 409 | |
|---|
| 410 | !! 0.2 Output variables |
|---|
| 411 | |
|---|
| 412 | |
|---|
| 413 | !! 0.3 Modified variables |
|---|
| 414 | |
|---|
| 415 | LOGICAL, DIMENSION(:,:), INTENT(inout) :: PFTpresent !! Tab indicating which PFTs are present in |
|---|
| 416 | !! each pixel |
|---|
| 417 | LOGICAL, DIMENSION(:,:), INTENT(inout) :: senescence !! Flag for setting senescence stage (only |
|---|
| 418 | !! for deciduous trees) |
|---|
| 419 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_month !! "Monthly" moisture availability (0 to 1, |
|---|
| 420 | !! unitless) |
|---|
| 421 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_week !! "Weekly" moisture availability |
|---|
| 422 | !! (0 to 1, unitless) |
|---|
| 423 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_week !! Mean weekly gross primary productivity |
|---|
| 424 | !! @tex $(gC m^{-2} day^{-1})$ @endtex |
|---|
| 425 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ngd_minus5 !! Number of growing days (days), threshold |
|---|
| 426 | !! -5 deg C (for phenology) |
|---|
| 427 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_maint !! Maintenance respiration |
|---|
| 428 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 429 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_growth !! Growth respiration |
|---|
| 430 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 431 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_daily !! Net primary productivity |
|---|
| 432 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 433 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: when_growthinit !! How many days ago was the beginning of |
|---|
| 434 | !! the growing season (days) |
|---|
| 435 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_longterm !! "Long term" mean yearly primary productivity |
|---|
| 436 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ind !! Number of individuals at the stand level |
|---|
| 437 | !! @tex $(m^{-2})$ @endtex |
|---|
| 438 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: veget_max !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 439 | !! May sum to |
|---|
| 440 | !! less than unity if the pixel has |
|---|
| 441 | !! nobio area. (unitless, 0-1) |
|---|
| 442 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: lm_lastyearmax !! last year's maximum leaf mass for each PFT |
|---|
| 443 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 444 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: everywhere !! is the PFT everywhere in the grid box or |
|---|
| 445 | !! very localized (after its introduction) (?) |
|---|
| 446 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: co2_to_bm !! CO2 taken from the atmosphere to get C to create |
|---|
| 447 | !! the seedlings @tex (gC.m^{-2}dt^{-1})$ @endtex |
|---|
| 448 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_daily !! Daily gross primary productivity |
|---|
| 449 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 450 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: time_hum_min !! Time elapsed since strongest moisture |
|---|
| 451 | !! availability (days) |
|---|
| 452 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_midwinter !! Growing degree days (K), since midwinter |
|---|
| 453 | !! (for phenology) - this is written to the |
|---|
| 454 | !! history files |
|---|
| 455 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_from_growthinit !! growing degree days, since growthinit |
|---|
| 456 | !! for crops |
|---|
| 457 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_m5_dormance !! Growing degree days (K), threshold -5 deg |
|---|
| 458 | !! C (for phenology) |
|---|
| 459 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ncd_dormance !! Number of chilling days (days), since |
|---|
| 460 | !! leaves were lost (for phenology) |
|---|
| 461 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: lignin_struc !! ratio Lignine/Carbon in structural litter, |
|---|
| 462 | ! !! above and below ground |
|---|
| 463 | ! REAL(r_std), DIMENSION(npts,nvm), INTENT(inout) :: lignin_struc_above !! Ratio of Lignin/Carbon in structural |
|---|
| 464 | ! !! litter, above ground, |
|---|
| 465 | ! !! @tex $(gC m^{-2})$ @endtex |
|---|
| 466 | ! REAL(r_std), DIMENSION(npts,nvm,ndeep), INTENT(inout) :: lignin_struc_below !! Ratio of Lignin/Carbon in structural |
|---|
| 467 | ! !! litter, below ground, |
|---|
| 468 | ! |
|---|
| 469 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: lignin_struc_above !! Ratio of Lignin/Carbon in structural |
|---|
| 470 | !! litter, above ground, |
|---|
| 471 | !! @tex $(gC m^{-2})$ @endtex |
|---|
| 472 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: lignin_struc_below !! Ratio of Lignin/Carbon in structural |
|---|
| 473 | !! litter, below ground, |
|---|
| 474 | ! |
|---|
| 475 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: carbon !! carbon pool: active, slow, or passive |
|---|
| 476 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 477 | ! REAL(r_std), DIMENSION(npts,ncarb,nvm,ndeep), INTENT(inout) :: carbon_32l !! Soil carbon pools: active, slow, or passive, \f$(gC m^{2})$\f |
|---|
| 478 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: carbon_32l !! Soil carbon pools: active, slow, or passive, \f$(gC m^{2})$\f |
|---|
| 479 | |
|---|
| 480 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_a !! Permafrost soil carbon (g/m**3) active |
|---|
| 481 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_s !! Permafrost soil carbon (g/m**3) slow |
|---|
| 482 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_p !! Permafrost soil carbon (g/m**3) passive |
|---|
| 483 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_frac !! fraction of leaves in leaf age class (unitless;0-1) |
|---|
| 484 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_age !! Leaf age (days) |
|---|
| 485 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: bm_to_litter !! Transfer of biomass to litter |
|---|
| 486 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 487 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: biomass !! Stand level biomass @tex $(gC.m^{-2})$ @endtex |
|---|
| 488 | ! REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: litter !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 489 | !! deforestation region. |
|---|
| 490 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: litter_above !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 491 | !! deforestation region. |
|---|
| 492 | REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: litter_below !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 493 | !! deforestation region. |
|---|
| 494 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1hr |
|---|
| 495 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_10hr |
|---|
| 496 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_100hr |
|---|
| 497 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1000hr |
|---|
| 498 | |
|---|
| 499 | !! 0.4 Local variables |
|---|
| 500 | |
|---|
| 501 | INTEGER(i_std) :: iele,ipar,ipft !! Indeces(unitless) |
|---|
| 502 | INTEGER(i_std) :: iagec,imbc,icirc !! Indeces(unitless) |
|---|
| 503 | INTEGER(i_std) :: ilit,ilev,icarb !! Indeces(unitless) |
|---|
| 504 | REAL(r_std) :: share_expanded !! Share of the veget_max of the existing vegetation |
|---|
| 505 | !! within a PFT over the total veget_max following |
|---|
| 506 | !! expansion of that PFT (unitless, 0-1) |
|---|
| 507 | !! @tex $(ind m^{-2})$ @endtex |
|---|
| 508 | REAL(r_std), DIMENSION(nlitt,nlevs) :: litter_weight_expanded !! The fraction of litter on the expanded |
|---|
| 509 | !! PFT. |
|---|
| 510 | |
|---|
| 511 | REAL(r_std), DIMENSION(nlitt) :: litter_weight_expanded_above !! The fraction of litter on the expanded |
|---|
| 512 | REAL(r_std), DIMENSION(nlitt,ndeep) :: litter_weight_expanded_below !! The fraction of litter on the expanded |
|---|
| 513 | |
|---|
| 514 | !_ ================================================================================================================================ |
|---|
| 515 | |
|---|
| 516 | !! 1 Check if the trees still belong to this age class |
|---|
| 517 | ! Note that the term age class is used but that the classes used in the |
|---|
| 518 | ! code are not defined on an age criterion. Instead the biomass or |
|---|
| 519 | ! or soil carbon pool is used. |
|---|
| 520 | IF (is_tree(start_index(ivma))) THEN |
|---|
| 521 | DO iagec = nagec_pft(ivma),1,-1 |
|---|
| 522 | |
|---|
| 523 | !start from oldest age class and then move to younger age classes. |
|---|
| 524 | ipft = start_index(ivma)+iagec-1 |
|---|
| 525 | |
|---|
| 526 | ! Check whether woodmass exceeds boundaries of |
|---|
| 527 | ! the age class. |
|---|
| 528 | IF(ld_agec)THEN |
|---|
| 529 | WRITE(numout,*) 'Checking to merge for: ' |
|---|
| 530 | WRITE(numout,*) 'ipft,iagec,ipts: ',ipft,iagec,ipts |
|---|
| 531 | WRITE(numout,*) 'nagec_pft,woodmass,age_class_bound: ',nagec_pft(ivma),& |
|---|
| 532 | woodmass(ipts,ipft),bound_spa(ipts,ipft) |
|---|
| 533 | ENDIF |
|---|
| 534 | |
|---|
| 535 | IF ( (iagec .EQ. nagec_pft(ivma)) .AND. & |
|---|
| 536 | woodmass(ipts,ipft) .GT. bound_spa(ipts,ipft) ) THEN |
|---|
| 537 | |
|---|
| 538 | ! If these conditions are satisfied our woodmass is |
|---|
| 539 | ! very unrealist |
|---|
| 540 | WRITE(numout,*) 'WARNING: age class indicator exceeds: ', & |
|---|
| 541 | bound_spa(ipts,ipft) |
|---|
| 542 | |
|---|
| 543 | ELSEIF ( (iagec .NE. nagec_pft(ivma)) .AND. & |
|---|
| 544 | woodmass(ipts,ipft) .GT. bound_spa(ipts,ipft)) THEN |
|---|
| 545 | |
|---|
| 546 | IF(ld_agec)THEN |
|---|
| 547 | WRITE(numout,*) 'Merging biomass' |
|---|
| 548 | WRITE(numout,*) 'ipts,ipft,iagec: ',ipts,ipft,iagec |
|---|
| 549 | WRITE(numout,*) 'age_class_bound: ',bound_spa(ipts,ipft) |
|---|
| 550 | WRITE(numout,*) 'woodmass: ',woodmass(ipts,ipft) |
|---|
| 551 | |
|---|
| 552 | ENDIF |
|---|
| 553 | |
|---|
| 554 | !! 2 Merge biomass |
|---|
| 555 | ! Biomass of two age classes needs to be merged. The established |
|---|
| 556 | ! vegetation is stored in ipft+1, the new vegetation is stored in |
|---|
| 557 | ! ipft |
|---|
| 558 | share_expanded = veget_max(ipts,ipft+1) / & |
|---|
| 559 | ( veget_max(ipts,ipft+1) + veget_max(ipts,ipft) ) |
|---|
| 560 | ! We also need a scaling factor which includes the litter |
|---|
| 561 | ! DO ilev=1,nlevs |
|---|
| 562 | ! DO ilit=1,nlitt |
|---|
| 563 | ! IF(litter(ipts,ilit,ipft,ilev,icarbon) .GE. min_stomate)THEN |
|---|
| 564 | ! litter_weight_expanded(ilit,ilev)=litter(ipts,ilit,ipft+1,ilev,icarbon) * veget_max(ipts,ipft+1)/ & |
|---|
| 565 | ! (litter(ipts,ilit,ipft+1,ilev,icarbon) * veget_max(ipts,ipft+1) + & |
|---|
| 566 | ! litter(ipts,ilit,ipft,ilev,icarbon) * veget_max(ipts,ipft)) |
|---|
| 567 | ! ELSE |
|---|
| 568 | ! litter_weight_expanded(ilit,ilev)=zero |
|---|
| 569 | ! ENDIF |
|---|
| 570 | ! END DO |
|---|
| 571 | ! ENDDO |
|---|
| 572 | !!SIMON added merge |
|---|
| 573 | DO ilit=1,nlitt |
|---|
| 574 | IF(litter_above(ipts,ilit,ipft,icarbon) .GE. min_stomate)THEN |
|---|
| 575 | litter_weight_expanded_above(ilit)=litter_above(ipts,ilit,ipft+1,icarbon) * veget_max(ipts,ipft+1)/ & |
|---|
| 576 | (litter_above(ipts,ilit,ipft+1,icarbon) * veget_max(ipts,ipft+1) + & |
|---|
| 577 | litter_above(ipts,ilit,ipft,icarbon) * veget_max(ipts,ipft)) |
|---|
| 578 | ELSE |
|---|
| 579 | litter_weight_expanded_above(ilit)=zero |
|---|
| 580 | ENDIF |
|---|
| 581 | ENDDO |
|---|
| 582 | |
|---|
| 583 | DO ilev=1,ndeep |
|---|
| 584 | DO ilit=1,nlitt |
|---|
| 585 | IF(litter_below(ipts,ilit,ipft,ilev,icarbon) .GE. min_stomate)THEN |
|---|
| 586 | litter_weight_expanded_below(ilit,ilev)=litter_below(ipts,ilit,ipft+1,ilev,icarbon) * veget_max(ipts,ipft+1)/ & |
|---|
| 587 | (litter_below(ipts,ilit,ipft+1,ilev,icarbon) * veget_max(ipts,ipft+1) + & |
|---|
| 588 | litter_below(ipts,ilit,ipft,ilev,icarbon) * veget_max(ipts,ipft)) |
|---|
| 589 | ELSE |
|---|
| 590 | litter_weight_expanded_below(ilit,ilev)=zero |
|---|
| 591 | ENDIF |
|---|
| 592 | END DO |
|---|
| 593 | ENDDO |
|---|
| 594 | !!END |
|---|
| 595 | |
|---|
| 596 | ! Merge the biomass and ind of the two age classes |
|---|
| 597 | biomass(ipts,ipft+1,:,:) = share_expanded * biomass(ipts,ipft+1,:,:) + & |
|---|
| 598 | (un - share_expanded) * biomass(ipts,ipft,:,:) |
|---|
| 599 | ind(ipts,ipft+1) = share_expanded * ind(ipts,ipft+1) + & |
|---|
| 600 | (un - share_expanded) * ind(ipts,ipft) |
|---|
| 601 | |
|---|
| 602 | !! 3 Empty the age class that was merged and update veget_max |
|---|
| 603 | ind(ipts,ipft) = zero |
|---|
| 604 | biomass(ipts,ipft,:,:) = zero |
|---|
| 605 | veget_max(ipts,ipft+1) = veget_max(ipts,ipft+1) + veget_max(ipts,ipft) |
|---|
| 606 | veget_max(ipts,ipft) = zero |
|---|
| 607 | |
|---|
| 608 | !! 4 Calculate the PFT characteristics of the merged PFT |
|---|
| 609 | ! Take the weighted mean of the existing vegetation and the new |
|---|
| 610 | ! vegetation joining this PFT. |
|---|
| 611 | ! Note that co2_to_bm is in gC. m-2 dt-1 , |
|---|
| 612 | ! so we should also take the weighted mean (rather than sum if |
|---|
| 613 | ! this where absolute values). |
|---|
| 614 | lm_lastyearmax(ipts,ipft+1) = share_expanded * lm_lastyearmax(ipts,ipft+1) + & |
|---|
| 615 | (un - share_expanded) * lm_lastyearmax(ipts,ipft) |
|---|
| 616 | lm_lastyearmax(ipts,ipft) = zero |
|---|
| 617 | !age(ipts,ipft+1) = share_expanded * age(ipts,ipft+1) + & |
|---|
| 618 | ! (un - share_expanded) * age(ipts,ipft) |
|---|
| 619 | !age(ipts,ipft) = zero |
|---|
| 620 | |
|---|
| 621 | !CHECK: more strictly this should be considered together with leaf mass |
|---|
| 622 | leaf_frac(ipts,ipft+1,:) = share_expanded * leaf_frac(ipts,ipft+1,:) + & |
|---|
| 623 | (un - share_expanded) * leaf_frac(ipts,ipft,:) |
|---|
| 624 | leaf_frac(ipts,ipft,:) = zero |
|---|
| 625 | leaf_age(ipts,ipft+1,:) = share_expanded * leaf_age(ipts,ipft+1,:) + & |
|---|
| 626 | (un - share_expanded) * leaf_age(ipts,ipft,:) |
|---|
| 627 | leaf_age(ipts,ipft,:) = zero |
|---|
| 628 | co2_to_bm(ipts,ipft+1) = share_expanded * co2_to_bm(ipts,ipft+1) + & |
|---|
| 629 | (un - share_expanded) * co2_to_bm(ipts,ipft) |
|---|
| 630 | co2_to_bm(ipts,ipft) = zero |
|---|
| 631 | |
|---|
| 632 | ! Everywhere deals with the migration of vegetation. Copy the |
|---|
| 633 | ! status of the most migrated vegetation for the whole PFT |
|---|
| 634 | everywhere(ipts,ipft+1) = MAX(everywhere(ipts,ipft), everywhere(ipts,ipft+1)) |
|---|
| 635 | everywhere(ipts,ipft) = zero |
|---|
| 636 | |
|---|
| 637 | ! The new soil&litter pools are the weighted mean of the newly |
|---|
| 638 | ! established vegetation for that PFT and the soil&litter pools |
|---|
| 639 | ! of the original vegetation that already exists in that PFT. |
|---|
| 640 | ! Since it is not only the amount of vegetation present (veget_max) but also |
|---|
| 641 | ! the amount of structural litter (litter) that is important, we have to |
|---|
| 642 | ! weight by both items here. |
|---|
| 643 | ! DO ilev=1,nlevs |
|---|
| 644 | ! lignin_struc(ipts,ipft+1,ilev) = litter_weight_expanded(istructural,ilev) * lignin_struc(ipts,ipft+1,ilev) + & |
|---|
| 645 | ! (un - litter_weight_expanded(istructural,ilev)) * lignin_struc(ipts,ipft,ilev) |
|---|
| 646 | ! lignin_struc(ipts,ipft,ilev) = zero |
|---|
| 647 | ! ENDDO |
|---|
| 648 | !!SIMON added merge |
|---|
| 649 | lignin_struc_above(ipts,ipft+1) = litter_weight_expanded_above(istructural) * lignin_struc_above(ipts,ipft+1) + & |
|---|
| 650 | (un - litter_weight_expanded_above(istructural)) * lignin_struc_above(ipts,ipft) |
|---|
| 651 | lignin_struc_above(ipts,ipft) = zero |
|---|
| 652 | |
|---|
| 653 | lignin_struc_below(ipts,ipft+1,:) = litter_weight_expanded_below(istructural,:) * lignin_struc_below(ipts,ipft+1,:) + & |
|---|
| 654 | (un - litter_weight_expanded_below(istructural,:)) * lignin_struc_below(ipts,ipft,:) |
|---|
| 655 | lignin_struc_below(ipts,ipft,:) = zero |
|---|
| 656 | |
|---|
| 657 | litter_above(ipts,:,ipft+1,:) = share_expanded * litter_above(ipts,:,ipft+1,:) + & |
|---|
| 658 | (un - share_expanded) * litter_above(ipts,:,ipft,:) |
|---|
| 659 | litter_above(ipts,:,ipft,:) = zero |
|---|
| 660 | |
|---|
| 661 | litter_below(ipts,:,ipft+1,:,:) = share_expanded * litter_below(ipts,:,ipft+1,:,:) + & |
|---|
| 662 | (un - share_expanded) * litter_below(ipts,:,ipft,:,:) |
|---|
| 663 | litter_below(ipts,:,ipft,:,:) = zero |
|---|
| 664 | !!END |
|---|
| 665 | ! litter(ipts,:,ipft+1,:,:) = share_expanded * litter(ipts,:,ipft+1,:,:) + & |
|---|
| 666 | ! (un - share_expanded) * litter(ipts,:,ipft,:,:) |
|---|
| 667 | ! litter(ipts,:,ipft,:,:) = zero |
|---|
| 668 | |
|---|
| 669 | fuel_1hr(ipts,ipft+1,:,:) = share_expanded * fuel_1hr(ipts,ipft+1,:,:) + & |
|---|
| 670 | (un - share_expanded) * fuel_1hr(ipts,ipft,:,:) |
|---|
| 671 | fuel_1hr(ipts,ipft,:,:) = zero |
|---|
| 672 | |
|---|
| 673 | fuel_10hr(ipts,ipft+1,:,:) = share_expanded * fuel_10hr(ipts,ipft+1,:,:) + & |
|---|
| 674 | (un - share_expanded) * fuel_10hr(ipts,ipft,:,:) |
|---|
| 675 | fuel_10hr(ipts,ipft,:,:) = zero |
|---|
| 676 | |
|---|
| 677 | fuel_100hr(ipts,ipft+1,:,:) = share_expanded * fuel_100hr(ipts,ipft+1,:,:) + & |
|---|
| 678 | (un - share_expanded) * fuel_100hr(ipts,ipft,:,:) |
|---|
| 679 | fuel_100hr(ipts,ipft,:,:) = zero |
|---|
| 680 | |
|---|
| 681 | fuel_1000hr(ipts,ipft+1,:,:) = share_expanded * fuel_1000hr(ipts,ipft+1,:,:) + & |
|---|
| 682 | (un - share_expanded) * fuel_1000hr(ipts,ipft,:,:) |
|---|
| 683 | fuel_1000hr(ipts,ipft,:,:) = zero |
|---|
| 684 | |
|---|
| 685 | carbon(ipts,:,ipft+1) = share_expanded * carbon(ipts,:,ipft+1) + & |
|---|
| 686 | (un - share_expanded) * carbon(ipts,:,ipft) |
|---|
| 687 | carbon(ipts,:,ipft) = zero |
|---|
| 688 | !!SIMON applied carbon_32l |
|---|
| 689 | carbon_32l(ipts,:,ipft+1,:) = share_expanded * carbon_32l(ipts,:,ipft+1,:) + & |
|---|
| 690 | (un - share_expanded) * carbon_32l(ipts,:,ipft,:) |
|---|
| 691 | carbon_32l(ipts,:,ipft,:) = zero |
|---|
| 692 | !!!END |
|---|
| 693 | deepC_a(ipts,:,ipft+1) = share_expanded * deepC_a(ipts,:,ipft+1) + & |
|---|
| 694 | (un - share_expanded) * deepC_a(ipts,:,ipft) |
|---|
| 695 | deepC_a(ipts,:,ipft) = zero |
|---|
| 696 | |
|---|
| 697 | deepC_s(ipts,:,ipft+1) = share_expanded * deepC_s(ipts,:,ipft+1) + & |
|---|
| 698 | (un - share_expanded) * deepC_s(ipts,:,ipft) |
|---|
| 699 | deepC_s(ipts,:,ipft) = zero |
|---|
| 700 | |
|---|
| 701 | deepC_p(ipts,:,ipft+1) = share_expanded * deepC_p(ipts,:,ipft+1) + & |
|---|
| 702 | (un - share_expanded) * deepC_p(ipts,:,ipft) |
|---|
| 703 | deepC_p(ipts,:,ipft) = zero |
|---|
| 704 | |
|---|
| 705 | bm_to_litter(ipts,ipft+1,:,:) = share_expanded * bm_to_litter(ipts,ipft+1,:,:) + & |
|---|
| 706 | (un - share_expanded) * bm_to_litter(ipts,ipft,:,:) |
|---|
| 707 | bm_to_litter(ipts,ipft,:,:) = zero |
|---|
| 708 | |
|---|
| 709 | ! Copy variables that depend on veget_max |
|---|
| 710 | when_growthinit(ipts,ipft+1) = share_expanded * when_growthinit(ipts,ipft+1) + & |
|---|
| 711 | (un - share_expanded) * when_growthinit(ipts,ipft) |
|---|
| 712 | when_growthinit(ipts,ipft) = zero |
|---|
| 713 | gdd_from_growthinit(ipts,ipft+1) = share_expanded * & |
|---|
| 714 | gdd_from_growthinit(ipts,ipft+1) + & |
|---|
| 715 | (un - share_expanded) * gdd_from_growthinit(ipts,ipft) |
|---|
| 716 | gdd_from_growthinit(ipts,ipft) = zero |
|---|
| 717 | gdd_midwinter(ipts,ipft+1) = share_expanded * gdd_midwinter(ipts,ipft+1) + & |
|---|
| 718 | (un - share_expanded) * gdd_midwinter(ipts,ipft) |
|---|
| 719 | gdd_midwinter(ipts,ipft) = zero |
|---|
| 720 | time_hum_min(ipts,ipft+1) = share_expanded * time_hum_min(ipts,ipft+1) + & |
|---|
| 721 | (un - share_expanded) * time_hum_min(ipts,ipft) |
|---|
| 722 | time_hum_min(ipts,ipft) = zero |
|---|
| 723 | gdd_m5_dormance(ipts,ipft+1) = share_expanded * gdd_m5_dormance(ipts,ipft+1) + & |
|---|
| 724 | (un - share_expanded) * gdd_m5_dormance(ipts,ipft) |
|---|
| 725 | gdd_m5_dormance(ipts,ipft) = zero |
|---|
| 726 | ncd_dormance(ipts,ipft+1) = share_expanded * ncd_dormance(ipts,ipft+1) + & |
|---|
| 727 | (un - share_expanded) * ncd_dormance(ipts,ipft) |
|---|
| 728 | ncd_dormance(ipts,ipft) = zero |
|---|
| 729 | moiavail_month(ipts,ipft+1) = share_expanded * moiavail_month(ipts,ipft+1) + & |
|---|
| 730 | (un - share_expanded) * moiavail_month(ipts,ipft) |
|---|
| 731 | moiavail_month(ipts,ipft) = zero |
|---|
| 732 | moiavail_week(ipts,ipft+1) = share_expanded * moiavail_week(ipts,ipft+1) + & |
|---|
| 733 | (un - share_expanded) * moiavail_week(ipts,ipft) |
|---|
| 734 | moiavail_week(ipts,ipft) = zero |
|---|
| 735 | ngd_minus5(ipts,ipft+1) = share_expanded * ngd_minus5(ipts,ipft+1) + & |
|---|
| 736 | (un - share_expanded) * ngd_minus5(ipts,ipft) |
|---|
| 737 | ngd_minus5(ipts,ipft) = zero |
|---|
| 738 | |
|---|
| 739 | ! Copy remaining properties |
|---|
| 740 | PFTpresent(ipts,ipft+1) = PFTpresent(ipts,ipft) |
|---|
| 741 | PFTpresent(ipts,ipft) = .FALSE. |
|---|
| 742 | senescence(ipts,ipft+1) = senescence(ipts,ipft) |
|---|
| 743 | senescence(ipts,ipft) = .FALSE. |
|---|
| 744 | npp_longterm(ipts,ipft+1) = share_expanded * npp_longterm(ipts,ipft+1) + & |
|---|
| 745 | (un - share_expanded) * npp_longterm(ipts,ipft) |
|---|
| 746 | npp_longterm(ipts,ipft) = zero |
|---|
| 747 | gpp_daily(ipts,ipft+1) = share_expanded * gpp_daily(ipts,ipft+1) + & |
|---|
| 748 | (un - share_expanded) * gpp_daily(ipts,ipft) |
|---|
| 749 | gpp_daily(ipts,ipft) = zero |
|---|
| 750 | gpp_week(ipts,ipft+1) = share_expanded * gpp_week(ipts,ipft+1) + & |
|---|
| 751 | (un - share_expanded) * gpp_week(ipts,ipft) |
|---|
| 752 | gpp_week(ipts,ipft) = zero |
|---|
| 753 | resp_maint(ipts,ipft+1) = share_expanded * resp_maint(ipts,ipft+1) + & |
|---|
| 754 | (un - share_expanded) * resp_maint(ipts,ipft) |
|---|
| 755 | resp_maint(ipts,ipft) = zero |
|---|
| 756 | resp_growth(ipts,ipft+1) = share_expanded * resp_growth(ipts,ipft+1) + & |
|---|
| 757 | (un - share_expanded) * resp_growth(ipts,ipft) |
|---|
| 758 | resp_growth(ipts,ipft) = zero |
|---|
| 759 | npp_daily(ipts,ipft+1) = share_expanded * npp_daily(ipts,ipft+1) + & |
|---|
| 760 | (un - share_expanded) * npp_daily(ipts,ipft) |
|---|
| 761 | npp_daily(ipts,ipft) = zero |
|---|
| 762 | |
|---|
| 763 | ENDIF |
|---|
| 764 | ENDDO |
|---|
| 765 | ! concerned MTC is grass/pasture/crop |
|---|
| 766 | ELSE |
|---|
| 767 | DO iagec = 1,nagec_pft(ivma),1 |
|---|
| 768 | |
|---|
| 769 | ! As the soil C gets smaller when forest-generating crop gets older, |
|---|
| 770 | ! we start from young age class and then move to older age classes. |
|---|
| 771 | ! If the soil C of ipft is smaller than the threshold, then it should |
|---|
| 772 | ! go to the next age class. |
|---|
| 773 | ipft = start_index(ivma)+iagec-1 |
|---|
| 774 | |
|---|
| 775 | ! Check whether woodmass exceeds boundaries of |
|---|
| 776 | ! the age class. |
|---|
| 777 | IF(ld_agec)THEN |
|---|
| 778 | WRITE(numout,*) 'Checking to merge for: ' |
|---|
| 779 | WRITE(numout,*) 'ipft,iagec,ipts: ',ipft,iagec,ipts |
|---|
| 780 | WRITE(numout,*) 'nagec_pft,woodmass,age_class_bound: ',nagec_pft(ivma),& |
|---|
| 781 | woodmass(ipts,ipft),bound_spa(ipts,ipft) |
|---|
| 782 | ENDIF |
|---|
| 783 | |
|---|
| 784 | !IF ( (iagec .EQ. 1) .AND. & |
|---|
| 785 | ! woodmass(ipts,ipft) .GT. bound_spa(ipts,ipft) ) THEN |
|---|
| 786 | ! |
|---|
| 787 | ! ! If this is satisfied than we're having a quite large |
|---|
| 788 | ! ! soil C in the newly initiated crop |
|---|
| 789 | ! WRITE(numout,*) 'WARNING: age class indicator exceeds: ', & |
|---|
| 790 | ! bound_spa(ipts,ipft) |
|---|
| 791 | |
|---|
| 792 | !ELSEIF ( (iagec .NE. nagec_pft(ivma)) .AND. & |
|---|
| 793 | ! woodmass(ipts,ipft) .LT. bound_spa(ipts,ipft)) THEN |
|---|
| 794 | |
|---|
| 795 | ! If the soil C is smaller than the threshold and the concerned |
|---|
| 796 | ! ipft is not the oldest age class, then it should move to the |
|---|
| 797 | ! next (older) age class. So we have to set the soil C threshold |
|---|
| 798 | ! for crop as: |
|---|
| 799 | |
|---|
| 800 | ! youngest: 0.9 of maximum end-spinup forest soil C |
|---|
| 801 | ! 2nd young: 0.75 of maximum end-spniup forest soil C |
|---|
| 802 | ! old: 0.55 of maximum end-spniup forest soil C |
|---|
| 803 | ! oldest: the oldest one should not be less than zero. |
|---|
| 804 | IF ( (iagec .NE. nagec_pft(ivma)) .AND. & |
|---|
| 805 | woodmass(ipts,ipft) .LT. bound_spa(ipts,ipft) .AND. veget_max(ipts,ipft) .GT. min_stomate) THEN |
|---|
| 806 | IF(ld_agec)THEN |
|---|
| 807 | WRITE(numout,*) 'Merging biomass' |
|---|
| 808 | WRITE(numout,*) 'ipts,ipft,iagec: ',ipts,ipft,iagec |
|---|
| 809 | WRITE(numout,*) 'age_class_bound: ',bound_spa(ipts,ipft) |
|---|
| 810 | WRITE(numout,*) 'woodmass: ',woodmass(ipts,ipft) |
|---|
| 811 | |
|---|
| 812 | ENDIF |
|---|
| 813 | |
|---|
| 814 | !! 2 Merge biomass |
|---|
| 815 | ! Biomass of two age classes needs to be merged. The established |
|---|
| 816 | ! vegetation is stored in ipft+1, the new vegetation is stored in |
|---|
| 817 | ! ipft |
|---|
| 818 | share_expanded = veget_max(ipts,ipft+1) / & |
|---|
| 819 | ( veget_max(ipts,ipft+1) + veget_max(ipts,ipft) ) |
|---|
| 820 | ! We also need a scaling factor which includes the litter |
|---|
| 821 | ! DO ilev=1,nlevs |
|---|
| 822 | ! DO ilit=1,nlitt |
|---|
| 823 | ! IF(litter(ipts,ilit,ipft,ilev,icarbon) .GE. min_stomate)THEN |
|---|
| 824 | ! litter_weight_expanded(ilit,ilev)=litter(ipts,ilit,ipft+1,ilev,icarbon) * veget_max(ipts,ipft+1)/ & |
|---|
| 825 | ! (litter(ipts,ilit,ipft+1,ilev,icarbon) * veget_max(ipts,ipft+1) + & |
|---|
| 826 | ! litter(ipts,ilit,ipft,ilev,icarbon) * veget_max(ipts,ipft)) |
|---|
| 827 | ! ELSE |
|---|
| 828 | ! litter_weight_expanded(ilit,ilev)=zero |
|---|
| 829 | ! ENDIF |
|---|
| 830 | ! END DO |
|---|
| 831 | ! ENDDO |
|---|
| 832 | !!SIMON added merge |
|---|
| 833 | DO ilit=1,nlitt |
|---|
| 834 | IF(litter_above(ipts,ilit,ipft,icarbon) .GE. min_stomate)THEN |
|---|
| 835 | litter_weight_expanded_above(ilit)=litter_above(ipts,ilit,ipft+1,icarbon) * veget_max(ipts,ipft+1)/ & |
|---|
| 836 | (litter_above(ipts,ilit,ipft+1,icarbon) * veget_max(ipts,ipft+1) + & |
|---|
| 837 | litter_above(ipts,ilit,ipft,icarbon) * veget_max(ipts,ipft)) |
|---|
| 838 | ELSE |
|---|
| 839 | litter_weight_expanded_above(ilit)=zero |
|---|
| 840 | ENDIF |
|---|
| 841 | ENDDO |
|---|
| 842 | |
|---|
| 843 | DO ilev=1,ndeep |
|---|
| 844 | DO ilit=1,nlitt |
|---|
| 845 | IF(litter_below(ipts,ilit,ipft,ilev,icarbon) .GE. min_stomate)THEN |
|---|
| 846 | litter_weight_expanded_below(ilit,ilev)=litter_below(ipts,ilit,ipft+1,ilev,icarbon) * veget_max(ipts,ipft+1)/ & |
|---|
| 847 | (litter_below(ipts,ilit,ipft+1,ilev,icarbon) * veget_max(ipts,ipft+1) + & |
|---|
| 848 | litter_below(ipts,ilit,ipft,ilev,icarbon) * veget_max(ipts,ipft)) |
|---|
| 849 | ELSE |
|---|
| 850 | litter_weight_expanded_below(ilit,ilev)=zero |
|---|
| 851 | ENDIF |
|---|
| 852 | END DO |
|---|
| 853 | ENDDO |
|---|
| 854 | !!END merge |
|---|
| 855 | ! Merge the biomass and ind of the two age classes |
|---|
| 856 | biomass(ipts,ipft+1,:,:) = share_expanded * biomass(ipts,ipft+1,:,:) + & |
|---|
| 857 | (un - share_expanded) * biomass(ipts,ipft,:,:) |
|---|
| 858 | ind(ipts,ipft+1) = share_expanded * ind(ipts,ipft+1) + & |
|---|
| 859 | (un - share_expanded) * ind(ipts,ipft) |
|---|
| 860 | |
|---|
| 861 | !! 3 Empty the age class that was merged and update veget_max |
|---|
| 862 | ind(ipts,ipft) = zero |
|---|
| 863 | biomass(ipts,ipft,:,:) = zero |
|---|
| 864 | veget_max(ipts,ipft+1) = veget_max(ipts,ipft+1) + veget_max(ipts,ipft) |
|---|
| 865 | veget_max(ipts,ipft) = zero |
|---|
| 866 | |
|---|
| 867 | !! 4 Calculate the PFT characteristics of the merged PFT |
|---|
| 868 | ! Take the weighted mean of the existing vegetation and the new |
|---|
| 869 | ! vegetation joining this PFT. |
|---|
| 870 | ! Note that co2_to_bm is in gC. m-2 dt-1 , |
|---|
| 871 | ! so we should also take the weighted mean (rather than sum if |
|---|
| 872 | ! this where absolute values). |
|---|
| 873 | lm_lastyearmax(ipts,ipft+1) = share_expanded * lm_lastyearmax(ipts,ipft+1) + & |
|---|
| 874 | (un - share_expanded) * lm_lastyearmax(ipts,ipft) |
|---|
| 875 | lm_lastyearmax(ipts,ipft) = zero |
|---|
| 876 | !age(ipts,ipft+1) = share_expanded * age(ipts,ipft+1) + & |
|---|
| 877 | ! (un - share_expanded) * age(ipts,ipft) |
|---|
| 878 | !age(ipts,ipft) = zero |
|---|
| 879 | |
|---|
| 880 | !CHECK: more strictly this should be considered together with leaf mass |
|---|
| 881 | leaf_frac(ipts,ipft+1,:) = share_expanded * leaf_frac(ipts,ipft+1,:) + & |
|---|
| 882 | (un - share_expanded) * leaf_frac(ipts,ipft,:) |
|---|
| 883 | leaf_frac(ipts,ipft,:) = zero |
|---|
| 884 | leaf_age(ipts,ipft+1,:) = share_expanded * leaf_age(ipts,ipft+1,:) + & |
|---|
| 885 | (un - share_expanded) * leaf_age(ipts,ipft,:) |
|---|
| 886 | leaf_age(ipts,ipft,:) = zero |
|---|
| 887 | co2_to_bm(ipts,ipft+1) = share_expanded * co2_to_bm(ipts,ipft+1) + & |
|---|
| 888 | (un - share_expanded) * co2_to_bm(ipts,ipft) |
|---|
| 889 | co2_to_bm(ipts,ipft) = zero |
|---|
| 890 | |
|---|
| 891 | ! Everywhere deals with the migration of vegetation. Copy the |
|---|
| 892 | ! status of the most migrated vegetation for the whole PFT |
|---|
| 893 | everywhere(ipts,ipft+1) = MAX(everywhere(ipts,ipft), everywhere(ipts,ipft+1)) |
|---|
| 894 | everywhere(ipts,ipft) = zero |
|---|
| 895 | |
|---|
| 896 | ! The new soil&litter pools are the weighted mean of the newly |
|---|
| 897 | ! established vegetation for that PFT and the soil&litter pools |
|---|
| 898 | ! of the original vegetation that already exists in that PFT. |
|---|
| 899 | ! Since it is not only the amount of vegetation present (veget_max) but also |
|---|
| 900 | ! the amount of structural litter (litter) that is important, we have to |
|---|
| 901 | ! weight by both items here. |
|---|
| 902 | ! DO ilev=1,nlevs |
|---|
| 903 | ! lignin_struc(ipts,ipft+1,ilev) = litter_weight_expanded(istructural,ilev) * lignin_struc(ipts,ipft+1,ilev) + & |
|---|
| 904 | ! (un - litter_weight_expanded(istructural,ilev)) * lignin_struc(ipts,ipft,ilev) |
|---|
| 905 | ! lignin_struc(ipts,ipft,ilev) = zero |
|---|
| 906 | ! ENDDO |
|---|
| 907 | |
|---|
| 908 | !SIMON added merge |
|---|
| 909 | lignin_struc_above(ipts,ipft+1) = litter_weight_expanded_above(istructural) * lignin_struc_above(ipts,ipft+1) + & |
|---|
| 910 | (un - litter_weight_expanded_above(istructural)) * lignin_struc_above(ipts,ipft) |
|---|
| 911 | lignin_struc_above(ipts,ipft) = zero |
|---|
| 912 | |
|---|
| 913 | lignin_struc_below(ipts,ipft+1,:) = litter_weight_expanded_below(istructural,:) * lignin_struc_below(ipts,ipft+1,:) + & |
|---|
| 914 | (un - litter_weight_expanded_below(istructural,:)) * lignin_struc_below(ipts,ipft,:) |
|---|
| 915 | lignin_struc_below(ipts,ipft,:) = zero |
|---|
| 916 | |
|---|
| 917 | litter_above(ipts,:,ipft+1,:) = share_expanded * litter_above(ipts,:,ipft+1,:) + & |
|---|
| 918 | (un - share_expanded) * litter_above(ipts,:,ipft,:) |
|---|
| 919 | litter_above(ipts,:,ipft,:) = zero |
|---|
| 920 | |
|---|
| 921 | litter_below(ipts,:,ipft+1,:,:) = share_expanded * litter_below(ipts,:,ipft+1,:,:) + & |
|---|
| 922 | (un - share_expanded) * litter_below(ipts,:,ipft,:,:) |
|---|
| 923 | litter_below(ipts,:,ipft,:,:) = zero |
|---|
| 924 | !!END merge |
|---|
| 925 | ! litter(ipts,:,ipft+1,:,:) = share_expanded * litter(ipts,:,ipft+1,:,:) + & |
|---|
| 926 | ! (un - share_expanded) * litter(ipts,:,ipft,:,:) |
|---|
| 927 | ! litter(ipts,:,ipft,:,:) = zero |
|---|
| 928 | ! |
|---|
| 929 | fuel_1hr(ipts,ipft+1,:,:) = share_expanded * fuel_1hr(ipts,ipft+1,:,:) + & |
|---|
| 930 | (un - share_expanded) * fuel_1hr(ipts,ipft,:,:) |
|---|
| 931 | fuel_1hr(ipts,ipft,:,:) = zero |
|---|
| 932 | |
|---|
| 933 | fuel_10hr(ipts,ipft+1,:,:) = share_expanded * fuel_10hr(ipts,ipft+1,:,:) + & |
|---|
| 934 | (un - share_expanded) * fuel_10hr(ipts,ipft,:,:) |
|---|
| 935 | fuel_10hr(ipts,ipft,:,:) = zero |
|---|
| 936 | |
|---|
| 937 | fuel_100hr(ipts,ipft+1,:,:) = share_expanded * fuel_100hr(ipts,ipft+1,:,:) + & |
|---|
| 938 | (un - share_expanded) * fuel_100hr(ipts,ipft,:,:) |
|---|
| 939 | fuel_100hr(ipts,ipft,:,:) = zero |
|---|
| 940 | |
|---|
| 941 | fuel_1000hr(ipts,ipft+1,:,:) = share_expanded * fuel_1000hr(ipts,ipft+1,:,:) + & |
|---|
| 942 | (un - share_expanded) * fuel_1000hr(ipts,ipft,:,:) |
|---|
| 943 | fuel_1000hr(ipts,ipft,:,:) = zero |
|---|
| 944 | |
|---|
| 945 | carbon(ipts,:,ipft+1) = share_expanded * carbon(ipts,:,ipft+1) + & |
|---|
| 946 | (un - share_expanded) * carbon(ipts,:,ipft) |
|---|
| 947 | carbon(ipts,:,ipft) = zero |
|---|
| 948 | |
|---|
| 949 | !!SIMON applied carbon_32l |
|---|
| 950 | carbon_32l(ipts,:,ipft+1,:) = share_expanded * carbon_32l(ipts,:,ipft+1,:) + & |
|---|
| 951 | (un - share_expanded) * carbon_32l(ipts,:,ipft,:) |
|---|
| 952 | carbon_32l(ipts,:,ipft,:) = zero |
|---|
| 953 | !!!END |
|---|
| 954 | |
|---|
| 955 | deepC_a(ipts,:,ipft+1) = share_expanded * deepC_a(ipts,:,ipft+1) + & |
|---|
| 956 | (un - share_expanded) * deepC_a(ipts,:,ipft) |
|---|
| 957 | deepC_a(ipts,:,ipft) = zero |
|---|
| 958 | |
|---|
| 959 | deepC_s(ipts,:,ipft+1) = share_expanded * deepC_s(ipts,:,ipft+1) + & |
|---|
| 960 | (un - share_expanded) * deepC_s(ipts,:,ipft) |
|---|
| 961 | deepC_s(ipts,:,ipft) = zero |
|---|
| 962 | |
|---|
| 963 | deepC_p(ipts,:,ipft+1) = share_expanded * deepC_p(ipts,:,ipft+1) + & |
|---|
| 964 | (un - share_expanded) * deepC_p(ipts,:,ipft) |
|---|
| 965 | deepC_p(ipts,:,ipft) = zero |
|---|
| 966 | |
|---|
| 967 | bm_to_litter(ipts,ipft+1,:,:) = share_expanded * bm_to_litter(ipts,ipft+1,:,:) + & |
|---|
| 968 | (un - share_expanded) * bm_to_litter(ipts,ipft,:,:) |
|---|
| 969 | bm_to_litter(ipts,ipft,:,:) = zero |
|---|
| 970 | |
|---|
| 971 | ! Copy variables that depend on veget_max |
|---|
| 972 | when_growthinit(ipts,ipft+1) = share_expanded * when_growthinit(ipts,ipft+1) + & |
|---|
| 973 | (un - share_expanded) * when_growthinit(ipts,ipft) |
|---|
| 974 | when_growthinit(ipts,ipft) = zero |
|---|
| 975 | gdd_from_growthinit(ipts,ipft+1) = share_expanded * & |
|---|
| 976 | gdd_from_growthinit(ipts,ipft+1) + & |
|---|
| 977 | (un - share_expanded) * gdd_from_growthinit(ipts,ipft) |
|---|
| 978 | gdd_from_growthinit(ipts,ipft) = zero |
|---|
| 979 | gdd_midwinter(ipts,ipft+1) = share_expanded * gdd_midwinter(ipts,ipft+1) + & |
|---|
| 980 | (un - share_expanded) * gdd_midwinter(ipts,ipft) |
|---|
| 981 | gdd_midwinter(ipts,ipft) = zero |
|---|
| 982 | time_hum_min(ipts,ipft+1) = share_expanded * time_hum_min(ipts,ipft+1) + & |
|---|
| 983 | (un - share_expanded) * time_hum_min(ipts,ipft) |
|---|
| 984 | time_hum_min(ipts,ipft) = zero |
|---|
| 985 | gdd_m5_dormance(ipts,ipft+1) = share_expanded * gdd_m5_dormance(ipts,ipft+1) + & |
|---|
| 986 | (un - share_expanded) * gdd_m5_dormance(ipts,ipft) |
|---|
| 987 | gdd_m5_dormance(ipts,ipft) = zero |
|---|
| 988 | ncd_dormance(ipts,ipft+1) = share_expanded * ncd_dormance(ipts,ipft+1) + & |
|---|
| 989 | (un - share_expanded) * ncd_dormance(ipts,ipft) |
|---|
| 990 | ncd_dormance(ipts,ipft) = zero |
|---|
| 991 | moiavail_month(ipts,ipft+1) = share_expanded * moiavail_month(ipts,ipft+1) + & |
|---|
| 992 | (un - share_expanded) * moiavail_month(ipts,ipft) |
|---|
| 993 | moiavail_month(ipts,ipft) = zero |
|---|
| 994 | moiavail_week(ipts,ipft+1) = share_expanded * moiavail_week(ipts,ipft+1) + & |
|---|
| 995 | (un - share_expanded) * moiavail_week(ipts,ipft) |
|---|
| 996 | moiavail_week(ipts,ipft) = zero |
|---|
| 997 | ngd_minus5(ipts,ipft+1) = share_expanded * ngd_minus5(ipts,ipft+1) + & |
|---|
| 998 | (un - share_expanded) * ngd_minus5(ipts,ipft) |
|---|
| 999 | ngd_minus5(ipts,ipft) = zero |
|---|
| 1000 | |
|---|
| 1001 | ! Copy remaining properties |
|---|
| 1002 | PFTpresent(ipts,ipft+1) = PFTpresent(ipts,ipft) |
|---|
| 1003 | PFTpresent(ipts,ipft) = .FALSE. |
|---|
| 1004 | senescence(ipts,ipft+1) = senescence(ipts,ipft) |
|---|
| 1005 | senescence(ipts,ipft) = .FALSE. |
|---|
| 1006 | npp_longterm(ipts,ipft+1) = share_expanded * npp_longterm(ipts,ipft+1) + & |
|---|
| 1007 | (un - share_expanded) * npp_longterm(ipts,ipft) |
|---|
| 1008 | npp_longterm(ipts,ipft) = zero |
|---|
| 1009 | gpp_daily(ipts,ipft+1) = share_expanded * gpp_daily(ipts,ipft+1) + & |
|---|
| 1010 | (un - share_expanded) * gpp_daily(ipts,ipft) |
|---|
| 1011 | gpp_daily(ipts,ipft) = zero |
|---|
| 1012 | gpp_week(ipts,ipft+1) = share_expanded * gpp_week(ipts,ipft+1) + & |
|---|
| 1013 | (un - share_expanded) * gpp_week(ipts,ipft) |
|---|
| 1014 | gpp_week(ipts,ipft) = zero |
|---|
| 1015 | resp_maint(ipts,ipft+1) = share_expanded * resp_maint(ipts,ipft+1) + & |
|---|
| 1016 | (un - share_expanded) * resp_maint(ipts,ipft) |
|---|
| 1017 | resp_maint(ipts,ipft) = zero |
|---|
| 1018 | resp_growth(ipts,ipft+1) = share_expanded * resp_growth(ipts,ipft+1) + & |
|---|
| 1019 | (un - share_expanded) * resp_growth(ipts,ipft) |
|---|
| 1020 | resp_growth(ipts,ipft) = zero |
|---|
| 1021 | npp_daily(ipts,ipft+1) = share_expanded * npp_daily(ipts,ipft+1) + & |
|---|
| 1022 | (un - share_expanded) * npp_daily(ipts,ipft) |
|---|
| 1023 | npp_daily(ipts,ipft) = zero |
|---|
| 1024 | |
|---|
| 1025 | ENDIF |
|---|
| 1026 | ENDDO |
|---|
| 1027 | |
|---|
| 1028 | ENDIF |
|---|
| 1029 | |
|---|
| 1030 | END SUBROUTINE check_merge_same_MTC |
|---|
| 1031 | |
|---|
| 1032 | |
|---|
| 1033 | |
|---|
| 1034 | ! ================================================================================================================================ |
|---|
| 1035 | !! SUBROUTINE : harvest_forest |
|---|
| 1036 | !! |
|---|
| 1037 | !>\BRIEF : Handle forest harvest before its legacy is transferred to |
|---|
| 1038 | ! newly initialized youngest-age-class PFT. |
|---|
| 1039 | !! |
|---|
| 1040 | !>\DESCRIPTION |
|---|
| 1041 | !_ ================================================================================================================================ |
|---|
| 1042 | !!++TEMP++ biomass,veget_frac are not used because the remaining biomass to be |
|---|
| 1043 | !! harvested is calculated within the deforestation fire module. |
|---|
| 1044 | SUBROUTINE harvest_forest (npts,ipts,ivm,biomass,frac, & |
|---|
| 1045 | litter_above, litter_below, deforest_biomass_remain,& |
|---|
| 1046 | fuel_1hr,fuel_10hr,& |
|---|
| 1047 | fuel_100hr,fuel_1000hr,& |
|---|
| 1048 | ! lignin_struc,& |
|---|
| 1049 | bm_to_litter_pro,convflux,prod10,prod100,& |
|---|
| 1050 | litter_pro, fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, & |
|---|
| 1051 | fuel_1000hr_pro, lignin_content_pro, & |
|---|
| 1052 | !!SIMON added merge |
|---|
| 1053 | lignin_struc_above, lignin_struc_below, & |
|---|
| 1054 | litter_above_pro, litter_below_pro, & |
|---|
| 1055 | lignin_content_above_pro, lignin_content_below_pro) |
|---|
| 1056 | |
|---|
| 1057 | |
|---|
| 1058 | IMPLICIT NONE |
|---|
| 1059 | |
|---|
| 1060 | !! 0.1 Input variables |
|---|
| 1061 | INTEGER, INTENT(in) :: npts |
|---|
| 1062 | INTEGER, INTENT(in) :: ipts |
|---|
| 1063 | INTEGER, INTENT(in) :: ivm |
|---|
| 1064 | REAL(r_std), INTENT(in) :: frac !! the fraction of land covered by forest to be deforested |
|---|
| 1065 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: biomass !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 1066 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_1hr |
|---|
| 1067 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_10hr |
|---|
| 1068 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_100hr |
|---|
| 1069 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_1000hr |
|---|
| 1070 | REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements) :: litter !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 1071 | !! deforestation region. |
|---|
| 1072 | REAL(r_std), DIMENSION(npts,nlitt,nvm,nelements), INTENT(in) :: litter_above !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 1073 | !! deforestation region. |
|---|
| 1074 | REAL(r_std), DIMENSION(npts,nlitt,nvm,ndeep,nelements), INTENT(in) :: litter_below !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 1075 | !! deforestation region. |
|---|
| 1076 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: deforest_biomass_remain !! Vegetmax-weighted remaining biomass on the ground for |
|---|
| 1077 | !! deforestation region. |
|---|
| 1078 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: lignin_struc !! ratio Lignine/Carbon in structural litter, |
|---|
| 1079 | !! above and below ground |
|---|
| 1080 | |
|---|
| 1081 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: lignin_struc_above !! Ratio of Lignin/Carbon in structural |
|---|
| 1082 | !! litter, above ground, |
|---|
| 1083 | !! @tex $(gC m^{-2})$ @endtex |
|---|
| 1084 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: lignin_struc_below !! Ratio of Lignin/Carbon in structural |
|---|
| 1085 | !! litter, below ground, |
|---|
| 1086 | |
|---|
| 1087 | !! 0.2 Modified variables |
|---|
| 1088 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: bm_to_litter_pro !! conversion of biomass to litter |
|---|
| 1089 | !! @tex ($gC m^{-2} day^{-1}$) @endtex |
|---|
| 1090 | REAL(r_std), DIMENSION(:), INTENT(inout) :: convflux !! release during first year following land cover |
|---|
| 1091 | !! change |
|---|
| 1092 | |
|---|
| 1093 | REAL(r_std), DIMENSION(npts,0:10), INTENT(inout) :: prod10 !! products remaining in the 10 year-turnover |
|---|
| 1094 | !! pool after the annual release for each |
|---|
| 1095 | !! compartment (10 + 1 : input from year of land |
|---|
| 1096 | !! cover change) |
|---|
| 1097 | REAL(r_std), DIMENSION(npts,0:100), INTENT(inout) :: prod100 !! products remaining in the 100 year-turnover |
|---|
| 1098 | !! pool after the annual release for each |
|---|
| 1099 | !! compartment (100 + 1 : input from year of land |
|---|
| 1100 | !! cover change) |
|---|
| 1101 | |
|---|
| 1102 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: litter_pro |
|---|
| 1103 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: fuel_1hr_pro |
|---|
| 1104 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: fuel_10hr_pro |
|---|
| 1105 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: fuel_100hr_pro |
|---|
| 1106 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: fuel_1000hr_pro |
|---|
| 1107 | |
|---|
| 1108 | REAL(r_std), DIMENSION(:),INTENT(inout) :: lignin_content_pro |
|---|
| 1109 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: litter_above_pro |
|---|
| 1110 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: litter_below_pro |
|---|
| 1111 | REAL(r_std), INTENT(inout) :: lignin_content_above_pro |
|---|
| 1112 | REAL(r_std), DIMENSION(:), INTENT(inout) :: lignin_content_below_pro |
|---|
| 1113 | |
|---|
| 1114 | |
|---|
| 1115 | !! 0.4 Local variables |
|---|
| 1116 | REAL(r_std) :: above |
|---|
| 1117 | |
|---|
| 1118 | ! harvest of aboveground sap- and heartwood biomass after taking into |
|---|
| 1119 | ! account of deforestation fire |
|---|
| 1120 | IF (allow_deforest_fire) THEN |
|---|
| 1121 | above = deforest_biomass_remain(ipts,ivm,isapabove,icarbon)+ & |
|---|
| 1122 | deforest_biomass_remain(ipts,ivm,iheartabove,icarbon) |
|---|
| 1123 | convflux(ipts) = convflux(ipts) + 0 |
|---|
| 1124 | prod10(ipts,0) = prod10(ipts,0) + 0.4*above |
|---|
| 1125 | prod100(ipts,0) = prod100(ipts,0) + 0.6*above |
|---|
| 1126 | ELSE |
|---|
| 1127 | above = (biomass(ipts,ivm,isapabove,icarbon)+ & |
|---|
| 1128 | biomass(ipts,ivm,iheartabove,icarbon))*frac |
|---|
| 1129 | convflux(ipts) = convflux(ipts) + coeff_lcchange_1(ivm) * above |
|---|
| 1130 | prod10(ipts,0) = prod10(ipts,0) + coeff_lcchange_10(ivm) * above |
|---|
| 1131 | prod100(ipts,0) = prod100(ipts,0) + coeff_lcchange_100(ivm) * above |
|---|
| 1132 | ENDIF |
|---|
| 1133 | |
|---|
| 1134 | ! the transfer of dead biomass to litter |
|---|
| 1135 | bm_to_litter_pro(isapbelow,:) = bm_to_litter_pro(isapbelow,:) + & |
|---|
| 1136 | biomass(ipts,ivm,isapbelow,:)*frac |
|---|
| 1137 | bm_to_litter_pro(iheartbelow,:) = bm_to_litter_pro(iheartbelow,:) + & |
|---|
| 1138 | biomass(ipts,ivm,iheartbelow,:)*frac |
|---|
| 1139 | bm_to_litter_pro(iroot,:) = bm_to_litter_pro(iroot,:) + & |
|---|
| 1140 | biomass(ipts,ivm,iroot,:)*frac |
|---|
| 1141 | bm_to_litter_pro(ifruit,:) = bm_to_litter_pro(ifruit,:) + & |
|---|
| 1142 | biomass(ipts,ivm,ifruit,:)*frac |
|---|
| 1143 | bm_to_litter_pro(icarbres,:) = bm_to_litter_pro(icarbres,:) + & |
|---|
| 1144 | biomass(ipts,ivm,icarbres,:)*frac |
|---|
| 1145 | bm_to_litter_pro(ileaf,:) = bm_to_litter_pro(ileaf,:) + & |
|---|
| 1146 | biomass(ipts,ivm,ileaf,:)*frac |
|---|
| 1147 | |
|---|
| 1148 | !update litter_pro |
|---|
| 1149 | litter_pro(:,:,:) = litter_pro(:,:,:) + litter(ipts,:,ivm,:,:)*frac |
|---|
| 1150 | !!SIMON added merge |
|---|
| 1151 | litter_above_pro(:,:)=litter_above_pro(:,:) + litter_above(ipts,:,ivm,:)*frac |
|---|
| 1152 | litter_below_pro(:,:,:)=litter_below_pro(:,:,:) + litter_below(ipts,:,ivm,:,:)*frac |
|---|
| 1153 | |
|---|
| 1154 | fuel_1hr_pro(:,:) = fuel_1hr_pro(:,:) + fuel_1hr(ipts,ivm,:,:)*frac |
|---|
| 1155 | fuel_10hr_pro(:,:) = fuel_10hr_pro(:,:) + fuel_10hr(ipts,ivm,:,:)*frac |
|---|
| 1156 | fuel_100hr_pro(:,:) = fuel_100hr_pro(:,:) + fuel_100hr(ipts,ivm,:,:)*frac |
|---|
| 1157 | fuel_1000hr_pro(:,:) = fuel_1000hr_pro(:,:) + fuel_1000hr(ipts,ivm,:,:)*frac |
|---|
| 1158 | !don't forget to hanle litter lignin content |
|---|
| 1159 | ! lignin_content_pro(:)= lignin_content_pro(:) + & |
|---|
| 1160 | ! litter(ipts,istructural,ivm,:,icarbon)*frac*lignin_struc(ipts,ivm,:) |
|---|
| 1161 | !SIMON added merge |
|---|
| 1162 | ! |
|---|
| 1163 | lignin_content_above_pro = lignin_content_above_pro + & |
|---|
| 1164 | litter_above(ipts,istructural,ivm,icarbon)*frac*lignin_struc_above(ipts,ivm) |
|---|
| 1165 | ! |
|---|
| 1166 | lignin_content_below_pro(:) = lignin_content_below_pro(:) + & |
|---|
| 1167 | litter_below(ipts,istructural,ivm,:,icarbon)*frac*lignin_struc_below(ipts,ivm,:) |
|---|
| 1168 | END SUBROUTINE harvest_forest |
|---|
| 1169 | |
|---|
| 1170 | ! ================================================================================================================================ |
|---|
| 1171 | !! SUBROUTINE : harvest_herb |
|---|
| 1172 | !! |
|---|
| 1173 | !>\BRIEF : Handle herbaceous PFT clearing before its legacy is transferred to |
|---|
| 1174 | ! newly initialized youngest-age-class PFT. |
|---|
| 1175 | !! |
|---|
| 1176 | !>\DESCRIPTION |
|---|
| 1177 | !_ ================================================================================================================================ |
|---|
| 1178 | SUBROUTINE harvest_herb (ipts,ivm,biomass,veget_frac,bm_to_litter_pro) |
|---|
| 1179 | |
|---|
| 1180 | IMPLICIT NONE |
|---|
| 1181 | |
|---|
| 1182 | !! 0.1 Input variables |
|---|
| 1183 | INTEGER, INTENT(in) :: ipts |
|---|
| 1184 | INTEGER, INTENT(in) :: ivm |
|---|
| 1185 | REAL(r_std), INTENT(in) :: veget_frac !! the fraction of land covered by herbaceous PFT to be cleared |
|---|
| 1186 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: biomass !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 1187 | |
|---|
| 1188 | !! 0.2 Modified variables |
|---|
| 1189 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: bm_to_litter_pro |
|---|
| 1190 | |
|---|
| 1191 | |
|---|
| 1192 | |
|---|
| 1193 | ! the transfer of dead biomass to litter |
|---|
| 1194 | bm_to_litter_pro(:,:) = bm_to_litter_pro(:,:) + biomass(ipts,ivm,:,:)*veget_frac |
|---|
| 1195 | |
|---|
| 1196 | END SUBROUTINE harvest_herb |
|---|
| 1197 | |
|---|
| 1198 | |
|---|
| 1199 | ! ================================================================================================================================ |
|---|
| 1200 | !! SUBROUTINE : initialize_proxy_pft |
|---|
| 1201 | !! |
|---|
| 1202 | !>\BRIEF Initialize a proxy new youngest age class PFT. |
|---|
| 1203 | !! |
|---|
| 1204 | !>\DESCRIPTION Initialize a proxy new youngest age class PFT that will be |
|---|
| 1205 | !! merged with existing yongest age class, or fill the empty |
|---|
| 1206 | !! niche of the youngest age class PFT. |
|---|
| 1207 | !_ ================================================================================================================================ |
|---|
| 1208 | SUBROUTINE initialize_proxy_pft(ipts,ipft_young_agec,veget_max_pro, & |
|---|
| 1209 | biomass_pro, co2_to_bm_pro, ind_pro, age_pro, & |
|---|
| 1210 | senescence_pro, PFTpresent_pro, & |
|---|
| 1211 | lm_lastyearmax_pro, everywhere_pro, npp_longterm_pro, & |
|---|
| 1212 | leaf_frac_pro,leaf_age_pro) |
|---|
| 1213 | |
|---|
| 1214 | IMPLICIT NONE |
|---|
| 1215 | |
|---|
| 1216 | !! 0.1 Input variables |
|---|
| 1217 | INTEGER, INTENT(in) :: ipts !! |
|---|
| 1218 | INTEGER, INTENT(in) :: ipft_young_agec !! index of the concerned youngest-age-class PFT |
|---|
| 1219 | REAL(r_std), INTENT(in) :: veget_max_pro !! fraction of grid cell land area that's to be occupied |
|---|
| 1220 | |
|---|
| 1221 | !! 0.2 Modified variables |
|---|
| 1222 | REAL(r_std), INTENT(inout) :: co2_to_bm_pro |
|---|
| 1223 | |
|---|
| 1224 | !! 0.3 Output variables |
|---|
| 1225 | REAL(r_std), DIMENSION(:,:), INTENT(out) :: biomass_pro !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 1226 | REAL(r_std), DIMENSION(:), INTENT(out) :: leaf_frac_pro !! fraction of leaves in leaf age class |
|---|
| 1227 | REAL(r_std), DIMENSION(:), INTENT(out) :: leaf_age_pro !! fraction of leaves in leaf age class |
|---|
| 1228 | REAL(r_std), INTENT(out) :: age_pro, ind_pro, lm_lastyearmax_pro |
|---|
| 1229 | REAL(r_std), INTENT(out) :: npp_longterm_pro |
|---|
| 1230 | REAL(r_std), INTENT(out) :: everywhere_pro !! is the PFT everywhere in the grid box or very |
|---|
| 1231 | LOGICAL, INTENT(out) :: senescence_pro !! plant senescent (only for deciduous trees) Set |
|---|
| 1232 | !! to .FALSE. if PFT is introduced or killed |
|---|
| 1233 | LOGICAL, INTENT(out) :: PFTpresent_pro !! Is pft there (unitless) |
|---|
| 1234 | |
|---|
| 1235 | !! 0.4 Local variables |
|---|
| 1236 | !REAL(r_std), DIMENSION(npts,nvm) :: when_growthinit !! how many days ago was the beginning of the |
|---|
| 1237 | ! !! growing season (days) |
|---|
| 1238 | |
|---|
| 1239 | REAL(r_std), DIMENSION(nparts,nelements) :: bm_new !! biomass increase @tex ($gC m^{-2}$) @endtex |
|---|
| 1240 | REAL(r_std) :: cn_ind,ind |
|---|
| 1241 | INTEGER :: i,j,k,l |
|---|
| 1242 | |
|---|
| 1243 | ! -Note- |
|---|
| 1244 | ! This part of codes are copied from the original lcchange_main subroutine |
|---|
| 1245 | ! that initialize a new PFT. |
|---|
| 1246 | |
|---|
| 1247 | i=ipts |
|---|
| 1248 | j=ipft_young_agec |
|---|
| 1249 | |
|---|
| 1250 | !! Initialization of some variables |
|---|
| 1251 | leaf_frac_pro(:) = zero |
|---|
| 1252 | leaf_age_pro(:) = zero |
|---|
| 1253 | |
|---|
| 1254 | !! Initial setting of new establishment |
|---|
| 1255 | IF (is_tree(j)) THEN |
|---|
| 1256 | ! cn_sapl(j)=0.5; stomate_data.f90 |
|---|
| 1257 | cn_ind = cn_sapl(j) |
|---|
| 1258 | ELSE |
|---|
| 1259 | cn_ind = un |
|---|
| 1260 | ENDIF |
|---|
| 1261 | ind = veget_max_pro / cn_ind |
|---|
| 1262 | ind_pro = ind*veget_max_pro |
|---|
| 1263 | PFTpresent_pro = .TRUE. |
|---|
| 1264 | senescence_pro = .FALSE. |
|---|
| 1265 | everywhere_pro = 1.*veget_max_pro |
|---|
| 1266 | age_pro = zero |
|---|
| 1267 | |
|---|
| 1268 | ! large_value = 1.E33_r_std |
|---|
| 1269 | ! when_growthinit(i,j) = large_value |
|---|
| 1270 | leaf_frac_pro(1) = 1.0 * veget_max_pro |
|---|
| 1271 | leaf_age_pro(1) = 1.0 * veget_max_pro !This was not included in original lcchange_main subroutine |
|---|
| 1272 | npp_longterm_pro = npp_longterm_init * veget_max_pro |
|---|
| 1273 | lm_lastyearmax_pro = bm_sapl(j,ileaf,icarbon) * ind * veget_max_pro |
|---|
| 1274 | |
|---|
| 1275 | !! Update of biomass in each each carbon stock component (leaf, sapabove, sapbelow, |
|---|
| 1276 | !> heartabove, heartbelow, root, fruit, and carbres)\n |
|---|
| 1277 | DO k = 1, nparts ! loop over # carbon stock components, nparts = 8; stomate_constant.f90 |
|---|
| 1278 | DO l = 1,nelements ! loop over # elements |
|---|
| 1279 | biomass_pro(k,l) = ind * bm_sapl(j,k,l) |
|---|
| 1280 | END DO ! loop over # elements |
|---|
| 1281 | co2_to_bm_pro = co2_to_bm_pro + ind * bm_sapl(j,k,icarbon) |
|---|
| 1282 | ENDDO ! loop over # carbon stock components |
|---|
| 1283 | |
|---|
| 1284 | END SUBROUTINE initialize_proxy_pft |
|---|
| 1285 | |
|---|
| 1286 | ! ================================================================================================================================ |
|---|
| 1287 | !! SUBROUTINE sap_take |
|---|
| 1288 | !! |
|---|
| 1289 | !>\BRIEF : Take the sapling biomass of the new PFTs from the existing biomass, otherwise |
|---|
| 1290 | ! take from co2_to_bm |
|---|
| 1291 | !! |
|---|
| 1292 | !>\DESCRIPTION |
|---|
| 1293 | !_ ================================================================================================================================ |
|---|
| 1294 | SUBROUTINE sap_take (ipts,ivma,veget_max,biomass_pro,biomass,co2_to_bm_pro) |
|---|
| 1295 | |
|---|
| 1296 | INTEGER, INTENT(in) :: ipts !! |
|---|
| 1297 | INTEGER, INTENT(in) :: ivma |
|---|
| 1298 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: veget_max !! "maximal" coverage fraction of a PFT (LAI -> |
|---|
| 1299 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: biomass_pro !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 1300 | |
|---|
| 1301 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: biomass !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 1302 | REAL(r_std), INTENT(inout) :: co2_to_bm_pro |
|---|
| 1303 | |
|---|
| 1304 | |
|---|
| 1305 | REAL(r_std), DIMENSION(nparts,nelements) :: biomass_total !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 1306 | REAL(r_std) :: bm_org,bmpro_share |
|---|
| 1307 | INTEGER :: i,ivm,ipart |
|---|
| 1308 | |
|---|
| 1309 | biomass_total(:,:) = zero |
|---|
| 1310 | bm_org = zero |
|---|
| 1311 | bmpro_share = zero |
|---|
| 1312 | |
|---|
| 1313 | DO i = 1,nagec_pft(ivma) |
|---|
| 1314 | ivm = start_index(ivma)+i-1 |
|---|
| 1315 | IF (veget_max(ipts,ivm) .GT. min_stomate) THEN |
|---|
| 1316 | biomass_total = biomass_total + biomass(ipts,ivm,:,:)*veget_max(ipts,ivm) |
|---|
| 1317 | ENDIF |
|---|
| 1318 | ENDDO |
|---|
| 1319 | |
|---|
| 1320 | DO ipart = 1, nparts |
|---|
| 1321 | IF (biomass_total(ipart,icarbon) .GT. biomass_pro(ipart,icarbon)) THEN |
|---|
| 1322 | co2_to_bm_pro = co2_to_bm_pro - biomass_pro(ipart,icarbon) |
|---|
| 1323 | !treat each PFT of the MTC |
|---|
| 1324 | DO i = 1,nagec_pft(ivma) |
|---|
| 1325 | ivm = start_index(ivma)+i-1 |
|---|
| 1326 | IF (veget_max(ipts,ivm) .GT. min_stomate) THEN |
|---|
| 1327 | bm_org = biomass(ipts,ivm,ipart,icarbon) * veget_max(ipts,ivm) |
|---|
| 1328 | bmpro_share = bm_org/biomass_total(ipart,icarbon) * biomass_pro(ipart,icarbon) |
|---|
| 1329 | biomass(ipts,ivm,ipart,icarbon) = (bm_org - bmpro_share)/veget_max(ipts,ivm) |
|---|
| 1330 | ENDIF |
|---|
| 1331 | ENDDO |
|---|
| 1332 | ENDIF |
|---|
| 1333 | ENDDO |
|---|
| 1334 | |
|---|
| 1335 | END SUBROUTINE |
|---|
| 1336 | |
|---|
| 1337 | ! ================================================================================================================================ |
|---|
| 1338 | !! SUBROUTINE collect_legacy_pft |
|---|
| 1339 | !! |
|---|
| 1340 | !>\BRIEF : Collect the legacy variables that are going to be included |
|---|
| 1341 | ! in the newly initialized PFT. |
|---|
| 1342 | !! |
|---|
| 1343 | !>\DESCRIPTION |
|---|
| 1344 | !_ ================================================================================================================================ |
|---|
| 1345 | SUBROUTINE collect_legacy_pft(npts, ipts, ivma, glcc_pftmtc, & |
|---|
| 1346 | biomass, bm_to_litter, carbon, carbon_32l, DOC, litter_above, litter_below, & |
|---|
| 1347 | deepC_a, deepC_s, deepC_p, & |
|---|
| 1348 | fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 1349 | lignin_struc_above, lignin_struc_below, & |
|---|
| 1350 | co2_to_bm, gpp_daily, npp_daily, & |
|---|
| 1351 | resp_maint, resp_growth, resp_hetero, co2_fire, & |
|---|
| 1352 | def_fuel_1hr_remain, def_fuel_10hr_remain, & |
|---|
| 1353 | def_fuel_100hr_remain, def_fuel_1000hr_remain, & |
|---|
| 1354 | deforest_litter_remain, deforest_biomass_remain, & |
|---|
| 1355 | veget_max_pro, carbon_pro, carbon_32l_pro, DOC_pro, & |
|---|
| 1356 | lignin_struc_pro, litter_pro, & |
|---|
| 1357 | deepC_a_pro, deepC_s_pro, deepC_p_pro, & |
|---|
| 1358 | fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, fuel_1000hr_pro, & |
|---|
| 1359 | bm_to_litter_pro, co2_to_bm_pro, gpp_daily_pro, & |
|---|
| 1360 | npp_daily_pro, resp_maint_pro, resp_growth_pro, & |
|---|
| 1361 | resp_hetero_pro, co2_fire_pro, & |
|---|
| 1362 | convflux,prod10,prod100, & |
|---|
| 1363 | !!SIMON added merge |
|---|
| 1364 | litter_above_pro, litter_below_pro, lignin_struc_above_pro, & |
|---|
| 1365 | lignin_struc_below_pro) |
|---|
| 1366 | |
|---|
| 1367 | |
|---|
| 1368 | IMPLICIT NONE |
|---|
| 1369 | |
|---|
| 1370 | !! 0.1 Input variables |
|---|
| 1371 | INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 1372 | INTEGER, INTENT(in) :: ipts !! Domain size - number of pixels (unitless) |
|---|
| 1373 | INTEGER, INTENT(in) :: ivma !! Index for metaclass |
|---|
| 1374 | REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: glcc_pftmtc !! a temporary variable to hold the fractions each PFT is going to lose |
|---|
| 1375 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: biomass !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 1376 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: bm_to_litter !! Transfer of biomass to litter |
|---|
| 1377 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 1378 | REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: carbon !! carbon pool: active, slow, or passive |
|---|
| 1379 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 1380 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: carbon_32l !! carbon pool: active, slow, or passive |
|---|
| 1381 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 1382 | REAL(r_std), DIMENSION(:,:,:,:,:,:), INTENT(in) :: DOC !! carbon pool: active, slow, or passive |
|---|
| 1383 | |
|---|
| 1384 | REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: deepC_a !! Permafrost soil carbon (g/m**3) active |
|---|
| 1385 | REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: deepC_s !! Permafrost soil carbon (g/m**3) slow |
|---|
| 1386 | REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: deepC_p !! Permafrost soil carbon (g/m**3) passive |
|---|
| 1387 | REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements) :: litter !! metabolic and structural litter, above and |
|---|
| 1388 | !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 1389 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: litter_above !! metabolic and structural litter, above and |
|---|
| 1390 | !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 1391 | REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(in) :: litter_below !! metabolic and structural litter, above and |
|---|
| 1392 | !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 1393 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_1hr |
|---|
| 1394 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_10hr |
|---|
| 1395 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_100hr |
|---|
| 1396 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_1000hr |
|---|
| 1397 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: lignin_struc !! ratio Lignine/Carbon in structural litter, |
|---|
| 1398 | !! above and below ground |
|---|
| 1399 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: lignin_struc_above !! Ratio of Lignin/Carbon in structural |
|---|
| 1400 | !! litter, above ground, |
|---|
| 1401 | !! @tex $(gC m^{-2})$ @endtex |
|---|
| 1402 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: lignin_struc_below !! Ratio of Lignin/Carbon in structural |
|---|
| 1403 | !! litter, below ground, |
|---|
| 1404 | |
|---|
| 1405 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: co2_to_bm !! biomass uptaken |
|---|
| 1406 | !! @tex ($gC m^{-2} day^{-1}$) @endtex |
|---|
| 1407 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: gpp_daily !! Daily gross primary productivity |
|---|
| 1408 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 1409 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: npp_daily !! Net primary productivity |
|---|
| 1410 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 1411 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: resp_maint !! Maintenance respiration |
|---|
| 1412 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 1413 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: resp_growth !! Growth respiration |
|---|
| 1414 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 1415 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: resp_hetero !! Heterotrophic respiration |
|---|
| 1416 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 1417 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: co2_fire !! Heterotrophic respiration |
|---|
| 1418 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 1419 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: def_fuel_1hr_remain |
|---|
| 1420 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: def_fuel_10hr_remain |
|---|
| 1421 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: def_fuel_100hr_remain |
|---|
| 1422 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: def_fuel_1000hr_remain |
|---|
| 1423 | REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(in) :: deforest_litter_remain !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 1424 | !! deforestation region. |
|---|
| 1425 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: deforest_biomass_remain !! Vegetmax-weighted remaining biomass on the ground for |
|---|
| 1426 | !! deforestation region. |
|---|
| 1427 | |
|---|
| 1428 | !! 0.2 Output variables |
|---|
| 1429 | REAL(r_std), DIMENSION(:), INTENT(out) :: carbon_pro |
|---|
| 1430 | REAL(r_std), DIMENSION(:,:), INTENT(out) :: carbon_32l_pro |
|---|
| 1431 | REAL(r_std), DIMENSION(:,:,:), INTENT(out) :: DOC_pro |
|---|
| 1432 | |
|---|
| 1433 | REAL(r_std), DIMENSION(:), INTENT(out) :: deepC_a_pro |
|---|
| 1434 | REAL(r_std), DIMENSION(:), INTENT(out) :: deepC_s_pro |
|---|
| 1435 | REAL(r_std), DIMENSION(:), INTENT(out) :: deepC_p_pro |
|---|
| 1436 | REAL(r_std), DIMENSION(:), INTENT(out) :: lignin_struc_pro !! ratio Lignine/Carbon in structural litter |
|---|
| 1437 | !! above and below ground |
|---|
| 1438 | REAL(r_std), DIMENSION(:,:,:), INTENT(out) :: litter_pro |
|---|
| 1439 | REAL(r_std), DIMENSION(:,:), INTENT(out) :: litter_above_pro |
|---|
| 1440 | REAL(r_std), DIMENSION(:,:,:), INTENT(out) :: litter_below_pro |
|---|
| 1441 | REAL(r_std), INTENT(out) :: lignin_struc_above_pro |
|---|
| 1442 | REAL(r_std), DIMENSION(:), INTENT(out) :: lignin_struc_below_pro |
|---|
| 1443 | |
|---|
| 1444 | REAL(r_std), DIMENSION(:,:), INTENT(out) :: fuel_1hr_pro |
|---|
| 1445 | REAL(r_std), DIMENSION(:,:), INTENT(out) :: fuel_10hr_pro |
|---|
| 1446 | REAL(r_std), DIMENSION(:,:), INTENT(out) :: fuel_100hr_pro |
|---|
| 1447 | REAL(r_std), DIMENSION(:,:), INTENT(out) :: fuel_1000hr_pro |
|---|
| 1448 | REAL(r_std), DIMENSION(:,:), INTENT(out) :: bm_to_litter_pro |
|---|
| 1449 | REAL(r_std), INTENT(out) :: veget_max_pro, co2_to_bm_pro |
|---|
| 1450 | REAL(r_std), INTENT(out) :: gpp_daily_pro, npp_daily_pro |
|---|
| 1451 | REAL(r_std), INTENT(out) :: resp_maint_pro, resp_growth_pro |
|---|
| 1452 | REAL(r_std), INTENT(out) :: resp_hetero_pro, co2_fire_pro |
|---|
| 1453 | |
|---|
| 1454 | !! 0.3 Modified variables |
|---|
| 1455 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: convflux !! release during first year following land cover |
|---|
| 1456 | !! change |
|---|
| 1457 | |
|---|
| 1458 | REAL(r_std), DIMENSION(npts,0:10,nwp), INTENT(inout) :: prod10 !! products remaining in the 10 year-turnover |
|---|
| 1459 | !! pool after the annual release for each |
|---|
| 1460 | !! compartment (10 + 1 : input from year of land |
|---|
| 1461 | !! cover change) |
|---|
| 1462 | REAL(r_std), DIMENSION(npts,0:100,nwp), INTENT(inout) :: prod100 !! products remaining in the 100 year-turnover |
|---|
| 1463 | !! pool after the annual release for each |
|---|
| 1464 | !! compartment (100 + 1 : input from year of land |
|---|
| 1465 | !! cover change) |
|---|
| 1466 | |
|---|
| 1467 | !! 0.4 Local variables |
|---|
| 1468 | REAL(r_std), DIMENSION(nlevs) :: lignin_content_pro |
|---|
| 1469 | REAL(r_std) :: frac |
|---|
| 1470 | INTEGER :: ivm |
|---|
| 1471 | REAL(r_std) :: lignin_content_above_pro |
|---|
| 1472 | REAL(r_std), DIMENSION(nlevs) :: lignin_content_below_pro |
|---|
| 1473 | |
|---|
| 1474 | |
|---|
| 1475 | ! All *_pro variables collect the legacy pools/fluxes of the ancestor |
|---|
| 1476 | ! PFTs for the receiving youngest age class. All *_pro variables |
|---|
| 1477 | ! represent the quantity weighted by the fraction of ancestor contributing |
|---|
| 1478 | ! PFTs. |
|---|
| 1479 | ! Exceptions: |
|---|
| 1480 | ! lignin_struc_pro:: the ratio of lignin content in structural litter. |
|---|
| 1481 | |
|---|
| 1482 | veget_max_pro=zero |
|---|
| 1483 | carbon_pro(:)=zero |
|---|
| 1484 | carbon_32l_pro(:,:)=zero |
|---|
| 1485 | DOC_pro(:,:,:)=zero |
|---|
| 1486 | deepC_a_pro(:)=zero |
|---|
| 1487 | deepC_s_pro(:)=zero |
|---|
| 1488 | deepC_p_pro(:)=zero |
|---|
| 1489 | lignin_struc_pro(:)=zero |
|---|
| 1490 | lignin_struc_above_pro=zero |
|---|
| 1491 | lignin_struc_below_pro(:)=zero |
|---|
| 1492 | lignin_content_pro(:)=zero |
|---|
| 1493 | lignin_content_above_pro=zero |
|---|
| 1494 | lignin_content_below_pro(:)=zero |
|---|
| 1495 | litter_pro(:,:,:)=zero |
|---|
| 1496 | litter_above_pro(:,:)=zero |
|---|
| 1497 | litter_below_pro(:,:,:)=zero |
|---|
| 1498 | fuel_1hr_pro(:,:)=zero |
|---|
| 1499 | fuel_10hr_pro(:,:)=zero |
|---|
| 1500 | fuel_100hr_pro(:,:)=zero |
|---|
| 1501 | fuel_1000hr_pro(:,:)=zero |
|---|
| 1502 | bm_to_litter_pro(:,:)=zero |
|---|
| 1503 | co2_to_bm_pro=zero |
|---|
| 1504 | gpp_daily_pro=zero |
|---|
| 1505 | npp_daily_pro=zero |
|---|
| 1506 | resp_maint_pro=zero |
|---|
| 1507 | resp_growth_pro=zero |
|---|
| 1508 | resp_hetero_pro=zero |
|---|
| 1509 | co2_fire_pro=zero |
|---|
| 1510 | |
|---|
| 1511 | DO ivm = 1,nvm |
|---|
| 1512 | frac = glcc_pftmtc(ipts,ivm,ivma) |
|---|
| 1513 | IF (frac>zero) THEN |
|---|
| 1514 | veget_max_pro = veget_max_pro+frac |
|---|
| 1515 | |
|---|
| 1516 | IF (is_tree(ivm)) THEN |
|---|
| 1517 | IF (is_tree(start_index(ivma))) THEN |
|---|
| 1518 | |
|---|
| 1519 | ! SUBROUTINE harvest_forest (npts,ipts,ivm,biomass,frac, & |
|---|
| 1520 | ! litter_above, litter_below, deforest_biomass_remain,& |
|---|
| 1521 | ! fuel_1hr,fuel_10hr,& |
|---|
| 1522 | ! fuel_100hr,fuel_1000hr,& |
|---|
| 1523 | ! lignin_struc,& |
|---|
| 1524 | ! bm_to_litter_pro,convflux,prod10,prod100,& |
|---|
| 1525 | ! litter_pro, fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, & |
|---|
| 1526 | ! fuel_1000hr_pro, lignin_content_pro, & |
|---|
| 1527 | ! !!SIMON added merge |
|---|
| 1528 | ! lignin_struc_above, lignin_struc_below, & |
|---|
| 1529 | ! litter_above_pro, litter_below_pro, & |
|---|
| 1530 | ! lignin_content_above_pro, lignin_content_below_pro) |
|---|
| 1531 | |
|---|
| 1532 | |
|---|
| 1533 | |
|---|
| 1534 | CALL harvest_forest (npts,ipts,ivm,biomass,frac, & |
|---|
| 1535 | litter_above, litter_below, deforest_biomass_remain,& |
|---|
| 1536 | fuel_1hr,fuel_10hr,& |
|---|
| 1537 | fuel_100hr,fuel_1000hr,& |
|---|
| 1538 | ! lignin_struc,& |
|---|
| 1539 | bm_to_litter_pro,convflux(:,iwphar),prod10(:,:,iwphar),prod100(:,:,iwphar),& |
|---|
| 1540 | litter_pro, fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, & |
|---|
| 1541 | fuel_1000hr_pro, lignin_content_pro, & |
|---|
| 1542 | lignin_struc_above, lignin_struc_below, & |
|---|
| 1543 | litter_above_pro, litter_below_pro, & |
|---|
| 1544 | lignin_content_above_pro, lignin_content_below_pro) |
|---|
| 1545 | |
|---|
| 1546 | ELSE |
|---|
| 1547 | CALL harvest_forest (npts,ipts,ivm,biomass,frac, & |
|---|
| 1548 | litter_above, litter_below, deforest_biomass_remain,& |
|---|
| 1549 | fuel_1hr,fuel_10hr,& |
|---|
| 1550 | fuel_100hr,fuel_1000hr,& |
|---|
| 1551 | ! lignin_struc,& |
|---|
| 1552 | bm_to_litter_pro,convflux(:,iwplcc),prod10(:,:,iwplcc),prod100(:,:,iwplcc),& |
|---|
| 1553 | litter_pro, fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, & |
|---|
| 1554 | fuel_1000hr_pro, lignin_content_pro, & |
|---|
| 1555 | lignin_struc_above, lignin_struc_below, & |
|---|
| 1556 | litter_above_pro, litter_below_pro, & |
|---|
| 1557 | lignin_content_above_pro, lignin_content_below_pro) |
|---|
| 1558 | |
|---|
| 1559 | ENDIF |
|---|
| 1560 | ELSE |
|---|
| 1561 | CALL harvest_herb(ipts,ivm,biomass,frac, & |
|---|
| 1562 | bm_to_litter_pro) |
|---|
| 1563 | litter_pro(:,:,:) = litter_pro(:,:,:) + litter(ipts,:,ivm,:,:)*frac |
|---|
| 1564 | !!SIMON added merge |
|---|
| 1565 | litter_above_pro(:,:)=litter_above_pro(:,:) + litter_above(ipts,:,ivm,:)*frac |
|---|
| 1566 | litter_below_pro(:,:,:)=litter_below_pro(:,:,:) + litter_below(ipts,:,ivm,:,:)*frac |
|---|
| 1567 | !!end |
|---|
| 1568 | fuel_1hr_pro(:,:) = fuel_1hr_pro(:,:) + fuel_1hr(ipts,ivm,:,:)*frac |
|---|
| 1569 | fuel_10hr_pro(:,:) = fuel_10hr_pro(:,:) + fuel_10hr(ipts,ivm,:,:)*frac |
|---|
| 1570 | fuel_100hr_pro(:,:) = fuel_100hr_pro(:,:) + fuel_100hr(ipts,ivm,:,:)*frac |
|---|
| 1571 | fuel_1000hr_pro(:,:) = fuel_1000hr_pro(:,:) + fuel_1000hr(ipts,ivm,:,:)*frac |
|---|
| 1572 | !don't forget to hanle litter lignin content |
|---|
| 1573 | ! lignin_content_pro(:)= lignin_content_pro(:) + & |
|---|
| 1574 | ! litter(ipts,istructural,ivm,:,icarbon)*lignin_struc(ipts,ivm,:)*frac |
|---|
| 1575 | !!!SIMON added merge |
|---|
| 1576 | lignin_content_above_pro=lignin_content_above_pro + litter_above(ipts,istructural,ivm,icarbon)*lignin_struc_above(ipts,ivm)*frac |
|---|
| 1577 | |
|---|
| 1578 | lignin_content_below_pro(:)=lignin_content_below_pro(:) + litter_below(ipts,istructural,ivm,:,icarbon)*lignin_struc_below(ipts,ivm,:)*frac |
|---|
| 1579 | |
|---|
| 1580 | ENDIF |
|---|
| 1581 | |
|---|
| 1582 | !! scalar variables to be accumulated and inherited |
|---|
| 1583 | !! by the destination PFT |
|---|
| 1584 | bm_to_litter_pro(:,:) = bm_to_litter_pro(:,:) + & |
|---|
| 1585 | bm_to_litter(ipts,ivm,:,:)*frac |
|---|
| 1586 | carbon_pro(:) = carbon_pro(:)+carbon(ipts,:,ivm)*frac |
|---|
| 1587 | !!SIMON added ORCHIDOC |
|---|
| 1588 | carbon_32l_pro(:,:) = carbon_32l_pro(:,:) + carbon_32l(ipts,:,ivm,:)*frac !npool, nlayer |
|---|
| 1589 | DOC_pro(:,:,:)=DOC_pro(:,:,:)+ DOC(ipts,ivm,:,:,:,icarbon)*frac |
|---|
| 1590 | |
|---|
| 1591 | deepC_a_pro(:) = deepC_a_pro(:)+deepC_a(ipts,:,ivm)*frac |
|---|
| 1592 | deepC_s_pro(:) = deepC_s_pro(:)+deepC_s(ipts,:,ivm)*frac |
|---|
| 1593 | deepC_p_pro(:) = deepC_p_pro(:)+deepC_p(ipts,:,ivm)*frac |
|---|
| 1594 | co2_to_bm_pro = co2_to_bm_pro + co2_to_bm(ipts,ivm)*frac |
|---|
| 1595 | |
|---|
| 1596 | gpp_daily_pro = gpp_daily_pro + gpp_daily(ipts,ivm)*frac |
|---|
| 1597 | npp_daily_pro = npp_daily_pro + npp_daily(ipts,ivm)*frac |
|---|
| 1598 | resp_maint_pro = resp_maint_pro + resp_maint(ipts,ivm)*frac |
|---|
| 1599 | resp_growth_pro = resp_growth_pro + resp_growth(ipts,ivm)*frac |
|---|
| 1600 | resp_hetero_pro = resp_hetero_pro + resp_hetero(ipts,ivm)*frac |
|---|
| 1601 | co2_fire_pro = co2_fire_pro + co2_fire(ipts,ivm)*frac |
|---|
| 1602 | ENDIF |
|---|
| 1603 | ENDDO |
|---|
| 1604 | |
|---|
| 1605 | WHERE (litter_pro(istructural,:,icarbon) .GT. min_stomate) |
|---|
| 1606 | lignin_struc_pro(:) = lignin_content_pro(:)/litter_pro(istructural,:,icarbon) |
|---|
| 1607 | ENDWHERE |
|---|
| 1608 | |
|---|
| 1609 | IF (litter_above_pro(istructural,icarbon) .GT. min_stomate) THEN |
|---|
| 1610 | lignin_struc_above_pro = lignin_content_above_pro/litter_above_pro(istructural,icarbon) |
|---|
| 1611 | ENDIF |
|---|
| 1612 | |
|---|
| 1613 | WHERE(litter_below_pro(istructural,:,icarbon) .GT. min_stomate) |
|---|
| 1614 | lignin_struc_below_pro(:) = lignin_content_below_pro(:)/litter_below_pro(istructural,:,icarbon) |
|---|
| 1615 | ENDWHERE |
|---|
| 1616 | |
|---|
| 1617 | |
|---|
| 1618 | END SUBROUTINE collect_legacy_pft |
|---|
| 1619 | |
|---|
| 1620 | |
|---|
| 1621 | ! ================================================================================================================================ |
|---|
| 1622 | !! SUBROUTINE gross_lcchange |
|---|
| 1623 | !! |
|---|
| 1624 | !>\BRIEF : Apply gross land cover change. |
|---|
| 1625 | !! |
|---|
| 1626 | !>\DESCRIPTION |
|---|
| 1627 | !_ ================================================================================================================================ |
|---|
| 1628 | SUBROUTINE gross_glcchange_fh (npts, dt_days, harvest_matrix, & |
|---|
| 1629 | glccSecondShift,glccPrimaryShift,glccNetLCC,& |
|---|
| 1630 | def_fuel_1hr_remain, def_fuel_10hr_remain, & |
|---|
| 1631 | def_fuel_100hr_remain, def_fuel_1000hr_remain, & |
|---|
| 1632 | deforest_litter_remain, deforest_biomass_remain, & |
|---|
| 1633 | convflux, cflux_prod10, cflux_prod100, & |
|---|
| 1634 | glccReal, IncreDeficit, glcc_pft, glcc_pftmtc, & |
|---|
| 1635 | veget_max, prod10, prod100, flux10, flux100, & |
|---|
| 1636 | PFTpresent, senescence, moiavail_month, moiavail_week, & |
|---|
| 1637 | gpp_week, ngd_minus5, resp_maint, resp_growth, & |
|---|
| 1638 | resp_hetero, npp_daily, when_growthinit, npp_longterm, & |
|---|
| 1639 | ind, lm_lastyearmax, everywhere, age, & |
|---|
| 1640 | co2_to_bm, gpp_daily, co2_fire, & |
|---|
| 1641 | time_hum_min, gdd_midwinter, gdd_from_growthinit, & |
|---|
| 1642 | gdd_m5_dormance, ncd_dormance, & |
|---|
| 1643 | lignin_struc_above, lignin_struc_below, carbon, carbon_32l, DOC, leaf_frac, & |
|---|
| 1644 | deepC_a, deepC_s, deepC_p, & |
|---|
| 1645 | leaf_age, bm_to_litter, biomass, litter_above, litter_below, & |
|---|
| 1646 | fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr) |
|---|
| 1647 | |
|---|
| 1648 | |
|---|
| 1649 | IMPLICIT NONE |
|---|
| 1650 | |
|---|
| 1651 | !! 0.1 Input variables |
|---|
| 1652 | |
|---|
| 1653 | INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 1654 | REAL(r_std), INTENT(in) :: dt_days !! Time step of vegetation dynamics for stomate |
|---|
| 1655 | REAL(r_std), DIMENSION (npts,12),INTENT(in) :: glccSecondShift !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 1656 | !! used. |
|---|
| 1657 | REAL(r_std), DIMENSION (npts,12),INTENT(in) :: glccPrimaryShift !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 1658 | !! used. |
|---|
| 1659 | REAL(r_std), DIMENSION (npts,12),INTENT(in) :: glccNetLCC !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 1660 | !! used. |
|---|
| 1661 | REAL(r_std), DIMENSION (npts,12),INTENT(in) :: harvest_matrix !! |
|---|
| 1662 | !! |
|---|
| 1663 | |
|---|
| 1664 | REAL(r_std), DIMENSION(npts,nvm,nlitt,nelements), INTENT(in) :: def_fuel_1hr_remain |
|---|
| 1665 | REAL(r_std), DIMENSION(npts,nvm,nlitt,nelements), INTENT(in) :: def_fuel_10hr_remain |
|---|
| 1666 | REAL(r_std), DIMENSION(npts,nvm,nlitt,nelements), INTENT(in) :: def_fuel_100hr_remain |
|---|
| 1667 | REAL(r_std), DIMENSION(npts,nvm,nlitt,nelements), INTENT(in) :: def_fuel_1000hr_remain |
|---|
| 1668 | REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements), INTENT(in) :: deforest_litter_remain !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 1669 | !! deforestation region. |
|---|
| 1670 | REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(in) :: deforest_biomass_remain !! Vegetmax-weighted remaining biomass on the ground for |
|---|
| 1671 | !! deforestation region. |
|---|
| 1672 | |
|---|
| 1673 | |
|---|
| 1674 | !! 0.2 Output variables |
|---|
| 1675 | REAL(r_std), DIMENSION(npts,nwp), INTENT(out) :: convflux !! release during first year following land cover |
|---|
| 1676 | !! change |
|---|
| 1677 | REAL(r_std), DIMENSION(npts,nwp), INTENT(out) :: cflux_prod10 !! total annual release from the 10 year-turnover |
|---|
| 1678 | !! pool @tex ($gC m^{-2}$) @endtex |
|---|
| 1679 | REAL(r_std), DIMENSION(npts,nwp), INTENT(out) :: cflux_prod100 !! total annual release from the 100 year- |
|---|
| 1680 | REAL(r_std), DIMENSION(npts,12), INTENT(inout) :: glccReal !! The "real" glcc matrix that we apply in the model |
|---|
| 1681 | !! after considering the consistency between presribed |
|---|
| 1682 | !! glcc matrix and existing vegetation fractions. |
|---|
| 1683 | REAL(r_std), DIMENSION(npts,4), INTENT(inout) :: IncreDeficit !! "Increment" deficits, negative values mean that |
|---|
| 1684 | !! there are not enough fractions in the source PFTs |
|---|
| 1685 | !! /vegetations to target PFTs/vegetations. I.e., these |
|---|
| 1686 | !! fraction transfers are presribed in LCC matrix but |
|---|
| 1687 | !! not realized. |
|---|
| 1688 | REAL(r_std), DIMENSION(npts,nvm), INTENT(inout) :: glcc_pft !! Loss of fraction in each PFT |
|---|
| 1689 | REAL(r_std), DIMENSION(npts,nvm,nvmap), INTENT(inout):: glcc_pftmtc !! a temporary variable to hold the fractions each PFT is going to lose |
|---|
| 1690 | !! i.e., the contribution of each PFT to the youngest age-class of MTC |
|---|
| 1691 | |
|---|
| 1692 | !! 0.3 Modified variables |
|---|
| 1693 | REAL(r_std), DIMENSION(npts,nvm), INTENT(inout) :: veget_max !! "maximal" coverage fraction of a PFT (LAI -> |
|---|
| 1694 | !! infinity) on ground (unitless) |
|---|
| 1695 | REAL(r_std), DIMENSION(npts,0:10,nwp), INTENT(inout) :: prod10 !! products remaining in the 10 year-turnover |
|---|
| 1696 | !! pool after the annual release for each |
|---|
| 1697 | !! compartment (10 + 1 : input from year of land |
|---|
| 1698 | !! cover change) |
|---|
| 1699 | REAL(r_std), DIMENSION(npts,0:100,nwp), INTENT(inout) :: prod100 !! products remaining in the 100 year-turnover |
|---|
| 1700 | !! pool after the annual release for each |
|---|
| 1701 | !! compartment (100 + 1 : input from year of land |
|---|
| 1702 | !! cover change) |
|---|
| 1703 | REAL(r_std), DIMENSION(npts,10,nwp), INTENT(inout) :: flux10 !! annual release from the 10/100 year-turnover |
|---|
| 1704 | !! pool compartments |
|---|
| 1705 | REAL(r_std), DIMENSION(npts,100,nwp), INTENT(inout) :: flux100 !! annual release from the 10/100 year-turnover |
|---|
| 1706 | !! pool compartments |
|---|
| 1707 | LOGICAL, DIMENSION(:,:), INTENT(inout) :: PFTpresent !! Tab indicating which PFTs are present in |
|---|
| 1708 | !! each pixel |
|---|
| 1709 | LOGICAL, DIMENSION(:,:), INTENT(inout) :: senescence !! Flag for setting senescence stage (only |
|---|
| 1710 | !! for deciduous trees) |
|---|
| 1711 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_month !! "Monthly" moisture availability (0 to 1, |
|---|
| 1712 | !! unitless) |
|---|
| 1713 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_week !! "Weekly" moisture availability |
|---|
| 1714 | !! (0 to 1, unitless) |
|---|
| 1715 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_week !! Mean weekly gross primary productivity |
|---|
| 1716 | !! @tex $(gC m^{-2} day^{-1})$ @endtex |
|---|
| 1717 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ngd_minus5 !! Number of growing days (days), threshold |
|---|
| 1718 | !! -5 deg C (for phenology) |
|---|
| 1719 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_maint !! Maintenance respiration |
|---|
| 1720 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 1721 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_growth !! Growth respiration |
|---|
| 1722 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 1723 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_hetero !! Heterotrophic respiration |
|---|
| 1724 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 1725 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_daily !! Net primary productivity |
|---|
| 1726 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 1727 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: when_growthinit !! How many days ago was the beginning of |
|---|
| 1728 | !! the growing season (days) |
|---|
| 1729 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_longterm !! "Long term" mean yearly primary productivity |
|---|
| 1730 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ind !! Number of individuals at the stand level |
|---|
| 1731 | !! @tex $(m^{-2})$ @endtex |
|---|
| 1732 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: lm_lastyearmax !! last year's maximum leaf mass for each PFT |
|---|
| 1733 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 1734 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: everywhere !! is the PFT everywhere in the grid box or |
|---|
| 1735 | !! very localized (after its introduction) (?) |
|---|
| 1736 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: age !! mean age (years) |
|---|
| 1737 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: co2_to_bm !! CO2 taken from the atmosphere to get C to create |
|---|
| 1738 | !! the seedlings @tex (gC.m^{-2}dt^{-1})$ @endtex |
|---|
| 1739 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_daily !! Daily gross primary productivity |
|---|
| 1740 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 1741 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: co2_fire !! Fire carbon emissions |
|---|
| 1742 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 1743 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: time_hum_min !! Time elapsed since strongest moisture |
|---|
| 1744 | !! availability (days) |
|---|
| 1745 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_midwinter !! Growing degree days (K), since midwinter |
|---|
| 1746 | !! (for phenology) - this is written to the |
|---|
| 1747 | !! history files |
|---|
| 1748 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_from_growthinit !! growing degree days, since growthinit |
|---|
| 1749 | !! for crops |
|---|
| 1750 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_m5_dormance !! Growing degree days (K), threshold -5 deg |
|---|
| 1751 | !! C (for phenology) |
|---|
| 1752 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ncd_dormance !! Number of chilling days (days), since |
|---|
| 1753 | !! leaves were lost (for phenology) |
|---|
| 1754 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: lignin_struc !! ratio Lignine/Carbon in structural litter, |
|---|
| 1755 | !! above and below ground |
|---|
| 1756 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: lignin_struc_above !! Ratio of Lignin/Carbon in structural |
|---|
| 1757 | !! litter, above ground, |
|---|
| 1758 | !! @tex $(gC m^{-2})$ @endtex |
|---|
| 1759 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: lignin_struc_below !! Ratio of Lignin/Carbon in structural |
|---|
| 1760 | !! litter, below ground, |
|---|
| 1761 | |
|---|
| 1762 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: carbon !! carbon pool: active, slow, or passive |
|---|
| 1763 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 1764 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_a !! Permafrost soil carbon (g/m**3) active |
|---|
| 1765 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_s !! Permafrost soil carbon (g/m**3) slow |
|---|
| 1766 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_p !! Permafrost soil carbon (g/m**3) passive |
|---|
| 1767 | !!SIMON ADDED ORCHIDOC |
|---|
| 1768 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: carbon_32l !! carbon pool: active, slow, or passive |
|---|
| 1769 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 1770 | |
|---|
| 1771 | REAL(r_std), DIMENSION(:,:,:,:,:,:), INTENT(inout) :: DOC !! carbon pool: active, slow, or passive |
|---|
| 1772 | |
|---|
| 1773 | |
|---|
| 1774 | |
|---|
| 1775 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_frac !! fraction of leaves in leaf age class (unitless;0-1) |
|---|
| 1776 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_age !! Leaf age (days) |
|---|
| 1777 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: bm_to_litter !! Transfer of biomass to litter |
|---|
| 1778 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 1779 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: biomass !! Stand level biomass @tex $(gC.m^{-2})$ @endtex |
|---|
| 1780 | ! |
|---|
| 1781 | REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements) :: litter !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 1782 | !! deforestation region. |
|---|
| 1783 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: litter_above !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 1784 | !! deforestation region. |
|---|
| 1785 | REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: litter_below !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 1786 | !! deforestation region. |
|---|
| 1787 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1hr |
|---|
| 1788 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_10hr |
|---|
| 1789 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_100hr |
|---|
| 1790 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1000hr |
|---|
| 1791 | |
|---|
| 1792 | !! 0.4 Local variables |
|---|
| 1793 | REAL(r_std), DIMENSION(nparts,nelements) :: bm_to_litter_pro !! conversion of biomass to litter |
|---|
| 1794 | !! @tex ($gC m^{-2} day^{-1}$) @endtex |
|---|
| 1795 | REAL(r_std), DIMENSION(nparts,nelements) :: biomass_pro !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 1796 | REAL(r_std) :: veget_max_pro !! "maximal" coverage fraction of a PFT (LAI -> |
|---|
| 1797 | !! infinity) on ground (unitless) |
|---|
| 1798 | REAL(r_std), DIMENSION(ncarb) :: carbon_pro !! carbon pool: active, slow, or passive |
|---|
| 1799 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 1800 | REAL(r_std), DIMENSION(ndeep) :: deepC_a_pro !! Permafrost carbon pool: active, slow, or passive |
|---|
| 1801 | !! @tex ($gC m^{-3}$) @endtex |
|---|
| 1802 | REAL(r_std), DIMENSION(ndeep) :: deepC_s_pro !! Permafrost carbon pool: active, slow, or passive |
|---|
| 1803 | !! @tex ($gC m^{-3}$) @endtex |
|---|
| 1804 | REAL(r_std), DIMENSION(ndeep) :: deepC_p_pro !! Permafrost carbon pool: active, slow, or passive |
|---|
| 1805 | !! @tex ($gC m^{-3}$) @endtex |
|---|
| 1806 | REAL(r_std), DIMENSION(nlitt,nlevs,nelements) :: litter_pro !! metabolic and structural litter, above and |
|---|
| 1807 | REAL(r_std), DIMENSION(ncarb,ndeep) :: carbon_32l_pro |
|---|
| 1808 | REAL(r_std), DIMENSION(ndeep,ndoc,npool) :: DOC_pro |
|---|
| 1809 | !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 1810 | !!!SIMON added merge |
|---|
| 1811 | REAL(r_std), DIMENSION(nlitt,nelements) :: litter_above_pro |
|---|
| 1812 | REAL(r_std), DIMENSION(nlitt,ndeep,nelements) :: litter_below_pro |
|---|
| 1813 | REAL(r_std) :: lignin_struc_above_pro |
|---|
| 1814 | REAL(r_std), DIMENSION(ndeep) :: lignin_struc_below_pro |
|---|
| 1815 | REAL(r_std) :: lignin_content_above_pro |
|---|
| 1816 | REAL(r_std), DIMENSION(ndeep) :: lignin_content_below_pro |
|---|
| 1817 | !!!END merge |
|---|
| 1818 | REAL(r_std), DIMENSION(nlitt,nelements) :: fuel_1hr_pro |
|---|
| 1819 | REAL(r_std), DIMENSION(nlitt,nelements) :: fuel_10hr_pro |
|---|
| 1820 | REAL(r_std), DIMENSION(nlitt,nelements) :: fuel_100hr_pro |
|---|
| 1821 | REAL(r_std), DIMENSION(nlitt,nelements) :: fuel_1000hr_pro |
|---|
| 1822 | REAL(r_std), DIMENSION(nlevs) :: lignin_struc_pro !! ratio Lignine/Carbon in structural litter |
|---|
| 1823 | !! above and below ground |
|---|
| 1824 | REAL(r_std), DIMENSION(nleafages) :: leaf_frac_pro !! fraction of leaves in leaf age class |
|---|
| 1825 | REAL(r_std), DIMENSION(nleafages) :: leaf_age_pro !! fraction of leaves in leaf age class |
|---|
| 1826 | LOGICAL :: PFTpresent_pro, senescence_pro !! Is pft there (unitless) |
|---|
| 1827 | REAL(r_std) :: ind_pro, age_pro, lm_lastyearmax_pro, npp_longterm_pro |
|---|
| 1828 | REAL(r_std) :: everywhere_pro |
|---|
| 1829 | REAL(r_std) :: gpp_daily_pro, npp_daily_pro, co2_to_bm_pro |
|---|
| 1830 | REAL(r_std) :: resp_maint_pro, resp_growth_pro |
|---|
| 1831 | REAL(r_std) :: resp_hetero_pro, co2_fire_pro |
|---|
| 1832 | |
|---|
| 1833 | INTEGER :: ipts,ivm,ivma,l,m,ipft_young_agec |
|---|
| 1834 | CHARACTER(LEN=10) :: part_str !! string suffix indicating an index |
|---|
| 1835 | |
|---|
| 1836 | REAL(r_std), DIMENSION(npts,nvmap) :: glcc_mtc !! Increase in fraction of each MTC in its youngest age-class |
|---|
| 1837 | REAL(r_std), DIMENSION(npts,nvm) :: glccReal_tmp !! A temporary variable to hold glccReal |
|---|
| 1838 | REAL(r_std), DIMENSION(npts) :: Deficit_pf2yf_final !! |
|---|
| 1839 | REAL(r_std), DIMENSION(npts) :: Deficit_sf2yf_final !! |
|---|
| 1840 | REAL(r_std), DIMENSION(npts) :: pf2yf_compen_sf2yf !! |
|---|
| 1841 | REAL(r_std), DIMENSION(npts) :: sf2yf_compen_pf2yf !! |
|---|
| 1842 | REAL(r_std), DIMENSION(npts,nvm) :: glcc_harvest !! Loss of fraction due to forestry harvest |
|---|
| 1843 | |
|---|
| 1844 | WRITE(numout,*) 'Entering gross_lcchange_fh' |
|---|
| 1845 | glcc_harvest(:,:) = zero |
|---|
| 1846 | glccReal_tmp(:,:) = zero |
|---|
| 1847 | |
|---|
| 1848 | !! Some initialization |
|---|
| 1849 | convflux(:,:)=zero |
|---|
| 1850 | prod10(:,0,:) = zero |
|---|
| 1851 | prod100(:,0,:) = zero |
|---|
| 1852 | cflux_prod10(:,:) = zero |
|---|
| 1853 | cflux_prod100(:,:) = zero |
|---|
| 1854 | |
|---|
| 1855 | CALL gross_glcc_firstday_fh(npts,veget_max,harvest_matrix, & |
|---|
| 1856 | glccSecondShift,glccPrimaryShift,glccNetLCC,& |
|---|
| 1857 | glccReal,glcc_pft,glcc_pftmtc,IncreDeficit, & |
|---|
| 1858 | Deficit_pf2yf_final, Deficit_sf2yf_final, & |
|---|
| 1859 | pf2yf_compen_sf2yf, sf2yf_compen_pf2yf) |
|---|
| 1860 | |
|---|
| 1861 | glcc_mtc(:,:) = SUM(glcc_pftmtc,DIM=2) |
|---|
| 1862 | DO ipts=1,npts |
|---|
| 1863 | ! Note that we assume people don't intentionally change baresoil to |
|---|
| 1864 | ! vegetated land. |
|---|
| 1865 | DO ivma = 2,nvmap |
|---|
| 1866 | ! we assume only the youngest age class receives the incoming PFT |
|---|
| 1867 | ! [chaoyuejoy@gmail.com 2015-08-04] This line is commented to allow |
|---|
| 1868 | ! the case of only single age class being handled. |
|---|
| 1869 | IF ( glcc_mtc(ipts,ivma) .GT. min_stomate ) THEN |
|---|
| 1870 | ipft_young_agec = start_index(ivma) |
|---|
| 1871 | |
|---|
| 1872 | ! 1. we accumulate the scalar variables that will be inherited |
|---|
| 1873 | ! note we don't handle the case of harvesting forest because |
|---|
| 1874 | ! we assume glcc_pftmtc(forest->forest) would be zero and this |
|---|
| 1875 | ! case won't occur as it's filtered by the condition of |
|---|
| 1876 | ! (frac>min_stomate) |
|---|
| 1877 | CALL collect_legacy_pft(npts, ipts, ivma, glcc_pftmtc, & |
|---|
| 1878 | biomass, bm_to_litter, carbon, carbon_32l, DOC, litter_above, litter_below, & |
|---|
| 1879 | deepC_a, deepC_s, deepC_p, & |
|---|
| 1880 | fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 1881 | lignin_struc_above, lignin_struc_below, & |
|---|
| 1882 | co2_to_bm, gpp_daily, npp_daily, & |
|---|
| 1883 | resp_maint, resp_growth, resp_hetero, co2_fire, & |
|---|
| 1884 | def_fuel_1hr_remain, def_fuel_10hr_remain, & |
|---|
| 1885 | def_fuel_100hr_remain, def_fuel_1000hr_remain, & |
|---|
| 1886 | deforest_litter_remain, deforest_biomass_remain, & |
|---|
| 1887 | veget_max_pro, carbon_pro, carbon_32l_pro, DOC_pro, & |
|---|
| 1888 | lignin_struc_pro, litter_pro, & |
|---|
| 1889 | deepC_a_pro, deepC_s_pro, deepC_p_pro, & |
|---|
| 1890 | fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, fuel_1000hr_pro, & |
|---|
| 1891 | bm_to_litter_pro, co2_to_bm_pro, gpp_daily_pro, & |
|---|
| 1892 | npp_daily_pro, resp_maint_pro, resp_growth_pro, & |
|---|
| 1893 | resp_hetero_pro, co2_fire_pro, & |
|---|
| 1894 | convflux,prod10,prod100, & |
|---|
| 1895 | !!SIMON added merge |
|---|
| 1896 | litter_above_pro, litter_below_pro, lignin_struc_above_pro, & |
|---|
| 1897 | lignin_struc_below_pro) |
|---|
| 1898 | |
|---|
| 1899 | |
|---|
| 1900 | ! (npts, ipts, ivma, glcc_pftmtc, & |
|---|
| 1901 | ! biomass, bm_to_litter, carbon, carbon_32l, DOC, litter_above, litter_below, & |
|---|
| 1902 | ! deepC_a, deepC_s, deepC_p, & |
|---|
| 1903 | ! fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 1904 | ! lignin_struc, co2_to_bm, gpp_daily, npp_daily, & |
|---|
| 1905 | ! resp_maint, resp_growth, resp_hetero, co2_fire, & |
|---|
| 1906 | ! def_fuel_1hr_remain, def_fuel_10hr_remain, & |
|---|
| 1907 | ! def_fuel_100hr_remain, def_fuel_1000hr_remain, & |
|---|
| 1908 | ! deforest_litter_remain, deforest_biomass_remain, & |
|---|
| 1909 | ! veget_max_pro, carbon_pro, carbon_32l_pro, DOC_pro, & |
|---|
| 1910 | ! lignin_struc_pro, litter_pro, & |
|---|
| 1911 | ! deepC_a_pro, deepC_s_pro, deepC_p_pro, & |
|---|
| 1912 | ! fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, fuel_1000hr_pro, & |
|---|
| 1913 | ! bm_to_litter_pro, co2_to_bm_pro, gpp_daily_pro, & |
|---|
| 1914 | ! npp_daily_pro, resp_maint_pro, resp_growth_pro, & |
|---|
| 1915 | ! resp_hetero_pro, co2_fire_pro, & |
|---|
| 1916 | ! convflux,prod10,prod100, & |
|---|
| 1917 | |
|---|
| 1918 | !++TEMP++ |
|---|
| 1919 | ! Here we substract the outgoing fraction from the source PFT. |
|---|
| 1920 | ! If a too small fraction remains in this source PFT, then it is |
|---|
| 1921 | ! exhausted, we empty it. The subroutine 'empty_pft' might be |
|---|
| 1922 | ! combined with 'collect_legacy_pft', but now we just put it here. |
|---|
| 1923 | DO ivm = 1,nvm |
|---|
| 1924 | IF( glcc_pftmtc(ipts,ivm,ivma)>min_stomate ) THEN |
|---|
| 1925 | veget_max(ipts,ivm) = veget_max(ipts,ivm)-glcc_pftmtc(ipts,ivm,ivma) |
|---|
| 1926 | IF ( veget_max(ipts,ivm)<min_stomate ) THEN |
|---|
| 1927 | CALL empty_pft(ipts, ivm, veget_max, biomass, ind, & |
|---|
| 1928 | carbon, carbon_32l, DOC, litter_above, litter_below, & |
|---|
| 1929 | lignin_struc_above, lignin_struc_below, & |
|---|
| 1930 | bm_to_litter, & |
|---|
| 1931 | deepC_a, deepC_s, deepC_p, & |
|---|
| 1932 | fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 1933 | gpp_daily, npp_daily, gpp_week, npp_longterm, & |
|---|
| 1934 | co2_to_bm, resp_maint, resp_growth, resp_hetero, & |
|---|
| 1935 | lm_lastyearmax, leaf_frac, leaf_age, age, & |
|---|
| 1936 | everywhere, PFTpresent, when_growthinit, & |
|---|
| 1937 | senescence, gdd_from_growthinit, gdd_midwinter, & |
|---|
| 1938 | time_hum_min, gdd_m5_dormance, ncd_dormance, & |
|---|
| 1939 | moiavail_month, moiavail_week, ngd_minus5) |
|---|
| 1940 | ENDIF |
|---|
| 1941 | ENDIF |
|---|
| 1942 | ENDDO |
|---|
| 1943 | |
|---|
| 1944 | ! 2. we establish a proxy PFT with the fraction of veget_max_pro, |
|---|
| 1945 | ! which is going to be either merged with existing target |
|---|
| 1946 | ! `ipft_young_agec` PFT, or fill the place if no existing target PFT |
|---|
| 1947 | ! exits. |
|---|
| 1948 | CALL initialize_proxy_pft(ipts,ipft_young_agec,veget_max_pro, & |
|---|
| 1949 | biomass_pro, co2_to_bm_pro, ind_pro, age_pro, & |
|---|
| 1950 | senescence_pro, PFTpresent_pro, & |
|---|
| 1951 | lm_lastyearmax_pro, everywhere_pro, npp_longterm_pro, & |
|---|
| 1952 | leaf_frac_pro,leaf_age_pro) |
|---|
| 1953 | |
|---|
| 1954 | CALL sap_take (ipts,ivma,veget_max,biomass_pro,biomass,co2_to_bm_pro) |
|---|
| 1955 | |
|---|
| 1956 | ! 3. we merge the newly initiazlized proxy PFT into existing one |
|---|
| 1957 | ! or use it to fill an empty PFT slot. |
|---|
| 1958 | CALL add_incoming_proxy_pft(npts, ipts, ipft_young_agec, veget_max_pro,& |
|---|
| 1959 | carbon_pro, carbon_32l_pro, DOC_pro, litter_pro, & |
|---|
| 1960 | litter_above_pro, litter_below_pro, lignin_struc_above_pro, & |
|---|
| 1961 | lignin_struc_below_pro, & |
|---|
| 1962 | lignin_struc_pro, bm_to_litter_pro, & |
|---|
| 1963 | deepC_a_pro, deepC_s_pro, deepC_p_pro, & |
|---|
| 1964 | fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, fuel_1000hr_pro, & |
|---|
| 1965 | biomass_pro, co2_to_bm_pro, npp_longterm_pro, ind_pro, & |
|---|
| 1966 | lm_lastyearmax_pro, age_pro, everywhere_pro, & |
|---|
| 1967 | leaf_frac_pro, leaf_age_pro, PFTpresent_pro, senescence_pro, & |
|---|
| 1968 | gpp_daily_pro, npp_daily_pro, resp_maint_pro, resp_growth_pro, & |
|---|
| 1969 | resp_hetero_pro, co2_fire_pro, & |
|---|
| 1970 | veget_max, carbon, carbon_32l, DOC, & |
|---|
| 1971 | litter_above, litter_below, & |
|---|
| 1972 | lignin_struc_above, lignin_struc_below, bm_to_litter, & |
|---|
| 1973 | deepC_a, deepC_s, deepC_p, & |
|---|
| 1974 | fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 1975 | biomass, co2_to_bm, npp_longterm, ind, & |
|---|
| 1976 | lm_lastyearmax, age, everywhere, & |
|---|
| 1977 | leaf_frac, leaf_age, PFTpresent, senescence, & |
|---|
| 1978 | gpp_daily, npp_daily, resp_maint, resp_growth, & |
|---|
| 1979 | resp_hetero, co2_fire) |
|---|
| 1980 | |
|---|
| 1981 | ENDIF !IF ( glcc_mtc(ipts,ivma) .GT. min_stomate ) |
|---|
| 1982 | |
|---|
| 1983 | ENDDO |
|---|
| 1984 | ENDDO |
|---|
| 1985 | |
|---|
| 1986 | !! Update 10 year-turnover pool content following flux emission |
|---|
| 1987 | !! (linear decay (10%) of the initial carbon input) |
|---|
| 1988 | DO l = 0, 8 |
|---|
| 1989 | m = 10 - l |
|---|
| 1990 | cflux_prod10(:,:) = cflux_prod10(:,:) + flux10(:,m,:) |
|---|
| 1991 | prod10(:,m,:) = prod10(:,m-1,:) - flux10(:,m-1,:) |
|---|
| 1992 | flux10(:,m,:) = flux10(:,m-1,:) |
|---|
| 1993 | WHERE (prod10(:,m,:) .LT. 1.0) prod10(:,m,:) = zero |
|---|
| 1994 | ENDDO |
|---|
| 1995 | |
|---|
| 1996 | cflux_prod10(:,:) = cflux_prod10(:,:) + flux10(:,1,:) |
|---|
| 1997 | flux10(:,1,:) = 0.1 * prod10(:,0,:) |
|---|
| 1998 | prod10(:,1,:) = prod10(:,0,:) |
|---|
| 1999 | |
|---|
| 2000 | !! 2.4.3 update 100 year-turnover pool content following flux emission\n |
|---|
| 2001 | DO l = 0, 98 |
|---|
| 2002 | m = 100 - l |
|---|
| 2003 | cflux_prod100(:,:) = cflux_prod100(:,:) + flux100(:,m,:) |
|---|
| 2004 | prod100(:,m,:) = prod100(:,m-1,:) - flux100(:,m-1,:) |
|---|
| 2005 | flux100(:,m,:) = flux100(:,m-1,:) |
|---|
| 2006 | |
|---|
| 2007 | WHERE (prod100(:,m,:).LT.1.0) prod100(:,m,:) = zero |
|---|
| 2008 | ENDDO |
|---|
| 2009 | |
|---|
| 2010 | cflux_prod100(:,:) = cflux_prod100(:,:) + flux100(:,1,:) |
|---|
| 2011 | flux100(:,1,:) = 0.01 * prod100(:,0,:) |
|---|
| 2012 | prod100(:,1,:) = prod100(:,0,:) |
|---|
| 2013 | prod10(:,0,:) = zero |
|---|
| 2014 | prod100(:,0,:) = zero |
|---|
| 2015 | |
|---|
| 2016 | convflux = convflux/one_year*dt_days |
|---|
| 2017 | cflux_prod10 = cflux_prod10/one_year*dt_days |
|---|
| 2018 | cflux_prod100 = cflux_prod100/one_year*dt_days |
|---|
| 2019 | |
|---|
| 2020 | ! Write out history files |
|---|
| 2021 | CALL histwrite_p (hist_id_stomate, 'glcc_pft', itime, & |
|---|
| 2022 | glcc_pft, npts*nvm, horipft_index) |
|---|
| 2023 | |
|---|
| 2024 | glccReal_tmp(:,1:12) = glccReal |
|---|
| 2025 | CALL histwrite_p (hist_id_stomate, 'glccReal', itime, & |
|---|
| 2026 | glccReal_tmp, npts*nvm, horipft_index) |
|---|
| 2027 | |
|---|
| 2028 | ! Write out forestry harvest variables |
|---|
| 2029 | DO ipts = 1,npts |
|---|
| 2030 | DO ivm = 1,nvm |
|---|
| 2031 | DO ivma = 1,nvmap |
|---|
| 2032 | IF (is_tree(ivm) .AND. is_tree(start_index(ivma))) THEN |
|---|
| 2033 | glcc_harvest(ipts,ivm) = glcc_harvest(ipts,ivm) + glcc_pftmtc(ipts,ivm,ivma) |
|---|
| 2034 | ENDIF |
|---|
| 2035 | ENDDO |
|---|
| 2036 | ENDDO |
|---|
| 2037 | ENDDO |
|---|
| 2038 | CALL histwrite_p (hist_id_stomate, 'glcc_harvest', itime, & |
|---|
| 2039 | glcc_harvest, npts*nvm, horipft_index) |
|---|
| 2040 | |
|---|
| 2041 | glccReal_tmp(:,:) = zero |
|---|
| 2042 | glccReal_tmp(:,1:4) = IncreDeficit |
|---|
| 2043 | CALL histwrite_p (hist_id_stomate, 'IncreDeficit', itime, & |
|---|
| 2044 | glccReal_tmp, npts*nvm, horipft_index) |
|---|
| 2045 | |
|---|
| 2046 | glccReal_tmp(:,:) = zero |
|---|
| 2047 | glccReal_tmp(:,1) = Deficit_pf2yf_final |
|---|
| 2048 | glccReal_tmp(:,2) = Deficit_sf2yf_final |
|---|
| 2049 | glccReal_tmp(:,3) = pf2yf_compen_sf2yf |
|---|
| 2050 | glccReal_tmp(:,4) = sf2yf_compen_pf2yf |
|---|
| 2051 | |
|---|
| 2052 | CALL histwrite_p (hist_id_stomate, 'DefiComForHarvest', itime, & |
|---|
| 2053 | glccReal_tmp, npts*nvm, horipft_index) |
|---|
| 2054 | |
|---|
| 2055 | DO ivma = 1, nvmap |
|---|
| 2056 | WRITE(part_str,'(I2)') ivma |
|---|
| 2057 | IF (ivma < 10) part_str(1:1) = '0' |
|---|
| 2058 | CALL histwrite_p (hist_id_stomate, 'glcc_pftmtc_'//part_str(1:LEN_TRIM(part_str)), & |
|---|
| 2059 | itime, glcc_pftmtc(:,:,ivma), npts*nvm, horipft_index) |
|---|
| 2060 | ENDDO |
|---|
| 2061 | END SUBROUTINE gross_glcchange_fh |
|---|
| 2062 | |
|---|
| 2063 | |
|---|
| 2064 | ! ================================================================================================================================ |
|---|
| 2065 | !! SUBROUTINE : add_incoming_proxy_pft |
|---|
| 2066 | !! |
|---|
| 2067 | !>\BRIEF : Merge the newly incoming proxy PFT cohort with the exisiting |
|---|
| 2068 | !! cohort. |
|---|
| 2069 | !! \n |
|---|
| 2070 | ! |
|---|
| 2071 | !_ ================================================================================================================================ |
|---|
| 2072 | SUBROUTINE add_incoming_proxy_pft(npts, ipts, ipft, veget_max_pro, & |
|---|
| 2073 | carbon_pro, carbon_32l_pro, DOC_pro, litter_pro, & |
|---|
| 2074 | litter_above_pro, litter_below_pro, lignin_struc_above_pro, & |
|---|
| 2075 | lignin_struc_below_pro, & |
|---|
| 2076 | lignin_struc_pro, bm_to_litter_pro, & |
|---|
| 2077 | deepC_a_pro, deepC_s_pro, deepC_p_pro, & |
|---|
| 2078 | fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, fuel_1000hr_pro, & |
|---|
| 2079 | biomass_pro, co2_to_bm_pro, npp_longterm_pro, ind_pro, & |
|---|
| 2080 | lm_lastyearmax_pro, age_pro, everywhere_pro, & |
|---|
| 2081 | leaf_frac_pro, leaf_age_pro, PFTpresent_pro, senescence_pro, & |
|---|
| 2082 | gpp_daily_pro, npp_daily_pro, resp_maint_pro, resp_growth_pro, & |
|---|
| 2083 | resp_hetero_pro, co2_fire_pro, & |
|---|
| 2084 | veget_max, carbon, carbon_32l, DOC, & |
|---|
| 2085 | litter_above, litter_below, & |
|---|
| 2086 | lignin_struc_above, lignin_struc_below, bm_to_litter, & |
|---|
| 2087 | deepC_a, deepC_s, deepC_p, & |
|---|
| 2088 | fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 2089 | biomass, co2_to_bm, npp_longterm, ind, & |
|---|
| 2090 | lm_lastyearmax, age, everywhere, & |
|---|
| 2091 | leaf_frac, leaf_age, PFTpresent, senescence, & |
|---|
| 2092 | gpp_daily, npp_daily, resp_maint, resp_growth, & |
|---|
| 2093 | resp_hetero, co2_fire) |
|---|
| 2094 | |
|---|
| 2095 | IMPLICIT NONE |
|---|
| 2096 | |
|---|
| 2097 | !! 0.1 Input variables |
|---|
| 2098 | INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 2099 | INTEGER, INTENT(in) :: ipts !! Domain size - number of pixels (unitless) |
|---|
| 2100 | INTEGER, INTENT(in) :: ipft |
|---|
| 2101 | REAL(r_std), INTENT(in) :: veget_max_pro !! The land fraction of incoming new PFTs that are |
|---|
| 2102 | !! the sum of all its ancestor PFTs |
|---|
| 2103 | |
|---|
| 2104 | REAL(r_std), DIMENSION(:), INTENT(in) :: carbon_pro |
|---|
| 2105 | REAL(r_std), DIMENSION(:), INTENT(in) :: deepC_a_pro |
|---|
| 2106 | REAL(r_std), DIMENSION(:), INTENT(in) :: deepC_s_pro |
|---|
| 2107 | REAL(r_std), DIMENSION(:), INTENT(in) :: deepC_p_pro |
|---|
| 2108 | REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: litter_pro |
|---|
| 2109 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: carbon_32l_pro |
|---|
| 2110 | |
|---|
| 2111 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: DOC_pro |
|---|
| 2112 | |
|---|
| 2113 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: litter_above_pro |
|---|
| 2114 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: litter_below_pro |
|---|
| 2115 | REAL(r_std), INTENT(inout) :: lignin_struc_above_pro |
|---|
| 2116 | REAL(r_std), DIMENSION(:), INTENT(inout) :: lignin_struc_below_pro |
|---|
| 2117 | |
|---|
| 2118 | ! REAL(r_std), INTENT(out) :: lignin_content_above_pro |
|---|
| 2119 | ! REAL(r_std), DIMENSION(:), INTENT(out) :: lignin_content_below_pro |
|---|
| 2120 | ! |
|---|
| 2121 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: fuel_1hr_pro |
|---|
| 2122 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: fuel_10hr_pro |
|---|
| 2123 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: fuel_100hr_pro |
|---|
| 2124 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: fuel_1000hr_pro |
|---|
| 2125 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: bm_to_litter_pro |
|---|
| 2126 | REAL(r_std), DIMENSION(:), INTENT(in) :: lignin_struc_pro !! ratio Lignine/Carbon in structural litter |
|---|
| 2127 | !! above and below ground |
|---|
| 2128 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: biomass_pro !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 2129 | REAL(r_std), DIMENSION(:), INTENT(in) :: leaf_frac_pro !! fraction of leaves in leaf age class |
|---|
| 2130 | REAL(r_std), DIMENSION(:), INTENT(in) :: leaf_age_pro !! fraction of leaves in leaf age class |
|---|
| 2131 | REAL(r_std), INTENT(in) :: ind_pro, age_pro, lm_lastyearmax_pro |
|---|
| 2132 | REAL(r_std), INTENT(in) :: npp_longterm_pro, co2_to_bm_pro |
|---|
| 2133 | REAL(r_std), INTENT(in) :: everywhere_pro !! is the PFT everywhere in the grid box or very |
|---|
| 2134 | LOGICAL, INTENT(in) :: PFTpresent_pro, senescence_pro !! Is pft there (unitless) |
|---|
| 2135 | |
|---|
| 2136 | REAL(r_std), INTENT(in) :: gpp_daily_pro, npp_daily_pro |
|---|
| 2137 | REAL(r_std), INTENT(in) :: resp_maint_pro, resp_growth_pro |
|---|
| 2138 | REAL(r_std), INTENT(in) :: resp_hetero_pro, co2_fire_pro |
|---|
| 2139 | |
|---|
| 2140 | !! 0.2 Output variables |
|---|
| 2141 | |
|---|
| 2142 | !! 0.3 Modified variables |
|---|
| 2143 | |
|---|
| 2144 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: veget_max !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 2145 | !! May sum to |
|---|
| 2146 | !! less than unity if the pixel has |
|---|
| 2147 | !! nobio area. (unitless, 0-1) |
|---|
| 2148 | |
|---|
| 2149 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: carbon !! carbon pool: active, slow, or passive |
|---|
| 2150 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 2151 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: carbon_32l !! carbon pool: active, slow, or passive |
|---|
| 2152 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 2153 | REAL(r_std), DIMENSION(:,:,:,:,:,:), INTENT(inout) :: DOC !! carbon pool: active, slow, or passive |
|---|
| 2154 | |
|---|
| 2155 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_a !! Permafrost soil carbon (g/m**3) active |
|---|
| 2156 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_s !! Permafrost soil carbon (g/m**3) slow |
|---|
| 2157 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_p !! Permafrost soil carbon (g/m**3) passive |
|---|
| 2158 | REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements) :: litter !! metabolic and structural litter, above and |
|---|
| 2159 | !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 2160 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: litter_above !! metabolic and structural litter, above and |
|---|
| 2161 | !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 2162 | REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: litter_below !! metabolic and structural litter, above and |
|---|
| 2163 | !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 2164 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1hr |
|---|
| 2165 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_10hr |
|---|
| 2166 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_100hr |
|---|
| 2167 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1000hr |
|---|
| 2168 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: lignin_struc !! ratio Lignine/Carbon in structural litter, |
|---|
| 2169 | !! above and below ground |
|---|
| 2170 | REAL(r_std), DIMENSION(npts,nvm), INTENT(inout) :: lignin_struc_above !! Ratio of Lignin/Carbon in structural |
|---|
| 2171 | !! litter, above ground, |
|---|
| 2172 | !! @tex $(gC m^{-2})$ @endtex |
|---|
| 2173 | REAL(r_std), DIMENSION(npts,nvm,ndeep), INTENT(inout) :: lignin_struc_below !! Ratio of Lignin/Carbon in structural |
|---|
| 2174 | !! litter, below ground, |
|---|
| 2175 | |
|---|
| 2176 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: bm_to_litter !! Transfer of biomass to litter |
|---|
| 2177 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 2178 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: biomass !! Stand level biomass @tex $(gC.m^{-2})$ @endtex |
|---|
| 2179 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: co2_to_bm !! CO2 taken from the atmosphere to get C to create |
|---|
| 2180 | !! the seedlings @tex (gC.m^{-2}dt^{-1})$ @endtex |
|---|
| 2181 | |
|---|
| 2182 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_longterm !! "Long term" mean yearly primary productivity |
|---|
| 2183 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ind !! Number of individuals at the stand level |
|---|
| 2184 | !! @tex $(m^{-2})$ @endtex |
|---|
| 2185 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: age !! mean age (years) |
|---|
| 2186 | LOGICAL, DIMENSION(:,:), INTENT(inout) :: PFTpresent !! Tab indicating which PFTs are present in |
|---|
| 2187 | !! each pixel |
|---|
| 2188 | LOGICAL, DIMENSION(:,:), INTENT(inout) :: senescence !! Flag for setting senescence stage (only |
|---|
| 2189 | !! for deciduous trees) |
|---|
| 2190 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: lm_lastyearmax !! last year's maximum leaf mass for each PFT |
|---|
| 2191 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 2192 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: everywhere !! is the PFT everywhere in the grid box or |
|---|
| 2193 | !! very localized (after its introduction) (?) |
|---|
| 2194 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_frac !! fraction of leaves in leaf age class (unitless;0-1) |
|---|
| 2195 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_age !! Leaf age (days) |
|---|
| 2196 | |
|---|
| 2197 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_daily !! Daily gross primary productivity |
|---|
| 2198 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 2199 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_daily !! Net primary productivity |
|---|
| 2200 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 2201 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_maint !! Maintenance respiration |
|---|
| 2202 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 2203 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_growth !! Growth respiration |
|---|
| 2204 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 2205 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_hetero !! Heterotrophic respiration |
|---|
| 2206 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 2207 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: co2_fire !! Heterotrophic respiration |
|---|
| 2208 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 2209 | |
|---|
| 2210 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_month !! "Monthly" moisture availability (0 to 1, |
|---|
| 2211 | ! !! unitless) |
|---|
| 2212 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_week !! "Weekly" moisture availability |
|---|
| 2213 | ! !! (0 to 1, unitless) |
|---|
| 2214 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_week !! Mean weekly gross primary productivity |
|---|
| 2215 | ! !! @tex $(gC m^{-2} day^{-1})$ @endtex |
|---|
| 2216 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ngd_minus5 !! Number of growing days (days), threshold |
|---|
| 2217 | ! !! -5 deg C (for phenology) |
|---|
| 2218 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: when_growthinit !! How many days ago was the beginning of |
|---|
| 2219 | ! !! the growing season (days) |
|---|
| 2220 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: time_hum_min !! Time elapsed since strongest moisture |
|---|
| 2221 | ! !! availability (days) |
|---|
| 2222 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_midwinter !! Growing degree days (K), since midwinter |
|---|
| 2223 | ! !! (for phenology) - this is written to the |
|---|
| 2224 | ! !! history files |
|---|
| 2225 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_from_growthinit !! growing degree days, since growthinit |
|---|
| 2226 | ! !! for crops |
|---|
| 2227 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_m5_dormance !! Growing degree days (K), threshold -5 deg |
|---|
| 2228 | ! !! C (for phenology) |
|---|
| 2229 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ncd_dormance !! Number of chilling days (days), since |
|---|
| 2230 | ! !! leaves were lost (for phenology) |
|---|
| 2231 | |
|---|
| 2232 | !! 0.4 Local variables |
|---|
| 2233 | |
|---|
| 2234 | INTEGER(i_std) :: iele !! Indeces(unitless) |
|---|
| 2235 | INTEGER(i_std) :: ilit,ilev,icarb !! Indeces(unitless) |
|---|
| 2236 | REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements) :: litter_old !! metabolic and structural litter, above and |
|---|
| 2237 | !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 2238 | REAL(r_std), DIMENSION(npts,nlitt,nvm,nelements) :: litter_above_old !! metabolic and structural litter, above and |
|---|
| 2239 | REAL(r_std), DIMENSION(npts,nlitt,nvm,ndeep,nelements) :: litter_below_old !! metabolic and structural litter, above and |
|---|
| 2240 | |
|---|
| 2241 | REAL(r_std) :: veget_old,veget_total |
|---|
| 2242 | |
|---|
| 2243 | |
|---|
| 2244 | ! Back up some variables in case they're needed later |
|---|
| 2245 | litter_old(:,:,:,:,:) = litter(:,:,:,:,:) |
|---|
| 2246 | litter_above_old(:,:,:,:) = litter_above(:,:,:,:) |
|---|
| 2247 | litter_below_old(:,:,:,:,:) = litter_below(:,:,:,:,:) |
|---|
| 2248 | !! General idea |
|---|
| 2249 | ! The established proxy vegetation has a fraction of 'veget_max_pro'; the |
|---|
| 2250 | ! existing iPFT has a fraction of veget_max(ipts,ipft). |
|---|
| 2251 | ! Suppose we want to merge a scalar variable B, the value of B after merging |
|---|
| 2252 | ! is (Bi*Vi+Bj*Vj)/(Vi+Vj), where Vi is the original veget_max, Vj is the |
|---|
| 2253 | ! incoming veget_max. Note that in case Vi=0, this equation remains solid, |
|---|
| 2254 | ! i.e. the veget_max after merging is Vj and B after merging is Bj. In other |
|---|
| 2255 | ! words, the proxy vegetation "fills" up the empty niche of iPFT. |
|---|
| 2256 | ! Also note that for many scalar variables our input value is Bj*Vj, which |
|---|
| 2257 | ! is accumulated from multiple ancestor PFTs. |
|---|
| 2258 | veget_old = veget_max(ipts,ipft) |
|---|
| 2259 | veget_total = veget_old+veget_max_pro |
|---|
| 2260 | |
|---|
| 2261 | !! Different ways of handling merging depending on nature of variables: |
|---|
| 2262 | |
|---|
| 2263 | !! 1. Area-based scalar variables, use the equation above |
|---|
| 2264 | ! biomass,carbon, litter, bm_to_litter, co2_to_bm, ind, |
|---|
| 2265 | ! lm_lastyearmax, npp_longterm, lm_lastyearmax, |
|---|
| 2266 | ! lignin_struc (ratio variable depending on area-based variable) |
|---|
| 2267 | |
|---|
| 2268 | !! 2. Variables are tentatively handled like area-based variables: |
|---|
| 2269 | ! leaf_frac, leaf_age, |
|---|
| 2270 | |
|---|
| 2271 | !! 3. Variables that are overwritten by the newly initialized PFT: |
|---|
| 2272 | ! PFTpresent, senescence |
|---|
| 2273 | |
|---|
| 2274 | !! 4. Variables whose operation is uncertain and are not handled currently: |
|---|
| 2275 | ! when_growthinit :: how many days ago was the beginning of the growing season (days) |
|---|
| 2276 | ! gdd_from_growthinit :: growing degree days, since growthinit |
|---|
| 2277 | ! gdd_midwinter, time_hum_min, gdd_m5_dormance, ncd_dormance, |
|---|
| 2278 | ! moiavail_month, moiavail_week, ngd_minus5 |
|---|
| 2279 | |
|---|
| 2280 | !! 5. Variables that concern with short-term fluxes that do not apply in |
|---|
| 2281 | ! this case: |
|---|
| 2282 | ! gpp_daily, npp_daily etc. |
|---|
| 2283 | |
|---|
| 2284 | ! Add the coming veget_max_pro into existing veget_max |
|---|
| 2285 | veget_max(ipts,ipft) = veget_total |
|---|
| 2286 | |
|---|
| 2287 | ! Merge scalar variables which are defined on area basis |
|---|
| 2288 | carbon(ipts,:,ipft) = (veget_old * carbon(ipts,:,ipft) + & |
|---|
| 2289 | carbon_pro(:))/veget_total |
|---|
| 2290 | !!SIMON merge |
|---|
| 2291 | carbon_32l(ipts,:,ipft,:) = (veget_old * carbon_32l(ipts,:,ipft,:) + & |
|---|
| 2292 | carbon_32l_pro(:,:))/veget_total |
|---|
| 2293 | DOC(ipts,ipft,:,:,:,icarbon)=(veget_old *DOC(ipts,ipft,:,:,:,icarbon) + & |
|---|
| 2294 | DOC_pro(:,:,:))/veget_total |
|---|
| 2295 | deepC_a(ipts,:,ipft) = (veget_old * deepC_a(ipts,:,ipft) + & |
|---|
| 2296 | deepC_a_pro(:))/veget_total |
|---|
| 2297 | deepC_s(ipts,:,ipft) = (veget_old * deepC_s(ipts,:,ipft) + & |
|---|
| 2298 | deepC_s_pro(:))/veget_total |
|---|
| 2299 | deepC_p(ipts,:,ipft) = (veget_old * deepC_p(ipts,:,ipft) + & |
|---|
| 2300 | deepC_p_pro(:))/veget_total |
|---|
| 2301 | litter(ipts,:,ipft,:,:) = (veget_old * litter(ipts,:,ipft,:,:) + & |
|---|
| 2302 | litter_pro(:,:,:))/veget_total |
|---|
| 2303 | |
|---|
| 2304 | litter_above(ipts,:,ipft,:)=(veget_old * litter_above(ipts,:,ipft,:) + & |
|---|
| 2305 | litter_above_pro(:,:))/veget_total |
|---|
| 2306 | litter_below(ipts,:,ipft,:,:)=(veget_old * litter_below(ipts,:,ipft,:,:) + & |
|---|
| 2307 | litter_below_pro(:,:,:))/veget_total |
|---|
| 2308 | |
|---|
| 2309 | fuel_1hr(ipts,ipft,:,:) = (veget_old * fuel_1hr(ipts,ipft,:,:) + & |
|---|
| 2310 | fuel_1hr_pro(:,:))/veget_total |
|---|
| 2311 | fuel_10hr(ipts,ipft,:,:) = (veget_old * fuel_10hr(ipts,ipft,:,:) + & |
|---|
| 2312 | fuel_10hr_pro(:,:))/veget_total |
|---|
| 2313 | fuel_100hr(ipts,ipft,:,:) = (veget_old * fuel_100hr(ipts,ipft,:,:) + & |
|---|
| 2314 | fuel_100hr_pro(:,:))/veget_total |
|---|
| 2315 | fuel_1000hr(ipts,ipft,:,:) = (veget_old * fuel_1000hr(ipts,ipft,:,:) + & |
|---|
| 2316 | fuel_1000hr_pro(:,:))/veget_total |
|---|
| 2317 | |
|---|
| 2318 | ! WHERE (litter(ipts,istructural,ipft,:,icarbon) .GT. min_stomate) |
|---|
| 2319 | ! lignin_struc(ipts,ipft,:) = (veget_old*litter_old(ipts,istructural,ipft,:,icarbon)* & |
|---|
| 2320 | ! lignin_struc(ipts,ipft,:) + litter_pro(istructural,:,icarbon)* & |
|---|
| 2321 | ! lignin_struc_pro(:))/(veget_total*litter(ipts,istructural,ipft,:,icarbon)) |
|---|
| 2322 | ! ENDWHERE |
|---|
| 2323 | |
|---|
| 2324 | IF (litter_above(ipts,istructural,ipft,icarbon) .GT. min_stomate) THEN |
|---|
| 2325 | lignin_struc_above(ipts,ipft) = (veget_old*litter_above_old(ipts,istructural,ipft,icarbon)* & |
|---|
| 2326 | lignin_struc_above(ipts,ipft) + litter_above_pro(istructural,icarbon)* & |
|---|
| 2327 | lignin_struc_above_pro)/(veget_total*litter_above(ipts,istructural,ipft,icarbon)) |
|---|
| 2328 | ENDIF |
|---|
| 2329 | |
|---|
| 2330 | WHERE (litter_below(ipts,istructural,ipft,:,icarbon) .GT. min_stomate) |
|---|
| 2331 | lignin_struc_below(ipts,ipft,:) = (veget_old*litter_below_old(ipts,istructural,ipft,:,icarbon)* & |
|---|
| 2332 | lignin_struc_below(ipts,ipft,:) + litter_below_pro(istructural,:,icarbon)* & |
|---|
| 2333 | lignin_struc_below_pro(:))/(veget_total*litter_below(ipts,istructural,ipft,:,icarbon)) |
|---|
| 2334 | ENDWHERE |
|---|
| 2335 | |
|---|
| 2336 | !!Simon END |
|---|
| 2337 | bm_to_litter(ipts,ipft,:,:) = (veget_old * bm_to_litter(ipts,ipft,:,:) + & |
|---|
| 2338 | bm_to_litter_pro(:,:))/veget_total |
|---|
| 2339 | |
|---|
| 2340 | biomass(ipts,ipft,:,:) = (biomass(ipts,ipft,:,:)*veget_old + & |
|---|
| 2341 | biomass_pro(:,:))/veget_total |
|---|
| 2342 | co2_to_bm(ipts,ipft) = (veget_old*co2_to_bm(ipts,ipft) + & |
|---|
| 2343 | co2_to_bm_pro)/veget_total |
|---|
| 2344 | ind(ipts,ipft) = (ind(ipts,ipft)*veget_old + ind_pro)/veget_total |
|---|
| 2345 | lm_lastyearmax(ipts,ipft) = (lm_lastyearmax(ipts,ipft)*veget_old + & |
|---|
| 2346 | lm_lastyearmax_pro)/veget_total |
|---|
| 2347 | npp_longterm(ipts,ipft) = (veget_old * npp_longterm(ipts,ipft) + & |
|---|
| 2348 | npp_longterm_pro)/veget_total |
|---|
| 2349 | |
|---|
| 2350 | !CHECK: Here follows the original idea in DOFOCO, more strictly, |
|---|
| 2351 | ! leas mass should be considered together. The same also applies on |
|---|
| 2352 | ! leaf age. |
|---|
| 2353 | leaf_frac(ipts,ipft,:) = (leaf_frac(ipts,ipft,:)*veget_old + & |
|---|
| 2354 | leaf_frac_pro(:))/veget_total |
|---|
| 2355 | leaf_age(ipts,ipft,:) = (leaf_age(ipts,ipft,:)*veget_old + & |
|---|
| 2356 | leaf_age_pro(:))/veget_total |
|---|
| 2357 | age(ipts,ipft) = (veget_old * age(ipts,ipft) + & |
|---|
| 2358 | age_pro)/veget_total |
|---|
| 2359 | |
|---|
| 2360 | ! Everywhere deals with the migration of vegetation. Copy the |
|---|
| 2361 | ! status of the most migrated vegetation for the whole PFT |
|---|
| 2362 | everywhere(ipts,ipft) = MAX(everywhere(ipts,ipft), everywhere_pro) |
|---|
| 2363 | |
|---|
| 2364 | ! Overwrite the original variables with that from newly initialized |
|---|
| 2365 | ! proxy PFT |
|---|
| 2366 | PFTpresent(ipts,ipft) = PFTpresent_pro |
|---|
| 2367 | senescence(ipts,ipft) = senescence_pro |
|---|
| 2368 | |
|---|
| 2369 | ! This is to close carbon loop when writing history variables. |
|---|
| 2370 | gpp_daily(ipts,ipft) = (veget_old * gpp_daily(ipts,ipft) + & |
|---|
| 2371 | gpp_daily_pro)/veget_total |
|---|
| 2372 | npp_daily(ipts,ipft) = (veget_old * npp_daily(ipts,ipft) + & |
|---|
| 2373 | npp_daily_pro)/veget_total |
|---|
| 2374 | resp_maint(ipts,ipft) = (veget_old * resp_maint(ipts,ipft) + & |
|---|
| 2375 | resp_maint_pro)/veget_total |
|---|
| 2376 | resp_growth(ipts,ipft) = (veget_old * resp_growth(ipts,ipft) + & |
|---|
| 2377 | resp_growth_pro)/veget_total |
|---|
| 2378 | resp_hetero(ipts,ipft) = (veget_old * resp_hetero(ipts,ipft) + & |
|---|
| 2379 | resp_hetero_pro)/veget_total |
|---|
| 2380 | co2_fire(ipts,ipft) = (veget_old * co2_fire(ipts,ipft) + & |
|---|
| 2381 | co2_fire_pro)/veget_total |
|---|
| 2382 | |
|---|
| 2383 | ! Phenology- or time-related variables will be copied from original values if |
|---|
| 2384 | ! there is already youngest-age-class PFT there, otherwise they're left |
|---|
| 2385 | ! untouched, because 1. to initiliaze all new PFTs here is wrong and |
|---|
| 2386 | ! phenology is not explicitly considered, so we cannot assign a value |
|---|
| 2387 | ! to these variables. 2. We assume they will be correctly filled if |
|---|
| 2388 | ! other variables are in place (e.g., non-zero leaf mass will lead to |
|---|
| 2389 | ! onset of growing season). In this case, merging a newly initialized PFT |
|---|
| 2390 | ! to an existing one is not the same as merging PFTs when they grow |
|---|
| 2391 | ! old enough to exceed thresholds. |
|---|
| 2392 | |
|---|
| 2393 | ! gpp_week(ipts,ipft) = (veget_old * gpp_week(ipts,ipft) + & |
|---|
| 2394 | ! gpp_week_pro)/veget_total |
|---|
| 2395 | ! when_growthinit(ipts,ipft) = (veget_old * when_growthinit(ipts,ipft) + & |
|---|
| 2396 | ! when_growthinit_pro)/veget_total |
|---|
| 2397 | ! gdd_from_growthinit(ipts,ipft) = (veget_old * gdd_from_growthinit(ipts,ipft) + & |
|---|
| 2398 | ! gdd_from_growthinit_pro)/veget_total |
|---|
| 2399 | ! gdd_midwinter(ipts,ipft) = (veget_old * gdd_midwinter(ipts,ipft) + & |
|---|
| 2400 | ! gdd_midwinter_pro)/veget_total |
|---|
| 2401 | ! time_hum_min(ipts,ipft) = (veget_old * time_hum_min(ipts,ipft) + & |
|---|
| 2402 | ! time_hum_min_pro)/veget_total |
|---|
| 2403 | ! gdd_m5_dormance(ipts,ipft) = (veget_old * gdd_m5_dormance(ipts,ipft) + & |
|---|
| 2404 | ! gdd_m5_dormance_pro)/veget_total |
|---|
| 2405 | ! ncd_dormance(ipts,ipft) = (veget_old * ncd_dormance(ipts,ipft) + & |
|---|
| 2406 | ! ncd_dormance_pro)/veget_total |
|---|
| 2407 | ! moiavail_month(ipts,ipft) = (veget_old * moiavail_month(ipts,ipft) + & |
|---|
| 2408 | ! moiavail_month_pro)/veget_total |
|---|
| 2409 | ! moiavail_week(ipts,ipft) = (veget_old * moiavail_week(ipts,ipft) + & |
|---|
| 2410 | ! moiavail_week_pro)/veget_total |
|---|
| 2411 | ! ngd_minus5(ipts,ipft) = (veget_old * ngd_minus5(ipts,ipft) + & |
|---|
| 2412 | ! ngd_minus5_pro)/veget_total |
|---|
| 2413 | |
|---|
| 2414 | |
|---|
| 2415 | END SUBROUTINE add_incoming_proxy_pft |
|---|
| 2416 | |
|---|
| 2417 | |
|---|
| 2418 | ! ================================================================================================================================ |
|---|
| 2419 | !! SUBROUTINE : empty_pft |
|---|
| 2420 | !! |
|---|
| 2421 | !>\BRIEF : Empty a PFT when, |
|---|
| 2422 | !! - it is exhausted because of land cover change. |
|---|
| 2423 | !! - it moves to the next age class |
|---|
| 2424 | !! \n |
|---|
| 2425 | !_ ================================================================================================================================ |
|---|
| 2426 | SUBROUTINE empty_pft(ipts, ivm, veget_max, biomass, ind, & |
|---|
| 2427 | carbon, carbon_32l, DOC, litter_above, litter_below, & |
|---|
| 2428 | lignin_struc_above, lignin_struc_below, bm_to_litter, & |
|---|
| 2429 | deepC_a, deepC_s, deepC_p, & |
|---|
| 2430 | fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 2431 | gpp_daily, npp_daily, gpp_week, npp_longterm, & |
|---|
| 2432 | co2_to_bm, resp_maint, resp_growth, resp_hetero, & |
|---|
| 2433 | lm_lastyearmax, leaf_frac, leaf_age, age, & |
|---|
| 2434 | everywhere, PFTpresent, when_growthinit, & |
|---|
| 2435 | senescence, gdd_from_growthinit, gdd_midwinter, & |
|---|
| 2436 | time_hum_min, gdd_m5_dormance, ncd_dormance, & |
|---|
| 2437 | moiavail_month, moiavail_week, ngd_minus5) |
|---|
| 2438 | |
|---|
| 2439 | IMPLICIT NONE |
|---|
| 2440 | |
|---|
| 2441 | !! 0.1 Input variables |
|---|
| 2442 | ! INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 2443 | INTEGER, INTENT(in) :: ipts !! index for grid cell |
|---|
| 2444 | INTEGER, INTENT(in) :: ivm !! index for pft |
|---|
| 2445 | |
|---|
| 2446 | !! 0.2 Output variables |
|---|
| 2447 | |
|---|
| 2448 | !! 0.3 Modified variables |
|---|
| 2449 | |
|---|
| 2450 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: veget_max !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 2451 | !! May sum to |
|---|
| 2452 | !! less than unity if the pixel has |
|---|
| 2453 | !! nobio area. (unitless, 0-1) |
|---|
| 2454 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: biomass !! Stand level biomass @tex $(gC.m^{-2})$ @endtex |
|---|
| 2455 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ind !! Number of individuals at the stand level |
|---|
| 2456 | !! @tex $(m^{-2})$ @endtex |
|---|
| 2457 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: carbon !! carbon pool: active, slow, or passive |
|---|
| 2458 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 2459 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: carbon_32l !! carbon pool: active, slow, or passive |
|---|
| 2460 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 2461 | REAL(r_std), DIMENSION(:,:,:,:,:,:), INTENT(inout) :: DOC !! carbon pool: active, slow, or passive |
|---|
| 2462 | |
|---|
| 2463 | |
|---|
| 2464 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_a !! Permafrost soil carbon (g/m**3) active |
|---|
| 2465 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_s !! Permafrost soil carbon (g/m**3) slow |
|---|
| 2466 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_p !! Permafrost soil carbon (g/m**3) passive |
|---|
| 2467 | REAL(r_std), DIMENSION(ipts,nlitt,nvm,nlevs,nelements) :: litter !! metabolic and structural litter, above and |
|---|
| 2468 | !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 2469 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: litter_above !! metabolic and structural litter, above and |
|---|
| 2470 | !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 2471 | REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: litter_below !! metabolic and structural litter, above and |
|---|
| 2472 | !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 2473 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1hr |
|---|
| 2474 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_10hr |
|---|
| 2475 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_100hr |
|---|
| 2476 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1000hr |
|---|
| 2477 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: lignin_struc !! ratio Lignine/Carbon in structural litter, |
|---|
| 2478 | !! above and below ground |
|---|
| 2479 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: lignin_struc_above !! Ratio of Lignin/Carbon in structural |
|---|
| 2480 | !! litter, above ground, |
|---|
| 2481 | !! @tex $(gC m^{-2})$ @endtex |
|---|
| 2482 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: lignin_struc_below !! Ratio of Lignin/Carbon in structural |
|---|
| 2483 | !! litter, below ground, |
|---|
| 2484 | |
|---|
| 2485 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: bm_to_litter !! Transfer of biomass to litter |
|---|
| 2486 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 2487 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_daily !! Daily gross primary productivity |
|---|
| 2488 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 2489 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_daily !! Net primary productivity |
|---|
| 2490 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 2491 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_week !! Mean weekly gross primary productivity |
|---|
| 2492 | !! @tex $(gC m^{-2} day^{-1})$ @endtex |
|---|
| 2493 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_longterm !! "Long term" mean yearly primary productivity |
|---|
| 2494 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: co2_to_bm !! CO2 taken from the atmosphere to get C to create |
|---|
| 2495 | !! the seedlings @tex (gC.m^{-2}dt^{-1})$ @endtex |
|---|
| 2496 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_maint !! Maintenance respiration |
|---|
| 2497 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 2498 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_growth !! Growth respiration |
|---|
| 2499 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 2500 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_hetero !! Heterotrophic respiration |
|---|
| 2501 | !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 2502 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: lm_lastyearmax !! last year's maximum leaf mass for each PFT |
|---|
| 2503 | !! @tex ($gC m^{-2}$) @endtex |
|---|
| 2504 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_frac !! fraction of leaves in leaf age class (unitless;0-1) |
|---|
| 2505 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_age !! Leaf age (days) |
|---|
| 2506 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: age !! mean age (years) |
|---|
| 2507 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: everywhere !! is the PFT everywhere in the grid box or |
|---|
| 2508 | !! very localized (after its introduction) (?) |
|---|
| 2509 | LOGICAL, DIMENSION(:,:), INTENT(inout) :: PFTpresent !! Tab indicating which PFTs are present in |
|---|
| 2510 | !! each pixel |
|---|
| 2511 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: when_growthinit !! How many days ago was the beginning of |
|---|
| 2512 | !! the growing season (days) |
|---|
| 2513 | LOGICAL, DIMENSION(:,:), INTENT(inout) :: senescence !! Flag for setting senescence stage (only |
|---|
| 2514 | !! for deciduous trees) |
|---|
| 2515 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_from_growthinit !! growing degree days, since growthinit |
|---|
| 2516 | !! for crops |
|---|
| 2517 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_midwinter !! Growing degree days (K), since midwinter |
|---|
| 2518 | !! (for phenology) - this is written to the |
|---|
| 2519 | !! history files |
|---|
| 2520 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: time_hum_min !! Time elapsed since strongest moisture |
|---|
| 2521 | !! availability (days) |
|---|
| 2522 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_m5_dormance !! Growing degree days (K), threshold -5 deg |
|---|
| 2523 | !! C (for phenology) |
|---|
| 2524 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ncd_dormance !! Number of chilling days (days), since |
|---|
| 2525 | !! leaves were lost (for phenology) |
|---|
| 2526 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_month !! "Monthly" moisture availability (0 to 1, |
|---|
| 2527 | !! unitless) |
|---|
| 2528 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_week !! "Weekly" moisture availability |
|---|
| 2529 | !! (0 to 1, unitless) |
|---|
| 2530 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ngd_minus5 !! Number of growing days (days), threshold |
|---|
| 2531 | !! -5 deg C (for phenology) |
|---|
| 2532 | |
|---|
| 2533 | !! 0.4 Local variables |
|---|
| 2534 | INTEGER(i_std) :: iele !! Indeces(unitless) |
|---|
| 2535 | INTEGER(i_std) :: ilit,ilev,icarb !! Indeces(unitless) |
|---|
| 2536 | |
|---|
| 2537 | veget_max(ipts,ivm) = zero |
|---|
| 2538 | ind(ipts,ivm) = zero |
|---|
| 2539 | biomass(ipts,ivm,:,:) = zero |
|---|
| 2540 | litter(ipts,:,ivm,:,:) = zero |
|---|
| 2541 | litter_above(ipts,:,ivm,:) = zero |
|---|
| 2542 | litter_below(ipts,:,ivm,:,:) = zero |
|---|
| 2543 | fuel_1hr(ipts,ivm,:,:) = zero |
|---|
| 2544 | fuel_10hr(ipts,ivm,:,:) = zero |
|---|
| 2545 | fuel_100hr(ipts,ivm,:,:) = zero |
|---|
| 2546 | fuel_1000hr(ipts,ivm,:,:) = zero |
|---|
| 2547 | carbon(ipts,:,ivm) = zero |
|---|
| 2548 | carbon_32l(ipts,:,ivm,:) = zero |
|---|
| 2549 | DOC(ipts,ivm,:,:,:,icarbon) = zero |
|---|
| 2550 | deepC_a(ipts,:,ivm) = zero |
|---|
| 2551 | deepC_s(ipts,:,ivm) = zero |
|---|
| 2552 | deepC_p(ipts,:,ivm) = zero |
|---|
| 2553 | bm_to_litter(ipts,ivm,:,:) = zero |
|---|
| 2554 | |
|---|
| 2555 | !Simon added merge |
|---|
| 2556 | lignin_struc_above(ipts,ivm) = zero |
|---|
| 2557 | lignin_struc_below(ipts,ivm,:)=zero |
|---|
| 2558 | npp_longterm(ipts,ivm) = zero |
|---|
| 2559 | gpp_daily(ipts,ivm) = zero |
|---|
| 2560 | gpp_week(ipts,ivm) = zero |
|---|
| 2561 | resp_maint(ipts,ivm) = zero |
|---|
| 2562 | resp_growth(ipts,ivm) = zero |
|---|
| 2563 | resp_hetero(ipts,ivm) = zero |
|---|
| 2564 | npp_daily(ipts,ivm) = zero |
|---|
| 2565 | co2_to_bm(ipts,ivm) = zero |
|---|
| 2566 | lm_lastyearmax(ipts,ivm) = zero |
|---|
| 2567 | age(ipts,ivm) = zero |
|---|
| 2568 | leaf_frac(ipts,ivm,:) = zero |
|---|
| 2569 | leaf_age(ipts,ivm,:) = zero |
|---|
| 2570 | everywhere(ipts,ivm) = zero |
|---|
| 2571 | when_growthinit(ipts,ivm) = zero |
|---|
| 2572 | gdd_from_growthinit(ipts,ivm) = zero |
|---|
| 2573 | gdd_midwinter(ipts,ivm) = zero |
|---|
| 2574 | time_hum_min(ipts,ivm) = zero |
|---|
| 2575 | gdd_m5_dormance(ipts,ivm) = zero |
|---|
| 2576 | ncd_dormance(ipts,ivm) = zero |
|---|
| 2577 | moiavail_month(ipts,ivm) = zero |
|---|
| 2578 | moiavail_week(ipts,ivm) = zero |
|---|
| 2579 | ngd_minus5(ipts,ivm) = zero |
|---|
| 2580 | PFTpresent(ipts,ivm) = .FALSE. |
|---|
| 2581 | senescence(ipts,ivm) = .FALSE. |
|---|
| 2582 | |
|---|
| 2583 | END SUBROUTINE empty_pft |
|---|
| 2584 | |
|---|
| 2585 | ! ================================================================================================================================ |
|---|
| 2586 | !! SUBROUTINE : gross_lcc_firstday |
|---|
| 2587 | !! |
|---|
| 2588 | !>\BRIEF : When necessary, adjust input glcc matrix, and allocate it |
|---|
| 2589 | !! into different contributing age classes and receiving |
|---|
| 2590 | !! youngest age classes. |
|---|
| 2591 | !! \n |
|---|
| 2592 | !_ ================================================================================================================================ |
|---|
| 2593 | |
|---|
| 2594 | ! Note: it has this name because this subroutine will also be called |
|---|
| 2595 | ! the first day of each year to precalculate the forest loss for the |
|---|
| 2596 | ! deforestation fire module. |
|---|
| 2597 | SUBROUTINE gross_glcc_firstday_fh(npts,veget_max_org,harvest_matrix, & |
|---|
| 2598 | glccSecondShift,glccPrimaryShift,glccNetLCC,& |
|---|
| 2599 | glccReal,glcc_pft,glcc_pftmtc,IncreDeficit, & |
|---|
| 2600 | Deficit_pf2yf_final, Deficit_sf2yf_final, & |
|---|
| 2601 | pf2yf_compen_sf2yf, sf2yf_compen_pf2yf) |
|---|
| 2602 | |
|---|
| 2603 | IMPLICIT NONE |
|---|
| 2604 | |
|---|
| 2605 | !! 0.1 Input variables |
|---|
| 2606 | |
|---|
| 2607 | INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 2608 | REAL(r_std), DIMENSION(npts,nvm), INTENT(in) :: veget_max_org !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 2609 | !! May sum to |
|---|
| 2610 | !! less than unity if the pixel has |
|---|
| 2611 | !! nobio area. (unitless, 0-1) |
|---|
| 2612 | REAL(r_std), DIMENSION(npts,12),INTENT(in) :: harvest_matrix !! |
|---|
| 2613 | !! |
|---|
| 2614 | REAL(r_std), DIMENSION (npts,12),INTENT(in) :: glccSecondShift !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 2615 | !! used. |
|---|
| 2616 | REAL(r_std), DIMENSION (npts,12),INTENT(in) :: glccPrimaryShift !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 2617 | !! used. |
|---|
| 2618 | REAL(r_std), DIMENSION (npts,12),INTENT(in) :: glccNetLCC !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 2619 | !! used. |
|---|
| 2620 | |
|---|
| 2621 | !! 0.2 Output variables |
|---|
| 2622 | REAL(r_std), DIMENSION(npts,nvm,nvmap), INTENT(inout) :: glcc_pftmtc !! a temporary variable to hold the fractions each PFT is going to lose |
|---|
| 2623 | REAL(r_std), DIMENSION(npts,nvm), INTENT(inout) :: glcc_pft !! Loss of fraction in each PFT |
|---|
| 2624 | REAL(r_std), DIMENSION(npts,12), INTENT(inout) :: glccReal !! The "real" glcc matrix that we apply in the model |
|---|
| 2625 | !! after considering the consistency between presribed |
|---|
| 2626 | !! glcc matrix and existing vegetation fractions. |
|---|
| 2627 | REAL(r_std), DIMENSION(npts,4), INTENT(inout) :: IncreDeficit !! "Increment" deficits, negative values mean that |
|---|
| 2628 | !! there are not enough fractions in the source PFTs |
|---|
| 2629 | !! /vegetations to target PFTs/vegetations. I.e., these |
|---|
| 2630 | !! fraction transfers are presribed in LCC matrix but |
|---|
| 2631 | !! not realized. |
|---|
| 2632 | REAL(r_std), DIMENSION(npts), INTENT(inout) :: Deficit_pf2yf_final !! |
|---|
| 2633 | REAL(r_std), DIMENSION(npts), INTENT(inout) :: Deficit_sf2yf_final !! |
|---|
| 2634 | REAL(r_std), DIMENSION(npts), INTENT(inout) :: pf2yf_compen_sf2yf !! |
|---|
| 2635 | REAL(r_std), DIMENSION(npts), INTENT(inout) :: sf2yf_compen_pf2yf !! |
|---|
| 2636 | |
|---|
| 2637 | |
|---|
| 2638 | !! 0.3 Modified variables |
|---|
| 2639 | |
|---|
| 2640 | !! 0.4 Local variables |
|---|
| 2641 | REAL(r_std), DIMENSION (npts,12) :: glcc !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 2642 | !! used. |
|---|
| 2643 | REAL(r_std), DIMENSION(npts,nvmap) :: veget_mtc !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 2644 | REAL(r_std), DIMENSION(npts,nagec_tree) :: vegagec_tree !! fraction of tree age-class groups, in sequence of old->young |
|---|
| 2645 | REAL(r_std), DIMENSION(npts,nagec_herb) :: vegagec_grass !! fraction of grass age-class groups, in sequence of old->young |
|---|
| 2646 | REAL(r_std), DIMENSION(npts,nagec_herb) :: vegagec_pasture !! fraction of pasture age-class groups, in sequence of old->young |
|---|
| 2647 | REAL(r_std), DIMENSION(npts,nagec_herb) :: vegagec_crop !! fraction of crop age-class groups, in sequence of old->young |
|---|
| 2648 | |
|---|
| 2649 | |
|---|
| 2650 | REAL(r_std), DIMENSION(npts,4) :: veget_4veg !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 2651 | REAL(r_std), DIMENSION(npts) :: veget_tree !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 2652 | REAL(r_std), DIMENSION(npts) :: veget_grass !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 2653 | REAL(r_std), DIMENSION(npts) :: veget_pasture !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 2654 | REAL(r_std), DIMENSION(npts) :: veget_crop !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 2655 | |
|---|
| 2656 | REAL(r_std), DIMENSION(npts,nvm) :: veget_max !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 2657 | REAL(r_std), DIMENSION(npts,nvm) :: veget_max_tmp !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 2658 | REAL(r_std), DIMENSION(npts,nvm) :: veget_max_old !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 2659 | REAL(r_std), DIMENSION(npts,nvm) :: glcc_pft_tmp !! Loss of fraction in each PFT |
|---|
| 2660 | |
|---|
| 2661 | ! Different indexes for convenient local uses |
|---|
| 2662 | ! We define the rules for gross land cover change matrix: |
|---|
| 2663 | ! 1 forest->grass |
|---|
| 2664 | ! 2 forest->pasture |
|---|
| 2665 | ! 3 forest->crop |
|---|
| 2666 | ! 4 grass->forest |
|---|
| 2667 | ! 5 grass->pasture |
|---|
| 2668 | ! 6 grass->crop |
|---|
| 2669 | ! 7 pasture->forest |
|---|
| 2670 | ! 8 pasture->grass |
|---|
| 2671 | ! 9 pasture->crop |
|---|
| 2672 | ! 10 crop->forest |
|---|
| 2673 | ! 11 crop->grass |
|---|
| 2674 | ! 12 crop->pasture |
|---|
| 2675 | INTEGER :: f2g=1, f2p=2, f2c=3 |
|---|
| 2676 | INTEGER :: g2f=4, g2p=5, g2c=6, p2f=7, p2g=8, p2c=9, c2f=10, c2g=11, c2p=12 |
|---|
| 2677 | |
|---|
| 2678 | INTEGER, ALLOCATABLE :: indall_tree(:) !! Indices for all tree PFTs |
|---|
| 2679 | INTEGER, ALLOCATABLE :: indold_tree(:) !! Indices for old tree cohort only |
|---|
| 2680 | INTEGER, ALLOCATABLE :: indagec_tree(:,:) !! Indices for secondary tree cohorts, |
|---|
| 2681 | !! note the sequence is old->young. |
|---|
| 2682 | INTEGER, ALLOCATABLE :: indall_grass(:) !! Indices for all grass PFTs |
|---|
| 2683 | INTEGER, ALLOCATABLE :: indold_grass(:) !! Indices for old grasses only |
|---|
| 2684 | INTEGER, ALLOCATABLE :: indagec_grass(:,:) !! Indices for secondary grass cohorts |
|---|
| 2685 | !! note the sequence is old->young. |
|---|
| 2686 | INTEGER, ALLOCATABLE :: indall_pasture(:) !! Indices for all pasture PFTs |
|---|
| 2687 | INTEGER, ALLOCATABLE :: indold_pasture(:) !! Indices for old pasture only |
|---|
| 2688 | INTEGER, ALLOCATABLE :: indagec_pasture(:,:) !! Indices for secondary pasture cohorts |
|---|
| 2689 | !! note the sequence is old->young. |
|---|
| 2690 | INTEGER, ALLOCATABLE :: indall_crop(:) !! Indices for all crop PFTs |
|---|
| 2691 | INTEGER, ALLOCATABLE :: indold_crop(:) !! Indices for old crops only |
|---|
| 2692 | INTEGER, ALLOCATABLE :: indagec_crop(:,:) !! Indices for secondary crop cohorts |
|---|
| 2693 | !! note the sequence is old->young. |
|---|
| 2694 | INTEGER :: num_tree_sinagec,num_tree_mulagec,num_grass_sinagec,num_grass_mulagec, & |
|---|
| 2695 | num_pasture_sinagec,num_pasture_mulagec,num_crop_sinagec,num_crop_mulagec, & |
|---|
| 2696 | itree,itree2,igrass,igrass2,ipasture,ipasture2,icrop,icrop2,pf2yf,sf2yf |
|---|
| 2697 | INTEGER :: i,j,ivma,staind,endind,ivm |
|---|
| 2698 | |
|---|
| 2699 | |
|---|
| 2700 | REAL(r_std), DIMENSION(npts,12) :: glccDef !! Gross LCC deficit, negative values mean that there |
|---|
| 2701 | !! are not enough fractions in the source vegetations |
|---|
| 2702 | !! to the target ones as presribed by the LCC matrix. |
|---|
| 2703 | REAL(r_std), DIMENSION(npts) :: Deficit_pf2yf !! |
|---|
| 2704 | REAL(r_std), DIMENSION(npts) :: Deficit_sf2yf !! |
|---|
| 2705 | REAL(r_std), DIMENSION(npts) :: Surplus_pf2yf !! |
|---|
| 2706 | REAL(r_std), DIMENSION(npts) :: Surplus_sf2yf !! |
|---|
| 2707 | REAL(r_std), DIMENSION(npts,12) :: HmatrixReal !! |
|---|
| 2708 | INTEGER :: ipts |
|---|
| 2709 | |
|---|
| 2710 | |
|---|
| 2711 | !! 1. We first build all different indices that we are going to use |
|---|
| 2712 | !! in handling the PFT exchanges, three types of indices are built: |
|---|
| 2713 | !! - for all age classes |
|---|
| 2714 | !! - include only oldest age classes |
|---|
| 2715 | !! - include all age classes excpet the oldest ones |
|---|
| 2716 | ! We have to build these indices because we would like to extract from |
|---|
| 2717 | ! donating PFTs in the sequnce of old->young age classes, and add in the |
|---|
| 2718 | ! receving PFTs only in the youngest-age-class PFTs. These indicies allow |
|---|
| 2719 | ! us to know where the different age classes are. |
|---|
| 2720 | |
|---|
| 2721 | num_tree_sinagec=0 ! number of tree PFTs with only one single age class |
|---|
| 2722 | ! considered as the oldest age class |
|---|
| 2723 | num_tree_mulagec=0 ! number of tree PFTs having multiple age classes |
|---|
| 2724 | num_grass_sinagec=0 |
|---|
| 2725 | num_grass_mulagec=0 |
|---|
| 2726 | num_pasture_sinagec=0 |
|---|
| 2727 | num_pasture_mulagec=0 |
|---|
| 2728 | num_crop_sinagec=0 |
|---|
| 2729 | num_crop_mulagec=0 |
|---|
| 2730 | |
|---|
| 2731 | !! 1.1 Calculate the number of PFTs for different MTCs and allocate |
|---|
| 2732 | !! the old and all indices arrays. |
|---|
| 2733 | |
|---|
| 2734 | ! [Note here the sequence to identify tree,pasture,grass,crop] is |
|---|
| 2735 | ! critical. The similar sequence is used in the subroutine "calc_cover". |
|---|
| 2736 | ! Do not forget to change the sequence there if you modify here. |
|---|
| 2737 | DO ivma =2,nvmap |
|---|
| 2738 | staind=start_index(ivma) |
|---|
| 2739 | IF (nagec_pft(ivma)==1) THEN |
|---|
| 2740 | IF (is_tree(staind)) THEN |
|---|
| 2741 | num_tree_sinagec = num_tree_sinagec+1 |
|---|
| 2742 | ELSE IF (is_grassland_manag(staind)) THEN |
|---|
| 2743 | num_pasture_sinagec = num_pasture_sinagec+1 |
|---|
| 2744 | ELSE IF (natural(staind)) THEN |
|---|
| 2745 | num_grass_sinagec = num_grass_sinagec+1 |
|---|
| 2746 | ELSE |
|---|
| 2747 | num_crop_sinagec = num_crop_sinagec+1 |
|---|
| 2748 | ENDIF |
|---|
| 2749 | |
|---|
| 2750 | ELSE |
|---|
| 2751 | IF (is_tree(staind)) THEN |
|---|
| 2752 | num_tree_mulagec = num_tree_mulagec+1 |
|---|
| 2753 | ELSE IF (is_grassland_manag(staind)) THEN |
|---|
| 2754 | num_pasture_mulagec = num_pasture_mulagec+1 |
|---|
| 2755 | ELSE IF (natural(staind)) THEN |
|---|
| 2756 | num_grass_mulagec = num_grass_mulagec+1 |
|---|
| 2757 | ELSE |
|---|
| 2758 | num_crop_mulagec = num_crop_mulagec+1 |
|---|
| 2759 | ENDIF |
|---|
| 2760 | ENDIF |
|---|
| 2761 | ENDDO |
|---|
| 2762 | |
|---|
| 2763 | !! Allocate index array |
|---|
| 2764 | ! allocate all index |
|---|
| 2765 | ALLOCATE(indall_tree(num_tree_sinagec+num_tree_mulagec*nagec_tree)) |
|---|
| 2766 | ALLOCATE(indall_grass(num_grass_sinagec+num_grass_mulagec*nagec_herb)) |
|---|
| 2767 | ALLOCATE(indall_pasture(num_pasture_sinagec+num_pasture_mulagec*nagec_herb)) |
|---|
| 2768 | ALLOCATE(indall_crop(num_crop_sinagec+num_crop_mulagec*nagec_herb)) |
|---|
| 2769 | |
|---|
| 2770 | ! allocate old-ageclass index |
|---|
| 2771 | ALLOCATE(indold_tree(num_tree_sinagec+num_tree_mulagec)) |
|---|
| 2772 | ALLOCATE(indold_grass(num_grass_sinagec+num_grass_mulagec)) |
|---|
| 2773 | ALLOCATE(indold_pasture(num_pasture_sinagec+num_pasture_mulagec)) |
|---|
| 2774 | ALLOCATE(indold_crop(num_crop_sinagec+num_crop_mulagec)) |
|---|
| 2775 | |
|---|
| 2776 | !! 1.2 Fill the oldest-age-class and all index arrays |
|---|
| 2777 | itree=0 |
|---|
| 2778 | igrass=0 |
|---|
| 2779 | ipasture=0 |
|---|
| 2780 | icrop=0 |
|---|
| 2781 | itree2=1 |
|---|
| 2782 | igrass2=1 |
|---|
| 2783 | ipasture2=1 |
|---|
| 2784 | icrop2=1 |
|---|
| 2785 | DO ivma =2,nvmap |
|---|
| 2786 | staind=start_index(ivma) |
|---|
| 2787 | IF (is_tree(staind)) THEN |
|---|
| 2788 | itree=itree+1 |
|---|
| 2789 | indold_tree(itree) = staind+nagec_pft(ivma)-1 |
|---|
| 2790 | DO j = 0,nagec_pft(ivma)-1 |
|---|
| 2791 | indall_tree(itree2+j) = staind+j |
|---|
| 2792 | ENDDO |
|---|
| 2793 | itree2=itree2+nagec_pft(ivma) |
|---|
| 2794 | ELSE IF (natural(staind) .AND. .NOT. is_grassland_manag(staind)) THEN |
|---|
| 2795 | igrass=igrass+1 |
|---|
| 2796 | indold_grass(igrass) = staind+nagec_pft(ivma)-1 |
|---|
| 2797 | DO j = 0,nagec_pft(ivma)-1 |
|---|
| 2798 | indall_grass(igrass2+j) = staind+j |
|---|
| 2799 | ENDDO |
|---|
| 2800 | igrass2=igrass2+nagec_pft(ivma) |
|---|
| 2801 | ELSE IF (is_grassland_manag(staind)) THEN |
|---|
| 2802 | ipasture = ipasture+1 |
|---|
| 2803 | indold_pasture(ipasture) = staind+nagec_pft(ivma)-1 |
|---|
| 2804 | DO j = 0,nagec_pft(ivma)-1 |
|---|
| 2805 | indall_pasture(ipasture2+j) = staind+j |
|---|
| 2806 | ENDDO |
|---|
| 2807 | ipasture2=ipasture2+nagec_pft(ivma) |
|---|
| 2808 | ELSE |
|---|
| 2809 | icrop = icrop+1 |
|---|
| 2810 | indold_crop(icrop) = staind+nagec_pft(ivma)-1 |
|---|
| 2811 | DO j = 0,nagec_pft(ivma)-1 |
|---|
| 2812 | indall_crop(icrop2+j) = staind+j |
|---|
| 2813 | ENDDO |
|---|
| 2814 | icrop2=icrop2+nagec_pft(ivma) |
|---|
| 2815 | ENDIF |
|---|
| 2816 | ENDDO |
|---|
| 2817 | |
|---|
| 2818 | !! 1.3 Allocate and fill other age class index |
|---|
| 2819 | |
|---|
| 2820 | ! [chaoyuejoy@gmail.com 2015-08-05] |
|---|
| 2821 | ! note that we treat the case of (num_tree_mulagec==0) differently. In this |
|---|
| 2822 | ! case there is no distinction of age groups among tree PFTs. But we still |
|---|
| 2823 | ! we want to use the "gross_lcchange" subroutine. In this case we consider |
|---|
| 2824 | ! them as having a single age group. In the subroutines |
|---|
| 2825 | ! of "type_conversion" and "cross_give_receive", only the youngest-age-group |
|---|
| 2826 | ! PFTs of a given MTC or vegetation type could receive the incoming fractions. |
|---|
| 2827 | ! To be able to handle this case with least amount of code change, we assign the index |
|---|
| 2828 | ! of PFT between youngest and second-oldes (i.e., indagec_tree etc) the same as |
|---|
| 2829 | ! those of oldest tree PFTs (or all tree PFTs because in this cases these two indices |
|---|
| 2830 | ! are identical) . So that this case could be correctly handled in the subrountines |
|---|
| 2831 | ! of "type_conversion" and "cross_give_receive". This treatment allows use |
|---|
| 2832 | ! of gross land cover change subroutine with only one single age class. This single |
|---|
| 2833 | ! age class is "simultanously the oldest and youngest age class". At the same |
|---|
| 2834 | ! time, we also change the num_tree_mulagec as the same of num_crop_sinagec. |
|---|
| 2835 | ! The similar case also applies in grass,pasture and crop. |
|---|
| 2836 | |
|---|
| 2837 | IF (num_tree_mulagec .EQ. 0) THEN |
|---|
| 2838 | ALLOCATE(indagec_tree(num_tree_sinagec,1)) |
|---|
| 2839 | indagec_tree(:,1) = indall_tree(:) |
|---|
| 2840 | num_tree_mulagec = num_tree_sinagec |
|---|
| 2841 | ELSE |
|---|
| 2842 | ALLOCATE(indagec_tree(num_tree_mulagec,nagec_tree-1)) |
|---|
| 2843 | END IF |
|---|
| 2844 | |
|---|
| 2845 | IF (num_grass_mulagec .EQ. 0) THEN |
|---|
| 2846 | ALLOCATE(indagec_grass(num_grass_sinagec,1)) |
|---|
| 2847 | indagec_grass(:,1) = indall_grass(:) |
|---|
| 2848 | num_grass_mulagec = num_grass_sinagec |
|---|
| 2849 | ELSE |
|---|
| 2850 | ALLOCATE(indagec_grass(num_grass_mulagec,nagec_herb-1)) |
|---|
| 2851 | END IF |
|---|
| 2852 | |
|---|
| 2853 | IF (num_pasture_mulagec .EQ. 0) THEN |
|---|
| 2854 | ALLOCATE(indagec_pasture(num_pasture_sinagec,1)) |
|---|
| 2855 | indagec_pasture(:,1) = indall_pasture(:) |
|---|
| 2856 | num_pasture_mulagec = num_pasture_sinagec |
|---|
| 2857 | ELSE |
|---|
| 2858 | ALLOCATE(indagec_pasture(num_pasture_mulagec,nagec_herb-1)) |
|---|
| 2859 | END IF |
|---|
| 2860 | |
|---|
| 2861 | IF (num_crop_mulagec .EQ. 0) THEN |
|---|
| 2862 | ALLOCATE(indagec_crop(num_crop_sinagec,1)) |
|---|
| 2863 | indagec_crop(:,1) = indall_crop(:) |
|---|
| 2864 | num_crop_mulagec = num_crop_sinagec |
|---|
| 2865 | ELSE |
|---|
| 2866 | ALLOCATE(indagec_crop(num_crop_mulagec,nagec_herb-1)) |
|---|
| 2867 | END IF |
|---|
| 2868 | |
|---|
| 2869 | ! fill the non-oldest age class index arrays when number of age classes |
|---|
| 2870 | ! is more than 1. |
|---|
| 2871 | ! [chaoyuejoy@gmail.com, 2015-08-05] |
|---|
| 2872 | ! Note the corresponding part of code will be automatically skipped |
|---|
| 2873 | ! when nagec_tree ==1 and/or nagec_herb ==1, i.e., the assginment |
|---|
| 2874 | ! in above codes when original num_*_mulagec variables are zero will be retained. |
|---|
| 2875 | itree=0 |
|---|
| 2876 | igrass=0 |
|---|
| 2877 | ipasture=0 |
|---|
| 2878 | icrop=0 |
|---|
| 2879 | DO ivma = 2,nvmap |
|---|
| 2880 | staind=start_index(ivma) |
|---|
| 2881 | IF (nagec_pft(ivma) > 1) THEN |
|---|
| 2882 | IF (is_tree(staind)) THEN |
|---|
| 2883 | itree=itree+1 |
|---|
| 2884 | DO j = 1,nagec_tree-1 |
|---|
| 2885 | indagec_tree(itree,j) = staind+nagec_tree-j-1 |
|---|
| 2886 | ENDDO |
|---|
| 2887 | ELSE IF (natural(staind) .AND. .NOT. is_grassland_manag(staind)) THEN |
|---|
| 2888 | igrass=igrass+1 |
|---|
| 2889 | DO j = 1,nagec_herb-1 |
|---|
| 2890 | indagec_grass(igrass,j) = staind+nagec_herb-j-1 |
|---|
| 2891 | ENDDO |
|---|
| 2892 | ELSE IF (is_grassland_manag(staind)) THEN |
|---|
| 2893 | ipasture=ipasture+1 |
|---|
| 2894 | DO j = 1,nagec_herb-1 |
|---|
| 2895 | indagec_pasture(ipasture,j) = staind+nagec_herb-j-1 |
|---|
| 2896 | ENDDO |
|---|
| 2897 | ELSE |
|---|
| 2898 | icrop=icrop+1 |
|---|
| 2899 | DO j = 1,nagec_herb-1 |
|---|
| 2900 | indagec_crop(icrop,j) = staind+nagec_herb-j-1 |
|---|
| 2901 | ENDDO |
|---|
| 2902 | ENDIF |
|---|
| 2903 | ENDIF |
|---|
| 2904 | ENDDO |
|---|
| 2905 | |
|---|
| 2906 | |
|---|
| 2907 | ! we make copies of original input veget_max |
|---|
| 2908 | ! veget_max will be modified through different operations in order to |
|---|
| 2909 | ! check various purposes, e.g., whether input glcc is compatible with |
|---|
| 2910 | ! existing veget_max and how to allocate it etc. |
|---|
| 2911 | ! veget_max_old will not be modified |
|---|
| 2912 | veget_max(:,:) = veget_max_org(:,:) |
|---|
| 2913 | veget_max_old(:,:) = veget_max_org(:,:) |
|---|
| 2914 | |
|---|
| 2915 | !! 2. Calcuate the fractions covered by tree, grass, pasture and crops |
|---|
| 2916 | !! for each age class |
|---|
| 2917 | |
|---|
| 2918 | !************************************************************************! |
|---|
| 2919 | !****block to calculate fractions for basic veg types and age classes ***! |
|---|
| 2920 | ! Note: |
|---|
| 2921 | ! 1. "calc_cover" subroutine does not depend on how many age classes |
|---|
| 2922 | ! there are in each MTC. |
|---|
| 2923 | ! 2. Fraction of baresoil is excluded here. This means transformation |
|---|
| 2924 | ! of baresoil to a vegetated PFT is excluded in gross land cover change. |
|---|
| 2925 | veget_mtc(:,:) = 0. |
|---|
| 2926 | vegagec_tree(:,:) = 0. |
|---|
| 2927 | vegagec_grass(:,:) = 0. |
|---|
| 2928 | vegagec_pasture(:,:) = 0. |
|---|
| 2929 | vegagec_crop(:,:) = 0. |
|---|
| 2930 | |
|---|
| 2931 | |
|---|
| 2932 | CALL calc_cover(npts,veget_max,veget_mtc,vegagec_tree,vegagec_grass, & |
|---|
| 2933 | vegagec_pasture,vegagec_crop) |
|---|
| 2934 | |
|---|
| 2935 | veget_tree(:) = SUM(vegagec_tree(:,:),DIM=2) |
|---|
| 2936 | veget_grass(:) = SUM(vegagec_grass(:,:),DIM=2) |
|---|
| 2937 | veget_pasture(:) = SUM(vegagec_pasture(:,:),DIM=2) |
|---|
| 2938 | veget_crop(:) = SUM(vegagec_crop(:,:),DIM=2) |
|---|
| 2939 | itree=1 |
|---|
| 2940 | igrass=2 |
|---|
| 2941 | ipasture=3 |
|---|
| 2942 | icrop=4 |
|---|
| 2943 | veget_4veg(:,itree) = veget_tree(:) |
|---|
| 2944 | veget_4veg(:,igrass) = veget_grass(:) |
|---|
| 2945 | veget_4veg(:,ipasture) = veget_pasture(:) |
|---|
| 2946 | veget_4veg(:,icrop) = veget_crop(:) |
|---|
| 2947 | !****end block to calculate fractions for basic veg types and age classes ***! |
|---|
| 2948 | !****************************************************************************! |
|---|
| 2949 | |
|---|
| 2950 | !********************** block to handle forestry harvest **************** |
|---|
| 2951 | !! 2B. Here we handle the forestry wood harvest |
|---|
| 2952 | ! Rules: |
|---|
| 2953 | ! 1. We take first from second oldest forest, then oldest forest |
|---|
| 2954 | |
|---|
| 2955 | pf2yf=1 !primary to young forest conversion because of harvest |
|---|
| 2956 | sf2yf=2 !old secondary to young forest conversion because of harvest |
|---|
| 2957 | |
|---|
| 2958 | !! Note that Deficit_pf2yf and Deficit_sf2yf are temporary, intermediate |
|---|
| 2959 | !! variables. The final deficits after mutual compensation are stored in |
|---|
| 2960 | !! Deficit_pf2yf_final and Deficit_sf2yf_final. |
|---|
| 2961 | Deficit_pf2yf(:) = zero |
|---|
| 2962 | Deficit_sf2yf(:) = zero |
|---|
| 2963 | Deficit_pf2yf_final(:) = zero |
|---|
| 2964 | Deficit_sf2yf_final(:) = zero |
|---|
| 2965 | |
|---|
| 2966 | !! Note that both Surplus_pf2yf and Surplus_sf2yf and temporary intermediate |
|---|
| 2967 | !! variables, the final surplus after mutual compensation are not outputed. |
|---|
| 2968 | Surplus_pf2yf(:) = zero |
|---|
| 2969 | Surplus_sf2yf(:) = zero |
|---|
| 2970 | |
|---|
| 2971 | !! Note in the naming of pf2yf_compen_sf2yf and sf2yf_compen_pf2yf, active |
|---|
| 2972 | !! tense is used. |
|---|
| 2973 | pf2yf_compen_sf2yf(:) = zero !primary->young conversion that compensates |
|---|
| 2974 | !the secondary->young conversion because of deficit |
|---|
| 2975 | !in the latter |
|---|
| 2976 | sf2yf_compen_pf2yf(:) = zero !seondary->young conversion that compensates |
|---|
| 2977 | !the primary->young conversion because of the deficit |
|---|
| 2978 | !in the latter |
|---|
| 2979 | |
|---|
| 2980 | |
|---|
| 2981 | !! Define the "real" harvest matrix after considering the mutual compenstation |
|---|
| 2982 | !! between primary->young and secondary->young transitions. |
|---|
| 2983 | HmatrixReal(:,:) = zero !Harvest matrix real, used to hold the |
|---|
| 2984 | !harvest matrix after considering the mutual |
|---|
| 2985 | !compensation between primary and old secondary |
|---|
| 2986 | !forest |
|---|
| 2987 | |
|---|
| 2988 | ! we sum together harvest from primary and secondary forest and consider |
|---|
| 2989 | ! as all happening on parimary forest. |
|---|
| 2990 | HmatrixReal(:,1) = harvest_matrix(:,pf2yf) + harvest_matrix(:,sf2yf) |
|---|
| 2991 | |
|---|
| 2992 | ! Check the availability of forest fractions for harvest |
|---|
| 2993 | WHERE (veget_tree(:) .LE. HmatrixReal(:,1)) |
|---|
| 2994 | Deficit_pf2yf_final(:) = veget_tree(:)-HmatrixReal(:,1) |
|---|
| 2995 | HmatrixReal(:,1) = veget_tree(:) |
|---|
| 2996 | ENDWHERE |
|---|
| 2997 | |
|---|
| 2998 | |
|---|
| 2999 | glcc_pft(:,:) = 0. |
|---|
| 3000 | glcc_pft_tmp(:,:) = 0. |
|---|
| 3001 | glcc_pftmtc(:,:,:) = 0. |
|---|
| 3002 | |
|---|
| 3003 | !! Allocate harvest-caused out-going primary and secondary forest fraction |
|---|
| 3004 | !! into different primary and secondary forest PFTs. |
|---|
| 3005 | ! [Note: here we need only glcc_pft, but not glcc_pft_tmp and glcc_pftmtc. |
|---|
| 3006 | ! The latter two variables will be set to zero again when handling LCC in |
|---|
| 3007 | ! later sections.] |
|---|
| 3008 | DO ipts=1,npts |
|---|
| 3009 | !pf2yf |
|---|
| 3010 | CALL type_conversion(ipts,pf2yf,HmatrixReal,veget_mtc, & |
|---|
| 3011 | indold_tree,indagec_tree,indagec_crop,num_crop_mulagec, & |
|---|
| 3012 | 1,nagec_herb, & |
|---|
| 3013 | vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3014 | ENDDO |
|---|
| 3015 | |
|---|
| 3016 | ! Because we use the container of type_conversion, now the glcc_pft_tmp |
|---|
| 3017 | ! and glcc_pftmtc have wrong information (because harvest loss is assigned |
|---|
| 3018 | ! on the newly created youngest-age-class pasture/crop MTCs). So they have |
|---|
| 3019 | ! to be re-initialized to zero. Only the information in glcc_pft is what |
|---|
| 3020 | ! we need. |
|---|
| 3021 | glcc_pft_tmp(:,:) = 0. |
|---|
| 3022 | glcc_pftmtc(:,:,:) = 0. |
|---|
| 3023 | !Here we need to put glcc_pft into glcc_pftmtc for forestry harvest. |
|---|
| 3024 | !The same MTC will be maintained when forest is harvested. |
|---|
| 3025 | DO ivm =1,nvm |
|---|
| 3026 | IF (is_tree(ivm)) THEN |
|---|
| 3027 | glcc_pftmtc(:,ivm,pft_to_mtc(ivm)) = glcc_pft(:,ivm) |
|---|
| 3028 | ENDIF |
|---|
| 3029 | ENDDO |
|---|
| 3030 | !****************** end block to handle forestry harvest **************** |
|---|
| 3031 | veget_max_tmp(:,:) = veget_max(:,:) |
|---|
| 3032 | |
|---|
| 3033 | |
|---|
| 3034 | !************************************************************************! |
|---|
| 3035 | !****block to calculate fractions for basic veg types and age classes ***! |
|---|
| 3036 | ! Note: |
|---|
| 3037 | ! 1. "calc_cover" subroutine does not depend on how many age classes |
|---|
| 3038 | ! there are in each MTC. |
|---|
| 3039 | ! 2. Fraction of baresoil is excluded here. This means transformation |
|---|
| 3040 | ! of baresoil to a vegetated PFT is excluded in gross land cover change. |
|---|
| 3041 | veget_mtc(:,:) = 0. |
|---|
| 3042 | vegagec_tree(:,:) = 0. |
|---|
| 3043 | vegagec_grass(:,:) = 0. |
|---|
| 3044 | vegagec_pasture(:,:) = 0. |
|---|
| 3045 | vegagec_crop(:,:) = 0. |
|---|
| 3046 | |
|---|
| 3047 | |
|---|
| 3048 | CALL calc_cover(npts,veget_max,veget_mtc,vegagec_tree,vegagec_grass, & |
|---|
| 3049 | vegagec_pasture,vegagec_crop) |
|---|
| 3050 | |
|---|
| 3051 | veget_tree(:) = SUM(vegagec_tree(:,:),DIM=2) |
|---|
| 3052 | veget_grass(:) = SUM(vegagec_grass(:,:),DIM=2) |
|---|
| 3053 | veget_pasture(:) = SUM(vegagec_pasture(:,:),DIM=2) |
|---|
| 3054 | veget_crop(:) = SUM(vegagec_crop(:,:),DIM=2) |
|---|
| 3055 | itree=1 |
|---|
| 3056 | igrass=2 |
|---|
| 3057 | ipasture=3 |
|---|
| 3058 | icrop=4 |
|---|
| 3059 | veget_4veg(:,itree) = veget_tree(:) |
|---|
| 3060 | veget_4veg(:,igrass) = veget_grass(:) |
|---|
| 3061 | veget_4veg(:,ipasture) = veget_pasture(:) |
|---|
| 3062 | veget_4veg(:,icrop) = veget_crop(:) |
|---|
| 3063 | !****end block to calculate fractions for basic veg types and age classes ***! |
|---|
| 3064 | !****************************************************************************! |
|---|
| 3065 | |
|---|
| 3066 | !! 3. Decompose the LCC matrix to different PFTs |
|---|
| 3067 | !! We do this through several steps: |
|---|
| 3068 | ! 3.1 Check whether input LCC matrix is feasible with current PFT fractions |
|---|
| 3069 | ! (i.e., the fractions of forest,grass,pasture and crops) |
|---|
| 3070 | ! and if not, adjust the transfer matrix by compensating the deficits |
|---|
| 3071 | ! using the surpluses. |
|---|
| 3072 | ! 3.2 Allocate the decreasing fractions of tree/grass/pasture/crop to their |
|---|
| 3073 | ! respective age classes, in the sequences of old->young. |
|---|
| 3074 | ! 3.3 Allocate the incoming fractions of tree/grass/pasture/crop to their |
|---|
| 3075 | ! respective youngest age classes. The incoming fractions are distributed |
|---|
| 3076 | ! according to the existing fractions of youngest-age-class PFTs of the |
|---|
| 3077 | ! same receiving vegetation type. If none of them exists, the incoming |
|---|
| 3078 | ! fraction is distributed equally. |
|---|
| 3079 | |
|---|
| 3080 | !! 3.1 Adjust LCC matrix if it's not feasible with current PFT fractions |
|---|
| 3081 | |
|---|
| 3082 | glcc(:,:) = glccSecondShift+glccPrimaryShift+glccNetLCC |
|---|
| 3083 | IncreDeficit(:,:) = 0. |
|---|
| 3084 | glccReal(:,:) = 0. |
|---|
| 3085 | glccDef(:,:) = 0. |
|---|
| 3086 | |
|---|
| 3087 | !to crop - sequence: p2c,g2c,f2c |
|---|
| 3088 | CALL glcc_compensation_full(npts,veget_4veg,glcc,glccReal,glccDef, & |
|---|
| 3089 | p2c,ipasture,g2c,igrass,f2c,itree,icrop, & |
|---|
| 3090 | IncreDeficit) |
|---|
| 3091 | |
|---|
| 3092 | !to pasture - sequence: g2p,c2p,f2p |
|---|
| 3093 | CALL glcc_compensation_full(npts,veget_4veg,glcc,glccReal,glccDef, & |
|---|
| 3094 | g2p,igrass,c2p,icrop,f2p,itree,ipasture, & |
|---|
| 3095 | IncreDeficit) |
|---|
| 3096 | |
|---|
| 3097 | !to grass - sequence: p2g,c2g,f2g |
|---|
| 3098 | CALL glcc_compensation_full(npts,veget_4veg,glcc,glccReal,glccDef, & |
|---|
| 3099 | p2g,ipasture,c2g,icrop,f2g,itree,igrass, & |
|---|
| 3100 | IncreDeficit) |
|---|
| 3101 | |
|---|
| 3102 | !to forest - sequence: c2f,p2f,g2f |
|---|
| 3103 | CALL glcc_compensation_full(npts,veget_4veg,glcc,glccReal,glccDef, & |
|---|
| 3104 | c2f,icrop,p2f,ipasture,g2f,igrass,itree, & |
|---|
| 3105 | IncreDeficit) |
|---|
| 3106 | |
|---|
| 3107 | !! 3.2 & 3.3 Allocate LCC matrix to different PFTs/age-classes |
|---|
| 3108 | |
|---|
| 3109 | ! because we use veget_max as a proxy variable and it has been changed |
|---|
| 3110 | ! when we derive the glccReal, so here we have to recover its original |
|---|
| 3111 | ! values, which is veget_max_tmp after the forestry harvest. |
|---|
| 3112 | veget_max(:,:) = veget_max_tmp(:,:) |
|---|
| 3113 | |
|---|
| 3114 | ! Calculate again fractions for different age-classes. |
|---|
| 3115 | veget_mtc(:,:) = 0. |
|---|
| 3116 | vegagec_tree(:,:) = 0. |
|---|
| 3117 | vegagec_grass(:,:) = 0. |
|---|
| 3118 | vegagec_pasture(:,:) = 0. |
|---|
| 3119 | vegagec_crop(:,:) = 0. |
|---|
| 3120 | |
|---|
| 3121 | CALL calc_cover(npts,veget_max,veget_mtc,vegagec_tree,vegagec_grass, & |
|---|
| 3122 | vegagec_pasture,vegagec_crop) |
|---|
| 3123 | |
|---|
| 3124 | ! We allocate in the sequences of old->young. Within the same age-class |
|---|
| 3125 | ! group, we allocate in proportion with existing PFT fractions. |
|---|
| 3126 | DO ipts=1,npts |
|---|
| 3127 | !f2c |
|---|
| 3128 | CALL type_conversion(ipts,f2c,glccReal,veget_mtc, & |
|---|
| 3129 | indold_tree,indagec_tree,indagec_crop,num_crop_mulagec, & |
|---|
| 3130 | nagec_tree,nagec_herb, & |
|---|
| 3131 | vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3132 | !f2p |
|---|
| 3133 | CALL type_conversion(ipts,f2p,glccReal,veget_mtc, & |
|---|
| 3134 | indold_tree,indagec_tree,indagec_pasture,num_pasture_mulagec, & |
|---|
| 3135 | nagec_tree,nagec_herb, & |
|---|
| 3136 | vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3137 | !f2g |
|---|
| 3138 | CALL type_conversion(ipts,f2g,glccReal,veget_mtc, & |
|---|
| 3139 | indold_tree,indagec_tree,indagec_grass,num_grass_mulagec, & |
|---|
| 3140 | nagec_tree,nagec_herb, & |
|---|
| 3141 | vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3142 | !g2c |
|---|
| 3143 | CALL type_conversion(ipts,g2c,glccReal,veget_mtc, & |
|---|
| 3144 | indold_grass,indagec_grass,indagec_crop,num_crop_mulagec, & |
|---|
| 3145 | nagec_herb,nagec_herb, & |
|---|
| 3146 | vegagec_grass,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3147 | !g2p |
|---|
| 3148 | CALL type_conversion(ipts,g2p,glccReal,veget_mtc, & |
|---|
| 3149 | indold_grass,indagec_grass,indagec_pasture,num_pasture_mulagec, & |
|---|
| 3150 | nagec_herb,nagec_herb, & |
|---|
| 3151 | vegagec_grass,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3152 | !g2f |
|---|
| 3153 | CALL type_conversion(ipts,g2f,glccReal,veget_mtc, & |
|---|
| 3154 | indold_grass,indagec_grass,indagec_tree,num_tree_mulagec, & |
|---|
| 3155 | nagec_herb,nagec_tree, & |
|---|
| 3156 | vegagec_grass,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3157 | !p2c |
|---|
| 3158 | CALL type_conversion(ipts,p2c,glccReal,veget_mtc, & |
|---|
| 3159 | indold_pasture,indagec_pasture,indagec_crop,num_crop_mulagec, & |
|---|
| 3160 | nagec_herb,nagec_herb, & |
|---|
| 3161 | vegagec_pasture,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3162 | !p2g |
|---|
| 3163 | CALL type_conversion(ipts,p2g,glccReal,veget_mtc, & |
|---|
| 3164 | indold_pasture,indagec_pasture,indagec_grass,num_grass_mulagec, & |
|---|
| 3165 | nagec_herb,nagec_herb, & |
|---|
| 3166 | vegagec_pasture,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3167 | !p2f |
|---|
| 3168 | CALL type_conversion(ipts,p2f,glccReal,veget_mtc, & |
|---|
| 3169 | indold_pasture,indagec_pasture,indagec_tree,num_tree_mulagec, & |
|---|
| 3170 | nagec_herb,nagec_tree, & |
|---|
| 3171 | vegagec_pasture,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3172 | !c2p |
|---|
| 3173 | CALL type_conversion(ipts,c2p,glccReal,veget_mtc, & |
|---|
| 3174 | indold_crop,indagec_crop,indagec_pasture,num_pasture_mulagec, & |
|---|
| 3175 | nagec_herb,nagec_herb, & |
|---|
| 3176 | vegagec_crop,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3177 | !c2g |
|---|
| 3178 | CALL type_conversion(ipts,c2g,glccReal,veget_mtc, & |
|---|
| 3179 | indold_crop,indagec_crop,indagec_grass,num_grass_mulagec, & |
|---|
| 3180 | nagec_herb,nagec_herb, & |
|---|
| 3181 | vegagec_crop,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3182 | !c2f |
|---|
| 3183 | CALL type_conversion(ipts,c2f,glccReal,veget_mtc, & |
|---|
| 3184 | indold_crop,indagec_crop,indagec_tree,num_tree_mulagec, & |
|---|
| 3185 | nagec_herb,nagec_tree, & |
|---|
| 3186 | vegagec_crop,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3187 | ENDDO |
|---|
| 3188 | |
|---|
| 3189 | END SUBROUTINE gross_glcc_firstday_fh |
|---|
| 3190 | |
|---|
| 3191 | |
|---|
| 3192 | SUBROUTINE cross_give_receive(ipts,frac_used,veget_mtc, & |
|---|
| 3193 | indold_tree,indagec_crop,nagec_receive,num_crop_mulagec, & |
|---|
| 3194 | veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3195 | |
|---|
| 3196 | |
|---|
| 3197 | IMPLICIT NONE |
|---|
| 3198 | |
|---|
| 3199 | !! 0. Input variables |
|---|
| 3200 | INTEGER, INTENT(in) :: ipts |
|---|
| 3201 | REAL(r_std), INTENT(in) :: frac_used !! fraction that the giving PFTs are going to collectively give |
|---|
| 3202 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: veget_mtc !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 3203 | INTEGER, DIMENSION(:), INTENT(in) :: indold_tree !! Indices for PFTs giving out fractions; |
|---|
| 3204 | !! here use old tree cohort as an example |
|---|
| 3205 | INTEGER, DIMENSION(:,:), INTENT(in) :: indagec_crop !! Indices for secondary basic-vegetation cohorts; The youngest age classes |
|---|
| 3206 | !! of these vegetations are going to receive fractions. |
|---|
| 3207 | !! here we use crop cohorts as an example |
|---|
| 3208 | INTEGER, INTENT(in) :: num_crop_mulagec !! number of crop MTCs with more than one age classes |
|---|
| 3209 | INTEGER, INTENT(in) :: nagec_receive !! number of age classes in the receiving basic types |
|---|
| 3210 | !! (i.e., tree, grass, pasture, crop), here we can use crop |
|---|
| 3211 | !! as an example, nagec_receive=nagec_herb |
|---|
| 3212 | |
|---|
| 3213 | !! 1. Modified variables |
|---|
| 3214 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: veget_max !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 3215 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: glcc_pft !! a temporary variable to hold the fractions each PFT is going to lose |
|---|
| 3216 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: glcc_pftmtc !! a temporary variable to hold the fraction of ipft->ivma, i.e., from |
|---|
| 3217 | !! PFT_{ipft} to the youngest age class of MTC_{ivma} |
|---|
| 3218 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: glcc_pft_tmp !! a temporary variable to hold the fractions each PFT is going to lose |
|---|
| 3219 | |
|---|
| 3220 | !! Local vriables |
|---|
| 3221 | INTEGER :: j,ipft, iyoung |
|---|
| 3222 | REAL(r_std) :: totalveg |
|---|
| 3223 | |
|---|
| 3224 | |
|---|
| 3225 | ! Out final objective is to know glcc_pftmtc, i.e., the fraction from each PFT |
|---|
| 3226 | ! to the youngest age group of each MTC. We separate this task into two steps: |
|---|
| 3227 | ! 1. we allocate the total outgoing fraction into the same age-class PFTs of |
|---|
| 3228 | ! the a basic-vegetation (for example, the same age-calss PFTs of forest); |
|---|
| 3229 | ! 2. we further allocate the outgoing fraction of each age-class PFT to |
|---|
| 3230 | ! the different receiving youngest age-class PFTs of the same basic-vegetation |
|---|
| 3231 | ! type, for example, the youngest age-calss PFTs of cropland. |
|---|
| 3232 | |
|---|
| 3233 | ! glcc_pft_tmp used only as a temporary variable to store the value |
|---|
| 3234 | glcc_pft_tmp(ipts,indold_tree) = veget_max(ipts,indold_tree)/SUM(veget_max(ipts,indold_tree))*frac_used |
|---|
| 3235 | glcc_pft(ipts,indold_tree) = glcc_pft(ipts,indold_tree) + glcc_pft_tmp(ipts,indold_tree) |
|---|
| 3236 | !we have to remove the outgoing fraction from veget_max in order to use this information for next loop |
|---|
| 3237 | veget_max(ipts,indold_tree) = veget_max(ipts,indold_tree) - glcc_pft_tmp(ipts,indold_tree) |
|---|
| 3238 | |
|---|
| 3239 | ! when receiving basic-vegetation type has a single age group, it will be considered as |
|---|
| 3240 | ! both old and young age group (thus recevie the fraction donation), otherwise the youngest |
|---|
| 3241 | ! age group is always the final element of indagec_crop. |
|---|
| 3242 | IF (nagec_receive == 1) THEN |
|---|
| 3243 | iyoung = 1 |
|---|
| 3244 | ELSE |
|---|
| 3245 | iyoung = nagec_receive - 1 |
|---|
| 3246 | ENDIF |
|---|
| 3247 | |
|---|
| 3248 | totalveg = 0. |
|---|
| 3249 | DO j=1,num_crop_mulagec |
|---|
| 3250 | totalveg = totalveg + veget_mtc(ipts,agec_group(indagec_crop(j,iyoung))) |
|---|
| 3251 | ENDDO |
|---|
| 3252 | |
|---|
| 3253 | IF (totalveg>min_stomate) THEN |
|---|
| 3254 | DO j=1,num_crop_mulagec |
|---|
| 3255 | ipft = indagec_crop(j,iyoung) |
|---|
| 3256 | glcc_pftmtc(ipts,indold_tree,agec_group(ipft)) = glcc_pft_tmp(ipts,indold_tree) & |
|---|
| 3257 | *veget_mtc(ipts,agec_group(ipft))/totalveg |
|---|
| 3258 | ENDDO |
|---|
| 3259 | ELSE |
|---|
| 3260 | DO j=1,num_crop_mulagec |
|---|
| 3261 | ipft = indagec_crop(j,iyoung) |
|---|
| 3262 | glcc_pftmtc(ipts,indold_tree,agec_group(ipft)) = glcc_pft_tmp(ipts,indold_tree)/num_crop_mulagec |
|---|
| 3263 | ENDDO |
|---|
| 3264 | ENDIF |
|---|
| 3265 | |
|---|
| 3266 | END SUBROUTINE cross_give_receive |
|---|
| 3267 | |
|---|
| 3268 | ! ================================================================================================================================ |
|---|
| 3269 | !! SUBROUTINE : type_conversion |
|---|
| 3270 | !>\BRIEF : Allocate outgoing into different age classes and incoming into |
|---|
| 3271 | !! yongest age-class of receiving MTCs. |
|---|
| 3272 | !! |
|---|
| 3273 | !! REMARK : The current dummy variables give an example of converting forests |
|---|
| 3274 | !! to crops. |
|---|
| 3275 | !! \n |
|---|
| 3276 | !_ ================================================================================================================================ |
|---|
| 3277 | SUBROUTINE type_conversion(ipts,f2c,glccReal,veget_mtc, & |
|---|
| 3278 | indold_tree,indagec_tree,indagec_crop,num_crop_mulagec, & |
|---|
| 3279 | nagec_giving,nagec_receive, & |
|---|
| 3280 | vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp, & |
|---|
| 3281 | iagec_start) |
|---|
| 3282 | |
|---|
| 3283 | IMPLICIT NONE |
|---|
| 3284 | |
|---|
| 3285 | !! Input variables |
|---|
| 3286 | INTEGER, INTENT(in) :: ipts,f2c |
|---|
| 3287 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: glccReal !! The "real" glcc matrix that we apply in the model |
|---|
| 3288 | !! after considering the consistency between presribed |
|---|
| 3289 | !! glcc matrix and existing vegetation fractions. |
|---|
| 3290 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: veget_mtc !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 3291 | INTEGER, DIMENSION(:), INTENT(in) :: indold_tree !! Indices for PFTs giving out fractions; |
|---|
| 3292 | !! here use old tree cohort as an example |
|---|
| 3293 | INTEGER, DIMENSION(:,:), INTENT(in) :: indagec_tree !! Indices for PFTs giving out fractions; |
|---|
| 3294 | !! here use old tree cohort as an example |
|---|
| 3295 | INTEGER, DIMENSION(:,:), INTENT(in) :: indagec_crop !! Indices for secondary basic-vegetation cohorts; The youngest age classes |
|---|
| 3296 | !! of these vegetations are going to receive fractions. |
|---|
| 3297 | !! here we use crop cohorts as an example |
|---|
| 3298 | INTEGER, INTENT(in) :: num_crop_mulagec !! number of crop MTCs with more than one age classes |
|---|
| 3299 | INTEGER, INTENT(in) :: nagec_giving !! number of age classes in the giving basic types |
|---|
| 3300 | !! (i.e., tree, grass, pasture, crop), here we can use tree |
|---|
| 3301 | !! as an example, nagec=nagec_tree |
|---|
| 3302 | INTEGER, INTENT(in) :: nagec_receive !! number of age classes in the receiving basic types |
|---|
| 3303 | !! (i.e., tree, grass, pasture, crop), here we can use crop |
|---|
| 3304 | !! as an example, nagec=nagec_herb |
|---|
| 3305 | INTEGER, OPTIONAL, INTENT(in) :: iagec_start !! starting index for iagec, this is added in order to handle |
|---|
| 3306 | !! the case of secondary forest harvest. |
|---|
| 3307 | |
|---|
| 3308 | !! 1. Modified variables |
|---|
| 3309 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: vegagec_tree !! fraction of tree age-class groups, in sequence of old->young |
|---|
| 3310 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: veget_max !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 3311 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: glcc_pft !! a temporary variable to hold the fractions each PFT is going to lose |
|---|
| 3312 | REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: glcc_pftmtc !! a temporary variable to hold the fraction of ipft->ivma, i.e., from |
|---|
| 3313 | REAL(r_std), DIMENSION(:,:), INTENT(inout) :: glcc_pft_tmp !! Loss of fraction in each PFT |
|---|
| 3314 | |
|---|
| 3315 | !! Local vriables |
|---|
| 3316 | INTEGER :: j,iagec,iagec_start_proxy |
|---|
| 3317 | REAL(r_std) :: frac_begin,frac_used |
|---|
| 3318 | !! PFT_{ipft} to the youngest age class of MTC_{ivma} |
|---|
| 3319 | IF (.NOT. PRESENT(iagec_start)) THEN |
|---|
| 3320 | iagec_start_proxy=1 |
|---|
| 3321 | ELSE |
|---|
| 3322 | iagec_start_proxy=iagec_start |
|---|
| 3323 | ENDIF |
|---|
| 3324 | |
|---|
| 3325 | ! This subroutine handles the conversion from one basic-vegetation type |
|---|
| 3326 | ! to another, by calling the subroutine cross_give_receive, which handles |
|---|
| 3327 | ! allocation of giving-receiving fraction among the giving age classes |
|---|
| 3328 | ! and receiving basic-vegetation young age classes. |
|---|
| 3329 | ! We allocate in the sequences of old->young. Within the same age-class |
|---|
| 3330 | ! group, we allocate in proportion with existing PFT fractions. The same |
|---|
| 3331 | ! also applies in the receiving youngest-age-class PFTs, i.e., the receiving |
|---|
| 3332 | ! total fraction is allocated according to existing fractions of |
|---|
| 3333 | ! MTCs of the same basic vegetation type, otherwise it will be equally |
|---|
| 3334 | ! distributed. |
|---|
| 3335 | |
|---|
| 3336 | frac_begin = glccReal(ipts,f2c) |
|---|
| 3337 | DO WHILE (frac_begin>min_stomate) |
|---|
| 3338 | DO iagec=iagec_start_proxy,nagec_giving |
|---|
| 3339 | IF (vegagec_tree(ipts,iagec)>frac_begin) THEN |
|---|
| 3340 | frac_used = frac_begin |
|---|
| 3341 | ELSE IF (vegagec_tree(ipts,iagec)>min_stomate) THEN |
|---|
| 3342 | frac_used = vegagec_tree(ipts,iagec) |
|---|
| 3343 | ELSE |
|---|
| 3344 | frac_used = 0. |
|---|
| 3345 | ENDIF |
|---|
| 3346 | |
|---|
| 3347 | IF (frac_used>min_stomate) THEN |
|---|
| 3348 | IF (iagec==1) THEN |
|---|
| 3349 | ! Note that vegagec_tree is fractions of tree age-class groups in the |
|---|
| 3350 | ! the sequence of old->young, so iagec==1 means that we're handling |
|---|
| 3351 | ! first the oldest-age-group tree PFTs. |
|---|
| 3352 | CALL cross_give_receive(ipts,frac_used,veget_mtc, & |
|---|
| 3353 | indold_tree,indagec_crop,nagec_receive,num_crop_mulagec, & |
|---|
| 3354 | veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3355 | ELSE |
|---|
| 3356 | ! Note also the sequence of indagec_tree is from old->young, so by |
|---|
| 3357 | ! increasing iagec, we're handling progressively the old to young |
|---|
| 3358 | ! tree age-class PFTs. |
|---|
| 3359 | CALL cross_give_receive(ipts,frac_used,veget_mtc, & |
|---|
| 3360 | indagec_tree(:,iagec-1),indagec_crop,nagec_receive,num_crop_mulagec, & |
|---|
| 3361 | veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 3362 | ENDIF |
|---|
| 3363 | frac_begin = frac_begin-frac_used |
|---|
| 3364 | vegagec_tree(ipts,iagec)=vegagec_tree(ipts,iagec)-frac_used |
|---|
| 3365 | ENDIF |
|---|
| 3366 | ENDDO |
|---|
| 3367 | ENDDO |
|---|
| 3368 | |
|---|
| 3369 | END SUBROUTINE type_conversion |
|---|
| 3370 | |
|---|
| 3371 | ! ================================================================================================================================ |
|---|
| 3372 | !! SUBROUTINE : calc_cover |
|---|
| 3373 | !! |
|---|
| 3374 | !>\BRIEF Calculate coverage fraction for different age classes of forest, |
|---|
| 3375 | !! grass, pasture and crops and also for each metaclass. Note baresoil is excluded. |
|---|
| 3376 | !! |
|---|
| 3377 | !! DESCRIPTION : |
|---|
| 3378 | !! |
|---|
| 3379 | !! |
|---|
| 3380 | !! MAIN OUTPUT VARIABLE(S) : |
|---|
| 3381 | !! |
|---|
| 3382 | !! \n |
|---|
| 3383 | !_ ================================================================================================================================ |
|---|
| 3384 | SUBROUTINE calc_cover(npts,veget_max,veget_mtc,vegagec_tree,vegagec_grass, & |
|---|
| 3385 | vegagec_pasture,vegagec_crop) |
|---|
| 3386 | |
|---|
| 3387 | |
|---|
| 3388 | IMPLICIT NONE |
|---|
| 3389 | |
|---|
| 3390 | !! Input variables |
|---|
| 3391 | INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 3392 | REAL(r_std), DIMENSION(npts,nvm), INTENT(in) :: veget_max !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 3393 | |
|---|
| 3394 | !! Output variables |
|---|
| 3395 | REAL(r_std), DIMENSION(npts,nvmap), INTENT(inout) :: veget_mtc !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 3396 | REAL(r_std), DIMENSION(npts,nagec_tree), INTENT(inout) :: vegagec_tree !! fraction of tree age-class groups, in sequence of old->young |
|---|
| 3397 | REAL(r_std), DIMENSION(npts,nagec_herb), INTENT(inout) :: vegagec_grass !! fraction of grass age-class groups, in sequence of old->young |
|---|
| 3398 | REAL(r_std), DIMENSION(npts,nagec_herb), INTENT(inout) :: vegagec_pasture !! fraction of pasture age-class groups, in sequence of old->young |
|---|
| 3399 | REAL(r_std), DIMENSION(npts,nagec_herb), INTENT(inout) :: vegagec_crop !! fraction of crop age-class groups, in sequence of old->young |
|---|
| 3400 | |
|---|
| 3401 | !! Local variables |
|---|
| 3402 | INTEGER(i_std) :: ivma,staind,endind,j !! indices (unitless) |
|---|
| 3403 | |
|---|
| 3404 | ! Calculate veget_max for MTCs |
|---|
| 3405 | DO ivma = 1,nvmap |
|---|
| 3406 | staind = start_index(ivma) |
|---|
| 3407 | IF (nagec_pft(ivma) == 1) THEN |
|---|
| 3408 | veget_mtc(:,ivma) = veget_max(:,staind) |
|---|
| 3409 | ELSE |
|---|
| 3410 | veget_mtc(:,ivma) = \ |
|---|
| 3411 | SUM(veget_max(:,staind:staind+nagec_pft(ivma)-1),DIM=2) |
|---|
| 3412 | ENDIF |
|---|
| 3413 | ENDDO |
|---|
| 3414 | |
|---|
| 3415 | ! Calculate veget_max for each age class |
|---|
| 3416 | DO ivma = 2,nvmap !here we start with 2 to exclude baresoil (always PFT1) |
|---|
| 3417 | staind = start_index(ivma) |
|---|
| 3418 | endind = staind+nagec_pft(ivma)-1 |
|---|
| 3419 | |
|---|
| 3420 | ! Single-age-class MTC goest to oldest age class. |
|---|
| 3421 | IF (nagec_pft(ivma) == 1) THEN |
|---|
| 3422 | IF (is_tree(staind)) THEN |
|---|
| 3423 | vegagec_tree(:,1) = vegagec_tree(:,1)+veget_max(:,staind) |
|---|
| 3424 | ELSE IF (is_grassland_manag(staind)) THEN |
|---|
| 3425 | vegagec_pasture(:,1) = vegagec_pasture(:,1)+veget_max(:,staind) |
|---|
| 3426 | ELSE IF (natural(staind)) THEN |
|---|
| 3427 | vegagec_grass(:,1) = vegagec_grass(:,1)+veget_max(:,staind) |
|---|
| 3428 | ELSE |
|---|
| 3429 | vegagec_crop(:,1) = vegagec_crop(:,1)+veget_max(:,staind) |
|---|
| 3430 | ENDIF |
|---|
| 3431 | |
|---|
| 3432 | ELSE |
|---|
| 3433 | IF (is_tree(staind)) THEN |
|---|
| 3434 | DO j=1,nagec_tree |
|---|
| 3435 | vegagec_tree(:,j) = vegagec_tree(:,j)+veget_max(:,endind-j+1) |
|---|
| 3436 | ENDDO |
|---|
| 3437 | ELSE IF (is_grassland_manag(staind)) THEN |
|---|
| 3438 | DO j=1,nagec_herb |
|---|
| 3439 | vegagec_pasture(:,j) = vegagec_pasture(:,j)+veget_max(:,endind-j+1) |
|---|
| 3440 | ENDDO |
|---|
| 3441 | ELSE IF (natural(staind)) THEN |
|---|
| 3442 | DO j=1,nagec_herb |
|---|
| 3443 | vegagec_grass(:,j) = vegagec_grass(:,j)+veget_max(:,endind-j+1) |
|---|
| 3444 | ENDDO |
|---|
| 3445 | ELSE |
|---|
| 3446 | DO j=1,nagec_herb |
|---|
| 3447 | vegagec_crop(:,j) = vegagec_crop(:,j)+veget_max(:,endind-j+1) |
|---|
| 3448 | ENDDO |
|---|
| 3449 | ENDIF |
|---|
| 3450 | ENDIF |
|---|
| 3451 | ENDDO |
|---|
| 3452 | |
|---|
| 3453 | END SUBROUTINE calc_cover |
|---|
| 3454 | |
|---|
| 3455 | ! Note this subroutine does not depend on how many age classes there are |
|---|
| 3456 | ! in different MTCs. |
|---|
| 3457 | SUBROUTINE glcc_compensation_full(npts,veget_4veg,glcc,glccReal,glccDef, & |
|---|
| 3458 | p2c,ipasture,g2c,igrass,f2c,itree,icrop, & |
|---|
| 3459 | IncreDeficit) |
|---|
| 3460 | |
|---|
| 3461 | IMPLICIT NONE |
|---|
| 3462 | |
|---|
| 3463 | !! 0.1 Input variables |
|---|
| 3464 | INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 3465 | INTEGER, INTENT(in) :: p2c,ipasture,g2c,igrass,f2c,itree,icrop |
|---|
| 3466 | REAL(r_std), DIMENSION (npts,12),INTENT(in) :: glcc !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 3467 | !! used. |
|---|
| 3468 | |
|---|
| 3469 | !! 0.2 Output variables |
|---|
| 3470 | |
|---|
| 3471 | |
|---|
| 3472 | !! 0.3 Modified variables |
|---|
| 3473 | REAL(r_std), DIMENSION(npts,4), INTENT(inout) :: veget_4veg !! "maximal" coverage of tree/grass/pasture/crop |
|---|
| 3474 | REAL(r_std), DIMENSION(npts,12), INTENT(inout) :: glccDef !! Gross LCC deficit, negative values mean that there |
|---|
| 3475 | !! are not enough fractions in the source vegetations |
|---|
| 3476 | !! to the target ones as presribed by the LCC matrix. |
|---|
| 3477 | REAL(r_std), DIMENSION(npts,12), INTENT(inout) :: glccReal !! The "real" glcc matrix that we apply in the model |
|---|
| 3478 | !! after considering the consistency between presribed |
|---|
| 3479 | !! glcc matrix and existing vegetation fractions. |
|---|
| 3480 | REAL(r_std), DIMENSION(npts,4), INTENT(inout) :: IncreDeficit !! "Increment" deficits, negative values mean that |
|---|
| 3481 | !! there are not enough fractions in the source PFTs |
|---|
| 3482 | !! /vegetations to target PFTs/vegetations. I.e., these |
|---|
| 3483 | !! fraction transfers are presribed in LCC matrix but |
|---|
| 3484 | !! not realized. |
|---|
| 3485 | |
|---|
| 3486 | !! 0.4 Local variables |
|---|
| 3487 | REAL(r_std), DIMENSION(npts) :: tmpdef !! LCC deficits by summing up all the deficits to the |
|---|
| 3488 | !! the same target vegetation. |
|---|
| 3489 | |
|---|
| 3490 | |
|---|
| 3491 | !! 0. We first handle the cases where veget_4veg might be very small |
|---|
| 3492 | !tree |
|---|
| 3493 | WHERE(veget_4veg(:,itree) > min_stomate) |
|---|
| 3494 | glccDef(:,f2c) = veget_4veg(:,itree)-glcc(:,f2c) |
|---|
| 3495 | WHERE(veget_4veg(:,itree)>glcc(:,f2c)) |
|---|
| 3496 | glccReal(:,f2c) = glcc(:,f2c) |
|---|
| 3497 | ELSEWHERE |
|---|
| 3498 | glccReal(:,f2c) = veget_4veg(:,itree) |
|---|
| 3499 | ENDWHERE |
|---|
| 3500 | ELSEWHERE |
|---|
| 3501 | glccReal(:,f2c) = 0. |
|---|
| 3502 | glccDef(:,f2c) = -1*glcc(:,f2c) |
|---|
| 3503 | ENDWHERE |
|---|
| 3504 | |
|---|
| 3505 | !pasture |
|---|
| 3506 | WHERE(veget_4veg(:,ipasture) > min_stomate) |
|---|
| 3507 | glccDef(:,p2c) = veget_4veg(:,ipasture)-glcc(:,p2c) |
|---|
| 3508 | WHERE(veget_4veg(:,ipasture)>glcc(:,p2c)) |
|---|
| 3509 | glccReal(:,p2c) = glcc(:,p2c) |
|---|
| 3510 | ELSEWHERE |
|---|
| 3511 | glccReal(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 3512 | ENDWHERE |
|---|
| 3513 | ELSEWHERE |
|---|
| 3514 | glccReal(:,p2c) = 0. |
|---|
| 3515 | glccDef(:,p2c) = -1*glcc(:,p2c) |
|---|
| 3516 | ENDWHERE |
|---|
| 3517 | |
|---|
| 3518 | !grass |
|---|
| 3519 | WHERE(veget_4veg(:,igrass) > min_stomate) |
|---|
| 3520 | glccDef(:,g2c) = veget_4veg(:,igrass)-glcc(:,g2c) |
|---|
| 3521 | WHERE(veget_4veg(:,igrass)>glcc(:,g2c)) |
|---|
| 3522 | glccReal(:,g2c) = glcc(:,g2c) |
|---|
| 3523 | ELSEWHERE |
|---|
| 3524 | glccReal(:,g2c) = veget_4veg(:,igrass) |
|---|
| 3525 | ENDWHERE |
|---|
| 3526 | ELSEWHERE |
|---|
| 3527 | glccReal(:,g2c) = 0. |
|---|
| 3528 | glccDef(:,g2c) = -1*glcc(:,g2c) |
|---|
| 3529 | ENDWHERE |
|---|
| 3530 | |
|---|
| 3531 | !! 1. Compensation sequence: pasture,grass,forest |
|---|
| 3532 | tmpdef(:) = glccDef(:,f2c)+glccDef(:,g2c)+glccDef(:,p2c) |
|---|
| 3533 | WHERE(glccDef(:,p2c)<0) |
|---|
| 3534 | WHERE(glccDef(:,g2c)<0) |
|---|
| 3535 | WHERE(glccDef(:,f2c)<0) ! 1 (-,-,-) |
|---|
| 3536 | IncreDeficit(:,icrop) = tmpdef(:) |
|---|
| 3537 | ELSEWHERE ! 2 (-,-,+) |
|---|
| 3538 | WHERE(tmpdef(:)>=min_stomate) |
|---|
| 3539 | glccReal(:,f2c) = glccReal(:,f2c)-glccDef(:,g2c)-glccDef(:,p2c) |
|---|
| 3540 | ELSEWHERE |
|---|
| 3541 | glccReal(:,f2c) = veget_4veg(:,itree) |
|---|
| 3542 | IncreDeficit(:,icrop) = tmpdef(:) |
|---|
| 3543 | ENDWHERE |
|---|
| 3544 | ENDWHERE |
|---|
| 3545 | ELSEWHERE |
|---|
| 3546 | WHERE(glccDef(:,f2c)<0) ! 3 (-,+,-) |
|---|
| 3547 | WHERE(tmpdef(:)>=min_stomate) |
|---|
| 3548 | glccReal(:,g2c) = glccReal(:,g2c)-glccDef(:,p2c)-glccDef(:,f2c) |
|---|
| 3549 | ELSEWHERE |
|---|
| 3550 | glccReal(:,g2c) = veget_4veg(:,igrass) |
|---|
| 3551 | IncreDeficit(:,icrop) = tmpdef(:) |
|---|
| 3552 | ENDWHERE |
|---|
| 3553 | ELSEWHERE ! 4 (-,+,+) |
|---|
| 3554 | WHERE(tmpdef(:)>=min_stomate) |
|---|
| 3555 | WHERE((glccDef(:,g2c)+glccDef(:,p2c))>=min_stomate) |
|---|
| 3556 | glccReal(:,g2c) = glccReal(:,g2c)-glccDef(:,p2c) |
|---|
| 3557 | ELSEWHERE |
|---|
| 3558 | glccReal(:,g2c) = veget_4veg(:,igrass) |
|---|
| 3559 | glccReal(:,f2c) = glccReal(:,f2c)-(glccDef(:,p2c)+glccDef(:,g2c)) |
|---|
| 3560 | ENDWHERE |
|---|
| 3561 | ELSEWHERE |
|---|
| 3562 | glccReal(:,g2c) = veget_4veg(:,igrass) |
|---|
| 3563 | glccReal(:,f2c) = veget_4veg(:,itree) |
|---|
| 3564 | IncreDeficit(:,icrop) = tmpdef(:) |
|---|
| 3565 | ENDWHERE |
|---|
| 3566 | ENDWHERE |
|---|
| 3567 | ENDWHERE |
|---|
| 3568 | ELSEWHERE |
|---|
| 3569 | WHERE(glccDef(:,g2c)<0) |
|---|
| 3570 | WHERE(glccDef(:,f2c)<0) ! 5 (+,-,-) |
|---|
| 3571 | WHERE(tmpdef(:)>=min_stomate) |
|---|
| 3572 | glccReal(:,p2c) = glccReal(:,p2c)-glccDef(:,g2c)-glccDef(:,f2c) |
|---|
| 3573 | ELSEWHERE |
|---|
| 3574 | IncreDeficit(:,icrop) = tmpdef(:) |
|---|
| 3575 | glccReal(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 3576 | ENDWHERE |
|---|
| 3577 | ELSEWHERE ! 6 (+,-,+) |
|---|
| 3578 | WHERE(tmpdef(:)>=min_stomate) |
|---|
| 3579 | WHERE((glccDef(:,p2c)+glccDef(:,g2c))>=min_stomate) |
|---|
| 3580 | glccReal(:,p2c) = glccReal(:,p2c)-glccDef(:,g2c) |
|---|
| 3581 | ELSEWHERE |
|---|
| 3582 | glccReal(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 3583 | glccReal(:,f2c) = glccReal(:,f2c)-(glccDef(:,g2c)+glccDef(:,p2c)) |
|---|
| 3584 | ENDWHERE |
|---|
| 3585 | ELSEWHERE |
|---|
| 3586 | IncreDeficit(:,icrop) = tmpdef(:) |
|---|
| 3587 | glccReal(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 3588 | glccReal(:,f2c) = veget_4veg(:,itree) |
|---|
| 3589 | ENDWHERE |
|---|
| 3590 | ENDWHERE |
|---|
| 3591 | ELSEWHERE |
|---|
| 3592 | WHERE(glccDef(:,f2c)<0) ! 7 (+,+,-) |
|---|
| 3593 | WHERE(tmpdef(:)>=min_stomate) |
|---|
| 3594 | WHERE((glccDef(:,p2c)+glccDef(:,f2c))>=min_stomate) |
|---|
| 3595 | glccReal(:,p2c) = glccReal(:,p2c)-glccDef(:,f2c) |
|---|
| 3596 | ELSEWHERE |
|---|
| 3597 | glccReal(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 3598 | glccReal(:,g2c) = glccReal(:,g2c)-(glccDef(:,f2c)+glccDef(:,p2c)) |
|---|
| 3599 | ENDWHERE |
|---|
| 3600 | ELSEWHERE |
|---|
| 3601 | IncreDeficit(:,icrop) = tmpdef(:) |
|---|
| 3602 | glccReal(:,g2c) = veget_4veg(:,igrass) |
|---|
| 3603 | glccReal(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 3604 | ENDWHERE |
|---|
| 3605 | ELSEWHERE ! 8 (+,+,+) |
|---|
| 3606 | !do nothing |
|---|
| 3607 | ENDWHERE |
|---|
| 3608 | ENDWHERE |
|---|
| 3609 | ENDWHERE |
|---|
| 3610 | veget_4veg(:,itree) = veget_4veg(:,itree) - glccReal(:,f2c) |
|---|
| 3611 | veget_4veg(:,igrass) = veget_4veg(:,igrass) - glccReal(:,g2c) |
|---|
| 3612 | veget_4veg(:,ipasture) = veget_4veg(:,ipasture) - glccReal(:,p2c) |
|---|
| 3613 | |
|---|
| 3614 | END SUBROUTINE glcc_compensation_full |
|---|
| 3615 | |
|---|
| 3616 | |
|---|
| 3617 | |
|---|
| 3618 | !! This subroutine implements non-full compensation, is currently |
|---|
| 3619 | !! abandoned. |
|---|
| 3620 | SUBROUTINE glcc_compensation(npts,veget_4veg,glcc,glccDef, & |
|---|
| 3621 | p2c,ipasture,g2c,igrass,f2c,itree,icrop, & |
|---|
| 3622 | IncreDeficit) |
|---|
| 3623 | |
|---|
| 3624 | IMPLICIT NONE |
|---|
| 3625 | |
|---|
| 3626 | !! 0.1 Input variables |
|---|
| 3627 | INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 3628 | REAL(r_std), DIMENSION(npts,4), INTENT(in) :: veget_4veg !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 3629 | INTEGER, INTENT(in) :: p2c,ipasture,g2c,igrass,f2c,itree,icrop |
|---|
| 3630 | |
|---|
| 3631 | !! 0.2 Output variables |
|---|
| 3632 | |
|---|
| 3633 | |
|---|
| 3634 | !! 0.3 Modified variables |
|---|
| 3635 | REAL(r_std), DIMENSION (npts,12),INTENT(inout) :: glcc !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 3636 | !! used. |
|---|
| 3637 | REAL(r_std), DIMENSION(npts,12), INTENT(inout) :: glccDef !! Gross LCC deficit, negative values mean that there |
|---|
| 3638 | !! are not enough fractions in the source vegetations |
|---|
| 3639 | !! to the target ones as presribed by the LCC matrix. |
|---|
| 3640 | REAL(r_std), DIMENSION(npts,4), INTENT(inout) :: IncreDeficit !! "Increment" deficits, negative values mean that |
|---|
| 3641 | !! there are not enough fractions in the source PFTs |
|---|
| 3642 | !! /vegetations to target PFTs/vegetations. I.e., these |
|---|
| 3643 | !! fraction transfers are presribed in LCC matrix but |
|---|
| 3644 | !! not realized. |
|---|
| 3645 | |
|---|
| 3646 | !! 0.4 Local variables |
|---|
| 3647 | REAL(r_std), DIMENSION(npts) :: glccDef_all !! LCC deficits by summing up all the deficits to the |
|---|
| 3648 | !! the same target vegetation. |
|---|
| 3649 | |
|---|
| 3650 | |
|---|
| 3651 | WHERE(veget_4veg(:,itree) > min_stomate) |
|---|
| 3652 | glccDef(:,f2c) = veget_4veg(:,itree)-glcc(:,f2c) |
|---|
| 3653 | ELSEWHERE |
|---|
| 3654 | glccDef(:,f2c) = -1*glcc(:,f2c) |
|---|
| 3655 | glcc(:,f2c) = 0. |
|---|
| 3656 | ENDWHERE |
|---|
| 3657 | |
|---|
| 3658 | WHERE(veget_4veg(:,ipasture) > min_stomate) |
|---|
| 3659 | glccDef(:,p2c) = veget_4veg(:,ipasture)-glcc(:,p2c) |
|---|
| 3660 | ELSEWHERE |
|---|
| 3661 | glccDef(:,p2c) = -1*glcc(:,p2c) |
|---|
| 3662 | glcc(:,p2c) = 0. |
|---|
| 3663 | ENDWHERE |
|---|
| 3664 | |
|---|
| 3665 | WHERE(veget_4veg(:,igrass) > min_stomate) |
|---|
| 3666 | glccDef(:,g2c) = veget_4veg(:,igrass)-glcc(:,g2c) |
|---|
| 3667 | ELSEWHERE |
|---|
| 3668 | glccDef(:,g2c) = -1*glcc(:,g2c) |
|---|
| 3669 | glcc(:,g2c) = 0. |
|---|
| 3670 | ENDWHERE |
|---|
| 3671 | |
|---|
| 3672 | glccDef_all(:) = glccDef(:,f2c)+glccDef(:,p2c)+glccDef(:,g2c) |
|---|
| 3673 | |
|---|
| 3674 | ! We allow the surpluses/deficits in p2c and g2c mutually compensating |
|---|
| 3675 | ! for each other. If there are still deficits after this compensation, |
|---|
| 3676 | ! they will be further compensated for by the surpluses from f2c (if there are any |
|---|
| 3677 | ! surpluses). The ultimate deficits that cannot be compensated for |
|---|
| 3678 | ! will be recorded and dropped. |
|---|
| 3679 | |
|---|
| 3680 | ! Because we assume the "pasture rule" is used, i.e., the crops |
|---|
| 3681 | ! are supposed to come primarily from pastures and grasses, normally |
|---|
| 3682 | ! we expect the deficits to occur in p2c or g2c rather than in f2c. But |
|---|
| 3683 | ! if it happens that f2c has deficits while p2c or g2c has surpluse, |
|---|
| 3684 | ! the surpluses will not be used to compensate for the f2c-deficits, |
|---|
| 3685 | ! instead, we will just record and drop the f2c-deficits. |
|---|
| 3686 | |
|---|
| 3687 | ! In following codes for convenience we're not going to check |
|---|
| 3688 | ! whether surpluses in f2c are enough to compensate for deficits |
|---|
| 3689 | ! in p2c or g2c or both. Instead, we just add their deficits on top |
|---|
| 3690 | ! of f2c. The issues of not-enough surpluses in f2c will be left for |
|---|
| 3691 | ! the codes after this section to handle. |
|---|
| 3692 | WHERE (glccDef(:,p2c) < 0.) |
|---|
| 3693 | glcc(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 3694 | WHERE (glccDef(:,g2c) < 0.) |
|---|
| 3695 | glcc(:,g2c) = veget_4veg(:,igrass) |
|---|
| 3696 | ELSEWHERE |
|---|
| 3697 | WHERE (glccDef(:,g2c)+glccDef(:,p2c) > min_stomate) |
|---|
| 3698 | glcc(:,g2c) = glcc(:,g2c)-glccDef(:,p2c) |
|---|
| 3699 | ELSEWHERE |
|---|
| 3700 | glcc(:,g2c) = veget_4veg(:,igrass) |
|---|
| 3701 | ! whatever the case, we simply add the dificts to f2c |
|---|
| 3702 | glcc(:,f2c) = glcc(:,f2c)-glccDef(:,p2c)-glccDef(:,g2c) |
|---|
| 3703 | ENDWHERE |
|---|
| 3704 | ENDWHERE |
|---|
| 3705 | |
|---|
| 3706 | ELSEWHERE |
|---|
| 3707 | WHERE(glccDef(:,g2c) < 0.) |
|---|
| 3708 | glcc(:,g2c) = veget_4veg(:,igrass) |
|---|
| 3709 | WHERE(glccDef(:,p2c)+glccDef(:,g2c) > min_stomate) |
|---|
| 3710 | glcc(:,p2c) = glcc(:,p2c)-glccDef(:,g2c) |
|---|
| 3711 | ELSEWHERE |
|---|
| 3712 | glcc(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 3713 | ! whatever the case, we simply add the dificts to f2c |
|---|
| 3714 | glcc(:,f2c) = glcc(:,f2c)-glccDef(:,p2c)-glccDef(:,g2c) |
|---|
| 3715 | ENDWHERE |
|---|
| 3716 | ELSEWHERE |
|---|
| 3717 | !Here p2c and g2c both show surplus, we're not going to check whether |
|---|
| 3718 | !glccDef(:,f2c) has negative values because we assume a "pasture rule" |
|---|
| 3719 | !is applied when constructing the gross LCC matrix, so deficits in |
|---|
| 3720 | !f2c will just be dropped but not be compensated for by the surpluses in |
|---|
| 3721 | !p2c or g2c. |
|---|
| 3722 | ENDWHERE |
|---|
| 3723 | ENDWHERE |
|---|
| 3724 | |
|---|
| 3725 | ! 1. We calculate again the f2c-deficit because f2c-glcc is adjusted in the |
|---|
| 3726 | ! codes above as we allocated the deficits of p2c and g2c into f2c. |
|---|
| 3727 | ! In cases where glccDef_all is less than zero, f2c-glcc will be larger |
|---|
| 3728 | ! than available forest veget_max and we therefore limit the f2c-glcc to |
|---|
| 3729 | ! available forest cover. |
|---|
| 3730 | ! 2. There is (probably) a second case where glccDef_all is larger then zero, |
|---|
| 3731 | ! but f2c-glcc is higher than veget_tree, i.e., Originally f2c is given a |
|---|
| 3732 | ! high value that there is deficit in f2c but surpluses exist for p2c and g2c. |
|---|
| 3733 | ! Normally we |
|---|
| 3734 | ! assume this won't happen as explained above, given that a "pasture rule" was |
|---|
| 3735 | ! used in constructing the gross LCC matrix. Nevertheless if this deos |
|---|
| 3736 | ! happen, we will just drop the f2c deficit without being compensated |
|---|
| 3737 | ! for by the surplus in p2c or g2c. |
|---|
| 3738 | |
|---|
| 3739 | ! we handle the 2nd case first |
|---|
| 3740 | WHERE(veget_4veg(:,itree) > min_stomate ) |
|---|
| 3741 | WHERE(glccDef(:,f2c) < 0.) |
|---|
| 3742 | glcc(:,f2c) = veget_4veg(:,itree) |
|---|
| 3743 | WHERE (glccDef(:,p2c)+glccDef(:,g2c) > min_stomate) |
|---|
| 3744 | IncreDeficit(:,icrop) = glccDef(:,f2c) |
|---|
| 3745 | ELSEWHERE |
|---|
| 3746 | IncreDeficit(:,icrop) = glccDef_all(:) |
|---|
| 3747 | ENDWHERE |
|---|
| 3748 | ELSEWHERE |
|---|
| 3749 | WHERE(glccDef_all(:) < 0.) !handle the 1st case |
|---|
| 3750 | glcc(:,f2c) = veget_4veg(:,itree) |
|---|
| 3751 | IncreDeficit(:,icrop) = glccDef_all(:) |
|---|
| 3752 | ENDWHERE |
|---|
| 3753 | ENDWHERE |
|---|
| 3754 | ELSEWHERE |
|---|
| 3755 | WHERE(glccDef(:,p2c)+glccDef(:,g2c)>min_stomate) |
|---|
| 3756 | IncreDeficit(:,icrop) = glccDef(:,f2c) |
|---|
| 3757 | ELSEWHERE |
|---|
| 3758 | IncreDeficit(:,icrop) = glccDef_all(:) |
|---|
| 3759 | ENDWHERE |
|---|
| 3760 | ENDWHERE |
|---|
| 3761 | |
|---|
| 3762 | END SUBROUTINE glcc_compensation |
|---|
| 3763 | |
|---|
| 3764 | |
|---|
| 3765 | |
|---|
| 3766 | END MODULE stomate_glcchange_fh |
|---|
| 3767 | |
|---|
| 3768 | |
|---|
| 3769 | |
|---|
| 3770 | |
|---|
| 3771 | |
|---|
| 3772 | |
|---|
| 3773 | |
|---|
| 3774 | |
|---|
| 3775 | |
|---|
| 3776 | |
|---|
| 3777 | |
|---|
| 3778 | |
|---|
| 3779 | !SIMON: Below is original stomate_glcchange_fh.f90 code (same as SinAge_C_fh but updated for merge) |
|---|
| 3780 | ! |
|---|
| 3781 | ! ! ================================================================================================================================ |
|---|
| 3782 | ! !! SUBROUTINE : harvest_forest |
|---|
| 3783 | ! !! |
|---|
| 3784 | ! !>\BRIEF : Handle forest harvest before its legacy is transferred to |
|---|
| 3785 | ! ! newly initialized youngest-age-class PFT. |
|---|
| 3786 | ! !! |
|---|
| 3787 | ! !>\DESCRIPTION |
|---|
| 3788 | ! !_ ================================================================================================================================ |
|---|
| 3789 | ! !!++TEMP++ biomass,veget_frac are not used because the remaining biomass to be |
|---|
| 3790 | ! !! harvested is calculated within the deforestation fire module. |
|---|
| 3791 | ! SUBROUTINE harvest_forest (npts,ipts,ivm,biomass,frac, & |
|---|
| 3792 | ! litter_above, litter_below, deforest_biomass_remain,& |
|---|
| 3793 | ! fuel_1hr,fuel_10hr, & |
|---|
| 3794 | ! fuel_100hr,fuel_1000hr,& |
|---|
| 3795 | ! lignin_struc,& |
|---|
| 3796 | ! bm_to_litter_pro,convflux,prod10,prod100,& |
|---|
| 3797 | ! litter_pro, fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, & |
|---|
| 3798 | ! fuel_1000hr_pro, lignin_content_pro) |
|---|
| 3799 | ! |
|---|
| 3800 | ! |
|---|
| 3801 | ! IMPLICIT NONE |
|---|
| 3802 | ! |
|---|
| 3803 | ! !! 0.1 Input variables |
|---|
| 3804 | ! INTEGER, INTENT(in) :: npts |
|---|
| 3805 | ! INTEGER, INTENT(in) :: ipts |
|---|
| 3806 | ! INTEGER, INTENT(in) :: ivm |
|---|
| 3807 | ! REAL(r_std), INTENT(in) :: frac !! the fraction of land covered by forest to be deforested |
|---|
| 3808 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: biomass !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 3809 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_1hr |
|---|
| 3810 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_10hr |
|---|
| 3811 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_100hr |
|---|
| 3812 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_1000hr |
|---|
| 3813 | ! REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements) :: litter !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 3814 | ! !! deforestation region. |
|---|
| 3815 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: litter_above !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 3816 | ! !! deforestation region. |
|---|
| 3817 | ! REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(in) :: litter_below !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 3818 | ! !! deforestation region. |
|---|
| 3819 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: deforest_biomass_remain !! Vegetmax-weighted remaining biomass on the ground for |
|---|
| 3820 | ! !! deforestation region. |
|---|
| 3821 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: lignin_struc !! ratio Lignine/Carbon in structural litter, |
|---|
| 3822 | ! !! above and below ground |
|---|
| 3823 | ! |
|---|
| 3824 | ! !! 0.2 Modified variables |
|---|
| 3825 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: bm_to_litter_pro !! conversion of biomass to litter |
|---|
| 3826 | ! !! @tex ($gC m^{-2} day^{-1}$) @endtex |
|---|
| 3827 | ! REAL(r_std), DIMENSION(:), INTENT(inout) :: convflux !! release during first year following land cover |
|---|
| 3828 | ! !! change |
|---|
| 3829 | ! |
|---|
| 3830 | ! REAL(r_std), DIMENSION(npts,0:10), INTENT(inout) :: prod10 !! products remaining in the 10 year-turnover |
|---|
| 3831 | ! !! pool after the annual release for each |
|---|
| 3832 | ! !! compartment (10 + 1 : input from year of land |
|---|
| 3833 | ! !! cover change) |
|---|
| 3834 | ! REAL(r_std), DIMENSION(npts,0:100), INTENT(inout) :: prod100 !! products remaining in the 100 year-turnover |
|---|
| 3835 | ! !! pool after the annual release for each |
|---|
| 3836 | ! !! compartment (100 + 1 : input from year of land |
|---|
| 3837 | ! !! cover change) |
|---|
| 3838 | ! |
|---|
| 3839 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: litter_pro |
|---|
| 3840 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: fuel_1hr_pro |
|---|
| 3841 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: fuel_10hr_pro |
|---|
| 3842 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: fuel_100hr_pro |
|---|
| 3843 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: fuel_1000hr_pro |
|---|
| 3844 | ! REAL(r_std), DIMENSION(:),INTENT(inout) :: lignin_content_pro |
|---|
| 3845 | ! |
|---|
| 3846 | ! |
|---|
| 3847 | ! |
|---|
| 3848 | ! !! 0.4 Local variables |
|---|
| 3849 | ! REAL(r_std) :: above |
|---|
| 3850 | ! |
|---|
| 3851 | ! ! harvest of aboveground sap- and heartwood biomass after taking into |
|---|
| 3852 | ! ! account of deforestation fire |
|---|
| 3853 | ! IF (allow_deforest_fire) THEN |
|---|
| 3854 | ! above = deforest_biomass_remain(ipts,ivm,isapabove,icarbon)+ & |
|---|
| 3855 | ! deforest_biomass_remain(ipts,ivm,iheartabove,icarbon) |
|---|
| 3856 | ! convflux(ipts) = convflux(ipts) + 0 |
|---|
| 3857 | ! prod10(ipts,0) = prod10(ipts,0) + 0.4*above |
|---|
| 3858 | ! prod100(ipts,0) = prod100(ipts,0) + 0.6*above |
|---|
| 3859 | ! ELSE |
|---|
| 3860 | ! above = (biomass(ipts,ivm,isapabove,icarbon)+ & |
|---|
| 3861 | ! biomass(ipts,ivm,iheartabove,icarbon))*frac |
|---|
| 3862 | ! convflux(ipts) = convflux(ipts) + coeff_lcchange_1(ivm) * above |
|---|
| 3863 | ! prod10(ipts,0) = prod10(ipts,0) + coeff_lcchange_10(ivm) * above |
|---|
| 3864 | ! prod100(ipts,0) = prod100(ipts,0) + coeff_lcchange_100(ivm) * above |
|---|
| 3865 | ! ENDIF |
|---|
| 3866 | ! |
|---|
| 3867 | ! ! the transfer of dead biomass to litter |
|---|
| 3868 | ! bm_to_litter_pro(isapbelow,:) = bm_to_litter_pro(isapbelow,:) + & |
|---|
| 3869 | ! biomass(ipts,ivm,isapbelow,:)*frac |
|---|
| 3870 | ! bm_to_litter_pro(iheartbelow,:) = bm_to_litter_pro(iheartbelow,:) + & |
|---|
| 3871 | ! biomass(ipts,ivm,iheartbelow,:)*frac |
|---|
| 3872 | ! bm_to_litter_pro(iroot,:) = bm_to_litter_pro(iroot,:) + & |
|---|
| 3873 | ! biomass(ipts,ivm,iroot,:)*frac |
|---|
| 3874 | ! bm_to_litter_pro(ifruit,:) = bm_to_litter_pro(ifruit,:) + & |
|---|
| 3875 | ! biomass(ipts,ivm,ifruit,:)*frac |
|---|
| 3876 | ! bm_to_litter_pro(icarbres,:) = bm_to_litter_pro(icarbres,:) + & |
|---|
| 3877 | ! biomass(ipts,ivm,icarbres,:)*frac |
|---|
| 3878 | ! bm_to_litter_pro(ileaf,:) = bm_to_litter_pro(ileaf,:) + & |
|---|
| 3879 | ! biomass(ipts,ivm,ileaf,:)*frac |
|---|
| 3880 | ! |
|---|
| 3881 | ! !update litter_pro |
|---|
| 3882 | ! litter_pro(:,:,:) = litter_pro(:,:,:) + litter(ipts,:,ivm,:,:)*frac |
|---|
| 3883 | ! fuel_1hr_pro(:,:) = fuel_1hr_pro(:,:) + fuel_1hr(ipts,ivm,:,:)*frac |
|---|
| 3884 | ! fuel_10hr_pro(:,:) = fuel_10hr_pro(:,:) + fuel_10hr(ipts,ivm,:,:)*frac |
|---|
| 3885 | ! fuel_100hr_pro(:,:) = fuel_100hr_pro(:,:) + fuel_100hr(ipts,ivm,:,:)*frac |
|---|
| 3886 | ! fuel_1000hr_pro(:,:) = fuel_1000hr_pro(:,:) + fuel_1000hr(ipts,ivm,:,:)*frac |
|---|
| 3887 | ! !don't forget to hanle litter lignin content |
|---|
| 3888 | ! lignin_content_pro(:)= lignin_content_pro(:) + & |
|---|
| 3889 | ! litter(ipts,istructural,ivm,:,icarbon)*frac*lignin_struc(ipts,ivm,:) |
|---|
| 3890 | ! |
|---|
| 3891 | ! END SUBROUTINE harvest_forest |
|---|
| 3892 | ! |
|---|
| 3893 | ! ! ================================================================================================================================ |
|---|
| 3894 | ! !! SUBROUTINE : harvest_herb |
|---|
| 3895 | ! !! |
|---|
| 3896 | ! !>\BRIEF : Handle herbaceous PFT clearing before its legacy is transferred to |
|---|
| 3897 | ! ! newly initialized youngest-age-class PFT. |
|---|
| 3898 | ! !! |
|---|
| 3899 | ! !>\DESCRIPTION |
|---|
| 3900 | ! !_ ================================================================================================================================ |
|---|
| 3901 | ! SUBROUTINE harvest_herb (ipts,ivm,biomass,veget_frac,bm_to_litter_pro) |
|---|
| 3902 | ! |
|---|
| 3903 | ! IMPLICIT NONE |
|---|
| 3904 | ! |
|---|
| 3905 | ! !! 0.1 Input variables |
|---|
| 3906 | ! INTEGER, INTENT(in) :: ipts |
|---|
| 3907 | ! INTEGER, INTENT(in) :: ivm |
|---|
| 3908 | ! REAL(r_std), INTENT(in) :: veget_frac !! the fraction of land covered by herbaceous PFT to be cleared |
|---|
| 3909 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: biomass !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 3910 | ! |
|---|
| 3911 | ! !! 0.2 Modified variables |
|---|
| 3912 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: bm_to_litter_pro |
|---|
| 3913 | ! |
|---|
| 3914 | ! |
|---|
| 3915 | ! |
|---|
| 3916 | ! ! the transfer of dead biomass to litter |
|---|
| 3917 | ! bm_to_litter_pro(:,:) = bm_to_litter_pro(:,:) + biomass(ipts,ivm,:,:)*veget_frac |
|---|
| 3918 | ! |
|---|
| 3919 | ! END SUBROUTINE harvest_herb |
|---|
| 3920 | ! |
|---|
| 3921 | ! |
|---|
| 3922 | ! ! ================================================================================================================================ |
|---|
| 3923 | ! !! SUBROUTINE : initialize_proxy_pft |
|---|
| 3924 | ! !! |
|---|
| 3925 | ! !>\BRIEF Initialize a proxy new youngest age class PFT. |
|---|
| 3926 | ! !! |
|---|
| 3927 | ! !>\DESCRIPTION Initialize a proxy new youngest age class PFT that will be |
|---|
| 3928 | ! !! merged with existing yongest age class, or fill the empty |
|---|
| 3929 | ! !! niche of the youngest age class PFT. |
|---|
| 3930 | ! !_ ================================================================================================================================ |
|---|
| 3931 | ! SUBROUTINE initialize_proxy_pft(ipts,ipft_young_agec,veget_max_pro, & |
|---|
| 3932 | ! biomass_pro, co2_to_bm_pro, ind_pro, age_pro, & |
|---|
| 3933 | ! senescence_pro, PFTpresent_pro, & |
|---|
| 3934 | ! lm_lastyearmax_pro, everywhere_pro, npp_longterm_pro, & |
|---|
| 3935 | ! leaf_frac_pro,leaf_age_pro) |
|---|
| 3936 | ! |
|---|
| 3937 | ! IMPLICIT NONE |
|---|
| 3938 | ! |
|---|
| 3939 | ! !! 0.1 Input variables |
|---|
| 3940 | ! INTEGER, INTENT(in) :: ipts !! |
|---|
| 3941 | ! INTEGER, INTENT(in) :: ipft_young_agec !! index of the concerned youngest-age-class PFT |
|---|
| 3942 | ! REAL(r_std), INTENT(in) :: veget_max_pro !! fraction of grid cell land area that's to be occupied |
|---|
| 3943 | ! |
|---|
| 3944 | ! !! 0.2 Modified variables |
|---|
| 3945 | ! REAL(r_std), INTENT(inout) :: co2_to_bm_pro |
|---|
| 3946 | ! |
|---|
| 3947 | ! !! 0.3 Output variables |
|---|
| 3948 | ! REAL(r_std), DIMENSION(:,:), INTENT(out) :: biomass_pro !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 3949 | ! REAL(r_std), DIMENSION(:), INTENT(out) :: leaf_frac_pro !! fraction of leaves in leaf age class |
|---|
| 3950 | ! REAL(r_std), DIMENSION(:), INTENT(out) :: leaf_age_pro !! fraction of leaves in leaf age class |
|---|
| 3951 | ! REAL(r_std), INTENT(out) :: age_pro, ind_pro, lm_lastyearmax_pro |
|---|
| 3952 | ! REAL(r_std), INTENT(out) :: npp_longterm_pro |
|---|
| 3953 | ! REAL(r_std), INTENT(out) :: everywhere_pro !! is the PFT everywhere in the grid box or very |
|---|
| 3954 | ! LOGICAL, INTENT(out) :: senescence_pro !! plant senescent (only for deciduous trees) Set |
|---|
| 3955 | ! !! to .FALSE. if PFT is introduced or killed |
|---|
| 3956 | ! LOGICAL, INTENT(out) :: PFTpresent_pro !! Is pft there (unitless) |
|---|
| 3957 | ! |
|---|
| 3958 | ! !! 0.4 Local variables |
|---|
| 3959 | ! !REAL(r_std), DIMENSION(npts,nvm) :: when_growthinit !! how many days ago was the beginning of the |
|---|
| 3960 | ! ! !! growing season (days) |
|---|
| 3961 | ! |
|---|
| 3962 | ! REAL(r_std), DIMENSION(nparts,nelements) :: bm_new !! biomass increase @tex ($gC m^{-2}$) @endtex |
|---|
| 3963 | ! REAL(r_std) :: cn_ind,ind |
|---|
| 3964 | ! INTEGER :: i,j,k,l |
|---|
| 3965 | ! |
|---|
| 3966 | ! ! -Note- |
|---|
| 3967 | ! ! This part of codes are copied from the original lcchange_main subroutine |
|---|
| 3968 | ! ! that initialize a new PFT. |
|---|
| 3969 | ! |
|---|
| 3970 | ! i=ipts |
|---|
| 3971 | ! j=ipft_young_agec |
|---|
| 3972 | ! |
|---|
| 3973 | ! !! Initialization of some variables |
|---|
| 3974 | ! leaf_frac_pro(:) = zero |
|---|
| 3975 | ! leaf_age_pro(:) = zero |
|---|
| 3976 | ! |
|---|
| 3977 | ! !! Initial setting of new establishment |
|---|
| 3978 | ! IF (is_tree(j)) THEN |
|---|
| 3979 | ! ! cn_sapl(j)=0.5; stomate_data.f90 |
|---|
| 3980 | ! cn_ind = cn_sapl(j) |
|---|
| 3981 | ! ELSE |
|---|
| 3982 | ! cn_ind = un |
|---|
| 3983 | ! ENDIF |
|---|
| 3984 | ! ind = veget_max_pro / cn_ind |
|---|
| 3985 | ! ind_pro = ind*veget_max_pro |
|---|
| 3986 | ! PFTpresent_pro = .TRUE. |
|---|
| 3987 | ! senescence_pro = .FALSE. |
|---|
| 3988 | ! everywhere_pro = 1.*veget_max_pro |
|---|
| 3989 | ! age_pro = zero |
|---|
| 3990 | ! |
|---|
| 3991 | ! ! large_value = 1.E33_r_std |
|---|
| 3992 | ! ! when_growthinit(i,j) = large_value |
|---|
| 3993 | ! leaf_frac_pro(1) = 1.0 * veget_max_pro |
|---|
| 3994 | ! leaf_age_pro(1) = 1.0 * veget_max_pro !This was not included in original lcchange_main subroutine |
|---|
| 3995 | ! npp_longterm_pro = npp_longterm_init * veget_max_pro |
|---|
| 3996 | ! lm_lastyearmax_pro = bm_sapl(j,ileaf,icarbon) * ind * veget_max_pro |
|---|
| 3997 | ! |
|---|
| 3998 | ! !! Update of biomass in each each carbon stock component (leaf, sapabove, sapbelow, |
|---|
| 3999 | ! !> heartabove, heartbelow, root, fruit, and carbres)\n |
|---|
| 4000 | ! DO k = 1, nparts ! loop over # carbon stock components, nparts = 8; stomate_constant.f90 |
|---|
| 4001 | ! DO l = 1,nelements ! loop over # elements |
|---|
| 4002 | ! biomass_pro(k,l) = ind * bm_sapl(j,k,l) |
|---|
| 4003 | ! END DO ! loop over # elements |
|---|
| 4004 | ! co2_to_bm_pro = co2_to_bm_pro + ind * bm_sapl(j,k,icarbon) |
|---|
| 4005 | ! ENDDO ! loop over # carbon stock components |
|---|
| 4006 | ! |
|---|
| 4007 | ! END SUBROUTINE initialize_proxy_pft |
|---|
| 4008 | ! |
|---|
| 4009 | ! ! ================================================================================================================================ |
|---|
| 4010 | ! !! SUBROUTINE sap_take |
|---|
| 4011 | ! !! |
|---|
| 4012 | ! !>\BRIEF : Take the sapling biomass of the new PFTs from the existing biomass, otherwise |
|---|
| 4013 | ! ! take from co2_to_bm |
|---|
| 4014 | ! !! |
|---|
| 4015 | ! !>\DESCRIPTION |
|---|
| 4016 | ! !_ ================================================================================================================================ |
|---|
| 4017 | ! SUBROUTINE sap_take (ipts,ivma,veget_max,biomass_pro,biomass,co2_to_bm_pro) |
|---|
| 4018 | ! |
|---|
| 4019 | ! INTEGER, INTENT(in) :: ipts !! |
|---|
| 4020 | ! INTEGER, INTENT(in) :: ivma |
|---|
| 4021 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: veget_max !! "maximal" coverage fraction of a PFT (LAI -> |
|---|
| 4022 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: biomass_pro !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 4023 | ! |
|---|
| 4024 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: biomass !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 4025 | ! REAL(r_std), INTENT(inout) :: co2_to_bm_pro |
|---|
| 4026 | ! |
|---|
| 4027 | ! |
|---|
| 4028 | ! REAL(r_std), DIMENSION(nparts,nelements) :: biomass_total !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 4029 | ! REAL(r_std) :: bm_org,bmpro_share |
|---|
| 4030 | ! INTEGER :: i,ivm,ipart |
|---|
| 4031 | ! |
|---|
| 4032 | ! biomass_total(:,:) = zero |
|---|
| 4033 | ! bm_org = zero |
|---|
| 4034 | ! bmpro_share = zero |
|---|
| 4035 | ! |
|---|
| 4036 | ! DO i = 1,nagec_pft(ivma) |
|---|
| 4037 | ! ivm = start_index(ivma)+i-1 |
|---|
| 4038 | ! IF (veget_max(ipts,ivm) .GT. min_stomate) THEN |
|---|
| 4039 | ! biomass_total = biomass_total + biomass(ipts,ivm,:,:)*veget_max(ipts,ivm) |
|---|
| 4040 | ! ENDIF |
|---|
| 4041 | ! ENDDO |
|---|
| 4042 | ! |
|---|
| 4043 | ! DO ipart = 1, nparts |
|---|
| 4044 | ! IF (biomass_total(ipart,icarbon) .GT. biomass_pro(ipart,icarbon)) THEN |
|---|
| 4045 | ! co2_to_bm_pro = co2_to_bm_pro - biomass_pro(ipart,icarbon) |
|---|
| 4046 | ! !treat each PFT of the MTC |
|---|
| 4047 | ! DO i = 1,nagec_pft(ivma) |
|---|
| 4048 | ! ivm = start_index(ivma)+i-1 |
|---|
| 4049 | ! IF (veget_max(ipts,ivm) .GT. min_stomate) THEN |
|---|
| 4050 | ! bm_org = biomass(ipts,ivm,ipart,icarbon) * veget_max(ipts,ivm) |
|---|
| 4051 | ! bmpro_share = bm_org/biomass_total(ipart,icarbon) * biomass_pro(ipart,icarbon) |
|---|
| 4052 | ! biomass(ipts,ivm,ipart,icarbon) = (bm_org - bmpro_share)/veget_max(ipts,ivm) |
|---|
| 4053 | ! ENDIF |
|---|
| 4054 | ! ENDDO |
|---|
| 4055 | ! ENDIF |
|---|
| 4056 | ! ENDDO |
|---|
| 4057 | ! |
|---|
| 4058 | ! END SUBROUTINE sap_take |
|---|
| 4059 | ! |
|---|
| 4060 | ! ! ================================================================================================================================ |
|---|
| 4061 | ! !! SUBROUTINE collect_legacy_pft |
|---|
| 4062 | ! !! |
|---|
| 4063 | ! !>\BRIEF : Collect the legacy variables that are going to be included |
|---|
| 4064 | ! ! in the newly initialized PFT. |
|---|
| 4065 | ! !! |
|---|
| 4066 | ! !>\DESCRIPTION |
|---|
| 4067 | ! !_ ================================================================================================================================ |
|---|
| 4068 | ! SUBROUTINE collect_legacy_pft(npts, ipts, ivma, glcc_pftmtc, & |
|---|
| 4069 | ! biomass, bm_to_litter, carbon, litter_above, litter_below, & |
|---|
| 4070 | ! deepC_a, deepC_s, deepC_p, & |
|---|
| 4071 | ! fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 4072 | ! lignin_struc, co2_to_bm, gpp_daily, npp_daily, & |
|---|
| 4073 | ! resp_maint, resp_growth, resp_hetero, co2_fire, & |
|---|
| 4074 | ! def_fuel_1hr_remain, def_fuel_10hr_remain, & |
|---|
| 4075 | ! def_fuel_100hr_remain, def_fuel_1000hr_remain, & |
|---|
| 4076 | ! deforest_litter_remain, deforest_biomass_remain, & |
|---|
| 4077 | ! veget_max_pro, carbon_pro, lignin_struc_pro, litter_pro, & |
|---|
| 4078 | ! deepC_a_pro, deepC_s_pro, deepC_p_pro, & |
|---|
| 4079 | ! fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, fuel_1000hr_pro, & |
|---|
| 4080 | ! bm_to_litter_pro, co2_to_bm_pro, gpp_daily_pro, & |
|---|
| 4081 | ! npp_daily_pro, resp_maint_pro, resp_growth_pro, & |
|---|
| 4082 | ! resp_hetero_pro, co2_fire_pro, & |
|---|
| 4083 | ! convflux,prod10,prod100) |
|---|
| 4084 | ! |
|---|
| 4085 | ! IMPLICIT NONE |
|---|
| 4086 | ! |
|---|
| 4087 | ! !! 0.1 Input variables |
|---|
| 4088 | ! INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 4089 | ! INTEGER, INTENT(in) :: ipts !! Domain size - number of pixels (unitless) |
|---|
| 4090 | ! INTEGER, INTENT(in) :: ivma !! Index for metaclass |
|---|
| 4091 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: glcc_pftmtc !! a temporary variable to hold the fractions each PFT is going to lose |
|---|
| 4092 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: biomass !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 4093 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: bm_to_litter !! Transfer of biomass to litter |
|---|
| 4094 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4095 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: carbon !! carbon pool: active, slow, or passive |
|---|
| 4096 | ! !! @tex ($gC m^{-2}$) @endtex |
|---|
| 4097 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: deepC_a !! Permafrost soil carbon (g/m**3) active |
|---|
| 4098 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: deepC_s !! Permafrost soil carbon (g/m**3) slow |
|---|
| 4099 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: deepC_p !! Permafrost soil carbon (g/m**3) passive |
|---|
| 4100 | ! REAL(r_std), DIMENSION(npts,nlitt,nvm,nelements), INTENT(inout) :: litter_above !! Metabolic and structural litter, above and |
|---|
| 4101 | ! REAL(r_std), DIMENSION(npts,nlitt,nvm,nbdl,nelements), INTENT(inout) :: litter_below !!(npts,nlitt,nvm,nlevs,nelements) |
|---|
| 4102 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_1hr |
|---|
| 4103 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_10hr |
|---|
| 4104 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_100hr |
|---|
| 4105 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: fuel_1000hr |
|---|
| 4106 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: lignin_struc !! ratio Lignine/Carbon in structural litter, |
|---|
| 4107 | ! !! above and below ground |
|---|
| 4108 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: co2_to_bm !! biomass uptaken |
|---|
| 4109 | ! !! @tex ($gC m^{-2} day^{-1}$) @endtex |
|---|
| 4110 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: gpp_daily !! Daily gross primary productivity |
|---|
| 4111 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4112 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: npp_daily !! Net primary productivity |
|---|
| 4113 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4114 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: resp_maint !! Maintenance respiration |
|---|
| 4115 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4116 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: resp_growth !! Growth respiration |
|---|
| 4117 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4118 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: resp_hetero !! Heterotrophic respiration |
|---|
| 4119 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4120 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: co2_fire !! Heterotrophic respiration |
|---|
| 4121 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4122 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: def_fuel_1hr_remain |
|---|
| 4123 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: def_fuel_10hr_remain |
|---|
| 4124 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: def_fuel_100hr_remain |
|---|
| 4125 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: def_fuel_1000hr_remain |
|---|
| 4126 | ! REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(in) :: deforest_litter_remain !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 4127 | ! !! deforestation region. |
|---|
| 4128 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: deforest_biomass_remain !! Vegetmax-weighted remaining biomass on the ground for |
|---|
| 4129 | ! !! deforestation region. |
|---|
| 4130 | ! |
|---|
| 4131 | ! !! 0.2 Output variables |
|---|
| 4132 | ! REAL(r_std), DIMENSION(:), INTENT(out) :: carbon_pro |
|---|
| 4133 | ! REAL(r_std), DIMENSION(:), INTENT(out) :: deepC_a_pro |
|---|
| 4134 | ! REAL(r_std), DIMENSION(:), INTENT(out) :: deepC_s_pro |
|---|
| 4135 | ! REAL(r_std), DIMENSION(:), INTENT(out) :: deepC_p_pro |
|---|
| 4136 | ! REAL(r_std), DIMENSION(:), INTENT(out) :: lignin_struc_pro !! ratio Lignine/Carbon in structural litter |
|---|
| 4137 | ! !! above and below ground |
|---|
| 4138 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(out) :: litter_pro |
|---|
| 4139 | ! REAL(r_std), DIMENSION(:,:), INTENT(out) :: fuel_1hr_pro |
|---|
| 4140 | ! REAL(r_std), DIMENSION(:,:), INTENT(out) :: fuel_10hr_pro |
|---|
| 4141 | ! REAL(r_std), DIMENSION(:,:), INTENT(out) :: fuel_100hr_pro |
|---|
| 4142 | ! REAL(r_std), DIMENSION(:,:), INTENT(out) :: fuel_1000hr_pro |
|---|
| 4143 | ! REAL(r_std), DIMENSION(:,:), INTENT(out) :: bm_to_litter_pro |
|---|
| 4144 | ! REAL(r_std), INTENT(out) :: veget_max_pro, co2_to_bm_pro |
|---|
| 4145 | ! REAL(r_std), INTENT(out) :: gpp_daily_pro, npp_daily_pro |
|---|
| 4146 | ! REAL(r_std), INTENT(out) :: resp_maint_pro, resp_growth_pro |
|---|
| 4147 | ! REAL(r_std), INTENT(out) :: resp_hetero_pro, co2_fire_pro |
|---|
| 4148 | ! |
|---|
| 4149 | ! !! 0.3 Modified variables |
|---|
| 4150 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: convflux !! release during first year following land cover |
|---|
| 4151 | ! !! change |
|---|
| 4152 | ! |
|---|
| 4153 | ! REAL(r_std), DIMENSION(npts,0:10,nwp), INTENT(inout) :: prod10 !! products remaining in the 10 year-turnover |
|---|
| 4154 | ! !! pool after the annual release for each |
|---|
| 4155 | ! !! compartment (10 + 1 : input from year of land |
|---|
| 4156 | ! !! cover change) |
|---|
| 4157 | ! REAL(r_std), DIMENSION(npts,0:100,nwp), INTENT(inout) :: prod100 !! products remaining in the 100 year-turnover |
|---|
| 4158 | ! !! pool after the annual release for each |
|---|
| 4159 | ! !! compartment (100 + 1 : input from year of land |
|---|
| 4160 | ! !! cover change) |
|---|
| 4161 | ! |
|---|
| 4162 | ! !! 0.4 Local variables |
|---|
| 4163 | ! REAL(r_std), DIMENSION(nlevs) :: lignin_content_pro |
|---|
| 4164 | ! REAL(r_std) :: frac |
|---|
| 4165 | ! INTEGER :: ivm |
|---|
| 4166 | ! |
|---|
| 4167 | ! |
|---|
| 4168 | ! ! All *_pro variables collect the legacy pools/fluxes of the ancestor |
|---|
| 4169 | ! ! PFTs for the receiving youngest age class. All *_pro variables |
|---|
| 4170 | ! ! represent the quantity weighted by the fraction of ancestor contributing |
|---|
| 4171 | ! ! PFTs. |
|---|
| 4172 | ! ! Exceptions: |
|---|
| 4173 | ! ! lignin_struc_pro:: the ratio of lignin content in structural litter. |
|---|
| 4174 | ! |
|---|
| 4175 | ! veget_max_pro=zero |
|---|
| 4176 | ! carbon_pro(:)=zero |
|---|
| 4177 | ! deepC_a_pro(:)=zero |
|---|
| 4178 | ! deepC_s_pro(:)=zero |
|---|
| 4179 | ! deepC_p_pro(:)=zero |
|---|
| 4180 | ! lignin_struc_pro(:)=zero |
|---|
| 4181 | ! lignin_content_pro(:)=zero |
|---|
| 4182 | ! litter_pro(:,:,:)=zero |
|---|
| 4183 | ! fuel_1hr_pro(:,:)=zero |
|---|
| 4184 | ! fuel_10hr_pro(:,:)=zero |
|---|
| 4185 | ! fuel_100hr_pro(:,:)=zero |
|---|
| 4186 | ! fuel_1000hr_pro(:,:)=zero |
|---|
| 4187 | ! bm_to_litter_pro(:,:)=zero |
|---|
| 4188 | ! co2_to_bm_pro=zero |
|---|
| 4189 | ! gpp_daily_pro=zero |
|---|
| 4190 | ! npp_daily_pro=zero |
|---|
| 4191 | ! resp_maint_pro=zero |
|---|
| 4192 | ! resp_growth_pro=zero |
|---|
| 4193 | ! resp_hetero_pro=zero |
|---|
| 4194 | ! co2_fire_pro=zero |
|---|
| 4195 | ! |
|---|
| 4196 | ! DO ivm = 1,nvm |
|---|
| 4197 | ! frac = glcc_pftmtc(ipts,ivm,ivma) |
|---|
| 4198 | ! IF (frac>zero) THEN |
|---|
| 4199 | ! veget_max_pro = veget_max_pro+frac |
|---|
| 4200 | ! |
|---|
| 4201 | ! IF (is_tree(ivm)) THEN |
|---|
| 4202 | ! IF (is_tree(start_index(ivma))) THEN |
|---|
| 4203 | ! CALL harvest_forest (npts,ipts,ivm,biomass,frac, & |
|---|
| 4204 | ! litter_above, litter_below, deforest_biomass_remain,& |
|---|
| 4205 | ! fuel_1hr,fuel_10hr,& |
|---|
| 4206 | ! fuel_100hr,fuel_1000hr,& |
|---|
| 4207 | ! lignin_struc,& |
|---|
| 4208 | ! bm_to_litter_pro,convflux(:,iwphar),prod10(:,:,iwphar),prod100(:,:,iwphar),& |
|---|
| 4209 | ! litter_pro, fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, & |
|---|
| 4210 | ! fuel_1000hr_pro, lignin_content_pro) |
|---|
| 4211 | ! ELSE |
|---|
| 4212 | ! CALL harvest_forest (npts,ipts,ivm,biomass,frac, & |
|---|
| 4213 | ! litter_above, litter_below, deforest_biomass_remain,& |
|---|
| 4214 | ! fuel_1hr,fuel_10hr,& |
|---|
| 4215 | ! fuel_100hr,fuel_1000hr,& |
|---|
| 4216 | ! lignin_struc,& |
|---|
| 4217 | ! bm_to_litter_pro,convflux(:,iwplcc),prod10(:,:,iwplcc),prod100(:,:,iwplcc),& |
|---|
| 4218 | ! litter_pro, fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, & |
|---|
| 4219 | ! fuel_1000hr_pro, lignin_content_pro) |
|---|
| 4220 | ! ENDIF |
|---|
| 4221 | ! ELSE |
|---|
| 4222 | ! CALL harvest_herb(ipts,ivm,biomass,frac, & |
|---|
| 4223 | ! bm_to_litter_pro) |
|---|
| 4224 | ! litter_pro(:,iabove,:) = litter_pro(:,iabove,:) + litter_above(ipts,:,ivm,:)*frac |
|---|
| 4225 | ! litter_pro(:,ibelow,:) = litter_pro(:,ibelow,:) + sum(litter_below(ipts,:,ivm,:,:),dim=2)*frac |
|---|
| 4226 | ! fuel_1hr_pro(:,:) = fuel_1hr_pro(:,:) + fuel_1hr(ipts,ivm,:,:)*frac |
|---|
| 4227 | ! fuel_10hr_pro(:,:) = fuel_10hr_pro(:,:) + fuel_10hr(ipts,ivm,:,:)*frac |
|---|
| 4228 | ! fuel_100hr_pro(:,:) = fuel_100hr_pro(:,:) + fuel_100hr(ipts,ivm,:,:)*frac |
|---|
| 4229 | ! fuel_1000hr_pro(:,:) = fuel_1000hr_pro(:,:) + fuel_1000hr(ipts,ivm,:,:)*frac |
|---|
| 4230 | ! !don't forget to hanle litter lignin content |
|---|
| 4231 | ! !lignin_content_pro(:)= lignin_content_pro(:) + & |
|---|
| 4232 | ! ! litter(ipts,istructural,ivm,:,icarbon)*lignin_struc(ipts,ivm,:)*frac |
|---|
| 4233 | ! |
|---|
| 4234 | ! lignin_content_pro(iabove)= lignin_content_pro(iabove) + & |
|---|
| 4235 | ! litter_above(ipts,istructural,ivm,icarbon)*lignin_struc(ipts,ivm,iabove)*frac |
|---|
| 4236 | ! |
|---|
| 4237 | ! lignin_content_pro(ibelow)= lignin_content_pro(ibelow) + & |
|---|
| 4238 | ! sum(litter_below(ipts,istructural,ivm,:,icarbon))*lignin_struc(ipts,ivm,ibelow)*frac |
|---|
| 4239 | ! ENDIF |
|---|
| 4240 | ! |
|---|
| 4241 | ! !! scalar variables to be accumulated and inherited |
|---|
| 4242 | ! !! by the destination PFT |
|---|
| 4243 | ! bm_to_litter_pro(:,:) = bm_to_litter_pro(:,:) + & |
|---|
| 4244 | ! bm_to_litter(ipts,ivm,:,:)*frac |
|---|
| 4245 | ! carbon_pro(:) = carbon_pro(:)+carbon(ipts,:,ivm)*frac |
|---|
| 4246 | ! deepC_a_pro(:) = deepC_a_pro(:)+deepC_a(ipts,:,ivm)*frac |
|---|
| 4247 | ! deepC_s_pro(:) = deepC_s_pro(:)+deepC_s(ipts,:,ivm)*frac |
|---|
| 4248 | ! deepC_p_pro(:) = deepC_p_pro(:)+deepC_p(ipts,:,ivm)*frac |
|---|
| 4249 | ! co2_to_bm_pro = co2_to_bm_pro + co2_to_bm(ipts,ivm)*frac |
|---|
| 4250 | ! |
|---|
| 4251 | ! gpp_daily_pro = gpp_daily_pro + gpp_daily(ipts,ivm)*frac |
|---|
| 4252 | ! npp_daily_pro = npp_daily_pro + npp_daily(ipts,ivm)*frac |
|---|
| 4253 | ! resp_maint_pro = resp_maint_pro + resp_maint(ipts,ivm)*frac |
|---|
| 4254 | ! resp_growth_pro = resp_growth_pro + resp_growth(ipts,ivm)*frac |
|---|
| 4255 | ! resp_hetero_pro = resp_hetero_pro + resp_hetero(ipts,ivm)*frac |
|---|
| 4256 | ! co2_fire_pro = co2_fire_pro + co2_fire(ipts,ivm)*frac |
|---|
| 4257 | ! ENDIF |
|---|
| 4258 | ! ENDDO |
|---|
| 4259 | ! |
|---|
| 4260 | ! WHERE (litter_pro(istructural,:,icarbon) .GT. min_stomate) |
|---|
| 4261 | ! lignin_struc_pro(:) = lignin_content_pro(:)/litter_pro(istructural,:,icarbon) |
|---|
| 4262 | ! ENDWHERE |
|---|
| 4263 | ! |
|---|
| 4264 | ! END SUBROUTINE collect_legacy_pft |
|---|
| 4265 | ! |
|---|
| 4266 | ! |
|---|
| 4267 | ! ! ================================================================================================================================ |
|---|
| 4268 | ! !! SUBROUTINE gross_lcchange |
|---|
| 4269 | ! !! |
|---|
| 4270 | ! !>\BRIEF : Apply gross land cover change. |
|---|
| 4271 | ! !! |
|---|
| 4272 | ! !>\DESCRIPTION |
|---|
| 4273 | ! !_ ================================================================================================================================ |
|---|
| 4274 | ! SUBROUTINE gross_glcchange_fh (npts, dt_days, harvest_matrix, & |
|---|
| 4275 | ! glccSecondShift,glccPrimaryShift,glccNetLCC,& |
|---|
| 4276 | ! def_fuel_1hr_remain, def_fuel_10hr_remain, & |
|---|
| 4277 | ! def_fuel_100hr_remain, def_fuel_1000hr_remain, & |
|---|
| 4278 | ! deforest_litter_remain, deforest_biomass_remain, & |
|---|
| 4279 | ! convflux, cflux_prod10, cflux_prod100, & |
|---|
| 4280 | ! glccReal, IncreDeficit, glcc_pft, glcc_pftmtc, & |
|---|
| 4281 | ! veget_max, prod10, prod100, flux10, flux100, & |
|---|
| 4282 | ! PFTpresent, senescence, moiavail_month, moiavail_week, & |
|---|
| 4283 | ! gpp_week, ngd_minus5, resp_maint, resp_growth, & |
|---|
| 4284 | ! resp_hetero, npp_daily, when_growthinit, npp_longterm, & |
|---|
| 4285 | ! ind, lm_lastyearmax, everywhere, age, & |
|---|
| 4286 | ! co2_to_bm, gpp_daily, co2_fire, & |
|---|
| 4287 | ! time_hum_min, gdd_midwinter, gdd_from_growthinit, & |
|---|
| 4288 | ! gdd_m5_dormance, ncd_dormance, & |
|---|
| 4289 | ! lignin_struc, carbon, leaf_frac, & |
|---|
| 4290 | ! deepC_a, deepC_s, deepC_p, & |
|---|
| 4291 | ! leaf_age, bm_to_litter, biomass, litter_above, litter_below, & |
|---|
| 4292 | ! fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr) |
|---|
| 4293 | ! |
|---|
| 4294 | ! IMPLICIT NONE |
|---|
| 4295 | ! |
|---|
| 4296 | ! !! 0.1 Input variables |
|---|
| 4297 | ! |
|---|
| 4298 | ! INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 4299 | ! REAL(r_std), INTENT(in) :: dt_days !! Time step of vegetation dynamics for stomate |
|---|
| 4300 | ! REAL(r_std), DIMENSION (npts,12),INTENT(in) :: glccSecondShift !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 4301 | ! !! used. |
|---|
| 4302 | ! REAL(r_std), DIMENSION (npts,12),INTENT(in) :: glccPrimaryShift !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 4303 | ! !! used. |
|---|
| 4304 | ! REAL(r_std), DIMENSION (npts,12),INTENT(in) :: glccNetLCC !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 4305 | ! !! used. |
|---|
| 4306 | ! REAL(r_std), DIMENSION (npts,12),INTENT(in) :: harvest_matrix !! |
|---|
| 4307 | ! !! |
|---|
| 4308 | ! |
|---|
| 4309 | ! REAL(r_std), DIMENSION(npts,nvm,nlitt,nelements), INTENT(in) :: def_fuel_1hr_remain |
|---|
| 4310 | ! REAL(r_std), DIMENSION(npts,nvm,nlitt,nelements), INTENT(in) :: def_fuel_10hr_remain |
|---|
| 4311 | ! REAL(r_std), DIMENSION(npts,nvm,nlitt,nelements), INTENT(in) :: def_fuel_100hr_remain |
|---|
| 4312 | ! REAL(r_std), DIMENSION(npts,nvm,nlitt,nelements), INTENT(in) :: def_fuel_1000hr_remain |
|---|
| 4313 | ! REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements), INTENT(in) :: deforest_litter_remain !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 4314 | ! !! deforestation region. |
|---|
| 4315 | ! REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(in) :: deforest_biomass_remain !! Vegetmax-weighted remaining biomass on the ground for |
|---|
| 4316 | ! !! deforestation region. |
|---|
| 4317 | ! |
|---|
| 4318 | ! |
|---|
| 4319 | ! !! 0.2 Output variables |
|---|
| 4320 | ! REAL(r_std), DIMENSION(npts,nwp), INTENT(out) :: convflux !! release during first year following land cover |
|---|
| 4321 | ! !! change |
|---|
| 4322 | ! REAL(r_std), DIMENSION(npts,nwp), INTENT(out) :: cflux_prod10 !! total annual release from the 10 year-turnover |
|---|
| 4323 | ! !! pool @tex ($gC m^{-2}$) @endtex |
|---|
| 4324 | ! REAL(r_std), DIMENSION(npts,nwp), INTENT(out) :: cflux_prod100 !! total annual release from the 100 year- |
|---|
| 4325 | ! REAL(r_std), DIMENSION(npts,12), INTENT(inout) :: glccReal !! The "real" glcc matrix that we apply in the model |
|---|
| 4326 | ! !! after considering the consistency between presribed |
|---|
| 4327 | ! !! glcc matrix and existing vegetation fractions. |
|---|
| 4328 | ! REAL(r_std), DIMENSION(npts,12), INTENT(inout) :: IncreDeficit !! "Increment" deficits, negative values mean that |
|---|
| 4329 | ! !! there are not enough fractions in the source PFTs |
|---|
| 4330 | ! !! /vegetations to target PFTs/vegetations. I.e., these |
|---|
| 4331 | ! !! fraction transfers are presribed in LCC matrix but |
|---|
| 4332 | ! !! not realized. |
|---|
| 4333 | ! REAL(r_std), DIMENSION(npts,nvm), INTENT(inout) :: glcc_pft !! Loss of fraction in each PFT |
|---|
| 4334 | ! REAL(r_std), DIMENSION(npts,nvm,nvmap), INTENT(inout):: glcc_pftmtc !! a temporary variable to hold the fractions each PFT is going to lose |
|---|
| 4335 | ! !! i.e., the contribution of each PFT to the youngest age-class of MTC |
|---|
| 4336 | ! |
|---|
| 4337 | ! !! 0.3 Modified variables |
|---|
| 4338 | ! REAL(r_std), DIMENSION(npts,nvm), INTENT(inout) :: veget_max !! "maximal" coverage fraction of a PFT (LAI -> |
|---|
| 4339 | ! !! infinity) on ground (unitless) |
|---|
| 4340 | ! REAL(r_std), DIMENSION(npts,0:10,nwp), INTENT(inout) :: prod10 !! products remaining in the 10 year-turnover |
|---|
| 4341 | ! !! pool after the annual release for each |
|---|
| 4342 | ! !! compartment (10 + 1 : input from year of land |
|---|
| 4343 | ! !! cover change) |
|---|
| 4344 | ! REAL(r_std), DIMENSION(npts,0:100,nwp), INTENT(inout) :: prod100 !! products remaining in the 100 year-turnover |
|---|
| 4345 | ! !! pool after the annual release for each |
|---|
| 4346 | ! !! compartment (100 + 1 : input from year of land |
|---|
| 4347 | ! !! cover change) |
|---|
| 4348 | ! REAL(r_std), DIMENSION(npts,10,nwp), INTENT(inout) :: flux10 !! annual release from the 10/100 year-turnover |
|---|
| 4349 | ! !! pool compartments |
|---|
| 4350 | ! REAL(r_std), DIMENSION(npts,100,nwp), INTENT(inout) :: flux100 !! annual release from the 10/100 year-turnover |
|---|
| 4351 | ! !! pool compartments |
|---|
| 4352 | ! LOGICAL, DIMENSION(:,:), INTENT(inout) :: PFTpresent !! Tab indicating which PFTs are present in |
|---|
| 4353 | ! !! each pixel |
|---|
| 4354 | ! LOGICAL, DIMENSION(:,:), INTENT(inout) :: senescence !! Flag for setting senescence stage (only |
|---|
| 4355 | ! !! for deciduous trees) |
|---|
| 4356 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_month !! "Monthly" moisture availability (0 to 1, |
|---|
| 4357 | ! !! unitless) |
|---|
| 4358 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_week !! "Weekly" moisture availability |
|---|
| 4359 | ! !! (0 to 1, unitless) |
|---|
| 4360 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_week !! Mean weekly gross primary productivity |
|---|
| 4361 | ! !! @tex $(gC m^{-2} day^{-1})$ @endtex |
|---|
| 4362 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ngd_minus5 !! Number of growing days (days), threshold |
|---|
| 4363 | ! !! -5 deg C (for phenology) |
|---|
| 4364 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_maint !! Maintenance respiration |
|---|
| 4365 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4366 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_growth !! Growth respiration |
|---|
| 4367 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4368 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_hetero !! Heterotrophic respiration |
|---|
| 4369 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4370 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_daily !! Net primary productivity |
|---|
| 4371 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4372 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: when_growthinit !! How many days ago was the beginning of |
|---|
| 4373 | ! !! the growing season (days) |
|---|
| 4374 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_longterm !! "Long term" mean yearly primary productivity |
|---|
| 4375 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ind !! Number of individuals at the stand level |
|---|
| 4376 | ! !! @tex $(m^{-2})$ @endtex |
|---|
| 4377 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: lm_lastyearmax !! last year's maximum leaf mass for each PFT |
|---|
| 4378 | ! !! @tex ($gC m^{-2}$) @endtex |
|---|
| 4379 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: everywhere !! is the PFT everywhere in the grid box or |
|---|
| 4380 | ! !! very localized (after its introduction) (?) |
|---|
| 4381 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: age !! mean age (years) |
|---|
| 4382 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: co2_to_bm !! CO2 taken from the atmosphere to get C to create |
|---|
| 4383 | ! !! the seedlings @tex (gC.m^{-2}dt^{-1})$ @endtex |
|---|
| 4384 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_daily !! Daily gross primary productivity |
|---|
| 4385 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4386 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: co2_fire !! Fire carbon emissions |
|---|
| 4387 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4388 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: time_hum_min !! Time elapsed since strongest moisture |
|---|
| 4389 | ! !! availability (days) |
|---|
| 4390 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_midwinter !! Growing degree days (K), since midwinter |
|---|
| 4391 | ! !! (for phenology) - this is written to the |
|---|
| 4392 | ! !! history files |
|---|
| 4393 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_from_growthinit !! growing degree days, since growthinit |
|---|
| 4394 | ! !! for crops |
|---|
| 4395 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_m5_dormance !! Growing degree days (K), threshold -5 deg |
|---|
| 4396 | ! !! C (for phenology) |
|---|
| 4397 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ncd_dormance !! Number of chilling days (days), since |
|---|
| 4398 | ! !! leaves were lost (for phenology) |
|---|
| 4399 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: lignin_struc !! ratio Lignine/Carbon in structural litter, |
|---|
| 4400 | ! !! above and below ground |
|---|
| 4401 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: carbon !! carbon pool: active, slow, or passive |
|---|
| 4402 | ! !! @tex ($gC m^{-2}$) @endtex |
|---|
| 4403 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_a !! Permafrost soil carbon (g/m**3) active |
|---|
| 4404 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_s !! Permafrost soil carbon (g/m**3) slow |
|---|
| 4405 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_p !! Permafrost soil carbon (g/m**3) passive |
|---|
| 4406 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_frac !! fraction of leaves in leaf age class (unitless;0-1) |
|---|
| 4407 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_age !! Leaf age (days) |
|---|
| 4408 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: bm_to_litter !! Transfer of biomass to litter |
|---|
| 4409 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4410 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: biomass !! Stand level biomass @tex $(gC.m^{-2})$ @endtex |
|---|
| 4411 | ! REAL(r_std), DIMENSION(npts,nlitt,nvm,nelements), INTENT(inout) :: litter_above !! Metabolic and structural litter, above and |
|---|
| 4412 | ! REAL(r_std), DIMENSION(npts,nlitt,nvm,nbdl,nelements), INTENT(inout) :: litter_below !!Below |
|---|
| 4413 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1hr |
|---|
| 4414 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_10hr |
|---|
| 4415 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_100hr |
|---|
| 4416 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1000hr |
|---|
| 4417 | ! |
|---|
| 4418 | ! !! 0.4 Local variables |
|---|
| 4419 | ! REAL(r_std), DIMENSION(nparts,nelements) :: bm_to_litter_pro !! conversion of biomass to litter |
|---|
| 4420 | ! !! @tex ($gC m^{-2} day^{-1}$) @endtex |
|---|
| 4421 | ! REAL(r_std), DIMENSION(nparts,nelements) :: biomass_pro !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 4422 | ! REAL(r_std) :: veget_max_pro !! "maximal" coverage fraction of a PFT (LAI -> |
|---|
| 4423 | ! !! infinity) on ground (unitless) |
|---|
| 4424 | ! REAL(r_std), DIMENSION(ncarb) :: carbon_pro !! carbon pool: active, slow, or passive |
|---|
| 4425 | ! !! @tex ($gC m^{-2}$) @endtex |
|---|
| 4426 | ! REAL(r_std), DIMENSION(ndeep) :: deepC_a_pro !! Permafrost carbon pool: active, slow, or passive |
|---|
| 4427 | ! !! @tex ($gC m^{-3}$) @endtex |
|---|
| 4428 | ! REAL(r_std), DIMENSION(ndeep) :: deepC_s_pro !! Permafrost carbon pool: active, slow, or passive |
|---|
| 4429 | ! !! @tex ($gC m^{-3}$) @endtex |
|---|
| 4430 | ! REAL(r_std), DIMENSION(ndeep) :: deepC_p_pro !! Permafrost carbon pool: active, slow, or passive |
|---|
| 4431 | ! !! @tex ($gC m^{-3}$) @endtex |
|---|
| 4432 | ! REAL(r_std), DIMENSION(nlitt,nlevs,nelements) :: litter_pro !! metabolic and structural litter, above and |
|---|
| 4433 | ! !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 4434 | ! REAL(r_std), DIMENSION(nlitt,nelements) :: fuel_1hr_pro |
|---|
| 4435 | ! REAL(r_std), DIMENSION(nlitt,nelements) :: fuel_10hr_pro |
|---|
| 4436 | ! REAL(r_std), DIMENSION(nlitt,nelements) :: fuel_100hr_pro |
|---|
| 4437 | ! REAL(r_std), DIMENSION(nlitt,nelements) :: fuel_1000hr_pro |
|---|
| 4438 | ! REAL(r_std), DIMENSION(nlevs) :: lignin_struc_pro !! ratio Lignine/Carbon in structural litter |
|---|
| 4439 | ! !! above and below ground |
|---|
| 4440 | ! REAL(r_std), DIMENSION(nleafages) :: leaf_frac_pro !! fraction of leaves in leaf age class |
|---|
| 4441 | ! REAL(r_std), DIMENSION(nleafages) :: leaf_age_pro !! fraction of leaves in leaf age class |
|---|
| 4442 | ! LOGICAL :: PFTpresent_pro, senescence_pro !! Is pft there (unitless) |
|---|
| 4443 | ! REAL(r_std) :: ind_pro, age_pro, lm_lastyearmax_pro, npp_longterm_pro |
|---|
| 4444 | ! REAL(r_std) :: everywhere_pro |
|---|
| 4445 | ! REAL(r_std) :: gpp_daily_pro, npp_daily_pro, co2_to_bm_pro |
|---|
| 4446 | ! REAL(r_std) :: resp_maint_pro, resp_growth_pro |
|---|
| 4447 | ! REAL(r_std) :: resp_hetero_pro, co2_fire_pro |
|---|
| 4448 | ! |
|---|
| 4449 | ! INTEGER :: ipts,ivm,ivma,l,m,ipft_young_agec |
|---|
| 4450 | ! CHARACTER(LEN=10) :: part_str !! string suffix indicating an index |
|---|
| 4451 | ! |
|---|
| 4452 | ! REAL(r_std), DIMENSION(npts,nvmap) :: glcc_mtc !! Increase in fraction of each MTC in its youngest age-class |
|---|
| 4453 | ! REAL(r_std), DIMENSION(npts,nvm) :: glccReal_tmp !! A temporary variable to hold glccReal |
|---|
| 4454 | ! REAL(r_std), DIMENSION(npts) :: Deficit_pf2yf_final !! |
|---|
| 4455 | ! REAL(r_std), DIMENSION(npts) :: Deficit_sf2yf_final !! |
|---|
| 4456 | ! REAL(r_std), DIMENSION(npts) :: pf2yf_compen_sf2yf !! |
|---|
| 4457 | ! REAL(r_std), DIMENSION(npts) :: sf2yf_compen_pf2yf !! |
|---|
| 4458 | ! REAL(r_std), DIMENSION(npts,nvm) :: glcc_harvest !! Loss of fraction due to forestry harvest |
|---|
| 4459 | ! |
|---|
| 4460 | ! WRITE(numout,*) 'Entering gross_glcchange_fh' |
|---|
| 4461 | ! glcc_harvest(:,:) = zero |
|---|
| 4462 | ! glccReal_tmp(:,:) = zero |
|---|
| 4463 | ! |
|---|
| 4464 | ! !! Some initialization |
|---|
| 4465 | ! convflux(:,:)=zero |
|---|
| 4466 | ! prod10(:,0,:) = zero |
|---|
| 4467 | ! prod100(:,0,:) = zero |
|---|
| 4468 | ! cflux_prod10(:,:) = zero |
|---|
| 4469 | ! cflux_prod100(:,:) = zero |
|---|
| 4470 | ! |
|---|
| 4471 | ! CALL gross_glcc_firstday_fh(npts,veget_max,harvest_matrix, & |
|---|
| 4472 | ! glccSecondShift,glccPrimaryShift,glccNetLCC,& |
|---|
| 4473 | ! glccReal,glcc_pft,glcc_pftmtc,IncreDeficit, & |
|---|
| 4474 | ! Deficit_pf2yf_final, Deficit_sf2yf_final, & |
|---|
| 4475 | ! pf2yf_compen_sf2yf, sf2yf_compen_pf2yf) |
|---|
| 4476 | ! |
|---|
| 4477 | ! glcc_mtc(:,:) = SUM(glcc_pftmtc,DIM=2) |
|---|
| 4478 | ! DO ipts=1,npts |
|---|
| 4479 | ! ! Note that we assume people don't intentionally change baresoil to |
|---|
| 4480 | ! ! vegetated land. |
|---|
| 4481 | ! DO ivma = 2,nvmap |
|---|
| 4482 | ! ! we assume only the youngest age class receives the incoming PFT |
|---|
| 4483 | ! ! [chaoyuejoy@gmail.com 2015-08-04] This line is commented to allow |
|---|
| 4484 | ! ! the case of only single age class being handled. |
|---|
| 4485 | ! IF ( glcc_mtc(ipts,ivma) .GT. min_stomate ) THEN |
|---|
| 4486 | ! ipft_young_agec = start_index(ivma) |
|---|
| 4487 | ! |
|---|
| 4488 | ! ! 1. we accumulate the scalar variables that will be inherited |
|---|
| 4489 | ! ! note we don't handle the case of harvesting forest because |
|---|
| 4490 | ! ! we assume glcc_pftmtc(forest->forest) would be zero and this |
|---|
| 4491 | ! ! case won't occur as it's filtered by the condition of |
|---|
| 4492 | ! ! (frac>min_stomate) |
|---|
| 4493 | ! CALL collect_legacy_pft(npts, ipts, ivma, glcc_pftmtc, & |
|---|
| 4494 | ! biomass, bm_to_litter, carbon, litter_above, litter_below, & |
|---|
| 4495 | ! deepC_a, deepC_s, deepC_p, & |
|---|
| 4496 | ! fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 4497 | ! lignin_struc, co2_to_bm, gpp_daily, npp_daily, & |
|---|
| 4498 | ! resp_maint, resp_growth, resp_hetero, co2_fire, & |
|---|
| 4499 | ! def_fuel_1hr_remain, def_fuel_10hr_remain, & |
|---|
| 4500 | ! def_fuel_100hr_remain, def_fuel_1000hr_remain, & |
|---|
| 4501 | ! deforest_litter_remain, deforest_biomass_remain, & |
|---|
| 4502 | ! veget_max_pro, carbon_pro, lignin_struc_pro, litter_pro, & |
|---|
| 4503 | ! deepC_a_pro, deepC_s_pro, deepC_p_pro, & |
|---|
| 4504 | ! fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, fuel_1000hr_pro, & |
|---|
| 4505 | ! bm_to_litter_pro, co2_to_bm_pro, gpp_daily_pro, & |
|---|
| 4506 | ! npp_daily_pro, resp_maint_pro, resp_growth_pro, & |
|---|
| 4507 | ! resp_hetero_pro, co2_fire_pro, & |
|---|
| 4508 | ! convflux,prod10,prod100) |
|---|
| 4509 | ! |
|---|
| 4510 | ! !++TEMP++ |
|---|
| 4511 | ! ! Here we substract the outgoing fraction from the source PFT. |
|---|
| 4512 | ! ! If a too small fraction remains in this source PFT, then it is |
|---|
| 4513 | ! ! exhausted, we empty it. The subroutine 'empty_pft' might be |
|---|
| 4514 | ! ! combined with 'collect_legacy_pft', but now we just put it here. |
|---|
| 4515 | ! DO ivm = 1,nvm |
|---|
| 4516 | ! IF( glcc_pftmtc(ipts,ivm,ivma)>min_stomate ) THEN |
|---|
| 4517 | ! veget_max(ipts,ivm) = veget_max(ipts,ivm)-glcc_pftmtc(ipts,ivm,ivma) |
|---|
| 4518 | ! IF ( veget_max(ipts,ivm)<min_stomate ) THEN |
|---|
| 4519 | ! CALL empty_pft(ipts, ivm, veget_max, biomass, ind, & |
|---|
| 4520 | ! carbon, litter_above, litter_below, lignin_struc, bm_to_litter, & |
|---|
| 4521 | ! deepC_a, deepC_s, deepC_p, & |
|---|
| 4522 | ! fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 4523 | ! gpp_daily, npp_daily, gpp_week, npp_longterm, & |
|---|
| 4524 | ! co2_to_bm, resp_maint, resp_growth, resp_hetero, & |
|---|
| 4525 | ! lm_lastyearmax, leaf_frac, leaf_age, age, & |
|---|
| 4526 | ! everywhere, PFTpresent, when_growthinit, & |
|---|
| 4527 | ! senescence, gdd_from_growthinit, gdd_midwinter, & |
|---|
| 4528 | ! time_hum_min, gdd_m5_dormance, ncd_dormance, & |
|---|
| 4529 | ! moiavail_month, moiavail_week, ngd_minus5) |
|---|
| 4530 | ! ENDIF |
|---|
| 4531 | ! ENDIF |
|---|
| 4532 | ! ENDDO |
|---|
| 4533 | ! |
|---|
| 4534 | ! ! 2. we establish a proxy PFT with the fraction of veget_max_pro, |
|---|
| 4535 | ! ! which is going to be either merged with existing target |
|---|
| 4536 | ! ! `ipft_young_agec` PFT, or fill the place if no existing target PFT |
|---|
| 4537 | ! ! exits. |
|---|
| 4538 | ! CALL initialize_proxy_pft(ipts,ipft_young_agec,veget_max_pro, & |
|---|
| 4539 | ! biomass_pro, co2_to_bm_pro, ind_pro, age_pro, & |
|---|
| 4540 | ! senescence_pro, PFTpresent_pro, & |
|---|
| 4541 | ! lm_lastyearmax_pro, everywhere_pro, npp_longterm_pro, & |
|---|
| 4542 | ! leaf_frac_pro,leaf_age_pro) |
|---|
| 4543 | ! |
|---|
| 4544 | ! CALL sap_take (ipts,ivma,veget_max,biomass_pro,biomass,co2_to_bm_pro) |
|---|
| 4545 | ! |
|---|
| 4546 | ! ! 3. we merge the newly initiazlized proxy PFT into existing one |
|---|
| 4547 | ! ! or use it to fill an empty PFT slot. |
|---|
| 4548 | ! CALL add_incoming_proxy_pft(npts, ipts, ipft_young_agec, veget_max_pro,& |
|---|
| 4549 | ! carbon_pro, litter_pro, lignin_struc_pro, bm_to_litter_pro, & |
|---|
| 4550 | ! deepC_a_pro, deepC_s_pro, deepC_p_pro, & |
|---|
| 4551 | ! fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, fuel_1000hr_pro, & |
|---|
| 4552 | ! biomass_pro, co2_to_bm_pro, npp_longterm_pro, ind_pro, & |
|---|
| 4553 | ! lm_lastyearmax_pro, age_pro, everywhere_pro, & |
|---|
| 4554 | ! leaf_frac_pro, leaf_age_pro, PFTpresent_pro, senescence_pro, & |
|---|
| 4555 | ! gpp_daily_pro, npp_daily_pro, resp_maint_pro, resp_growth_pro, & |
|---|
| 4556 | ! resp_hetero_pro, co2_fire_pro, & |
|---|
| 4557 | ! veget_max, carbon, litter_above, litter_below, lignin_struc, bm_to_litter, & |
|---|
| 4558 | ! deepC_a, deepC_s, deepC_p, & |
|---|
| 4559 | ! fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 4560 | ! biomass, co2_to_bm, npp_longterm, ind, & |
|---|
| 4561 | ! lm_lastyearmax, age, everywhere, & |
|---|
| 4562 | ! leaf_frac, leaf_age, PFTpresent, senescence, & |
|---|
| 4563 | ! gpp_daily, npp_daily, resp_maint, resp_growth, & |
|---|
| 4564 | ! resp_hetero, co2_fire) |
|---|
| 4565 | ! |
|---|
| 4566 | ! ENDIF !IF ( glcc_mtc(ipts,ivma) .GT. min_stomate ) |
|---|
| 4567 | ! |
|---|
| 4568 | ! ENDDO |
|---|
| 4569 | ! ENDDO |
|---|
| 4570 | ! |
|---|
| 4571 | ! !! Update 10 year-turnover pool content following flux emission |
|---|
| 4572 | ! !! (linear decay (10%) of the initial carbon input) |
|---|
| 4573 | ! DO l = 0, 8 |
|---|
| 4574 | ! m = 10 - l |
|---|
| 4575 | ! cflux_prod10(:,:) = cflux_prod10(:,:) + flux10(:,m,:) |
|---|
| 4576 | ! prod10(:,m,:) = prod10(:,m-1,:) - flux10(:,m-1,:) |
|---|
| 4577 | ! flux10(:,m,:) = flux10(:,m-1,:) |
|---|
| 4578 | ! WHERE (prod10(:,m,:) .LT. 1.0) prod10(:,m,:) = zero |
|---|
| 4579 | ! ENDDO |
|---|
| 4580 | ! |
|---|
| 4581 | ! cflux_prod10(:,:) = cflux_prod10(:,:) + flux10(:,1,:) |
|---|
| 4582 | ! flux10(:,1,:) = 0.1 * prod10(:,0,:) |
|---|
| 4583 | ! prod10(:,1,:) = prod10(:,0,:) |
|---|
| 4584 | ! |
|---|
| 4585 | ! !! 2.4.3 update 100 year-turnover pool content following flux emission\n |
|---|
| 4586 | ! DO l = 0, 98 |
|---|
| 4587 | ! m = 100 - l |
|---|
| 4588 | ! cflux_prod100(:,:) = cflux_prod100(:,:) + flux100(:,m,:) |
|---|
| 4589 | ! prod100(:,m,:) = prod100(:,m-1,:) - flux100(:,m-1,:) |
|---|
| 4590 | ! flux100(:,m,:) = flux100(:,m-1,:) |
|---|
| 4591 | ! |
|---|
| 4592 | ! WHERE (prod100(:,m,:).LT.1.0) prod100(:,m,:) = zero |
|---|
| 4593 | ! ENDDO |
|---|
| 4594 | ! |
|---|
| 4595 | ! cflux_prod100(:,:) = cflux_prod100(:,:) + flux100(:,1,:) |
|---|
| 4596 | ! flux100(:,1,:) = 0.01 * prod100(:,0,:) |
|---|
| 4597 | ! prod100(:,1,:) = prod100(:,0,:) |
|---|
| 4598 | ! prod10(:,0,:) = zero |
|---|
| 4599 | ! prod100(:,0,:) = zero |
|---|
| 4600 | ! |
|---|
| 4601 | ! convflux = convflux/one_year*dt_days |
|---|
| 4602 | ! cflux_prod10 = cflux_prod10/one_year*dt_days |
|---|
| 4603 | ! cflux_prod100 = cflux_prod100/one_year*dt_days |
|---|
| 4604 | ! |
|---|
| 4605 | ! ! Write out history files |
|---|
| 4606 | ! CALL histwrite_p (hist_id_stomate, 'glcc_pft', itime, & |
|---|
| 4607 | ! glcc_pft, npts*nvm, horipft_index) |
|---|
| 4608 | ! |
|---|
| 4609 | ! glccReal_tmp(:,1:12) = glccReal |
|---|
| 4610 | ! CALL histwrite_p (hist_id_stomate, 'glccReal', itime, & |
|---|
| 4611 | ! glccReal_tmp, npts*nvm, horipft_index) |
|---|
| 4612 | ! |
|---|
| 4613 | ! ! Write out forestry harvest variables |
|---|
| 4614 | ! DO ipts = 1,npts |
|---|
| 4615 | ! DO ivm = 1,nvm |
|---|
| 4616 | ! DO ivma = 1,nvmap |
|---|
| 4617 | ! IF (is_tree(ivm) .AND. is_tree(start_index(ivma))) THEN |
|---|
| 4618 | ! glcc_harvest(ipts,ivm) = glcc_harvest(ipts,ivm) + glcc_pftmtc(ipts,ivm,ivma) |
|---|
| 4619 | ! ENDIF |
|---|
| 4620 | ! ENDDO |
|---|
| 4621 | ! ENDDO |
|---|
| 4622 | ! ENDDO |
|---|
| 4623 | ! CALL histwrite_p (hist_id_stomate, 'glcc_harvest', itime, & |
|---|
| 4624 | ! glcc_harvest, npts*nvm, horipft_index) |
|---|
| 4625 | ! |
|---|
| 4626 | ! glccReal_tmp(:,:) = zero |
|---|
| 4627 | ! glccReal_tmp(:,1:12) = IncreDeficit |
|---|
| 4628 | ! CALL histwrite_p (hist_id_stomate, 'IncreDeficit', itime, & |
|---|
| 4629 | ! glccReal_tmp, npts*nvm, horipft_index) |
|---|
| 4630 | ! |
|---|
| 4631 | ! glccReal_tmp(:,:) = zero |
|---|
| 4632 | ! glccReal_tmp(:,1) = Deficit_pf2yf_final |
|---|
| 4633 | ! glccReal_tmp(:,2) = Deficit_sf2yf_final |
|---|
| 4634 | ! glccReal_tmp(:,3) = pf2yf_compen_sf2yf |
|---|
| 4635 | ! glccReal_tmp(:,4) = sf2yf_compen_pf2yf |
|---|
| 4636 | ! |
|---|
| 4637 | ! CALL histwrite_p (hist_id_stomate, 'DefiComForHarvest', itime, & |
|---|
| 4638 | ! glccReal_tmp, npts*nvm, horipft_index) |
|---|
| 4639 | ! |
|---|
| 4640 | ! DO ivma = 1, nvmap |
|---|
| 4641 | ! WRITE(part_str,'(I2)') ivma |
|---|
| 4642 | ! IF (ivma < 10) part_str(1:1) = '0' |
|---|
| 4643 | ! CALL histwrite_p (hist_id_stomate, 'glcc_pftmtc_'//part_str(1:LEN_TRIM(part_str)), & |
|---|
| 4644 | ! itime, glcc_pftmtc(:,:,ivma), npts*nvm, horipft_index) |
|---|
| 4645 | ! ENDDO |
|---|
| 4646 | ! END SUBROUTINE gross_glcchange_fh |
|---|
| 4647 | ! |
|---|
| 4648 | ! |
|---|
| 4649 | ! ! ================================================================================================================================ |
|---|
| 4650 | ! !! SUBROUTINE : add_incoming_proxy_pft |
|---|
| 4651 | ! !! |
|---|
| 4652 | ! !>\BRIEF : Merge the newly incoming proxy PFT cohort with the exisiting |
|---|
| 4653 | ! !! cohort. |
|---|
| 4654 | ! !! \n |
|---|
| 4655 | ! ! |
|---|
| 4656 | ! !_ ================================================================================================================================ |
|---|
| 4657 | ! SUBROUTINE add_incoming_proxy_pft(npts, ipts, ipft, veget_max_pro, & |
|---|
| 4658 | ! carbon_pro, litter_pro, lignin_struc_pro, bm_to_litter_pro, & |
|---|
| 4659 | ! deepC_a_pro, deepC_s_pro, deepC_p_pro, & |
|---|
| 4660 | ! fuel_1hr_pro, fuel_10hr_pro, fuel_100hr_pro, fuel_1000hr_pro, & |
|---|
| 4661 | ! biomass_pro, co2_to_bm_pro, npp_longterm_pro, ind_pro, & |
|---|
| 4662 | ! lm_lastyearmax_pro, age_pro, everywhere_pro, & |
|---|
| 4663 | ! leaf_frac_pro, leaf_age_pro, PFTpresent_pro, senescence_pro, & |
|---|
| 4664 | ! gpp_daily_pro, npp_daily_pro, resp_maint_pro, resp_growth_pro, & |
|---|
| 4665 | ! resp_hetero_pro, co2_fire_pro, & |
|---|
| 4666 | ! veget_max, carbon, litter_above, litter_below, lignin_struc, bm_to_litter, & |
|---|
| 4667 | ! deepC_a, deepC_s, deepC_p, & |
|---|
| 4668 | ! fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 4669 | ! biomass, co2_to_bm, npp_longterm, ind, & |
|---|
| 4670 | ! lm_lastyearmax, age, everywhere, & |
|---|
| 4671 | ! leaf_frac, leaf_age, PFTpresent, senescence, & |
|---|
| 4672 | ! gpp_daily, npp_daily, resp_maint, resp_growth, & |
|---|
| 4673 | ! resp_hetero, co2_fire) |
|---|
| 4674 | ! |
|---|
| 4675 | ! IMPLICIT NONE |
|---|
| 4676 | ! |
|---|
| 4677 | ! !! 0.1 Input variables |
|---|
| 4678 | ! INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 4679 | ! INTEGER, INTENT(in) :: ipts !! Domain size - number of pixels (unitless) |
|---|
| 4680 | ! INTEGER, INTENT(in) :: ipft |
|---|
| 4681 | ! REAL(r_std), INTENT(in) :: veget_max_pro !! The land fraction of incoming new PFTs that are |
|---|
| 4682 | ! !! the sum of all its ancestor PFTs |
|---|
| 4683 | ! REAL(r_std), DIMENSION(:), INTENT(in) :: carbon_pro |
|---|
| 4684 | ! REAL(r_std), DIMENSION(:), INTENT(in) :: deepC_a_pro |
|---|
| 4685 | ! REAL(r_std), DIMENSION(:), INTENT(in) :: deepC_s_pro |
|---|
| 4686 | ! REAL(r_std), DIMENSION(:), INTENT(in) :: deepC_p_pro |
|---|
| 4687 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: litter_pro |
|---|
| 4688 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: fuel_1hr_pro |
|---|
| 4689 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: fuel_10hr_pro |
|---|
| 4690 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: fuel_100hr_pro |
|---|
| 4691 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: fuel_1000hr_pro |
|---|
| 4692 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: bm_to_litter_pro |
|---|
| 4693 | ! REAL(r_std), DIMENSION(:), INTENT(in) :: lignin_struc_pro !! ratio Lignine/Carbon in structural litter |
|---|
| 4694 | ! !! above and below ground |
|---|
| 4695 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: biomass_pro !! biomass @tex ($gC m^{-2}$) @endtex |
|---|
| 4696 | ! REAL(r_std), DIMENSION(:), INTENT(in) :: leaf_frac_pro !! fraction of leaves in leaf age class |
|---|
| 4697 | ! REAL(r_std), DIMENSION(:), INTENT(in) :: leaf_age_pro !! fraction of leaves in leaf age class |
|---|
| 4698 | ! REAL(r_std), INTENT(in) :: ind_pro, age_pro, lm_lastyearmax_pro |
|---|
| 4699 | ! REAL(r_std), INTENT(in) :: npp_longterm_pro, co2_to_bm_pro |
|---|
| 4700 | ! REAL(r_std), INTENT(in) :: everywhere_pro !! is the PFT everywhere in the grid box or very |
|---|
| 4701 | ! LOGICAL, INTENT(in) :: PFTpresent_pro, senescence_pro !! Is pft there (unitless) |
|---|
| 4702 | ! |
|---|
| 4703 | ! REAL(r_std), INTENT(in) :: gpp_daily_pro, npp_daily_pro |
|---|
| 4704 | ! REAL(r_std), INTENT(in) :: resp_maint_pro, resp_growth_pro |
|---|
| 4705 | ! REAL(r_std), INTENT(in) :: resp_hetero_pro, co2_fire_pro |
|---|
| 4706 | ! |
|---|
| 4707 | ! !! 0.2 Output variables |
|---|
| 4708 | ! |
|---|
| 4709 | ! !! 0.3 Modified variables |
|---|
| 4710 | ! |
|---|
| 4711 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: veget_max !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 4712 | ! !! May sum to |
|---|
| 4713 | ! !! less than unity if the pixel has |
|---|
| 4714 | ! !! nobio area. (unitless, 0-1) |
|---|
| 4715 | ! |
|---|
| 4716 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: carbon !! carbon pool: active, slow, or passive |
|---|
| 4717 | ! !! @tex ($gC m^{-2}$) @endtex |
|---|
| 4718 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_a !! Permafrost soil carbon (g/m**3) active |
|---|
| 4719 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_s !! Permafrost soil carbon (g/m**3) slow |
|---|
| 4720 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_p !! Permafrost soil carbon (g/m**3) passive |
|---|
| 4721 | ! REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements) :: litter !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 4722 | ! !! deforestation region. |
|---|
| 4723 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: litter_above !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 4724 | ! !! deforestation region. |
|---|
| 4725 | ! REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(in) :: litter_below !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 4726 | ! !! deforestation region. |
|---|
| 4727 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1hr |
|---|
| 4728 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_10hr |
|---|
| 4729 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_100hr |
|---|
| 4730 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1000hr |
|---|
| 4731 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: lignin_struc !! ratio Lignine/Carbon in structural litter, |
|---|
| 4732 | ! !! above and below ground |
|---|
| 4733 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: bm_to_litter !! Transfer of biomass to litter |
|---|
| 4734 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4735 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: biomass !! Stand level biomass @tex $(gC.m^{-2})$ @endtex |
|---|
| 4736 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: co2_to_bm !! CO2 taken from the atmosphere to get C to create |
|---|
| 4737 | ! !! the seedlings @tex (gC.m^{-2}dt^{-1})$ @endtex |
|---|
| 4738 | ! |
|---|
| 4739 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_longterm !! "Long term" mean yearly primary productivity |
|---|
| 4740 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ind !! Number of individuals at the stand level |
|---|
| 4741 | ! !! @tex $(m^{-2})$ @endtex |
|---|
| 4742 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: age !! mean age (years) |
|---|
| 4743 | ! LOGICAL, DIMENSION(:,:), INTENT(inout) :: PFTpresent !! Tab indicating which PFTs are present in |
|---|
| 4744 | ! !! each pixel |
|---|
| 4745 | ! LOGICAL, DIMENSION(:,:), INTENT(inout) :: senescence !! Flag for setting senescence stage (only |
|---|
| 4746 | ! !! for deciduous trees) |
|---|
| 4747 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: lm_lastyearmax !! last year's maximum leaf mass for each PFT |
|---|
| 4748 | ! !! @tex ($gC m^{-2}$) @endtex |
|---|
| 4749 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: everywhere !! is the PFT everywhere in the grid box or |
|---|
| 4750 | ! !! very localized (after its introduction) (?) |
|---|
| 4751 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_frac !! fraction of leaves in leaf age class (unitless;0-1) |
|---|
| 4752 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_age !! Leaf age (days) |
|---|
| 4753 | ! |
|---|
| 4754 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_daily !! Daily gross primary productivity |
|---|
| 4755 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4756 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_daily !! Net primary productivity |
|---|
| 4757 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4758 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_maint !! Maintenance respiration |
|---|
| 4759 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4760 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_growth !! Growth respiration |
|---|
| 4761 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4762 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_hetero !! Heterotrophic respiration |
|---|
| 4763 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4764 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: co2_fire !! Heterotrophic respiration |
|---|
| 4765 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 4766 | ! |
|---|
| 4767 | ! ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_month !! "Monthly" moisture availability (0 to 1, |
|---|
| 4768 | ! ! !! unitless) |
|---|
| 4769 | ! ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_week !! "Weekly" moisture availability |
|---|
| 4770 | ! ! !! (0 to 1, unitless) |
|---|
| 4771 | ! ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_week !! Mean weekly gross primary productivity |
|---|
| 4772 | ! ! !! @tex $(gC m^{-2} day^{-1})$ @endtex |
|---|
| 4773 | ! ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ngd_minus5 !! Number of growing days (days), threshold |
|---|
| 4774 | ! ! !! -5 deg C (for phenology) |
|---|
| 4775 | ! ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: when_growthinit !! How many days ago was the beginning of |
|---|
| 4776 | ! ! !! the growing season (days) |
|---|
| 4777 | ! ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: time_hum_min !! Time elapsed since strongest moisture |
|---|
| 4778 | ! ! !! availability (days) |
|---|
| 4779 | ! ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_midwinter !! Growing degree days (K), since midwinter |
|---|
| 4780 | ! ! !! (for phenology) - this is written to the |
|---|
| 4781 | ! ! !! history files |
|---|
| 4782 | ! ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_from_growthinit !! growing degree days, since growthinit |
|---|
| 4783 | ! ! !! for crops |
|---|
| 4784 | ! ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_m5_dormance !! Growing degree days (K), threshold -5 deg |
|---|
| 4785 | ! ! !! C (for phenology) |
|---|
| 4786 | ! ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ncd_dormance !! Number of chilling days (days), since |
|---|
| 4787 | ! ! !! leaves were lost (for phenology) |
|---|
| 4788 | ! |
|---|
| 4789 | ! !! 0.4 Local variables |
|---|
| 4790 | ! |
|---|
| 4791 | ! INTEGER(i_std) :: iele !! Indeces(unitless) |
|---|
| 4792 | ! INTEGER(i_std) :: ilit,ilev,icarb !! Indeces(unitless) |
|---|
| 4793 | ! REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements) :: litter_old !! metabolic and structural litter, above and |
|---|
| 4794 | ! !! below ground @tex ($gC m^{-2}$) @endtex |
|---|
| 4795 | ! REAL(r_std) :: veget_old,veget_total |
|---|
| 4796 | ! |
|---|
| 4797 | ! |
|---|
| 4798 | ! ! Back up some variables in case they're needed later |
|---|
| 4799 | ! litter_old(:,:,:,:,:) = litter(:,:,:,:,:) |
|---|
| 4800 | ! |
|---|
| 4801 | ! !! General idea |
|---|
| 4802 | ! ! The established proxy vegetation has a fraction of 'veget_max_pro'; the |
|---|
| 4803 | ! ! existing iPFT has a fraction of veget_max(ipts,ipft). |
|---|
| 4804 | ! ! Suppose we want to merge a scalar variable B, the value of B after merging |
|---|
| 4805 | ! ! is (Bi*Vi+Bj*Vj)/(Vi+Vj), where Vi is the original veget_max, Vj is the |
|---|
| 4806 | ! ! incoming veget_max. Note that in case Vi=0, this equation remains solid, |
|---|
| 4807 | ! ! i.e. the veget_max after merging is Vj and B after merging is Bj. In other |
|---|
| 4808 | ! ! words, the proxy vegetation "fills" up the empty niche of iPFT. |
|---|
| 4809 | ! ! Also note that for many scalar variables our input value is Bj*Vj, which |
|---|
| 4810 | ! ! is accumulated from multiple ancestor PFTs. |
|---|
| 4811 | ! veget_old = veget_max(ipts,ipft) |
|---|
| 4812 | ! veget_total = veget_old+veget_max_pro |
|---|
| 4813 | ! |
|---|
| 4814 | ! !! Different ways of handling merging depending on nature of variables: |
|---|
| 4815 | ! |
|---|
| 4816 | ! !! 1. Area-based scalar variables, use the equation above |
|---|
| 4817 | ! ! biomass,carbon, litter, bm_to_litter, co2_to_bm, ind, |
|---|
| 4818 | ! ! lm_lastyearmax, npp_longterm, lm_lastyearmax, |
|---|
| 4819 | ! ! lignin_struc (ratio variable depending on area-based variable) |
|---|
| 4820 | ! |
|---|
| 4821 | ! !! 2. Variables are tentatively handled like area-based variables: |
|---|
| 4822 | ! ! leaf_frac, leaf_age, |
|---|
| 4823 | ! |
|---|
| 4824 | ! !! 3. Variables that are overwritten by the newly initialized PFT: |
|---|
| 4825 | ! ! PFTpresent, senescence |
|---|
| 4826 | ! |
|---|
| 4827 | ! !! 4. Variables whose operation is uncertain and are not handled currently: |
|---|
| 4828 | ! ! when_growthinit :: how many days ago was the beginning of the growing season (days) |
|---|
| 4829 | ! ! gdd_from_growthinit :: growing degree days, since growthinit |
|---|
| 4830 | ! ! gdd_midwinter, time_hum_min, gdd_m5_dormance, ncd_dormance, |
|---|
| 4831 | ! ! moiavail_month, moiavail_week, ngd_minus5 |
|---|
| 4832 | ! |
|---|
| 4833 | ! !! 5. Variables that concern with short-term fluxes that do not apply in |
|---|
| 4834 | ! ! this case: |
|---|
| 4835 | ! ! gpp_daily, npp_daily etc. |
|---|
| 4836 | ! |
|---|
| 4837 | ! ! Add the coming veget_max_pro into existing veget_max |
|---|
| 4838 | ! veget_max(ipts,ipft) = veget_total |
|---|
| 4839 | ! |
|---|
| 4840 | ! ! Merge scalar variables which are defined on area basis |
|---|
| 4841 | ! carbon(ipts,:,ipft) = (veget_old * carbon(ipts,:,ipft) + & |
|---|
| 4842 | ! carbon_pro(:))/veget_total |
|---|
| 4843 | ! deepC_a(ipts,:,ipft) = (veget_old * deepC_a(ipts,:,ipft) + & |
|---|
| 4844 | ! deepC_a_pro(:))/veget_total |
|---|
| 4845 | ! deepC_s(ipts,:,ipft) = (veget_old * deepC_s(ipts,:,ipft) + & |
|---|
| 4846 | ! deepC_s_pro(:))/veget_total |
|---|
| 4847 | ! deepC_p(ipts,:,ipft) = (veget_old * deepC_p(ipts,:,ipft) + & |
|---|
| 4848 | ! deepC_p_pro(:))/veget_total |
|---|
| 4849 | ! litter(ipts,:,ipft,:,:) = (veget_old * litter(ipts,:,ipft,:,:) + & |
|---|
| 4850 | ! litter_pro(:,:,:))/veget_total |
|---|
| 4851 | ! fuel_1hr(ipts,ipft,:,:) = (veget_old * fuel_1hr(ipts,ipft,:,:) + & |
|---|
| 4852 | ! fuel_1hr_pro(:,:))/veget_total |
|---|
| 4853 | ! fuel_10hr(ipts,ipft,:,:) = (veget_old * fuel_10hr(ipts,ipft,:,:) + & |
|---|
| 4854 | ! fuel_10hr_pro(:,:))/veget_total |
|---|
| 4855 | ! fuel_100hr(ipts,ipft,:,:) = (veget_old * fuel_100hr(ipts,ipft,:,:) + & |
|---|
| 4856 | ! fuel_100hr_pro(:,:))/veget_total |
|---|
| 4857 | ! fuel_1000hr(ipts,ipft,:,:) = (veget_old * fuel_1000hr(ipts,ipft,:,:) + & |
|---|
| 4858 | ! fuel_1000hr_pro(:,:))/veget_total |
|---|
| 4859 | ! |
|---|
| 4860 | ! WHERE (litter(ipts,istructural,ipft,:,icarbon) .GT. min_stomate) |
|---|
| 4861 | ! lignin_struc(ipts,ipft,:) = (veget_old*litter_old(ipts,istructural,ipft,:,icarbon)* & |
|---|
| 4862 | ! lignin_struc(ipts,ipft,:) + litter_pro(istructural,:,icarbon)* & |
|---|
| 4863 | ! lignin_struc_pro(:))/(veget_total*litter(ipts,istructural,ipft,:,icarbon)) |
|---|
| 4864 | ! ENDWHERE |
|---|
| 4865 | ! bm_to_litter(ipts,ipft,:,:) = (veget_old * bm_to_litter(ipts,ipft,:,:) + & |
|---|
| 4866 | ! bm_to_litter_pro(:,:))/veget_total |
|---|
| 4867 | ! |
|---|
| 4868 | ! biomass(ipts,ipft,:,:) = (biomass(ipts,ipft,:,:)*veget_old + & |
|---|
| 4869 | ! biomass_pro(:,:))/veget_total |
|---|
| 4870 | ! co2_to_bm(ipts,ipft) = (veget_old*co2_to_bm(ipts,ipft) + & |
|---|
| 4871 | ! co2_to_bm_pro)/veget_total |
|---|
| 4872 | ! ind(ipts,ipft) = (ind(ipts,ipft)*veget_old + ind_pro)/veget_total |
|---|
| 4873 | ! lm_lastyearmax(ipts,ipft) = (lm_lastyearmax(ipts,ipft)*veget_old + & |
|---|
| 4874 | ! lm_lastyearmax_pro)/veget_total |
|---|
| 4875 | ! npp_longterm(ipts,ipft) = (veget_old * npp_longterm(ipts,ipft) + & |
|---|
| 4876 | ! npp_longterm_pro)/veget_total |
|---|
| 4877 | ! |
|---|
| 4878 | ! !CHECK: Here follows the original idea in DOFOCO, more strictly, |
|---|
| 4879 | ! ! leas mass should be considered together. The same also applies on |
|---|
| 4880 | ! ! leaf age. |
|---|
| 4881 | ! leaf_frac(ipts,ipft,:) = (leaf_frac(ipts,ipft,:)*veget_old + & |
|---|
| 4882 | ! leaf_frac_pro(:))/veget_total |
|---|
| 4883 | ! leaf_age(ipts,ipft,:) = (leaf_age(ipts,ipft,:)*veget_old + & |
|---|
| 4884 | ! leaf_age_pro(:))/veget_total |
|---|
| 4885 | ! age(ipts,ipft) = (veget_old * age(ipts,ipft) + & |
|---|
| 4886 | ! age_pro)/veget_total |
|---|
| 4887 | ! |
|---|
| 4888 | ! ! Everywhere deals with the migration of vegetation. Copy the |
|---|
| 4889 | ! ! status of the most migrated vegetation for the whole PFT |
|---|
| 4890 | ! everywhere(ipts,ipft) = MAX(everywhere(ipts,ipft), everywhere_pro) |
|---|
| 4891 | ! |
|---|
| 4892 | ! ! Overwrite the original variables with that from newly initialized |
|---|
| 4893 | ! ! proxy PFT |
|---|
| 4894 | ! PFTpresent(ipts,ipft) = PFTpresent_pro |
|---|
| 4895 | ! senescence(ipts,ipft) = senescence_pro |
|---|
| 4896 | ! |
|---|
| 4897 | ! ! This is to close carbon loop when writing history variables. |
|---|
| 4898 | ! gpp_daily(ipts,ipft) = (veget_old * gpp_daily(ipts,ipft) + & |
|---|
| 4899 | ! gpp_daily_pro)/veget_total |
|---|
| 4900 | ! npp_daily(ipts,ipft) = (veget_old * npp_daily(ipts,ipft) + & |
|---|
| 4901 | ! npp_daily_pro)/veget_total |
|---|
| 4902 | ! resp_maint(ipts,ipft) = (veget_old * resp_maint(ipts,ipft) + & |
|---|
| 4903 | ! resp_maint_pro)/veget_total |
|---|
| 4904 | ! resp_growth(ipts,ipft) = (veget_old * resp_growth(ipts,ipft) + & |
|---|
| 4905 | ! resp_growth_pro)/veget_total |
|---|
| 4906 | ! resp_hetero(ipts,ipft) = (veget_old * resp_hetero(ipts,ipft) + & |
|---|
| 4907 | ! resp_hetero_pro)/veget_total |
|---|
| 4908 | ! co2_fire(ipts,ipft) = (veget_old * co2_fire(ipts,ipft) + & |
|---|
| 4909 | ! co2_fire_pro)/veget_total |
|---|
| 4910 | ! |
|---|
| 4911 | ! ! Phenology- or time-related variables will be copied from original values if |
|---|
| 4912 | ! ! there is already youngest-age-class PFT there, otherwise they're left |
|---|
| 4913 | ! ! untouched, because 1. to initiliaze all new PFTs here is wrong and |
|---|
| 4914 | ! ! phenology is not explicitly considered, so we cannot assign a value |
|---|
| 4915 | ! ! to these variables. 2. We assume they will be correctly filled if |
|---|
| 4916 | ! ! other variables are in place (e.g., non-zero leaf mass will lead to |
|---|
| 4917 | ! ! onset of growing season). In this case, merging a newly initialized PFT |
|---|
| 4918 | ! ! to an existing one is not the same as merging PFTs when they grow |
|---|
| 4919 | ! ! old enough to exceed thresholds. |
|---|
| 4920 | ! |
|---|
| 4921 | ! ! gpp_week(ipts,ipft) = (veget_old * gpp_week(ipts,ipft) + & |
|---|
| 4922 | ! ! gpp_week_pro)/veget_total |
|---|
| 4923 | ! ! when_growthinit(ipts,ipft) = (veget_old * when_growthinit(ipts,ipft) + & |
|---|
| 4924 | ! ! when_growthinit_pro)/veget_total |
|---|
| 4925 | ! ! gdd_from_growthinit(ipts,ipft) = (veget_old * gdd_from_growthinit(ipts,ipft) + & |
|---|
| 4926 | ! ! gdd_from_growthinit_pro)/veget_total |
|---|
| 4927 | ! ! gdd_midwinter(ipts,ipft) = (veget_old * gdd_midwinter(ipts,ipft) + & |
|---|
| 4928 | ! ! gdd_midwinter_pro)/veget_total |
|---|
| 4929 | ! ! time_hum_min(ipts,ipft) = (veget_old * time_hum_min(ipts,ipft) + & |
|---|
| 4930 | ! ! time_hum_min_pro)/veget_total |
|---|
| 4931 | ! ! gdd_m5_dormance(ipts,ipft) = (veget_old * gdd_m5_dormance(ipts,ipft) + & |
|---|
| 4932 | ! ! gdd_m5_dormance_pro)/veget_total |
|---|
| 4933 | ! ! ncd_dormance(ipts,ipft) = (veget_old * ncd_dormance(ipts,ipft) + & |
|---|
| 4934 | ! ! ncd_dormance_pro)/veget_total |
|---|
| 4935 | ! ! moiavail_month(ipts,ipft) = (veget_old * moiavail_month(ipts,ipft) + & |
|---|
| 4936 | ! ! moiavail_month_pro)/veget_total |
|---|
| 4937 | ! ! moiavail_week(ipts,ipft) = (veget_old * moiavail_week(ipts,ipft) + & |
|---|
| 4938 | ! ! moiavail_week_pro)/veget_total |
|---|
| 4939 | ! ! ngd_minus5(ipts,ipft) = (veget_old * ngd_minus5(ipts,ipft) + & |
|---|
| 4940 | ! ! ngd_minus5_pro)/veget_total |
|---|
| 4941 | ! |
|---|
| 4942 | ! |
|---|
| 4943 | ! END SUBROUTINE add_incoming_proxy_pft |
|---|
| 4944 | ! |
|---|
| 4945 | ! |
|---|
| 4946 | ! ! ================================================================================================================================ |
|---|
| 4947 | ! !! SUBROUTINE : empty_pft |
|---|
| 4948 | ! !! |
|---|
| 4949 | ! !>\BRIEF : Empty a PFT when, |
|---|
| 4950 | ! !! - it is exhausted because of land cover change. |
|---|
| 4951 | ! !! - it moves to the next age class |
|---|
| 4952 | ! !! \n |
|---|
| 4953 | ! !_ ================================================================================================================================ |
|---|
| 4954 | ! SUBROUTINE empty_pft(ipts, ivm, veget_max, biomass, ind, & |
|---|
| 4955 | ! carbon, litter_above, litter_below, lignin_struc, bm_to_litter, & |
|---|
| 4956 | ! deepC_a, deepC_s, deepC_p, & |
|---|
| 4957 | ! fuel_1hr, fuel_10hr, fuel_100hr, fuel_1000hr, & |
|---|
| 4958 | ! gpp_daily, npp_daily, gpp_week, npp_longterm, & |
|---|
| 4959 | ! co2_to_bm, resp_maint, resp_growth, resp_hetero, & |
|---|
| 4960 | ! lm_lastyearmax, leaf_frac, leaf_age, age, & |
|---|
| 4961 | ! everywhere, PFTpresent, when_growthinit, & |
|---|
| 4962 | ! senescence, gdd_from_growthinit, gdd_midwinter, & |
|---|
| 4963 | ! time_hum_min, gdd_m5_dormance, ncd_dormance, & |
|---|
| 4964 | ! moiavail_month, moiavail_week, ngd_minus5) |
|---|
| 4965 | ! |
|---|
| 4966 | ! IMPLICIT NONE |
|---|
| 4967 | ! |
|---|
| 4968 | ! !! 0.1 Input variables |
|---|
| 4969 | ! INTEGER, INTENT(in) :: ipts !! index for grid cell |
|---|
| 4970 | ! INTEGER, INTENT(in) :: ivm !! index for pft |
|---|
| 4971 | ! |
|---|
| 4972 | ! !! 0.2 Output variables |
|---|
| 4973 | ! |
|---|
| 4974 | ! !! 0.3 Modified variables |
|---|
| 4975 | ! |
|---|
| 4976 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: veget_max !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 4977 | ! !! May sum to |
|---|
| 4978 | ! !! less than unity if the pixel has |
|---|
| 4979 | ! !! nobio area. (unitless, 0-1) |
|---|
| 4980 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: biomass !! Stand level biomass @tex $(gC.m^{-2})$ @endtex |
|---|
| 4981 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ind !! Number of individuals at the stand level |
|---|
| 4982 | ! !! @tex $(m^{-2})$ @endtex |
|---|
| 4983 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: carbon !! carbon pool: active, slow, or passive |
|---|
| 4984 | ! !! @tex ($gC m^{-2}$) @endtex |
|---|
| 4985 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_a !! Permafrost soil carbon (g/m**3) active |
|---|
| 4986 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_s !! Permafrost soil carbon (g/m**3) slow |
|---|
| 4987 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: deepC_p !! Permafrost soil carbon (g/m**3) passive |
|---|
| 4988 | ! REAL(r_std), DIMENSION(ipts,nlitt,nvm,nlevs,nelements) :: litter !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 4989 | ! !! deforestation region. |
|---|
| 4990 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: litter_above !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 4991 | ! !! deforestation region. |
|---|
| 4992 | ! REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(in) :: litter_below !! Vegetmax-weighted remaining litter on the ground for |
|---|
| 4993 | ! !! deforestation region. |
|---|
| 4994 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1hr |
|---|
| 4995 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_10hr |
|---|
| 4996 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_100hr |
|---|
| 4997 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: fuel_1000hr |
|---|
| 4998 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: lignin_struc !! ratio Lignine/Carbon in structural litter, |
|---|
| 4999 | ! !! above and below ground |
|---|
| 5000 | ! REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: bm_to_litter !! Transfer of biomass to litter |
|---|
| 5001 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 5002 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_daily !! Daily gross primary productivity |
|---|
| 5003 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 5004 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_daily !! Net primary productivity |
|---|
| 5005 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 5006 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_week !! Mean weekly gross primary productivity |
|---|
| 5007 | ! !! @tex $(gC m^{-2} day^{-1})$ @endtex |
|---|
| 5008 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: npp_longterm !! "Long term" mean yearly primary productivity |
|---|
| 5009 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: co2_to_bm !! CO2 taken from the atmosphere to get C to create |
|---|
| 5010 | ! !! the seedlings @tex (gC.m^{-2}dt^{-1})$ @endtex |
|---|
| 5011 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_maint !! Maintenance respiration |
|---|
| 5012 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 5013 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_growth !! Growth respiration |
|---|
| 5014 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 5015 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: resp_hetero !! Heterotrophic respiration |
|---|
| 5016 | ! !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex |
|---|
| 5017 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: lm_lastyearmax !! last year's maximum leaf mass for each PFT |
|---|
| 5018 | ! !! @tex ($gC m^{-2}$) @endtex |
|---|
| 5019 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_frac !! fraction of leaves in leaf age class (unitless;0-1) |
|---|
| 5020 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_age !! Leaf age (days) |
|---|
| 5021 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: age !! mean age (years) |
|---|
| 5022 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: everywhere !! is the PFT everywhere in the grid box or |
|---|
| 5023 | ! !! very localized (after its introduction) (?) |
|---|
| 5024 | ! LOGICAL, DIMENSION(:,:), INTENT(inout) :: PFTpresent !! Tab indicating which PFTs are present in |
|---|
| 5025 | ! !! each pixel |
|---|
| 5026 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: when_growthinit !! How many days ago was the beginning of |
|---|
| 5027 | ! !! the growing season (days) |
|---|
| 5028 | ! LOGICAL, DIMENSION(:,:), INTENT(inout) :: senescence !! Flag for setting senescence stage (only |
|---|
| 5029 | ! !! for deciduous trees) |
|---|
| 5030 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_from_growthinit !! growing degree days, since growthinit |
|---|
| 5031 | ! !! for crops |
|---|
| 5032 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_midwinter !! Growing degree days (K), since midwinter |
|---|
| 5033 | ! !! (for phenology) - this is written to the |
|---|
| 5034 | ! !! history files |
|---|
| 5035 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: time_hum_min !! Time elapsed since strongest moisture |
|---|
| 5036 | ! !! availability (days) |
|---|
| 5037 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gdd_m5_dormance !! Growing degree days (K), threshold -5 deg |
|---|
| 5038 | ! !! C (for phenology) |
|---|
| 5039 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ncd_dormance !! Number of chilling days (days), since |
|---|
| 5040 | ! !! leaves were lost (for phenology) |
|---|
| 5041 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_month !! "Monthly" moisture availability (0 to 1, |
|---|
| 5042 | ! !! unitless) |
|---|
| 5043 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: moiavail_week !! "Weekly" moisture availability |
|---|
| 5044 | ! !! (0 to 1, unitless) |
|---|
| 5045 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ngd_minus5 !! Number of growing days (days), threshold |
|---|
| 5046 | ! !! -5 deg C (for phenology) |
|---|
| 5047 | ! |
|---|
| 5048 | ! !! 0.4 Local variables |
|---|
| 5049 | ! INTEGER(i_std) :: iele !! Indeces(unitless) |
|---|
| 5050 | ! INTEGER(i_std) :: ilit,ilev,icarb !! Indeces(unitless) |
|---|
| 5051 | ! |
|---|
| 5052 | ! veget_max(ipts,ivm) = zero |
|---|
| 5053 | ! ind(ipts,ivm) = zero |
|---|
| 5054 | ! biomass(ipts,ivm,:,:) = zero |
|---|
| 5055 | ! litter(ipts,:,ivm,:,:) = zero |
|---|
| 5056 | ! fuel_1hr(ipts,ivm,:,:) = zero |
|---|
| 5057 | ! fuel_10hr(ipts,ivm,:,:) = zero |
|---|
| 5058 | ! fuel_100hr(ipts,ivm,:,:) = zero |
|---|
| 5059 | ! fuel_1000hr(ipts,ivm,:,:) = zero |
|---|
| 5060 | ! carbon(ipts,:,ivm) = zero |
|---|
| 5061 | ! deepC_a(ipts,:,ivm) = zero |
|---|
| 5062 | ! deepC_s(ipts,:,ivm) = zero |
|---|
| 5063 | ! deepC_p(ipts,:,ivm) = zero |
|---|
| 5064 | ! bm_to_litter(ipts,ivm,:,:) = zero |
|---|
| 5065 | ! DO ilev=1,nlevs |
|---|
| 5066 | ! lignin_struc(ipts,ivm,ilev) = zero |
|---|
| 5067 | ! ENDDO |
|---|
| 5068 | ! npp_longterm(ipts,ivm) = zero |
|---|
| 5069 | ! gpp_daily(ipts,ivm) = zero |
|---|
| 5070 | ! gpp_week(ipts,ivm) = zero |
|---|
| 5071 | ! resp_maint(ipts,ivm) = zero |
|---|
| 5072 | ! resp_growth(ipts,ivm) = zero |
|---|
| 5073 | ! resp_hetero(ipts,ivm) = zero |
|---|
| 5074 | ! npp_daily(ipts,ivm) = zero |
|---|
| 5075 | ! co2_to_bm(ipts,ivm) = zero |
|---|
| 5076 | ! lm_lastyearmax(ipts,ivm) = zero |
|---|
| 5077 | ! age(ipts,ivm) = zero |
|---|
| 5078 | ! leaf_frac(ipts,ivm,:) = zero |
|---|
| 5079 | ! leaf_age(ipts,ivm,:) = zero |
|---|
| 5080 | ! everywhere(ipts,ivm) = zero |
|---|
| 5081 | ! when_growthinit(ipts,ivm) = zero |
|---|
| 5082 | ! gdd_from_growthinit(ipts,ivm) = zero |
|---|
| 5083 | ! gdd_midwinter(ipts,ivm) = zero |
|---|
| 5084 | ! time_hum_min(ipts,ivm) = zero |
|---|
| 5085 | ! gdd_m5_dormance(ipts,ivm) = zero |
|---|
| 5086 | ! ncd_dormance(ipts,ivm) = zero |
|---|
| 5087 | ! moiavail_month(ipts,ivm) = zero |
|---|
| 5088 | ! moiavail_week(ipts,ivm) = zero |
|---|
| 5089 | ! ngd_minus5(ipts,ivm) = zero |
|---|
| 5090 | ! PFTpresent(ipts,ivm) = .FALSE. |
|---|
| 5091 | ! senescence(ipts,ivm) = .FALSE. |
|---|
| 5092 | ! |
|---|
| 5093 | ! END SUBROUTINE empty_pft |
|---|
| 5094 | ! |
|---|
| 5095 | ! ! ================================================================================================================================ |
|---|
| 5096 | ! !! SUBROUTINE : gross_lcc_firstday |
|---|
| 5097 | ! !! |
|---|
| 5098 | ! !>\BRIEF : When necessary, adjust input glcc matrix, and allocate it |
|---|
| 5099 | ! !! into different contributing age classes and receiving |
|---|
| 5100 | ! !! youngest age classes. |
|---|
| 5101 | ! !! \n |
|---|
| 5102 | ! !_ ================================================================================================================================ |
|---|
| 5103 | ! |
|---|
| 5104 | ! ! Note: it has this name because this subroutine will also be called |
|---|
| 5105 | ! ! the first day of each year to precalculate the forest loss for the |
|---|
| 5106 | ! ! deforestation fire module. |
|---|
| 5107 | ! SUBROUTINE gross_glcc_firstday_fh(npts,veget_max_org,harvest_matrix, & |
|---|
| 5108 | ! glccSecondShift,glccPrimaryShift,glccNetLCC,& |
|---|
| 5109 | ! glccReal,glcc_pft,glcc_pftmtc,IncreDeficit, & |
|---|
| 5110 | ! Deficit_pf2yf_final, Deficit_sf2yf_final, & |
|---|
| 5111 | ! pf2yf_compen_sf2yf, sf2yf_compen_pf2yf) |
|---|
| 5112 | ! |
|---|
| 5113 | ! IMPLICIT NONE |
|---|
| 5114 | ! |
|---|
| 5115 | ! !! 0.1 Input variables |
|---|
| 5116 | ! |
|---|
| 5117 | ! INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 5118 | ! REAL(r_std), DIMENSION(npts,nvm), INTENT(in) :: veget_max_org !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 5119 | ! !! May sum to |
|---|
| 5120 | ! !! less than unity if the pixel has |
|---|
| 5121 | ! !! nobio area. (unitless, 0-1) |
|---|
| 5122 | ! REAL(r_std), DIMENSION(npts,12),INTENT(in) :: harvest_matrix !! |
|---|
| 5123 | ! !! |
|---|
| 5124 | ! REAL(r_std), DIMENSION (npts,12),INTENT(in) :: glccSecondShift !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 5125 | ! !! used. |
|---|
| 5126 | ! REAL(r_std), DIMENSION (npts,12),INTENT(in) :: glccPrimaryShift !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 5127 | ! !! used. |
|---|
| 5128 | ! REAL(r_std), DIMENSION (npts,12),INTENT(in) :: glccNetLCC !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 5129 | ! !! used. |
|---|
| 5130 | ! |
|---|
| 5131 | ! !! 0.2 Output variables |
|---|
| 5132 | ! REAL(r_std), DIMENSION(npts,nvm,nvmap), INTENT(inout) :: glcc_pftmtc !! a temporary variable to hold the fractions each PFT is going to lose |
|---|
| 5133 | ! REAL(r_std), DIMENSION(npts,nvm), INTENT(inout) :: glcc_pft !! Loss of fraction in each PFT |
|---|
| 5134 | ! REAL(r_std), DIMENSION(npts,12), INTENT(inout) :: glccReal !! The "real" glcc matrix that we apply in the model |
|---|
| 5135 | ! !! after considering the consistency between presribed |
|---|
| 5136 | ! !! glcc matrix and existing vegetation fractions. |
|---|
| 5137 | ! REAL(r_std), DIMENSION(npts,12), INTENT(inout) :: IncreDeficit !! "Increment" deficits, negative values mean that |
|---|
| 5138 | ! !! there are not enough fractions in the source PFTs |
|---|
| 5139 | ! !! /vegetations to target PFTs/vegetations. I.e., these |
|---|
| 5140 | ! !! fraction transfers are presribed in LCC matrix but |
|---|
| 5141 | ! !! not realized. |
|---|
| 5142 | ! REAL(r_std), DIMENSION(npts), INTENT(inout) :: Deficit_pf2yf_final !! |
|---|
| 5143 | ! REAL(r_std), DIMENSION(npts), INTENT(inout) :: Deficit_sf2yf_final !! |
|---|
| 5144 | ! REAL(r_std), DIMENSION(npts), INTENT(inout) :: pf2yf_compen_sf2yf !! |
|---|
| 5145 | ! REAL(r_std), DIMENSION(npts), INTENT(inout) :: sf2yf_compen_pf2yf !! |
|---|
| 5146 | ! |
|---|
| 5147 | ! |
|---|
| 5148 | ! !! 0.3 Modified variables |
|---|
| 5149 | ! |
|---|
| 5150 | ! !! 0.4 Local variables |
|---|
| 5151 | ! REAL(r_std), DIMENSION(npts,nvmap) :: veget_mtc !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 5152 | ! REAL(r_std), DIMENSION(npts,nagec_tree) :: vegagec_tree !! fraction of tree age-class groups, in sequence of old->young |
|---|
| 5153 | ! REAL(r_std), DIMENSION(npts,nagec_herb) :: vegagec_grass !! fraction of grass age-class groups, in sequence of old->young |
|---|
| 5154 | ! REAL(r_std), DIMENSION(npts,nagec_herb) :: vegagec_pasture !! fraction of pasture age-class groups, in sequence of old->young |
|---|
| 5155 | ! REAL(r_std), DIMENSION(npts,nagec_herb) :: vegagec_crop !! fraction of crop age-class groups, in sequence of old->young |
|---|
| 5156 | ! |
|---|
| 5157 | ! |
|---|
| 5158 | ! REAL(r_std), DIMENSION(npts,4) :: veget_4veg !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 5159 | ! REAL(r_std), DIMENSION(npts) :: veget_tree !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 5160 | ! REAL(r_std), DIMENSION(npts) :: veget_grass !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 5161 | ! REAL(r_std), DIMENSION(npts) :: veget_pasture !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 5162 | ! REAL(r_std), DIMENSION(npts) :: veget_crop !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 5163 | ! |
|---|
| 5164 | ! REAL(r_std), DIMENSION(npts,nvm) :: veget_max !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 5165 | ! REAL(r_std), DIMENSION(npts,nvm) :: veget_max_tmp !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 5166 | ! REAL(r_std), DIMENSION(npts,nvm) :: veget_max_old !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 5167 | ! REAL(r_std), DIMENSION(npts,nvm) :: glcc_pft_tmp !! Loss of fraction in each PFT |
|---|
| 5168 | ! |
|---|
| 5169 | ! ! Different indexes for convenient local uses |
|---|
| 5170 | ! ! We define the rules for gross land cover change matrix: |
|---|
| 5171 | ! ! 1 forest->grass |
|---|
| 5172 | ! ! 2 forest->pasture |
|---|
| 5173 | ! ! 3 forest->crop |
|---|
| 5174 | ! ! 4 grass->forest |
|---|
| 5175 | ! ! 5 grass->pasture |
|---|
| 5176 | ! ! 6 grass->crop |
|---|
| 5177 | ! ! 7 pasture->forest |
|---|
| 5178 | ! ! 8 pasture->grass |
|---|
| 5179 | ! ! 9 pasture->crop |
|---|
| 5180 | ! ! 10 crop->forest |
|---|
| 5181 | ! ! 11 crop->grass |
|---|
| 5182 | ! ! 12 crop->pasture |
|---|
| 5183 | ! INTEGER :: f2g=1, f2p=2, f2c=3 |
|---|
| 5184 | ! INTEGER :: g2f=4, g2p=5, g2c=6, p2f=7, p2g=8, p2c=9, c2f=10, c2g=11, c2p=12 |
|---|
| 5185 | ! |
|---|
| 5186 | ! INTEGER, ALLOCATABLE :: indall_tree(:) !! Indices for all tree PFTs |
|---|
| 5187 | ! INTEGER, ALLOCATABLE :: indold_tree(:) !! Indices for old tree cohort only |
|---|
| 5188 | ! INTEGER, ALLOCATABLE :: indagec_tree(:,:) !! Indices for secondary tree cohorts, |
|---|
| 5189 | ! !! note the sequence is old->young. |
|---|
| 5190 | ! INTEGER, ALLOCATABLE :: indall_grass(:) !! Indices for all grass PFTs |
|---|
| 5191 | ! INTEGER, ALLOCATABLE :: indold_grass(:) !! Indices for old grasses only |
|---|
| 5192 | ! INTEGER, ALLOCATABLE :: indagec_grass(:,:) !! Indices for secondary grass cohorts |
|---|
| 5193 | ! !! note the sequence is old->young. |
|---|
| 5194 | ! INTEGER, ALLOCATABLE :: indall_pasture(:) !! Indices for all pasture PFTs |
|---|
| 5195 | ! INTEGER, ALLOCATABLE :: indold_pasture(:) !! Indices for old pasture only |
|---|
| 5196 | ! INTEGER, ALLOCATABLE :: indagec_pasture(:,:) !! Indices for secondary pasture cohorts |
|---|
| 5197 | ! !! note the sequence is old->young. |
|---|
| 5198 | ! INTEGER, ALLOCATABLE :: indall_crop(:) !! Indices for all crop PFTs |
|---|
| 5199 | ! INTEGER, ALLOCATABLE :: indold_crop(:) !! Indices for old crops only |
|---|
| 5200 | ! INTEGER, ALLOCATABLE :: indagec_crop(:,:) !! Indices for secondary crop cohorts |
|---|
| 5201 | ! !! note the sequence is old->young. |
|---|
| 5202 | ! INTEGER :: num_tree_sinagec,num_tree_mulagec,num_grass_sinagec,num_grass_mulagec, & |
|---|
| 5203 | ! num_pasture_sinagec,num_pasture_mulagec,num_crop_sinagec,num_crop_mulagec, & |
|---|
| 5204 | ! itree,itree2,igrass,igrass2,ipasture,ipasture2,icrop,icrop2,pf2yf,sf2yf |
|---|
| 5205 | ! INTEGER :: i,j,ivma,staind,endind,ivm |
|---|
| 5206 | ! |
|---|
| 5207 | ! |
|---|
| 5208 | ! REAL(r_std), DIMENSION(npts,12) :: glccDef !! Gross LCC deficit, negative values mean that there |
|---|
| 5209 | ! !! are not enough fractions in the source vegetations |
|---|
| 5210 | ! !! to the target ones as presribed by the LCC matrix. |
|---|
| 5211 | ! REAL(r_std), DIMENSION(npts) :: Deficit_pf2yf !! |
|---|
| 5212 | ! REAL(r_std), DIMENSION(npts) :: Deficit_sf2yf !! |
|---|
| 5213 | ! REAL(r_std), DIMENSION(npts) :: Surplus_pf2yf !! |
|---|
| 5214 | ! REAL(r_std), DIMENSION(npts) :: Surplus_sf2yf !! |
|---|
| 5215 | ! REAL(r_std), DIMENSION(npts,12) :: FHmatrix_remainA !! |
|---|
| 5216 | ! REAL(r_std), DIMENSION(npts,12) :: FHmatrix_remainB !! |
|---|
| 5217 | ! REAL(r_std), DIMENSION(npts,12) :: glccRemain !! |
|---|
| 5218 | ! REAL(r_std), DIMENSION(npts,12) :: glccSecondShift_remain !! |
|---|
| 5219 | ! REAL(r_std), DIMENSION(npts,2) :: vegagec_tree_twocl !! Forest fraction in two big classes: the oldest and other |
|---|
| 5220 | ! !! age classes. |
|---|
| 5221 | ! |
|---|
| 5222 | ! INTEGER :: ipts,IndStart_f,IndEnd_f |
|---|
| 5223 | ! |
|---|
| 5224 | ! |
|---|
| 5225 | ! !! 1. We first build all different indices that we are going to use |
|---|
| 5226 | ! !! in handling the PFT exchanges, three types of indices are built: |
|---|
| 5227 | ! !! - for all age classes |
|---|
| 5228 | ! !! - include only oldest age classes |
|---|
| 5229 | ! !! - include all age classes excpet the oldest ones |
|---|
| 5230 | ! ! We have to build these indices because we would like to extract from |
|---|
| 5231 | ! ! donating PFTs in the sequnce of old->young age classes, and add in the |
|---|
| 5232 | ! ! receving PFTs only in the youngest-age-class PFTs. These indicies allow |
|---|
| 5233 | ! ! us to know where the different age classes are. |
|---|
| 5234 | ! |
|---|
| 5235 | ! num_tree_sinagec=0 ! number of tree PFTs with only one single age class |
|---|
| 5236 | ! ! considered as the oldest age class |
|---|
| 5237 | ! num_tree_mulagec=0 ! number of tree PFTs having multiple age classes |
|---|
| 5238 | ! num_grass_sinagec=0 |
|---|
| 5239 | ! num_grass_mulagec=0 |
|---|
| 5240 | ! num_pasture_sinagec=0 |
|---|
| 5241 | ! num_pasture_mulagec=0 |
|---|
| 5242 | ! num_crop_sinagec=0 |
|---|
| 5243 | ! num_crop_mulagec=0 |
|---|
| 5244 | ! |
|---|
| 5245 | ! !! 1.1 Calculate the number of PFTs for different MTCs and allocate |
|---|
| 5246 | ! !! the old and all indices arrays. |
|---|
| 5247 | ! |
|---|
| 5248 | ! ! [Note here the sequence to identify tree,pasture,grass,crop] is |
|---|
| 5249 | ! ! critical. The similar sequence is used in the subroutine "calc_cover". |
|---|
| 5250 | ! ! Do not forget to change the sequence there if you modify here. |
|---|
| 5251 | ! DO ivma =2,nvmap |
|---|
| 5252 | ! staind=start_index(ivma) |
|---|
| 5253 | ! IF (nagec_pft(ivma)==1) THEN |
|---|
| 5254 | ! IF (is_tree(staind)) THEN |
|---|
| 5255 | ! num_tree_sinagec = num_tree_sinagec+1 |
|---|
| 5256 | ! ELSE IF (is_grassland_manag(staind)) THEN |
|---|
| 5257 | ! num_pasture_sinagec = num_pasture_sinagec+1 |
|---|
| 5258 | ! ELSE IF (natural(staind)) THEN |
|---|
| 5259 | ! num_grass_sinagec = num_grass_sinagec+1 |
|---|
| 5260 | ! ELSE |
|---|
| 5261 | ! num_crop_sinagec = num_crop_sinagec+1 |
|---|
| 5262 | ! ENDIF |
|---|
| 5263 | ! |
|---|
| 5264 | ! ELSE |
|---|
| 5265 | ! IF (is_tree(staind)) THEN |
|---|
| 5266 | ! num_tree_mulagec = num_tree_mulagec+1 |
|---|
| 5267 | ! ELSE IF (is_grassland_manag(staind)) THEN |
|---|
| 5268 | ! num_pasture_mulagec = num_pasture_mulagec+1 |
|---|
| 5269 | ! ELSE IF (natural(staind)) THEN |
|---|
| 5270 | ! num_grass_mulagec = num_grass_mulagec+1 |
|---|
| 5271 | ! ELSE |
|---|
| 5272 | ! num_crop_mulagec = num_crop_mulagec+1 |
|---|
| 5273 | ! ENDIF |
|---|
| 5274 | ! ENDIF |
|---|
| 5275 | ! ENDDO |
|---|
| 5276 | ! |
|---|
| 5277 | ! !! Allocate index array |
|---|
| 5278 | ! ! allocate all index |
|---|
| 5279 | ! ALLOCATE(indall_tree(num_tree_sinagec+num_tree_mulagec*nagec_tree)) |
|---|
| 5280 | ! ALLOCATE(indall_grass(num_grass_sinagec+num_grass_mulagec*nagec_herb)) |
|---|
| 5281 | ! ALLOCATE(indall_pasture(num_pasture_sinagec+num_pasture_mulagec*nagec_herb)) |
|---|
| 5282 | ! ALLOCATE(indall_crop(num_crop_sinagec+num_crop_mulagec*nagec_herb)) |
|---|
| 5283 | ! |
|---|
| 5284 | ! ! allocate old-ageclass index |
|---|
| 5285 | ! ALLOCATE(indold_tree(num_tree_sinagec+num_tree_mulagec)) |
|---|
| 5286 | ! ALLOCATE(indold_grass(num_grass_sinagec+num_grass_mulagec)) |
|---|
| 5287 | ! ALLOCATE(indold_pasture(num_pasture_sinagec+num_pasture_mulagec)) |
|---|
| 5288 | ! ALLOCATE(indold_crop(num_crop_sinagec+num_crop_mulagec)) |
|---|
| 5289 | ! |
|---|
| 5290 | ! !! 1.2 Fill the oldest-age-class and all index arrays |
|---|
| 5291 | ! itree=0 |
|---|
| 5292 | ! igrass=0 |
|---|
| 5293 | ! ipasture=0 |
|---|
| 5294 | ! icrop=0 |
|---|
| 5295 | ! itree2=1 |
|---|
| 5296 | ! igrass2=1 |
|---|
| 5297 | ! ipasture2=1 |
|---|
| 5298 | ! icrop2=1 |
|---|
| 5299 | ! DO ivma =2,nvmap |
|---|
| 5300 | ! staind=start_index(ivma) |
|---|
| 5301 | ! IF (is_tree(staind)) THEN |
|---|
| 5302 | ! itree=itree+1 |
|---|
| 5303 | ! indold_tree(itree) = staind+nagec_pft(ivma)-1 |
|---|
| 5304 | ! DO j = 0,nagec_pft(ivma)-1 |
|---|
| 5305 | ! indall_tree(itree2+j) = staind+j |
|---|
| 5306 | ! ENDDO |
|---|
| 5307 | ! itree2=itree2+nagec_pft(ivma) |
|---|
| 5308 | ! ELSE IF (natural(staind) .AND. .NOT. is_grassland_manag(staind)) THEN |
|---|
| 5309 | ! igrass=igrass+1 |
|---|
| 5310 | ! indold_grass(igrass) = staind+nagec_pft(ivma)-1 |
|---|
| 5311 | ! DO j = 0,nagec_pft(ivma)-1 |
|---|
| 5312 | ! indall_grass(igrass2+j) = staind+j |
|---|
| 5313 | ! ENDDO |
|---|
| 5314 | ! igrass2=igrass2+nagec_pft(ivma) |
|---|
| 5315 | ! ELSE IF (is_grassland_manag(staind)) THEN |
|---|
| 5316 | ! ipasture = ipasture+1 |
|---|
| 5317 | ! indold_pasture(ipasture) = staind+nagec_pft(ivma)-1 |
|---|
| 5318 | ! DO j = 0,nagec_pft(ivma)-1 |
|---|
| 5319 | ! indall_pasture(ipasture2+j) = staind+j |
|---|
| 5320 | ! ENDDO |
|---|
| 5321 | ! ipasture2=ipasture2+nagec_pft(ivma) |
|---|
| 5322 | ! ELSE |
|---|
| 5323 | ! icrop = icrop+1 |
|---|
| 5324 | ! indold_crop(icrop) = staind+nagec_pft(ivma)-1 |
|---|
| 5325 | ! DO j = 0,nagec_pft(ivma)-1 |
|---|
| 5326 | ! indall_crop(icrop2+j) = staind+j |
|---|
| 5327 | ! ENDDO |
|---|
| 5328 | ! icrop2=icrop2+nagec_pft(ivma) |
|---|
| 5329 | ! ENDIF |
|---|
| 5330 | ! ENDDO |
|---|
| 5331 | ! |
|---|
| 5332 | ! !! 1.3 Allocate and fill other age class index |
|---|
| 5333 | ! |
|---|
| 5334 | ! ! [chaoyuejoy@gmail.com 2015-08-05] |
|---|
| 5335 | ! ! note that we treat the case of (num_tree_mulagec==0) differently. In this |
|---|
| 5336 | ! ! case there is no distinction of age groups among tree PFTs. But we still |
|---|
| 5337 | ! ! we want to use the "gross_lcchange" subroutine. In this case we consider |
|---|
| 5338 | ! ! them as having a single age group. In the subroutines |
|---|
| 5339 | ! ! of "type_conversion" and "cross_give_receive", only the youngest-age-group |
|---|
| 5340 | ! ! PFTs of a given MTC or vegetation type could receive the incoming fractions. |
|---|
| 5341 | ! ! To be able to handle this case with least amount of code change, we assign the index |
|---|
| 5342 | ! ! of PFT between youngest and second-oldes (i.e., indagec_tree etc) the same as |
|---|
| 5343 | ! ! those of oldest tree PFTs (or all tree PFTs because in this cases these two indices |
|---|
| 5344 | ! ! are identical) . So that this case could be correctly handled in the subrountines |
|---|
| 5345 | ! ! of "type_conversion" and "cross_give_receive". This treatment allows use |
|---|
| 5346 | ! ! of gross land cover change subroutine with only one single age class. This single |
|---|
| 5347 | ! ! age class is "simultanously the oldest and youngest age class". At the same |
|---|
| 5348 | ! ! time, we also change the num_tree_mulagec as the same of num_crop_sinagec. |
|---|
| 5349 | ! ! The similar case also applies in grass,pasture and crop. |
|---|
| 5350 | ! |
|---|
| 5351 | ! IF (num_tree_mulagec .EQ. 0) THEN |
|---|
| 5352 | ! ALLOCATE(indagec_tree(num_tree_sinagec,1)) |
|---|
| 5353 | ! indagec_tree(:,1) = indall_tree(:) |
|---|
| 5354 | ! num_tree_mulagec = num_tree_sinagec |
|---|
| 5355 | ! ELSE |
|---|
| 5356 | ! ALLOCATE(indagec_tree(num_tree_mulagec,nagec_tree-1)) |
|---|
| 5357 | ! END IF |
|---|
| 5358 | ! |
|---|
| 5359 | ! IF (num_grass_mulagec .EQ. 0) THEN |
|---|
| 5360 | ! ALLOCATE(indagec_grass(num_grass_sinagec,1)) |
|---|
| 5361 | ! indagec_grass(:,1) = indall_grass(:) |
|---|
| 5362 | ! num_grass_mulagec = num_grass_sinagec |
|---|
| 5363 | ! ELSE |
|---|
| 5364 | ! ALLOCATE(indagec_grass(num_grass_mulagec,nagec_herb-1)) |
|---|
| 5365 | ! END IF |
|---|
| 5366 | ! |
|---|
| 5367 | ! IF (num_pasture_mulagec .EQ. 0) THEN |
|---|
| 5368 | ! ALLOCATE(indagec_pasture(num_pasture_sinagec,1)) |
|---|
| 5369 | ! indagec_pasture(:,1) = indall_pasture(:) |
|---|
| 5370 | ! num_pasture_mulagec = num_pasture_sinagec |
|---|
| 5371 | ! ELSE |
|---|
| 5372 | ! ALLOCATE(indagec_pasture(num_pasture_mulagec,nagec_herb-1)) |
|---|
| 5373 | ! END IF |
|---|
| 5374 | ! |
|---|
| 5375 | ! IF (num_crop_mulagec .EQ. 0) THEN |
|---|
| 5376 | ! ALLOCATE(indagec_crop(num_crop_sinagec,1)) |
|---|
| 5377 | ! indagec_crop(:,1) = indall_crop(:) |
|---|
| 5378 | ! num_crop_mulagec = num_crop_sinagec |
|---|
| 5379 | ! ELSE |
|---|
| 5380 | ! ALLOCATE(indagec_crop(num_crop_mulagec,nagec_herb-1)) |
|---|
| 5381 | ! END IF |
|---|
| 5382 | ! |
|---|
| 5383 | ! ! fill the non-oldest age class index arrays when number of age classes |
|---|
| 5384 | ! ! is more than 1. |
|---|
| 5385 | ! ! [chaoyuejoy@gmail.com, 2015-08-05] |
|---|
| 5386 | ! ! Note the corresponding part of code will be automatically skipped |
|---|
| 5387 | ! ! when nagec_tree ==1 and/or nagec_herb ==1, i.e., the assginment |
|---|
| 5388 | ! ! in above codes when original num_*_mulagec variables are zero will be retained. |
|---|
| 5389 | ! itree=0 |
|---|
| 5390 | ! igrass=0 |
|---|
| 5391 | ! ipasture=0 |
|---|
| 5392 | ! icrop=0 |
|---|
| 5393 | ! DO ivma = 2,nvmap |
|---|
| 5394 | ! staind=start_index(ivma) |
|---|
| 5395 | ! IF (nagec_pft(ivma) > 1) THEN |
|---|
| 5396 | ! IF (is_tree(staind)) THEN |
|---|
| 5397 | ! itree=itree+1 |
|---|
| 5398 | ! DO j = 1,nagec_tree-1 |
|---|
| 5399 | ! indagec_tree(itree,j) = staind+nagec_tree-j-1 |
|---|
| 5400 | ! ENDDO |
|---|
| 5401 | ! ELSE IF (natural(staind) .AND. .NOT. is_grassland_manag(staind)) THEN |
|---|
| 5402 | ! igrass=igrass+1 |
|---|
| 5403 | ! DO j = 1,nagec_herb-1 |
|---|
| 5404 | ! indagec_grass(igrass,j) = staind+nagec_herb-j-1 |
|---|
| 5405 | ! ENDDO |
|---|
| 5406 | ! ELSE IF (is_grassland_manag(staind)) THEN |
|---|
| 5407 | ! ipasture=ipasture+1 |
|---|
| 5408 | ! DO j = 1,nagec_herb-1 |
|---|
| 5409 | ! indagec_pasture(ipasture,j) = staind+nagec_herb-j-1 |
|---|
| 5410 | ! ENDDO |
|---|
| 5411 | ! ELSE |
|---|
| 5412 | ! icrop=icrop+1 |
|---|
| 5413 | ! DO j = 1,nagec_herb-1 |
|---|
| 5414 | ! indagec_crop(icrop,j) = staind+nagec_herb-j-1 |
|---|
| 5415 | ! ENDDO |
|---|
| 5416 | ! ENDIF |
|---|
| 5417 | ! ENDIF |
|---|
| 5418 | ! ENDDO |
|---|
| 5419 | ! |
|---|
| 5420 | ! !!! ** Land cover change processes start here ** !!! |
|---|
| 5421 | ! ! we make copies of original input veget_max (which is veget_max_org |
|---|
| 5422 | ! ! in the subroutine parameter list). |
|---|
| 5423 | ! ! veget_max will be modified through different operations in order to |
|---|
| 5424 | ! ! check various purposes, e.g., whether input harvest and glcc matrix |
|---|
| 5425 | ! ! is compatible with existing veget_max and how to allocate it etc. |
|---|
| 5426 | ! ! veget_max_old will not be modified |
|---|
| 5427 | ! veget_max(:,:) = veget_max_org(:,:) |
|---|
| 5428 | ! veget_max_old(:,:) = veget_max_org(:,:) |
|---|
| 5429 | ! |
|---|
| 5430 | ! !********************** block to handle forestry harvest **************** |
|---|
| 5431 | ! !! 2. Handle the forestry harvest process |
|---|
| 5432 | ! |
|---|
| 5433 | ! !! 2.0 Some preparation |
|---|
| 5434 | ! |
|---|
| 5435 | ! pf2yf=1 !primary to young forest conversion because of harvest |
|---|
| 5436 | ! sf2yf=2 !old secondary to young forest conversion because of harvest |
|---|
| 5437 | ! |
|---|
| 5438 | ! ! Note that Deficit_pf2yf and Deficit_sf2yf are temporary, intermediate |
|---|
| 5439 | ! ! variables. The final deficits after mutual compensation are stored in |
|---|
| 5440 | ! ! Deficit_pf2yf_final and Deficit_sf2yf_final. |
|---|
| 5441 | ! Deficit_pf2yf(:) = zero |
|---|
| 5442 | ! Deficit_sf2yf(:) = zero |
|---|
| 5443 | ! Deficit_pf2yf_final(:) = zero |
|---|
| 5444 | ! Deficit_sf2yf_final(:) = zero |
|---|
| 5445 | ! |
|---|
| 5446 | ! ! Note that both Surplus_pf2yf and Surplus_sf2yf and temporary intermediate |
|---|
| 5447 | ! ! variables, the final surplus after mutual compensation are not outputed. |
|---|
| 5448 | ! Surplus_pf2yf(:) = zero |
|---|
| 5449 | ! Surplus_sf2yf(:) = zero |
|---|
| 5450 | ! |
|---|
| 5451 | ! ! Note in the naming of pf2yf_compen_sf2yf and sf2yf_compen_pf2yf, active |
|---|
| 5452 | ! ! tense is used. I.e., pf2yf_compen_sf2yf means the fraction which pf2yf |
|---|
| 5453 | ! ! compenstates for sf2yf |
|---|
| 5454 | ! pf2yf_compen_sf2yf(:) = zero !primary->young conversion that compensates |
|---|
| 5455 | ! !the secondary->young conversion because of deficit |
|---|
| 5456 | ! !in the latter |
|---|
| 5457 | ! sf2yf_compen_pf2yf(:) = zero !seondary->young conversion that compensates |
|---|
| 5458 | ! !the primary->young conversion because of the deficit |
|---|
| 5459 | ! !in the latter |
|---|
| 5460 | ! |
|---|
| 5461 | ! ! we now have to fill the transtion of forest->forest because of harvest |
|---|
| 5462 | ! ! into our target matrix glcc_pftmtc. Thus we will initiliaze them first. |
|---|
| 5463 | ! glcc_pft(:,:) = 0. |
|---|
| 5464 | ! glcc_pft_tmp(:,:) = 0. |
|---|
| 5465 | ! glcc_pftmtc(:,:,:) = 0. |
|---|
| 5466 | ! glccRemain(:,:) = harvest_matrix(:,:) |
|---|
| 5467 | ! |
|---|
| 5468 | ! !! 2.1 Handle secondary forest harvest |
|---|
| 5469 | ! |
|---|
| 5470 | ! CALL calc_cover(npts,veget_max,veget_mtc,vegagec_tree,vegagec_grass, & |
|---|
| 5471 | ! vegagec_pasture,vegagec_crop) |
|---|
| 5472 | ! |
|---|
| 5473 | ! ! Allocate harvest-caused out-going primary and secondary forest fraction |
|---|
| 5474 | ! ! into different primary and secondary (all other younger age classes) forest PFTs. |
|---|
| 5475 | ! ! [Note: below we used the tempelate of type_conversion but in fact we need |
|---|
| 5476 | ! ! only glcc_pft, which means the fraction loss in each PFT. We then need to |
|---|
| 5477 | ! ! use glcc_pft to fill glcc_pftmtc (our final target matrix), assuming that |
|---|
| 5478 | ! ! the loss of forest PFT will go to the youngest age class of its forest MTC. |
|---|
| 5479 | ! ! Thought glcc_pftmtc and glcc_pft_tmp will be automatically filled when |
|---|
| 5480 | ! ! we use the tempelate type_conversion by calling it as below, however they |
|---|
| 5481 | ! ! will be re-set to zero when handling shifting LCC in and net LCC in later |
|---|
| 5482 | ! ! sections.] |
|---|
| 5483 | ! |
|---|
| 5484 | ! !! 2.1.1 Secondary forest harvest within modeled secondary forest age classes. |
|---|
| 5485 | ! |
|---|
| 5486 | ! ! We first handle within the secondary forest age classes, in the sequence |
|---|
| 5487 | ! ! of old->young |
|---|
| 5488 | ! |
|---|
| 5489 | ! IndStart_f = 2 ! note the indecies and vegetfrac for tree age class |
|---|
| 5490 | ! ! is from old to young, thus index=2 means the |
|---|
| 5491 | ! ! 2nd oldest age class. |
|---|
| 5492 | ! IndEnd_f = nagec_tree-1 ! the 2nd youngest age class. |
|---|
| 5493 | ! |
|---|
| 5494 | ! DO ipts=1,npts |
|---|
| 5495 | ! !sf2yf |
|---|
| 5496 | ! CALL type_conversion(ipts,sf2yf,harvest_matrix,veget_mtc, & |
|---|
| 5497 | ! indold_tree,indagec_tree,indagec_pasture,num_pasture_mulagec,& |
|---|
| 5498 | ! IndEnd_f,nagec_herb, & |
|---|
| 5499 | ! vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5500 | ! glccRemain, & |
|---|
| 5501 | ! .TRUE., iagec_start=IndStart_f) |
|---|
| 5502 | ! ENDDO |
|---|
| 5503 | ! FHmatrix_remainA(:,:) = glccRemain |
|---|
| 5504 | ! |
|---|
| 5505 | ! !! 2.1.2 Use primary forest harvest to compensate the deficit in secondary |
|---|
| 5506 | ! !! forest harvest within secondary forest in the model. |
|---|
| 5507 | ! |
|---|
| 5508 | ! CALL calc_cover(npts,veget_max,veget_mtc,vegagec_tree,vegagec_grass, & |
|---|
| 5509 | ! vegagec_pasture,vegagec_crop) |
|---|
| 5510 | ! |
|---|
| 5511 | ! ! we check whether the required harvest of secondary forest |
|---|
| 5512 | ! ! is met by the existing secondary forest fractions. Otherwise |
|---|
| 5513 | ! ! we use the oldest-age-class forest to compenstate it. |
|---|
| 5514 | ! DO ipts=1,npts |
|---|
| 5515 | ! IF (FHmatrix_remainA(ipts,sf2yf) .GT. zero) THEN |
|---|
| 5516 | ! ! in this case, the existing secondary forest fraction |
|---|
| 5517 | ! ! is not enough for secondary forest harvest, we have to |
|---|
| 5518 | ! ! use primary (oldest age class) foret to compensate it. |
|---|
| 5519 | ! |
|---|
| 5520 | ! IndStart_f = 1 ! Oldest age class |
|---|
| 5521 | ! IndEnd_f = 1 ! Oldest age class |
|---|
| 5522 | ! |
|---|
| 5523 | ! !sf2yf |
|---|
| 5524 | ! CALL type_conversion(ipts,sf2yf,FHmatrix_remainA,veget_mtc, & |
|---|
| 5525 | ! indold_tree,indagec_tree,indagec_pasture,num_pasture_mulagec,& |
|---|
| 5526 | ! IndEnd_f,nagec_herb, & |
|---|
| 5527 | ! vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5528 | ! glccRemain, & |
|---|
| 5529 | ! .TRUE., iagec_start=IndStart_f) |
|---|
| 5530 | ! |
|---|
| 5531 | ! ENDIF |
|---|
| 5532 | ! ENDDO |
|---|
| 5533 | ! FHmatrix_remainB(:,:) = glccRemain |
|---|
| 5534 | ! |
|---|
| 5535 | ! !! 2.2 Handle primary forest harvest |
|---|
| 5536 | ! |
|---|
| 5537 | ! CALL calc_cover(npts,veget_max,veget_mtc,vegagec_tree,vegagec_grass, & |
|---|
| 5538 | ! vegagec_pasture,vegagec_crop) |
|---|
| 5539 | ! |
|---|
| 5540 | ! ! we check first if there is still deficit in the required secondary |
|---|
| 5541 | ! ! harvest. If yes, that means all existing forest (except the youngest |
|---|
| 5542 | ! ! age class) is depleted, thus required primary harvest will be suppressed. |
|---|
| 5543 | ! ! Otherwise we will treat primary forest harvest starting from modeled |
|---|
| 5544 | ! ! oldest-age-class forest |
|---|
| 5545 | ! |
|---|
| 5546 | ! DO ipts=1,npts |
|---|
| 5547 | ! IF (FHmatrix_remainB(ipts,sf2yf) .GT. min_stomate) THEN |
|---|
| 5548 | ! ! in this case, all forest fraction is depleted in handling |
|---|
| 5549 | ! ! required secondary forest harvest. We thus suppress the |
|---|
| 5550 | ! ! the required primary forest harvest. |
|---|
| 5551 | ! Deficit_sf2yf_final(ipts) = -1 * FHmatrix_remainB(ipts,sf2yf) |
|---|
| 5552 | ! Deficit_pf2yf_final(ipts) = -1 * FHmatrix_remainB(ipts,pf2yf) |
|---|
| 5553 | ! |
|---|
| 5554 | ! |
|---|
| 5555 | ! ELSE |
|---|
| 5556 | ! ! there are still forest can be used for required primary forest harvest. |
|---|
| 5557 | ! ! we treat primary harvest wihtin the modeled oldest age class. |
|---|
| 5558 | ! |
|---|
| 5559 | ! IndStart_f = 1 ! Oldest age class |
|---|
| 5560 | ! IndEnd_f = nagec_tree-1 ! 2nd youngest age class |
|---|
| 5561 | ! |
|---|
| 5562 | ! !pf2yf |
|---|
| 5563 | ! CALL type_conversion(ipts,pf2yf,FHmatrix_remainB,veget_mtc, & |
|---|
| 5564 | ! indold_tree,indagec_tree,indagec_pasture,num_pasture_mulagec,& |
|---|
| 5565 | ! IndEnd_f,nagec_herb, & |
|---|
| 5566 | ! vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5567 | ! glccRemain, & |
|---|
| 5568 | ! .TRUE., iagec_start=IndStart_f) |
|---|
| 5569 | ! ENDIF |
|---|
| 5570 | ! |
|---|
| 5571 | ! IF (glccRemain(ipts,pf2yf) .GT. min_stomate) THEN |
|---|
| 5572 | ! Deficit_pf2yf_final(ipts) = -1 * glccRemain(ipts,pf2yf) |
|---|
| 5573 | ! ENDIF |
|---|
| 5574 | ! ENDDO |
|---|
| 5575 | ! |
|---|
| 5576 | ! ! Because we use the container of type_conversion, now the glcc_pft_tmp |
|---|
| 5577 | ! ! and glcc_pftmtc have wrong information (because harvest loss is assigned |
|---|
| 5578 | ! ! on the newly created youngest-age-class pasture/crop MTCs). So they have |
|---|
| 5579 | ! ! to be re-initialized to zero. Only the information in glcc_pft is what |
|---|
| 5580 | ! ! we need, as explained above. |
|---|
| 5581 | ! glcc_pft_tmp(:,:) = 0. |
|---|
| 5582 | ! glcc_pftmtc(:,:,:) = 0. |
|---|
| 5583 | ! !Here we need to put glcc_pft into glcc_pftmtc for forestry harvest. |
|---|
| 5584 | ! !The same MTC will be maintained when forest is harvested. |
|---|
| 5585 | ! DO ivm =1,nvm |
|---|
| 5586 | ! IF (is_tree(ivm)) THEN |
|---|
| 5587 | ! glcc_pftmtc(:,ivm,pft_to_mtc(ivm)) = glcc_pft(:,ivm) |
|---|
| 5588 | ! ENDIF |
|---|
| 5589 | ! ENDDO |
|---|
| 5590 | ! !****************** end block to handle forestry harvest **************** |
|---|
| 5591 | ! |
|---|
| 5592 | ! !! 3. Treat secondary-agriculture shifting cultivation transition matrix |
|---|
| 5593 | ! !! [The primary-agriculture shifting cultivation will be treated together |
|---|
| 5594 | ! !! with the netLCC transitions, with the conversion sequence of oldest-> |
|---|
| 5595 | ! !! youngest is applied.] |
|---|
| 5596 | ! ! When we prepare the driving data, secondary-agriculture shifting cultivation |
|---|
| 5597 | ! ! is intended to include the "constant transitions" over time. Ideally, we |
|---|
| 5598 | ! ! should start applying this secondary-agriculture shifting cultivation with |
|---|
| 5599 | ! ! the "secondary forest" in the model. Here we tentatively start with the 3rd |
|---|
| 5600 | ! ! youngest age class and move to the 2ne youngest age class. But if the prescribed |
|---|
| 5601 | ! ! transition fraction is not met, we then move further to 4th youngest age class |
|---|
| 5602 | ! ! and then move to the oldest age class sequentially. |
|---|
| 5603 | ! |
|---|
| 5604 | ! CALL calc_cover(npts,veget_max,veget_mtc,vegagec_tree,vegagec_grass, & |
|---|
| 5605 | ! vegagec_pasture,vegagec_crop) |
|---|
| 5606 | ! |
|---|
| 5607 | ! !! 3.1 We start treating secondary-agriculture cultivation from the 3rd youngest |
|---|
| 5608 | ! !! age class and then move to the younger age class. |
|---|
| 5609 | ! ! Because it's rather complicated to calculate which transtion fraction between |
|---|
| 5610 | ! ! which vegetation types should stay in here in case there is deficit occuring |
|---|
| 5611 | ! ! for the overall donation vegetation type, we will just start from some |
|---|
| 5612 | ! ! priority and leave the unrealized parts into the latter section. |
|---|
| 5613 | ! |
|---|
| 5614 | ! ! For this purpose, we should first make a copy of glccSecondShift into |
|---|
| 5615 | ! ! glccRemain. glccRemain will tell us the transition fractions that have to |
|---|
| 5616 | ! ! be treated starting from 3rd oldest age class and moving torward older |
|---|
| 5617 | ! ! age class. |
|---|
| 5618 | ! glccRemain(:,:) = glccSecondShift(:,:) |
|---|
| 5619 | ! |
|---|
| 5620 | ! ! Now we will call type_conversion for each of the 12 transitions, starting |
|---|
| 5621 | ! ! from 2nd age class moving to the youngest age class. We use glccRemain |
|---|
| 5622 | ! ! to track the transtion fractions we should leave for the second case. |
|---|
| 5623 | ! ! To make the code more flexible, we will store the start and end indecies |
|---|
| 5624 | ! ! in variables. |
|---|
| 5625 | ! |
|---|
| 5626 | ! !*[Note: we do above process only for forest now, as we assume the conversion |
|---|
| 5627 | ! ! of crop/pasture/grass to other types will start always from the oldest |
|---|
| 5628 | ! ! age class] |
|---|
| 5629 | ! |
|---|
| 5630 | ! IndStart_f = nagec_tree-2 ! note the indecies and vegetfrac for tree age class |
|---|
| 5631 | ! ! is from old to young, thus nagec_tree-1 means the |
|---|
| 5632 | ! ! 3rd youngest age class. |
|---|
| 5633 | ! IndEnd_f = nagec_tree-2 ! nagec_tree-2: The 3rd youngest age class |
|---|
| 5634 | ! ! nagec_tree-1: The 2nd youngest age class |
|---|
| 5635 | ! ! nagec_tree: The youngest age class |
|---|
| 5636 | ! |
|---|
| 5637 | ! |
|---|
| 5638 | ! DO ipts=1,npts |
|---|
| 5639 | ! !f2c |
|---|
| 5640 | ! CALL type_conversion(ipts,f2c,glccSecondShift,veget_mtc, & |
|---|
| 5641 | ! indold_tree,indagec_tree,indagec_crop,num_crop_mulagec, & |
|---|
| 5642 | ! IndEnd_f,nagec_herb, & |
|---|
| 5643 | ! vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp, & |
|---|
| 5644 | ! glccRemain, & |
|---|
| 5645 | ! .TRUE., iagec_start=IndStart_f) |
|---|
| 5646 | ! !f2p |
|---|
| 5647 | ! CALL type_conversion(ipts,f2p,glccSecondShift,veget_mtc, & |
|---|
| 5648 | ! indold_tree,indagec_tree,indagec_pasture,num_pasture_mulagec, & |
|---|
| 5649 | ! IndEnd_f,nagec_herb, & |
|---|
| 5650 | ! vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp, & |
|---|
| 5651 | ! glccRemain, & |
|---|
| 5652 | ! .TRUE., iagec_start=IndStart_f) |
|---|
| 5653 | ! !f2g |
|---|
| 5654 | ! CALL type_conversion(ipts,f2g,glccSecondShift,veget_mtc, & |
|---|
| 5655 | ! indold_tree,indagec_tree,indagec_grass,num_grass_mulagec, & |
|---|
| 5656 | ! IndEnd_f,nagec_herb, & |
|---|
| 5657 | ! vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5658 | ! glccRemain, & |
|---|
| 5659 | ! .TRUE., iagec_start=IndStart_f) |
|---|
| 5660 | ! !g2c |
|---|
| 5661 | ! CALL type_conversion(ipts,g2c,glccSecondShift,veget_mtc, & |
|---|
| 5662 | ! indold_grass,indagec_grass,indagec_crop,num_crop_mulagec, & |
|---|
| 5663 | ! nagec_herb,nagec_herb, & |
|---|
| 5664 | ! vegagec_grass,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5665 | ! glccRemain, & |
|---|
| 5666 | ! .TRUE.) |
|---|
| 5667 | ! !g2p |
|---|
| 5668 | ! CALL type_conversion(ipts,g2p,glccSecondShift,veget_mtc, & |
|---|
| 5669 | ! indold_grass,indagec_grass,indagec_pasture,num_pasture_mulagec, & |
|---|
| 5670 | ! nagec_herb,nagec_herb, & |
|---|
| 5671 | ! vegagec_grass,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5672 | ! glccRemain, & |
|---|
| 5673 | ! .TRUE.) |
|---|
| 5674 | ! !g2f |
|---|
| 5675 | ! CALL type_conversion(ipts,g2f,glccSecondShift,veget_mtc, & |
|---|
| 5676 | ! indold_grass,indagec_grass,indagec_tree,num_tree_mulagec, & |
|---|
| 5677 | ! nagec_herb,nagec_tree, & |
|---|
| 5678 | ! vegagec_grass,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5679 | ! glccRemain, & |
|---|
| 5680 | ! .TRUE.) |
|---|
| 5681 | ! !p2c |
|---|
| 5682 | ! CALL type_conversion(ipts,p2c,glccSecondShift,veget_mtc, & |
|---|
| 5683 | ! indold_pasture,indagec_pasture,indagec_crop,num_crop_mulagec, & |
|---|
| 5684 | ! nagec_herb,nagec_herb, & |
|---|
| 5685 | ! vegagec_pasture,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5686 | ! glccRemain, & |
|---|
| 5687 | ! .TRUE.) |
|---|
| 5688 | ! !p2g |
|---|
| 5689 | ! CALL type_conversion(ipts,p2g,glccSecondShift,veget_mtc, & |
|---|
| 5690 | ! indold_pasture,indagec_pasture,indagec_grass,num_grass_mulagec, & |
|---|
| 5691 | ! nagec_herb,nagec_herb, & |
|---|
| 5692 | ! vegagec_pasture,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5693 | ! glccRemain, & |
|---|
| 5694 | ! .TRUE.) |
|---|
| 5695 | ! !p2f |
|---|
| 5696 | ! CALL type_conversion(ipts,p2f,glccSecondShift,veget_mtc, & |
|---|
| 5697 | ! indold_pasture,indagec_pasture,indagec_tree,num_tree_mulagec, & |
|---|
| 5698 | ! nagec_herb,nagec_tree, & |
|---|
| 5699 | ! vegagec_pasture,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5700 | ! glccRemain, & |
|---|
| 5701 | ! .TRUE.) |
|---|
| 5702 | ! !c2p |
|---|
| 5703 | ! CALL type_conversion(ipts,c2p,glccSecondShift,veget_mtc, & |
|---|
| 5704 | ! indold_crop,indagec_crop,indagec_pasture,num_pasture_mulagec, & |
|---|
| 5705 | ! nagec_herb,nagec_herb, & |
|---|
| 5706 | ! vegagec_crop,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5707 | ! glccRemain, & |
|---|
| 5708 | ! .TRUE.) |
|---|
| 5709 | ! !c2g |
|---|
| 5710 | ! CALL type_conversion(ipts,c2g,glccSecondShift,veget_mtc, & |
|---|
| 5711 | ! indold_crop,indagec_crop,indagec_grass,num_grass_mulagec, & |
|---|
| 5712 | ! nagec_herb,nagec_herb, & |
|---|
| 5713 | ! vegagec_crop,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5714 | ! glccRemain, & |
|---|
| 5715 | ! .TRUE.) |
|---|
| 5716 | ! !c2f |
|---|
| 5717 | ! CALL type_conversion(ipts,c2f,glccSecondShift,veget_mtc, & |
|---|
| 5718 | ! indold_crop,indagec_crop,indagec_tree,num_tree_mulagec, & |
|---|
| 5719 | ! nagec_herb,nagec_tree, & |
|---|
| 5720 | ! vegagec_crop,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5721 | ! glccRemain, & |
|---|
| 5722 | ! .TRUE.) |
|---|
| 5723 | ! ENDDO |
|---|
| 5724 | ! glccSecondShift_remain(:,:) = glccRemain(:,:) |
|---|
| 5725 | ! |
|---|
| 5726 | ! !! 3.2 We treat the remaing unrealized transtions from forest. Now we will |
|---|
| 5727 | ! !! start with the 3rd oldest age class and then move to the oldest age class. |
|---|
| 5728 | ! |
|---|
| 5729 | ! CALL calc_cover(npts,veget_max,veget_mtc,vegagec_tree,vegagec_grass, & |
|---|
| 5730 | ! vegagec_pasture,vegagec_crop) |
|---|
| 5731 | ! |
|---|
| 5732 | ! IndStart_f = nagec_tree-3 ! note the indecies and vegetfrac for tree age class |
|---|
| 5733 | ! ! is from old to young, thus nagec_tree-2 means the |
|---|
| 5734 | ! ! 3rd oldest age class. |
|---|
| 5735 | ! IndEnd_f = 1 |
|---|
| 5736 | ! |
|---|
| 5737 | ! ! we start with the 3rd youngest age class and move up to the oldest age |
|---|
| 5738 | ! ! class in the sequence of young->old, as indicated by the .FALSE. parameter |
|---|
| 5739 | ! ! when calling the subroutine type_conversion. |
|---|
| 5740 | ! DO ipts=1,npts |
|---|
| 5741 | ! !f2c |
|---|
| 5742 | ! CALL type_conversion(ipts,f2c,glccSecondShift_remain,veget_mtc, & |
|---|
| 5743 | ! indold_tree,indagec_tree,indagec_crop,num_crop_mulagec, & |
|---|
| 5744 | ! IndEnd_f,nagec_herb, & |
|---|
| 5745 | ! vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp, & |
|---|
| 5746 | ! glccRemain, & |
|---|
| 5747 | ! .FALSE., iagec_start=IndStart_f) |
|---|
| 5748 | ! !f2p |
|---|
| 5749 | ! CALL type_conversion(ipts,f2p,glccSecondShift_remain,veget_mtc, & |
|---|
| 5750 | ! indold_tree,indagec_tree,indagec_pasture,num_pasture_mulagec, & |
|---|
| 5751 | ! IndEnd_f,nagec_herb, & |
|---|
| 5752 | ! vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp, & |
|---|
| 5753 | ! glccRemain, & |
|---|
| 5754 | ! .FALSE., iagec_start=IndStart_f) |
|---|
| 5755 | ! !f2g |
|---|
| 5756 | ! CALL type_conversion(ipts,f2g,glccSecondShift_remain,veget_mtc, & |
|---|
| 5757 | ! indold_tree,indagec_tree,indagec_grass,num_grass_mulagec, & |
|---|
| 5758 | ! IndEnd_f,nagec_herb, & |
|---|
| 5759 | ! vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5760 | ! glccRemain, & |
|---|
| 5761 | ! .FALSE., iagec_start=IndStart_f) |
|---|
| 5762 | ! ENDDO |
|---|
| 5763 | ! |
|---|
| 5764 | ! ! we put the remaining glccRemain into the deficit |
|---|
| 5765 | ! IncreDeficit(:,:) = -1*glccRemain |
|---|
| 5766 | ! !*****end block to handle secondary-agriculture shifting cultivation ******* |
|---|
| 5767 | ! |
|---|
| 5768 | ! |
|---|
| 5769 | ! !+++ Code freezing: Compensation among different transition fractions +++ |
|---|
| 5770 | ! !+++ Description: This block of code and associated subroutines are originally |
|---|
| 5771 | ! !+++ developed to make the LCC module compatible with DGVM. |
|---|
| 5772 | ! ! |
|---|
| 5773 | ! !! we copy updated veget_max to veget_max_tmp. |
|---|
| 5774 | ! !! The latter will be used to retrieve the values of veget_max after checking |
|---|
| 5775 | ! !! the consistency of input glcc with existing vegetation fractions. |
|---|
| 5776 | ! !veget_max_tmp(:,:) = veget_max(:,:) |
|---|
| 5777 | ! |
|---|
| 5778 | ! !!************************************************************************! |
|---|
| 5779 | ! !!****block to calculate fractions for basic veg types and age classes ***! |
|---|
| 5780 | ! !! Note: |
|---|
| 5781 | ! !! 1. "calc_cover" subroutine does not depend on how many age classes |
|---|
| 5782 | ! !! there are in each MTC. |
|---|
| 5783 | ! !! 2. Fraction of baresoil is excluded here. This means transformation |
|---|
| 5784 | ! !! of baresoil to a vegetated PFT is excluded in gross land cover change. |
|---|
| 5785 | ! !veget_mtc(:,:) = 0. |
|---|
| 5786 | ! !vegagec_tree(:,:) = 0. |
|---|
| 5787 | ! !vegagec_grass(:,:) = 0. |
|---|
| 5788 | ! !vegagec_pasture(:,:) = 0. |
|---|
| 5789 | ! !vegagec_crop(:,:) = 0. |
|---|
| 5790 | ! |
|---|
| 5791 | ! |
|---|
| 5792 | ! !CALL calc_cover(npts,veget_max,veget_mtc,vegagec_tree,vegagec_grass, & |
|---|
| 5793 | ! ! vegagec_pasture,vegagec_crop) |
|---|
| 5794 | ! |
|---|
| 5795 | ! !veget_tree(:) = SUM(vegagec_tree(:,:),DIM=2) |
|---|
| 5796 | ! !veget_grass(:) = SUM(vegagec_grass(:,:),DIM=2) |
|---|
| 5797 | ! !veget_pasture(:) = SUM(vegagec_pasture(:,:),DIM=2) |
|---|
| 5798 | ! !veget_crop(:) = SUM(vegagec_crop(:,:),DIM=2) |
|---|
| 5799 | ! !itree=1 |
|---|
| 5800 | ! !igrass=2 |
|---|
| 5801 | ! !ipasture=3 |
|---|
| 5802 | ! !icrop=4 |
|---|
| 5803 | ! !veget_4veg(:,itree) = veget_tree(:) |
|---|
| 5804 | ! !veget_4veg(:,igrass) = veget_grass(:) |
|---|
| 5805 | ! !veget_4veg(:,ipasture) = veget_pasture(:) |
|---|
| 5806 | ! !veget_4veg(:,icrop) = veget_crop(:) |
|---|
| 5807 | ! !!****end block to calculate fractions for basic veg types and age classes ***! |
|---|
| 5808 | ! !!****************************************************************************! |
|---|
| 5809 | ! |
|---|
| 5810 | ! !!! 3. Decompose the LCC matrix to different PFTs |
|---|
| 5811 | ! !!! We do this through several steps: |
|---|
| 5812 | ! !! 3.1 Check whether input LCC matrix is feasible with current PFT fractions |
|---|
| 5813 | ! !! (i.e., the fractions of forest,grass,pasture and crops) |
|---|
| 5814 | ! !! and if not, adjust the transfer matrix by compensating the deficits |
|---|
| 5815 | ! !! using the surpluses. |
|---|
| 5816 | ! !! 3.2 Allocate the decreasing fractions of tree/grass/pasture/crop to their |
|---|
| 5817 | ! !! respective age classes, in the sequences of old->young. |
|---|
| 5818 | ! !! 3.3 Allocate the incoming fractions of tree/grass/pasture/crop to their |
|---|
| 5819 | ! !! respective youngest age classes. The incoming fractions are distributed |
|---|
| 5820 | ! !! according to the existing fractions of youngest-age-class PFTs of the |
|---|
| 5821 | ! !! same receiving vegetation type. If none of them exists, the incoming |
|---|
| 5822 | ! !! fraction is distributed equally. |
|---|
| 5823 | ! |
|---|
| 5824 | ! !!! 3.1 Adjust LCC matrix if it's not feasible with current PFT fractions |
|---|
| 5825 | ! |
|---|
| 5826 | ! !IncreDeficit(:,:) = 0. |
|---|
| 5827 | ! !glccReal(:,:) = 0. |
|---|
| 5828 | ! glccDef(:,:) = 0. |
|---|
| 5829 | ! |
|---|
| 5830 | ! !!to crop - sequence: p2c,g2c,f2c |
|---|
| 5831 | ! !CALL glcc_compensation_full(npts,veget_4veg,glcc,glccReal,glccDef, & |
|---|
| 5832 | ! ! p2c,ipasture,g2c,igrass,f2c,itree,icrop, & |
|---|
| 5833 | ! ! IncreDeficit) |
|---|
| 5834 | ! |
|---|
| 5835 | ! !!to pasture - sequence: g2p,c2p,f2p |
|---|
| 5836 | ! !CALL glcc_compensation_full(npts,veget_4veg,glcc,glccReal,glccDef, & |
|---|
| 5837 | ! ! g2p,igrass,c2p,icrop,f2p,itree,ipasture, & |
|---|
| 5838 | ! ! IncreDeficit) |
|---|
| 5839 | ! |
|---|
| 5840 | ! !!to grass - sequence: p2g,c2g,f2g |
|---|
| 5841 | ! !CALL glcc_compensation_full(npts,veget_4veg,glcc,glccReal,glccDef, & |
|---|
| 5842 | ! ! p2g,ipasture,c2g,icrop,f2g,itree,igrass, & |
|---|
| 5843 | ! ! IncreDeficit) |
|---|
| 5844 | ! |
|---|
| 5845 | ! !!to forest - sequence: c2f,p2f,g2f |
|---|
| 5846 | ! !CALL glcc_compensation_full(npts,veget_4veg,glcc,glccReal,glccDef, & |
|---|
| 5847 | ! ! c2f,icrop,p2f,ipasture,g2f,igrass,itree, & |
|---|
| 5848 | ! ! IncreDeficit) |
|---|
| 5849 | ! |
|---|
| 5850 | ! !!! 3.2 & 3.3 Allocate LCC matrix to different PFTs/age-classes |
|---|
| 5851 | ! |
|---|
| 5852 | ! !! because we use veget_max as a proxy variable and it has been changed |
|---|
| 5853 | ! !! when we derive the glccReal, so here we have to recover its original |
|---|
| 5854 | ! !! values, which is veget_max_tmp after the forestry harvest. |
|---|
| 5855 | ! !veget_max(:,:) = veget_max_tmp(:,:) |
|---|
| 5856 | ! ! |
|---|
| 5857 | ! !+++ end freezing block of code +++ |
|---|
| 5858 | ! |
|---|
| 5859 | ! |
|---|
| 5860 | ! !! 4. Treat the transtions involving the oldest age classes, which include |
|---|
| 5861 | ! !! the first-time primary-agriculture cultivation and the net land cover |
|---|
| 5862 | ! !! transtions |
|---|
| 5863 | ! |
|---|
| 5864 | ! CALL calc_cover(npts,veget_max,veget_mtc,vegagec_tree,vegagec_grass, & |
|---|
| 5865 | ! vegagec_pasture,vegagec_crop) |
|---|
| 5866 | ! |
|---|
| 5867 | ! |
|---|
| 5868 | ! ! the variable "glccReal" is originally for storing the realized maxtrix |
|---|
| 5869 | ! ! after considering the constraining and compensation of existing vegetation |
|---|
| 5870 | ! ! fractions. But as this case is not allowed at the moment, we will just |
|---|
| 5871 | ! ! simply put it as the sum of glccPrimaryShift and glccNetLCC |
|---|
| 5872 | ! glccReal(:,:) = glccPrimaryShift+glccNetLCC |
|---|
| 5873 | ! |
|---|
| 5874 | ! ! We copy the glccReal to glccRemain in order to track the remaining |
|---|
| 5875 | ! ! prescribed transtion fraction after applying each transition by calling |
|---|
| 5876 | ! ! the subroutine "type_conversion". For the moment this is mainly to fufill |
|---|
| 5877 | ! ! the parameter requirement of the type_conversion subroutine. |
|---|
| 5878 | ! glccRemain(:,:) = glccReal(:,:) |
|---|
| 5879 | ! |
|---|
| 5880 | ! ! We allocate in the sequences of old->young. Within the same age-class |
|---|
| 5881 | ! ! group, we allocate in proportion with existing PFT fractions. |
|---|
| 5882 | ! DO ipts=1,npts |
|---|
| 5883 | ! !f2c |
|---|
| 5884 | ! CALL type_conversion(ipts,f2c,glccReal,veget_mtc, & |
|---|
| 5885 | ! indold_tree,indagec_tree,indagec_crop,num_crop_mulagec, & |
|---|
| 5886 | ! nagec_tree,nagec_herb, & |
|---|
| 5887 | ! vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp, & |
|---|
| 5888 | ! glccRemain, & |
|---|
| 5889 | ! .TRUE.) |
|---|
| 5890 | ! !f2p |
|---|
| 5891 | ! CALL type_conversion(ipts,f2p,glccReal,veget_mtc, & |
|---|
| 5892 | ! indold_tree,indagec_tree,indagec_pasture,num_pasture_mulagec, & |
|---|
| 5893 | ! nagec_tree,nagec_herb, & |
|---|
| 5894 | ! vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp, & |
|---|
| 5895 | ! glccRemain, & |
|---|
| 5896 | ! .TRUE.) |
|---|
| 5897 | ! !f2g |
|---|
| 5898 | ! CALL type_conversion(ipts,f2g,glccReal,veget_mtc, & |
|---|
| 5899 | ! indold_tree,indagec_tree,indagec_grass,num_grass_mulagec, & |
|---|
| 5900 | ! nagec_tree,nagec_herb, & |
|---|
| 5901 | ! vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5902 | ! glccRemain, & |
|---|
| 5903 | ! .TRUE.) |
|---|
| 5904 | ! !g2c |
|---|
| 5905 | ! CALL type_conversion(ipts,g2c,glccReal,veget_mtc, & |
|---|
| 5906 | ! indold_grass,indagec_grass,indagec_crop,num_crop_mulagec, & |
|---|
| 5907 | ! nagec_herb,nagec_herb, & |
|---|
| 5908 | ! vegagec_grass,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5909 | ! glccRemain, & |
|---|
| 5910 | ! .TRUE.) |
|---|
| 5911 | ! !g2p |
|---|
| 5912 | ! CALL type_conversion(ipts,g2p,glccReal,veget_mtc, & |
|---|
| 5913 | ! indold_grass,indagec_grass,indagec_pasture,num_pasture_mulagec, & |
|---|
| 5914 | ! nagec_herb,nagec_herb, & |
|---|
| 5915 | ! vegagec_grass,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5916 | ! glccRemain, & |
|---|
| 5917 | ! .TRUE.) |
|---|
| 5918 | ! !g2f |
|---|
| 5919 | ! CALL type_conversion(ipts,g2f,glccReal,veget_mtc, & |
|---|
| 5920 | ! indold_grass,indagec_grass,indagec_tree,num_tree_mulagec, & |
|---|
| 5921 | ! nagec_herb,nagec_tree, & |
|---|
| 5922 | ! vegagec_grass,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5923 | ! glccRemain, & |
|---|
| 5924 | ! .TRUE.) |
|---|
| 5925 | ! !p2c |
|---|
| 5926 | ! CALL type_conversion(ipts,p2c,glccReal,veget_mtc, & |
|---|
| 5927 | ! indold_pasture,indagec_pasture,indagec_crop,num_crop_mulagec, & |
|---|
| 5928 | ! nagec_herb,nagec_herb, & |
|---|
| 5929 | ! vegagec_pasture,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5930 | ! glccRemain, & |
|---|
| 5931 | ! .TRUE.) |
|---|
| 5932 | ! !p2g |
|---|
| 5933 | ! CALL type_conversion(ipts,p2g,glccReal,veget_mtc, & |
|---|
| 5934 | ! indold_pasture,indagec_pasture,indagec_grass,num_grass_mulagec, & |
|---|
| 5935 | ! nagec_herb,nagec_herb, & |
|---|
| 5936 | ! vegagec_pasture,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5937 | ! glccRemain, & |
|---|
| 5938 | ! .TRUE.) |
|---|
| 5939 | ! !p2f |
|---|
| 5940 | ! CALL type_conversion(ipts,p2f,glccReal,veget_mtc, & |
|---|
| 5941 | ! indold_pasture,indagec_pasture,indagec_tree,num_tree_mulagec, & |
|---|
| 5942 | ! nagec_herb,nagec_tree, & |
|---|
| 5943 | ! vegagec_pasture,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5944 | ! glccRemain, & |
|---|
| 5945 | ! .TRUE.) |
|---|
| 5946 | ! !c2p |
|---|
| 5947 | ! CALL type_conversion(ipts,c2p,glccReal,veget_mtc, & |
|---|
| 5948 | ! indold_crop,indagec_crop,indagec_pasture,num_pasture_mulagec, & |
|---|
| 5949 | ! nagec_herb,nagec_herb, & |
|---|
| 5950 | ! vegagec_crop,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5951 | ! glccRemain, & |
|---|
| 5952 | ! .TRUE.) |
|---|
| 5953 | ! !c2g |
|---|
| 5954 | ! CALL type_conversion(ipts,c2g,glccReal,veget_mtc, & |
|---|
| 5955 | ! indold_crop,indagec_crop,indagec_grass,num_grass_mulagec, & |
|---|
| 5956 | ! nagec_herb,nagec_herb, & |
|---|
| 5957 | ! vegagec_crop,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5958 | ! glccRemain, & |
|---|
| 5959 | ! .TRUE.) |
|---|
| 5960 | ! !c2f |
|---|
| 5961 | ! CALL type_conversion(ipts,c2f,glccReal,veget_mtc, & |
|---|
| 5962 | ! indold_crop,indagec_crop,indagec_tree,num_tree_mulagec, & |
|---|
| 5963 | ! nagec_herb,nagec_tree, & |
|---|
| 5964 | ! vegagec_crop,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp,& |
|---|
| 5965 | ! glccRemain, & |
|---|
| 5966 | ! .TRUE.) |
|---|
| 5967 | ! ENDDO |
|---|
| 5968 | ! |
|---|
| 5969 | ! ! Note here IncreDeficit includes the deficit from secondary<->agriculgure shifting |
|---|
| 5970 | ! ! cultivation and the primary<->agriculture+NetLCC transitions. |
|---|
| 5971 | ! IncreDeficit(:,:) = IncreDeficit(:,:) - glccRemain(:,:) |
|---|
| 5972 | ! |
|---|
| 5973 | ! END SUBROUTINE gross_glcc_firstday_fh |
|---|
| 5974 | ! |
|---|
| 5975 | ! |
|---|
| 5976 | ! ! ================================================================================================================================ |
|---|
| 5977 | ! !! SUBROUTINE : cross_give_receive |
|---|
| 5978 | ! !! |
|---|
| 5979 | ! !>\BRIEF : Allocate the outgoing and receving fractions in respective |
|---|
| 5980 | ! !! PFTs. |
|---|
| 5981 | ! !! \n |
|---|
| 5982 | ! !! Notes: |
|---|
| 5983 | ! !! 1. veget_max is subtracted when fractions are taken out, but newly added |
|---|
| 5984 | ! !! fractions in the youngest age class is not added, to avoid this newly |
|---|
| 5985 | ! !! created fractions being used again the following transitions. This is |
|---|
| 5986 | ! !! is reasonable because the newly created youngest-age-class PFT fractions |
|---|
| 5987 | ! !! have nothing but small sapling biomass and it's unreasonable to use it |
|---|
| 5988 | ! !! for any further land use conversion activities. |
|---|
| 5989 | ! !_ ================================================================================================================================ |
|---|
| 5990 | ! SUBROUTINE cross_give_receive(ipts,frac_used,veget_mtc, & |
|---|
| 5991 | ! indold_tree,indagec_crop,nagec_receive,num_crop_mulagec, & |
|---|
| 5992 | ! veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 5993 | ! |
|---|
| 5994 | ! |
|---|
| 5995 | ! IMPLICIT NONE |
|---|
| 5996 | ! |
|---|
| 5997 | ! !! 0. Input variables |
|---|
| 5998 | ! INTEGER, INTENT(in) :: ipts |
|---|
| 5999 | ! REAL(r_std), INTENT(in) :: frac_used !! fraction that the giving PFTs are going to collectively give |
|---|
| 6000 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: veget_mtc !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 6001 | ! INTEGER, DIMENSION(:), INTENT(in) :: indold_tree !! Indices for PFTs giving out fractions; |
|---|
| 6002 | ! !! here use old tree cohort as an example |
|---|
| 6003 | ! INTEGER, DIMENSION(:,:), INTENT(in) :: indagec_crop !! Indices for secondary basic-vegetation cohorts; The youngest age classes |
|---|
| 6004 | ! !! of these vegetations are going to receive fractions. |
|---|
| 6005 | ! !! here we use crop cohorts as an example |
|---|
| 6006 | ! INTEGER, INTENT(in) :: num_crop_mulagec !! number of crop MTCs with more than one age classes |
|---|
| 6007 | ! INTEGER, INTENT(in) :: nagec_receive !! number of age classes in the receiving basic types |
|---|
| 6008 | ! !! (i.e., tree, grass, pasture, crop), here we can use crop |
|---|
| 6009 | ! !! as an example, nagec_receive=nagec_herb |
|---|
| 6010 | ! |
|---|
| 6011 | ! !! 1. Modified variables |
|---|
| 6012 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: veget_max !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 6013 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: glcc_pft !! a temporary variable to hold the fractions each PFT is going to lose |
|---|
| 6014 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: glcc_pftmtc !! a temporary variable to hold the fraction of ipft->ivma, i.e., from |
|---|
| 6015 | ! !! PFT_{ipft} to the youngest age class of MTC_{ivma} |
|---|
| 6016 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: glcc_pft_tmp !! a temporary variable to hold the fractions each PFT is going to lose |
|---|
| 6017 | ! |
|---|
| 6018 | ! !! Local vriables |
|---|
| 6019 | ! INTEGER :: j,ipft, iyoung |
|---|
| 6020 | ! REAL(r_std) :: totalveg |
|---|
| 6021 | ! |
|---|
| 6022 | ! |
|---|
| 6023 | ! ! Out final objective is to know glcc_pftmtc, i.e., the fraction from each PFT |
|---|
| 6024 | ! ! to the youngest age group of each MTC. We separate this task into two steps: |
|---|
| 6025 | ! ! 1. we allocate the total outgoing fraction into the same age-class PFTs of |
|---|
| 6026 | ! ! the a basic-vegetation (for example, the same age-calss PFTs of forest); |
|---|
| 6027 | ! ! 2. we further allocate the outgoing fraction of each age-class PFT to |
|---|
| 6028 | ! ! the different receiving youngest age-class PFTs of the same basic-vegetation |
|---|
| 6029 | ! ! type, for example, the youngest age-calss PFTs of cropland. |
|---|
| 6030 | ! |
|---|
| 6031 | ! ! glcc_pft_tmp used only as a temporary variable to store the value |
|---|
| 6032 | ! glcc_pft_tmp(ipts,indold_tree) = veget_max(ipts,indold_tree)/SUM(veget_max(ipts,indold_tree))*frac_used |
|---|
| 6033 | ! glcc_pft(ipts,indold_tree) = glcc_pft(ipts,indold_tree) + glcc_pft_tmp(ipts,indold_tree) |
|---|
| 6034 | ! !we have to remove the outgoing fraction from veget_max in order to use this information for next loop |
|---|
| 6035 | ! veget_max(ipts,indold_tree) = veget_max(ipts,indold_tree) - glcc_pft_tmp(ipts,indold_tree) |
|---|
| 6036 | ! |
|---|
| 6037 | ! ! when receiving basic-vegetation type has a single age group, it will be considered as |
|---|
| 6038 | ! ! both old and young age group (thus recevie the fraction donation), otherwise the youngest |
|---|
| 6039 | ! ! age group is always the final element of indagec_crop. |
|---|
| 6040 | ! IF (nagec_receive == 1) THEN |
|---|
| 6041 | ! iyoung = 1 |
|---|
| 6042 | ! ELSE |
|---|
| 6043 | ! iyoung = nagec_receive - 1 |
|---|
| 6044 | ! ENDIF |
|---|
| 6045 | ! |
|---|
| 6046 | ! ![20160130 note here totalveg is the total fraction of all existing MTCs |
|---|
| 6047 | ! ! that are going to recieve newly convervted fractions.] |
|---|
| 6048 | ! totalveg = 0. |
|---|
| 6049 | ! DO j=1,num_crop_mulagec |
|---|
| 6050 | ! totalveg = totalveg + veget_mtc(ipts,agec_group(indagec_crop(j,iyoung))) |
|---|
| 6051 | ! ENDDO |
|---|
| 6052 | ! |
|---|
| 6053 | ! IF (totalveg>min_stomate) THEN |
|---|
| 6054 | ! DO j=1,num_crop_mulagec |
|---|
| 6055 | ! ipft = indagec_crop(j,iyoung) |
|---|
| 6056 | ! glcc_pftmtc(ipts,indold_tree,agec_group(ipft)) = glcc_pft_tmp(ipts,indold_tree) & |
|---|
| 6057 | ! *veget_mtc(ipts,agec_group(ipft))/totalveg |
|---|
| 6058 | ! ENDDO |
|---|
| 6059 | ! ELSE |
|---|
| 6060 | ! DO j=1,num_crop_mulagec |
|---|
| 6061 | ! ipft = indagec_crop(j,iyoung) |
|---|
| 6062 | ! glcc_pftmtc(ipts,indold_tree,agec_group(ipft)) = glcc_pft_tmp(ipts,indold_tree)/num_crop_mulagec |
|---|
| 6063 | ! ENDDO |
|---|
| 6064 | ! ENDIF |
|---|
| 6065 | ! |
|---|
| 6066 | ! END SUBROUTINE cross_give_receive |
|---|
| 6067 | ! |
|---|
| 6068 | ! ! ================================================================================================================================ |
|---|
| 6069 | ! !! SUBROUTINE : type_conversion |
|---|
| 6070 | ! !>\BRIEF : Allocate outgoing into different age classes and incoming into |
|---|
| 6071 | ! !! yongest age-class of receiving MTCs. |
|---|
| 6072 | ! !! |
|---|
| 6073 | ! !! REMARK : The current dummy variables give an example of converting forests |
|---|
| 6074 | ! !! to crops. |
|---|
| 6075 | ! !! \n |
|---|
| 6076 | ! !_ ================================================================================================================================ |
|---|
| 6077 | ! SUBROUTINE type_conversion(ipts,f2c,glccReal,veget_mtc, & |
|---|
| 6078 | ! indold_tree,indagec_tree,indagec_crop,num_crop_mulagec, & |
|---|
| 6079 | ! iagec_tree_end,nagec_receive, & |
|---|
| 6080 | ! vegagec_tree,veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp, & |
|---|
| 6081 | ! glccRemain, & |
|---|
| 6082 | ! old_to_young, iagec_start) |
|---|
| 6083 | ! |
|---|
| 6084 | ! IMPLICIT NONE |
|---|
| 6085 | ! |
|---|
| 6086 | ! !! Input variables |
|---|
| 6087 | ! INTEGER, INTENT(in) :: ipts,f2c |
|---|
| 6088 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: glccReal !! The "real" glcc matrix that we apply in the model |
|---|
| 6089 | ! !! after considering the consistency between presribed |
|---|
| 6090 | ! !! glcc matrix and existing vegetation fractions. |
|---|
| 6091 | ! REAL(r_std), DIMENSION(:,:), INTENT(in) :: veget_mtc !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 6092 | ! INTEGER, DIMENSION(:), INTENT(in) :: indold_tree !! Indices for PFTs giving out fractions; |
|---|
| 6093 | ! !! here use old tree cohort as an example |
|---|
| 6094 | ! INTEGER, DIMENSION(:,:), INTENT(in) :: indagec_tree !! Indices for PFTs giving out fractions; |
|---|
| 6095 | ! !! here use old tree cohort as an example |
|---|
| 6096 | ! INTEGER, DIMENSION(:,:), INTENT(in) :: indagec_crop !! Indices for secondary basic-vegetation cohorts; The youngest age classes |
|---|
| 6097 | ! !! of these vegetations are going to receive fractions. |
|---|
| 6098 | ! !! here we use crop cohorts as an example |
|---|
| 6099 | ! INTEGER, INTENT(in) :: num_crop_mulagec !! number of crop MTCs with more than one age classes |
|---|
| 6100 | ! INTEGER, INTENT(in) :: iagec_tree_end !! End index of age classes in the giving basic types |
|---|
| 6101 | ! !! (i.e., tree, grass, pasture, crop) |
|---|
| 6102 | ! INTEGER, INTENT(in) :: nagec_receive !! number of age classes in the receiving basic types |
|---|
| 6103 | ! !! (i.e., tree, grass, pasture, crop), here we can use crop |
|---|
| 6104 | ! !! as an example, nagec=nagec_herb |
|---|
| 6105 | ! LOGICAL, INTENT(in) :: old_to_young !! an logical variable indicating whether we should handle donation |
|---|
| 6106 | ! !! vegetation in a sequence of old->young or young->old. TRUE is for |
|---|
| 6107 | ! !! old->young. |
|---|
| 6108 | ! INTEGER, OPTIONAL, INTENT(in) :: iagec_start !! starting index for iagec, this is added in order to handle |
|---|
| 6109 | ! !! the case of secondary forest harvest. |
|---|
| 6110 | ! |
|---|
| 6111 | ! !! 1. Modified variables |
|---|
| 6112 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: vegagec_tree !! fraction of tree age-class groups, in sequence of old->young |
|---|
| 6113 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: veget_max !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 6114 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: glcc_pft !! a temporary variable to hold the fractions each PFT is going to lose |
|---|
| 6115 | ! REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: glcc_pftmtc !! a temporary variable to hold the fraction of ipft->ivma, i.e., from |
|---|
| 6116 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: glcc_pft_tmp !! Loss of fraction in each PFT |
|---|
| 6117 | ! REAL(r_std), DIMENSION(:,:), INTENT(inout) :: glccRemain !! The remaining glcc matrix after applying the conversion. I.e., it will |
|---|
| 6118 | ! !! record the remaining unrealized transition fraction in case the donation |
|---|
| 6119 | ! !! vegetation is not enough compared with prescribed transition fraction. |
|---|
| 6120 | ! !! This variable should be initialized the same as glccReal before it's fed |
|---|
| 6121 | ! !! into this function. |
|---|
| 6122 | ! |
|---|
| 6123 | ! !! Local vriables |
|---|
| 6124 | ! INTEGER :: j,iagec,iagec_start_proxy |
|---|
| 6125 | ! REAL(r_std) :: frac_begin,frac_used |
|---|
| 6126 | ! !! PFT_{ipft} to the youngest age class of MTC_{ivma} |
|---|
| 6127 | ! IF (.NOT. PRESENT(iagec_start)) THEN |
|---|
| 6128 | ! iagec_start_proxy=1 |
|---|
| 6129 | ! ELSE |
|---|
| 6130 | ! iagec_start_proxy=iagec_start |
|---|
| 6131 | ! ENDIF |
|---|
| 6132 | ! |
|---|
| 6133 | ! ! This subroutine handles the conversion from one basic-vegetation type |
|---|
| 6134 | ! ! to another, by calling the subroutine cross_give_receive, which handles |
|---|
| 6135 | ! ! allocation of giving-receiving fraction among the giving age classes |
|---|
| 6136 | ! ! and receiving basic-vegetation young age classes. |
|---|
| 6137 | ! ! We allocate in the sequences of old->young. Within the same age-class |
|---|
| 6138 | ! ! group, we allocate in proportion with existing PFT fractions. The same |
|---|
| 6139 | ! ! also applies in the receiving youngest-age-class PFTs, i.e., the receiving |
|---|
| 6140 | ! ! total fraction is allocated according to existing fractions of |
|---|
| 6141 | ! ! MTCs of the same basic vegetation type, otherwise it will be equally |
|---|
| 6142 | ! ! distributed. |
|---|
| 6143 | ! |
|---|
| 6144 | ! frac_begin = glccReal(ipts,f2c) |
|---|
| 6145 | ! !DO WHILE (frac_begin>min_stomate) |
|---|
| 6146 | ! IF (old_to_young) THEN |
|---|
| 6147 | ! ! note that both indagec_tree and vegagec_tree are in sequence of old->young |
|---|
| 6148 | ! ! thus iagec_start_proxy must be smaller than iagec_tree_end |
|---|
| 6149 | ! DO iagec=iagec_start_proxy,iagec_tree_end,1 |
|---|
| 6150 | ! IF (vegagec_tree(ipts,iagec)>frac_begin) THEN |
|---|
| 6151 | ! frac_used = frac_begin |
|---|
| 6152 | ! ELSE IF (vegagec_tree(ipts,iagec)>min_stomate) THEN |
|---|
| 6153 | ! frac_used = vegagec_tree(ipts,iagec) |
|---|
| 6154 | ! ELSE |
|---|
| 6155 | ! frac_used = 0. |
|---|
| 6156 | ! ENDIF |
|---|
| 6157 | ! |
|---|
| 6158 | ! IF (frac_used>min_stomate) THEN |
|---|
| 6159 | ! IF (iagec==1) THEN |
|---|
| 6160 | ! ! Note that vegagec_tree is fractions of tree age-class groups in the |
|---|
| 6161 | ! ! the sequence of old->young, so iagec==1 means that we're handling |
|---|
| 6162 | ! ! first the oldest-age-group tree PFTs. |
|---|
| 6163 | ! CALL cross_give_receive(ipts,frac_used,veget_mtc, & |
|---|
| 6164 | ! indold_tree,indagec_crop,nagec_receive,num_crop_mulagec, & |
|---|
| 6165 | ! veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 6166 | ! ELSE |
|---|
| 6167 | ! ! Note also the sequence of indagec_tree is from old->young, so by |
|---|
| 6168 | ! ! increasing iagec, we're handling progressively the old to young |
|---|
| 6169 | ! ! tree age-class PFTs. |
|---|
| 6170 | ! CALL cross_give_receive(ipts,frac_used,veget_mtc, & |
|---|
| 6171 | ! indagec_tree(:,iagec-1),indagec_crop,nagec_receive,num_crop_mulagec, & |
|---|
| 6172 | ! veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 6173 | ! ENDIF |
|---|
| 6174 | ! frac_begin = frac_begin-frac_used |
|---|
| 6175 | ! vegagec_tree(ipts,iagec)=vegagec_tree(ipts,iagec)-frac_used |
|---|
| 6176 | ! glccRemain(ipts,f2c) = glccRemain(ipts,f2c) - frac_used |
|---|
| 6177 | ! ENDIF |
|---|
| 6178 | ! ENDDO |
|---|
| 6179 | ! ELSE ! in the sequence of young->old |
|---|
| 6180 | ! DO iagec=iagec_start_proxy,iagec_tree_end,-1 |
|---|
| 6181 | ! IF (vegagec_tree(ipts,iagec)>frac_begin) THEN |
|---|
| 6182 | ! frac_used = frac_begin |
|---|
| 6183 | ! ELSE IF (vegagec_tree(ipts,iagec)>min_stomate) THEN |
|---|
| 6184 | ! frac_used = vegagec_tree(ipts,iagec) |
|---|
| 6185 | ! ELSE |
|---|
| 6186 | ! frac_used = 0. |
|---|
| 6187 | ! ENDIF |
|---|
| 6188 | ! |
|---|
| 6189 | ! IF (frac_used>min_stomate) THEN |
|---|
| 6190 | ! IF (iagec==1) THEN |
|---|
| 6191 | ! ! Note that vegagec_tree is fractions of tree age-class groups in the |
|---|
| 6192 | ! ! the sequence of old->young, so iagec==1 means that we're handling |
|---|
| 6193 | ! ! first the oldest-age-group tree PFTs. |
|---|
| 6194 | ! CALL cross_give_receive(ipts,frac_used,veget_mtc, & |
|---|
| 6195 | ! indold_tree,indagec_crop,nagec_receive,num_crop_mulagec, & |
|---|
| 6196 | ! veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 6197 | ! ELSE |
|---|
| 6198 | ! ! Note also the sequence of indagec_tree is from old->young, so by |
|---|
| 6199 | ! ! increasing iagec, we're handling progressively the old to young |
|---|
| 6200 | ! ! tree age-class PFTs. |
|---|
| 6201 | ! CALL cross_give_receive(ipts,frac_used,veget_mtc, & |
|---|
| 6202 | ! indagec_tree(:,iagec-1),indagec_crop,nagec_receive,num_crop_mulagec, & |
|---|
| 6203 | ! veget_max,glcc_pft,glcc_pftmtc,glcc_pft_tmp) |
|---|
| 6204 | ! ENDIF |
|---|
| 6205 | ! frac_begin = frac_begin-frac_used |
|---|
| 6206 | ! vegagec_tree(ipts,iagec)=vegagec_tree(ipts,iagec)-frac_used |
|---|
| 6207 | ! glccRemain(ipts,f2c) = glccRemain(ipts,f2c) - frac_used |
|---|
| 6208 | ! ENDIF |
|---|
| 6209 | ! ENDDO |
|---|
| 6210 | ! ENDIF |
|---|
| 6211 | ! !ENDDO |
|---|
| 6212 | ! |
|---|
| 6213 | ! END SUBROUTINE type_conversion |
|---|
| 6214 | ! |
|---|
| 6215 | ! ! ================================================================================================================================ |
|---|
| 6216 | ! !! SUBROUTINE : calc_cover |
|---|
| 6217 | ! !! |
|---|
| 6218 | ! !>\BRIEF Calculate coverage fraction for different age classes of forest, |
|---|
| 6219 | ! !! grass, pasture and crops and also for each metaclass. Note baresoil is excluded. |
|---|
| 6220 | ! !! |
|---|
| 6221 | ! !! DESCRIPTION : |
|---|
| 6222 | ! !! Note: |
|---|
| 6223 | ! !! 1. "calc_cover" subroutine does not depend on how many age classes |
|---|
| 6224 | ! !! there are in each MTC. |
|---|
| 6225 | ! !! 2. Fraction of baresoil is excluded here. This means transformation |
|---|
| 6226 | ! !! of baresoil to a vegetated PFT is excluded in gross land cover change. |
|---|
| 6227 | ! !! |
|---|
| 6228 | ! !! |
|---|
| 6229 | ! !! MAIN OUTPUT VARIABLE(S) : |
|---|
| 6230 | ! !! |
|---|
| 6231 | ! !! \n |
|---|
| 6232 | ! !_ ================================================================================================================================ |
|---|
| 6233 | ! SUBROUTINE calc_cover(npts,veget_max,veget_mtc,vegagec_tree,vegagec_grass, & |
|---|
| 6234 | ! vegagec_pasture,vegagec_crop) |
|---|
| 6235 | ! |
|---|
| 6236 | ! |
|---|
| 6237 | ! IMPLICIT NONE |
|---|
| 6238 | ! |
|---|
| 6239 | ! !! Input variables |
|---|
| 6240 | ! INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 6241 | ! REAL(r_std), DIMENSION(npts,nvm), INTENT(in) :: veget_max !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 6242 | ! |
|---|
| 6243 | ! !! Output variables |
|---|
| 6244 | ! REAL(r_std), DIMENSION(npts,nvmap), INTENT(inout) :: veget_mtc !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 6245 | ! REAL(r_std), DIMENSION(npts,nagec_tree), INTENT(inout) :: vegagec_tree !! fraction of tree age-class groups, in sequence of old->young |
|---|
| 6246 | ! REAL(r_std), DIMENSION(npts,nagec_herb), INTENT(inout) :: vegagec_grass !! fraction of grass age-class groups, in sequence of old->young |
|---|
| 6247 | ! REAL(r_std), DIMENSION(npts,nagec_herb), INTENT(inout) :: vegagec_pasture !! fraction of pasture age-class groups, in sequence of old->young |
|---|
| 6248 | ! REAL(r_std), DIMENSION(npts,nagec_herb), INTENT(inout) :: vegagec_crop !! fraction of crop age-class groups, in sequence of old->young |
|---|
| 6249 | ! |
|---|
| 6250 | ! !! Local variables |
|---|
| 6251 | ! INTEGER(i_std) :: ivma,staind,endind,j !! indices (unitless) |
|---|
| 6252 | ! |
|---|
| 6253 | ! veget_mtc(:,:) = 0. |
|---|
| 6254 | ! vegagec_tree(:,:) = 0. |
|---|
| 6255 | ! vegagec_grass(:,:) = 0. |
|---|
| 6256 | ! vegagec_pasture(:,:) = 0. |
|---|
| 6257 | ! vegagec_crop(:,:) = 0. |
|---|
| 6258 | ! |
|---|
| 6259 | ! ! Calculate veget_max for MTCs |
|---|
| 6260 | ! DO ivma = 1,nvmap |
|---|
| 6261 | ! staind = start_index(ivma) |
|---|
| 6262 | ! IF (nagec_pft(ivma) == 1) THEN |
|---|
| 6263 | ! veget_mtc(:,ivma) = veget_max(:,staind) |
|---|
| 6264 | ! ELSE |
|---|
| 6265 | ! veget_mtc(:,ivma) = \ |
|---|
| 6266 | ! SUM(veget_max(:,staind:staind+nagec_pft(ivma)-1),DIM=2) |
|---|
| 6267 | ! ENDIF |
|---|
| 6268 | ! ENDDO |
|---|
| 6269 | ! |
|---|
| 6270 | ! ! Calculate veget_max for each age class |
|---|
| 6271 | ! DO ivma = 2,nvmap !here we start with 2 to exclude baresoil (always PFT1) |
|---|
| 6272 | ! staind = start_index(ivma) |
|---|
| 6273 | ! endind = staind+nagec_pft(ivma)-1 |
|---|
| 6274 | ! |
|---|
| 6275 | ! ! Single-age-class MTC goest to oldest age class. |
|---|
| 6276 | ! IF (nagec_pft(ivma) == 1) THEN |
|---|
| 6277 | ! IF (is_tree(staind)) THEN |
|---|
| 6278 | ! vegagec_tree(:,1) = vegagec_tree(:,1)+veget_max(:,staind) |
|---|
| 6279 | ! ELSE IF (is_grassland_manag(staind)) THEN |
|---|
| 6280 | ! vegagec_pasture(:,1) = vegagec_pasture(:,1)+veget_max(:,staind) |
|---|
| 6281 | ! ELSE IF (natural(staind)) THEN |
|---|
| 6282 | ! vegagec_grass(:,1) = vegagec_grass(:,1)+veget_max(:,staind) |
|---|
| 6283 | ! ELSE |
|---|
| 6284 | ! vegagec_crop(:,1) = vegagec_crop(:,1)+veget_max(:,staind) |
|---|
| 6285 | ! ENDIF |
|---|
| 6286 | ! |
|---|
| 6287 | ! ELSE |
|---|
| 6288 | ! IF (is_tree(staind)) THEN |
|---|
| 6289 | ! DO j=1,nagec_tree |
|---|
| 6290 | ! vegagec_tree(:,j) = vegagec_tree(:,j)+veget_max(:,endind-j+1) |
|---|
| 6291 | ! ENDDO |
|---|
| 6292 | ! ELSE IF (is_grassland_manag(staind)) THEN |
|---|
| 6293 | ! DO j=1,nagec_herb |
|---|
| 6294 | ! vegagec_pasture(:,j) = vegagec_pasture(:,j)+veget_max(:,endind-j+1) |
|---|
| 6295 | ! ENDDO |
|---|
| 6296 | ! ELSE IF (natural(staind)) THEN |
|---|
| 6297 | ! DO j=1,nagec_herb |
|---|
| 6298 | ! vegagec_grass(:,j) = vegagec_grass(:,j)+veget_max(:,endind-j+1) |
|---|
| 6299 | ! ENDDO |
|---|
| 6300 | ! ELSE |
|---|
| 6301 | ! DO j=1,nagec_herb |
|---|
| 6302 | ! vegagec_crop(:,j) = vegagec_crop(:,j)+veget_max(:,endind-j+1) |
|---|
| 6303 | ! ENDDO |
|---|
| 6304 | ! ENDIF |
|---|
| 6305 | ! ENDIF |
|---|
| 6306 | ! ENDDO |
|---|
| 6307 | ! |
|---|
| 6308 | ! END SUBROUTINE calc_cover |
|---|
| 6309 | ! |
|---|
| 6310 | ! ! Note this subroutine does not depend on how many age classes there are |
|---|
| 6311 | ! ! in different MTCs. |
|---|
| 6312 | ! SUBROUTINE glcc_compensation_full(npts,veget_4veg,glcc,glccReal,glccDef, & |
|---|
| 6313 | ! p2c,ipasture,g2c,igrass,f2c,itree,icrop, & |
|---|
| 6314 | ! IncreDeficit) |
|---|
| 6315 | ! |
|---|
| 6316 | ! IMPLICIT NONE |
|---|
| 6317 | ! |
|---|
| 6318 | ! !! 0.1 Input variables |
|---|
| 6319 | ! INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 6320 | ! INTEGER, INTENT(in) :: p2c,ipasture,g2c,igrass,f2c,itree,icrop |
|---|
| 6321 | ! REAL(r_std), DIMENSION (npts,12),INTENT(in) :: glcc !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 6322 | ! !! used. |
|---|
| 6323 | ! |
|---|
| 6324 | ! !! 0.2 Output variables |
|---|
| 6325 | ! |
|---|
| 6326 | ! |
|---|
| 6327 | ! !! 0.3 Modified variables |
|---|
| 6328 | ! REAL(r_std), DIMENSION(npts,4), INTENT(inout) :: veget_4veg !! "maximal" coverage of tree/grass/pasture/crop |
|---|
| 6329 | ! REAL(r_std), DIMENSION(npts,12), INTENT(inout) :: glccDef !! Gross LCC deficit, negative values mean that there |
|---|
| 6330 | ! !! are not enough fractions in the source vegetations |
|---|
| 6331 | ! !! to the target ones as presribed by the LCC matrix. |
|---|
| 6332 | ! REAL(r_std), DIMENSION(npts,12), INTENT(inout) :: glccReal !! The "real" glcc matrix that we apply in the model |
|---|
| 6333 | ! !! after considering the consistency between presribed |
|---|
| 6334 | ! !! glcc matrix and existing vegetation fractions. |
|---|
| 6335 | ! REAL(r_std), DIMENSION(npts,4), INTENT(inout) :: IncreDeficit !! "Increment" deficits, negative values mean that |
|---|
| 6336 | ! !! there are not enough fractions in the source PFTs |
|---|
| 6337 | ! !! /vegetations to target PFTs/vegetations. I.e., these |
|---|
| 6338 | ! !! fraction transfers are presribed in LCC matrix but |
|---|
| 6339 | ! !! not realized. |
|---|
| 6340 | ! |
|---|
| 6341 | ! !! 0.4 Local variables |
|---|
| 6342 | ! REAL(r_std), DIMENSION(npts) :: tmpdef !! LCC deficits by summing up all the deficits to the |
|---|
| 6343 | ! !! the same target vegetation. |
|---|
| 6344 | ! |
|---|
| 6345 | ! |
|---|
| 6346 | ! !! 0. We first handle the cases where veget_4veg might be very small |
|---|
| 6347 | ! !tree |
|---|
| 6348 | ! WHERE(veget_4veg(:,itree) > min_stomate) |
|---|
| 6349 | ! glccDef(:,f2c) = veget_4veg(:,itree)-glcc(:,f2c) |
|---|
| 6350 | ! WHERE(veget_4veg(:,itree)>glcc(:,f2c)) |
|---|
| 6351 | ! glccReal(:,f2c) = glcc(:,f2c) |
|---|
| 6352 | ! ELSEWHERE |
|---|
| 6353 | ! glccReal(:,f2c) = veget_4veg(:,itree) |
|---|
| 6354 | ! ENDWHERE |
|---|
| 6355 | ! ELSEWHERE |
|---|
| 6356 | ! glccReal(:,f2c) = 0. |
|---|
| 6357 | ! glccDef(:,f2c) = -1*glcc(:,f2c) |
|---|
| 6358 | ! ENDWHERE |
|---|
| 6359 | ! |
|---|
| 6360 | ! !pasture |
|---|
| 6361 | ! WHERE(veget_4veg(:,ipasture) > min_stomate) |
|---|
| 6362 | ! glccDef(:,p2c) = veget_4veg(:,ipasture)-glcc(:,p2c) |
|---|
| 6363 | ! WHERE(veget_4veg(:,ipasture)>glcc(:,p2c)) |
|---|
| 6364 | ! glccReal(:,p2c) = glcc(:,p2c) |
|---|
| 6365 | ! ELSEWHERE |
|---|
| 6366 | ! glccReal(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 6367 | ! ENDWHERE |
|---|
| 6368 | ! ELSEWHERE |
|---|
| 6369 | ! glccReal(:,p2c) = 0. |
|---|
| 6370 | ! glccDef(:,p2c) = -1*glcc(:,p2c) |
|---|
| 6371 | ! ENDWHERE |
|---|
| 6372 | ! |
|---|
| 6373 | ! !grass |
|---|
| 6374 | ! WHERE(veget_4veg(:,igrass) > min_stomate) |
|---|
| 6375 | ! glccDef(:,g2c) = veget_4veg(:,igrass)-glcc(:,g2c) |
|---|
| 6376 | ! WHERE(veget_4veg(:,igrass)>glcc(:,g2c)) |
|---|
| 6377 | ! glccReal(:,g2c) = glcc(:,g2c) |
|---|
| 6378 | ! ELSEWHERE |
|---|
| 6379 | ! glccReal(:,g2c) = veget_4veg(:,igrass) |
|---|
| 6380 | ! ENDWHERE |
|---|
| 6381 | ! ELSEWHERE |
|---|
| 6382 | ! glccReal(:,g2c) = 0. |
|---|
| 6383 | ! glccDef(:,g2c) = -1*glcc(:,g2c) |
|---|
| 6384 | ! ENDWHERE |
|---|
| 6385 | ! |
|---|
| 6386 | ! !! 1. Compensation sequence: pasture,grass,forest |
|---|
| 6387 | ! tmpdef(:) = glccDef(:,f2c)+glccDef(:,g2c)+glccDef(:,p2c) |
|---|
| 6388 | ! WHERE(glccDef(:,p2c)<0) |
|---|
| 6389 | ! WHERE(glccDef(:,g2c)<0) |
|---|
| 6390 | ! WHERE(glccDef(:,f2c)<0) ! 1 (-,-,-) |
|---|
| 6391 | ! IncreDeficit(:,icrop) = tmpdef(:) |
|---|
| 6392 | ! ELSEWHERE ! 2 (-,-,+) |
|---|
| 6393 | ! WHERE(tmpdef(:)>=min_stomate) |
|---|
| 6394 | ! glccReal(:,f2c) = glccReal(:,f2c)-glccDef(:,g2c)-glccDef(:,p2c) |
|---|
| 6395 | ! ELSEWHERE |
|---|
| 6396 | ! glccReal(:,f2c) = veget_4veg(:,itree) |
|---|
| 6397 | ! IncreDeficit(:,icrop) = tmpdef(:) |
|---|
| 6398 | ! ENDWHERE |
|---|
| 6399 | ! ENDWHERE |
|---|
| 6400 | ! ELSEWHERE |
|---|
| 6401 | ! WHERE(glccDef(:,f2c)<0) ! 3 (-,+,-) |
|---|
| 6402 | ! WHERE(tmpdef(:)>=min_stomate) |
|---|
| 6403 | ! glccReal(:,g2c) = glccReal(:,g2c)-glccDef(:,p2c)-glccDef(:,f2c) |
|---|
| 6404 | ! ELSEWHERE |
|---|
| 6405 | ! glccReal(:,g2c) = veget_4veg(:,igrass) |
|---|
| 6406 | ! IncreDeficit(:,icrop) = tmpdef(:) |
|---|
| 6407 | ! ENDWHERE |
|---|
| 6408 | ! ELSEWHERE ! 4 (-,+,+) |
|---|
| 6409 | ! WHERE(tmpdef(:)>=min_stomate) |
|---|
| 6410 | ! WHERE((glccDef(:,g2c)+glccDef(:,p2c))>=min_stomate) |
|---|
| 6411 | ! glccReal(:,g2c) = glccReal(:,g2c)-glccDef(:,p2c) |
|---|
| 6412 | ! ELSEWHERE |
|---|
| 6413 | ! glccReal(:,g2c) = veget_4veg(:,igrass) |
|---|
| 6414 | ! glccReal(:,f2c) = glccReal(:,f2c)-(glccDef(:,p2c)+glccDef(:,g2c)) |
|---|
| 6415 | ! ENDWHERE |
|---|
| 6416 | ! ELSEWHERE |
|---|
| 6417 | ! glccReal(:,g2c) = veget_4veg(:,igrass) |
|---|
| 6418 | ! glccReal(:,f2c) = veget_4veg(:,itree) |
|---|
| 6419 | ! IncreDeficit(:,icrop) = tmpdef(:) |
|---|
| 6420 | ! ENDWHERE |
|---|
| 6421 | ! ENDWHERE |
|---|
| 6422 | ! ENDWHERE |
|---|
| 6423 | ! ELSEWHERE |
|---|
| 6424 | ! WHERE(glccDef(:,g2c)<0) |
|---|
| 6425 | ! WHERE(glccDef(:,f2c)<0) ! 5 (+,-,-) |
|---|
| 6426 | ! WHERE(tmpdef(:)>=min_stomate) |
|---|
| 6427 | ! glccReal(:,p2c) = glccReal(:,p2c)-glccDef(:,g2c)-glccDef(:,f2c) |
|---|
| 6428 | ! ELSEWHERE |
|---|
| 6429 | ! IncreDeficit(:,icrop) = tmpdef(:) |
|---|
| 6430 | ! glccReal(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 6431 | ! ENDWHERE |
|---|
| 6432 | ! ELSEWHERE ! 6 (+,-,+) |
|---|
| 6433 | ! WHERE(tmpdef(:)>=min_stomate) |
|---|
| 6434 | ! WHERE((glccDef(:,p2c)+glccDef(:,g2c))>=min_stomate) |
|---|
| 6435 | ! glccReal(:,p2c) = glccReal(:,p2c)-glccDef(:,g2c) |
|---|
| 6436 | ! ELSEWHERE |
|---|
| 6437 | ! glccReal(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 6438 | ! glccReal(:,f2c) = glccReal(:,f2c)-(glccDef(:,g2c)+glccDef(:,p2c)) |
|---|
| 6439 | ! ENDWHERE |
|---|
| 6440 | ! ELSEWHERE |
|---|
| 6441 | ! IncreDeficit(:,icrop) = tmpdef(:) |
|---|
| 6442 | ! glccReal(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 6443 | ! glccReal(:,f2c) = veget_4veg(:,itree) |
|---|
| 6444 | ! ENDWHERE |
|---|
| 6445 | ! ENDWHERE |
|---|
| 6446 | ! ELSEWHERE |
|---|
| 6447 | ! WHERE(glccDef(:,f2c)<0) ! 7 (+,+,-) |
|---|
| 6448 | ! WHERE(tmpdef(:)>=min_stomate) |
|---|
| 6449 | ! WHERE((glccDef(:,p2c)+glccDef(:,f2c))>=min_stomate) |
|---|
| 6450 | ! glccReal(:,p2c) = glccReal(:,p2c)-glccDef(:,f2c) |
|---|
| 6451 | ! ELSEWHERE |
|---|
| 6452 | ! glccReal(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 6453 | ! glccReal(:,g2c) = glccReal(:,g2c)-(glccDef(:,f2c)+glccDef(:,p2c)) |
|---|
| 6454 | ! ENDWHERE |
|---|
| 6455 | ! ELSEWHERE |
|---|
| 6456 | ! IncreDeficit(:,icrop) = tmpdef(:) |
|---|
| 6457 | ! glccReal(:,g2c) = veget_4veg(:,igrass) |
|---|
| 6458 | ! glccReal(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 6459 | ! ENDWHERE |
|---|
| 6460 | ! ELSEWHERE ! 8 (+,+,+) |
|---|
| 6461 | ! !do nothing |
|---|
| 6462 | ! ENDWHERE |
|---|
| 6463 | ! ENDWHERE |
|---|
| 6464 | ! ENDWHERE |
|---|
| 6465 | ! veget_4veg(:,itree) = veget_4veg(:,itree) - glccReal(:,f2c) |
|---|
| 6466 | ! veget_4veg(:,igrass) = veget_4veg(:,igrass) - glccReal(:,g2c) |
|---|
| 6467 | ! veget_4veg(:,ipasture) = veget_4veg(:,ipasture) - glccReal(:,p2c) |
|---|
| 6468 | ! |
|---|
| 6469 | ! END SUBROUTINE glcc_compensation_full |
|---|
| 6470 | ! |
|---|
| 6471 | ! |
|---|
| 6472 | ! |
|---|
| 6473 | ! !! This subroutine implements non-full compensation, is currently |
|---|
| 6474 | ! !! abandoned. |
|---|
| 6475 | ! SUBROUTINE glcc_compensation(npts,veget_4veg,glcc,glccDef, & |
|---|
| 6476 | ! p2c,ipasture,g2c,igrass,f2c,itree,icrop, & |
|---|
| 6477 | ! IncreDeficit) |
|---|
| 6478 | ! |
|---|
| 6479 | ! IMPLICIT NONE |
|---|
| 6480 | ! |
|---|
| 6481 | ! !! 0.1 Input variables |
|---|
| 6482 | ! INTEGER, INTENT(in) :: npts !! Domain size - number of pixels (unitless) |
|---|
| 6483 | ! REAL(r_std), DIMENSION(npts,4), INTENT(in) :: veget_4veg !! "maximal" coverage fraction of a PFT on the ground |
|---|
| 6484 | ! INTEGER, INTENT(in) :: p2c,ipasture,g2c,igrass,f2c,itree,icrop |
|---|
| 6485 | ! |
|---|
| 6486 | ! !! 0.2 Output variables |
|---|
| 6487 | ! |
|---|
| 6488 | ! |
|---|
| 6489 | ! !! 0.3 Modified variables |
|---|
| 6490 | ! REAL(r_std), DIMENSION (npts,12),INTENT(inout) :: glcc !! the land-cover-change (LCC) matrix in case a gross LCC is |
|---|
| 6491 | ! !! used. |
|---|
| 6492 | ! REAL(r_std), DIMENSION(npts,12), INTENT(inout) :: glccDef !! Gross LCC deficit, negative values mean that there |
|---|
| 6493 | ! !! are not enough fractions in the source vegetations |
|---|
| 6494 | ! !! to the target ones as presribed by the LCC matrix. |
|---|
| 6495 | ! REAL(r_std), DIMENSION(npts,4), INTENT(inout) :: IncreDeficit !! "Increment" deficits, negative values mean that |
|---|
| 6496 | ! !! there are not enough fractions in the source PFTs |
|---|
| 6497 | ! !! /vegetations to target PFTs/vegetations. I.e., these |
|---|
| 6498 | ! !! fraction transfers are presribed in LCC matrix but |
|---|
| 6499 | ! !! not realized. |
|---|
| 6500 | ! |
|---|
| 6501 | ! !! 0.4 Local variables |
|---|
| 6502 | ! REAL(r_std), DIMENSION(npts) :: glccDef_all !! LCC deficits by summing up all the deficits to the |
|---|
| 6503 | ! !! the same target vegetation. |
|---|
| 6504 | ! |
|---|
| 6505 | ! |
|---|
| 6506 | ! WHERE(veget_4veg(:,itree) > min_stomate) |
|---|
| 6507 | ! glccDef(:,f2c) = veget_4veg(:,itree)-glcc(:,f2c) |
|---|
| 6508 | ! ELSEWHERE |
|---|
| 6509 | ! glccDef(:,f2c) = -1*glcc(:,f2c) |
|---|
| 6510 | ! glcc(:,f2c) = 0. |
|---|
| 6511 | ! ENDWHERE |
|---|
| 6512 | ! |
|---|
| 6513 | ! WHERE(veget_4veg(:,ipasture) > min_stomate) |
|---|
| 6514 | ! glccDef(:,p2c) = veget_4veg(:,ipasture)-glcc(:,p2c) |
|---|
| 6515 | ! ELSEWHERE |
|---|
| 6516 | ! glccDef(:,p2c) = -1*glcc(:,p2c) |
|---|
| 6517 | ! glcc(:,p2c) = 0. |
|---|
| 6518 | ! ENDWHERE |
|---|
| 6519 | ! |
|---|
| 6520 | ! WHERE(veget_4veg(:,igrass) > min_stomate) |
|---|
| 6521 | ! glccDef(:,g2c) = veget_4veg(:,igrass)-glcc(:,g2c) |
|---|
| 6522 | ! ELSEWHERE |
|---|
| 6523 | ! glccDef(:,g2c) = -1*glcc(:,g2c) |
|---|
| 6524 | ! glcc(:,g2c) = 0. |
|---|
| 6525 | ! ENDWHERE |
|---|
| 6526 | ! |
|---|
| 6527 | ! glccDef_all(:) = glccDef(:,f2c)+glccDef(:,p2c)+glccDef(:,g2c) |
|---|
| 6528 | ! |
|---|
| 6529 | ! ! We allow the surpluses/deficits in p2c and g2c mutually compensating |
|---|
| 6530 | ! ! for each other. If there are still deficits after this compensation, |
|---|
| 6531 | ! ! they will be further compensated for by the surpluses from f2c (if there are any |
|---|
| 6532 | ! ! surpluses). The ultimate deficits that cannot be compensated for |
|---|
| 6533 | ! ! will be recorded and dropped. |
|---|
| 6534 | ! |
|---|
| 6535 | ! ! Because we assume the "pasture rule" is used, i.e., the crops |
|---|
| 6536 | ! ! are supposed to come primarily from pastures and grasses, normally |
|---|
| 6537 | ! ! we expect the deficits to occur in p2c or g2c rather than in f2c. But |
|---|
| 6538 | ! ! if it happens that f2c has deficits while p2c or g2c has surpluse, |
|---|
| 6539 | ! ! the surpluses will not be used to compensate for the f2c-deficits, |
|---|
| 6540 | ! ! instead, we will just record and drop the f2c-deficits. |
|---|
| 6541 | ! |
|---|
| 6542 | ! ! In following codes for convenience we're not going to check |
|---|
| 6543 | ! ! whether surpluses in f2c are enough to compensate for deficits |
|---|
| 6544 | ! ! in p2c or g2c or both. Instead, we just add their deficits on top |
|---|
| 6545 | ! ! of f2c. The issues of not-enough surpluses in f2c will be left for |
|---|
| 6546 | ! ! the codes after this section to handle. |
|---|
| 6547 | ! WHERE (glccDef(:,p2c) < 0.) |
|---|
| 6548 | ! glcc(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 6549 | ! WHERE (glccDef(:,g2c) < 0.) |
|---|
| 6550 | ! glcc(:,g2c) = veget_4veg(:,igrass) |
|---|
| 6551 | ! ELSEWHERE |
|---|
| 6552 | ! WHERE (glccDef(:,g2c)+glccDef(:,p2c) > min_stomate) |
|---|
| 6553 | ! glcc(:,g2c) = glcc(:,g2c)-glccDef(:,p2c) |
|---|
| 6554 | ! ELSEWHERE |
|---|
| 6555 | ! glcc(:,g2c) = veget_4veg(:,igrass) |
|---|
| 6556 | ! ! whatever the case, we simply add the dificts to f2c |
|---|
| 6557 | ! glcc(:,f2c) = glcc(:,f2c)-glccDef(:,p2c)-glccDef(:,g2c) |
|---|
| 6558 | ! ENDWHERE |
|---|
| 6559 | ! ENDWHERE |
|---|
| 6560 | ! |
|---|
| 6561 | ! ELSEWHERE |
|---|
| 6562 | ! WHERE(glccDef(:,g2c) < 0.) |
|---|
| 6563 | ! glcc(:,g2c) = veget_4veg(:,igrass) |
|---|
| 6564 | ! WHERE(glccDef(:,p2c)+glccDef(:,g2c) > min_stomate) |
|---|
| 6565 | ! glcc(:,p2c) = glcc(:,p2c)-glccDef(:,g2c) |
|---|
| 6566 | ! ELSEWHERE |
|---|
| 6567 | ! glcc(:,p2c) = veget_4veg(:,ipasture) |
|---|
| 6568 | ! ! whatever the case, we simply add the dificts to f2c |
|---|
| 6569 | ! glcc(:,f2c) = glcc(:,f2c)-glccDef(:,p2c)-glccDef(:,g2c) |
|---|
| 6570 | ! ENDWHERE |
|---|
| 6571 | ! ELSEWHERE |
|---|
| 6572 | ! !Here p2c and g2c both show surplus, we're not going to check whether |
|---|
| 6573 | ! !glccDef(:,f2c) has negative values because we assume a "pasture rule" |
|---|
| 6574 | ! !is applied when constructing the gross LCC matrix, so deficits in |
|---|
| 6575 | ! !f2c will just be dropped but not be compensated for by the surpluses in |
|---|
| 6576 | ! !p2c or g2c. |
|---|
| 6577 | ! ENDWHERE |
|---|
| 6578 | ! ENDWHERE |
|---|
| 6579 | ! |
|---|
| 6580 | ! ! 1. We calculate again the f2c-deficit because f2c-glcc is adjusted in the |
|---|
| 6581 | ! ! codes above as we allocated the deficits of p2c and g2c into f2c. |
|---|
| 6582 | ! ! In cases where glccDef_all is less than zero, f2c-glcc will be larger |
|---|
| 6583 | ! ! than available forest veget_max and we therefore limit the f2c-glcc to |
|---|
| 6584 | ! ! available forest cover. |
|---|
| 6585 | ! ! 2. There is (probably) a second case where glccDef_all is larger then zero, |
|---|
| 6586 | ! ! but f2c-glcc is higher than veget_tree, i.e., Originally f2c is given a |
|---|
| 6587 | ! ! high value that there is deficit in f2c but surpluses exist for p2c and g2c. |
|---|
| 6588 | ! ! Normally we |
|---|
| 6589 | ! ! assume this won't happen as explained above, given that a "pasture rule" was |
|---|
| 6590 | ! ! used in constructing the gross LCC matrix. Nevertheless if this deos |
|---|
| 6591 | ! ! happen, we will just drop the f2c deficit without being compensated |
|---|
| 6592 | ! ! for by the surplus in p2c or g2c. |
|---|
| 6593 | ! |
|---|
| 6594 | ! ! we handle the 2nd case first |
|---|
| 6595 | ! WHERE(veget_4veg(:,itree) > min_stomate ) |
|---|
| 6596 | ! WHERE(glccDef(:,f2c) < 0.) |
|---|
| 6597 | ! glcc(:,f2c) = veget_4veg(:,itree) |
|---|
| 6598 | ! WHERE (glccDef(:,p2c)+glccDef(:,g2c) > min_stomate) |
|---|
| 6599 | ! IncreDeficit(:,icrop) = glccDef(:,f2c) |
|---|
| 6600 | ! ELSEWHERE |
|---|
| 6601 | ! IncreDeficit(:,icrop) = glccDef_all(:) |
|---|
| 6602 | ! ENDWHERE |
|---|
| 6603 | ! ELSEWHERE |
|---|
| 6604 | ! WHERE(glccDef_all(:) < 0.) !handle the 1st case |
|---|
| 6605 | ! glcc(:,f2c) = veget_4veg(:,itree) |
|---|
| 6606 | ! IncreDeficit(:,icrop) = glccDef_all(:) |
|---|
| 6607 | ! ENDWHERE |
|---|
| 6608 | ! ENDWHERE |
|---|
| 6609 | ! ELSEWHERE |
|---|
| 6610 | ! WHERE(glccDef(:,p2c)+glccDef(:,g2c)>min_stomate) |
|---|
| 6611 | ! IncreDeficit(:,icrop) = glccDef(:,f2c) |
|---|
| 6612 | ! ELSEWHERE |
|---|
| 6613 | ! IncreDeficit(:,icrop) = glccDef_all(:) |
|---|
| 6614 | ! ENDWHERE |
|---|
| 6615 | ! ENDWHERE |
|---|
| 6616 | ! |
|---|
| 6617 | ! END SUBROUTINE glcc_compensation |
|---|
| 6618 | ! |
|---|
| 6619 | ! |
|---|
| 6620 | ! |
|---|
| 6621 | ! END MODULE stomate_glcchange_fh |
|---|
