Context Navigation

source: tags/ORCHIDEE_4_1/ORCHIDEE/src_stomate/stomate_growth_fun_all.f90

Last change on this file was 7615, checked in by sebastiaan.luyssaert, 2 years ago
Enhanced consistency of variable names: input has been changed in n_input throughout the code and the variable name vegstress introduced in sechiba is now also used in stomate. Enhnaced computational consistency: Pgap_cumul is used in stomate rather than recalculating it before calculating light_tran_to_floor_season. Edited getin_p while checking the code (but no real changes were made) and added several missing stomate and sechiba variables to age_class_distr to improve the 1+1=2 issue when comparing a model run with against a run without age classes. Finally: Write warning 10b in allocation to the history file rather than the out_orchidee file
Property svn:executable set to ``*
File size: 401.4 KB

Line
1	!=================================================================================================================================
2	! MODULE : stomate_allocation
3	!
4	! CONTACT : orchidee-help _at_ listes.ipsl.fr
5	!
6	! LICENCE : IPSL (2006)
7	! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
8	!
9	!>\BRIEF Plant growth and C-allocation among the biomass components (leaves, wood, roots, fruit, reserves, labile)
10	!! is calculated making use of functional allocation which combines the pipe model and allometric relationships
11	!! proposed by Sitch et al 2003 and adjusted by Zaehle et al 2010.
12	!!
13	!!\n DESCRIPTION: This module calculates three processes: (1) daily maintenance respiration based on the half-hourly
14	!! respiration calculated in stomate_resp.f90, (2) the absolute allocation to the different biomass
15	!! components based on functional allocation approach and (3) the allocatable biomass as the residual
16	!! of GPP-Ra. Multiplication of the allocation fractions and allocatable biomass given the changes in
17	!! biomass pools.
18	!!
19	!! RECENT CHANGE(S): Until 1.9.6 only one allocation scheme was available (now contained in stomate_grwoth_res_lim.f90).
20	!! This module consists of an alternative formalization of plant growth.
21	!!
22	!! REFERENCE(S) : - Sitch, S., Smith, B., Prentice, I.C., Arneth, A., Bondeau, A., Cramer, W.,
23	!! Kaplan, J.O., Levis, S., Lucht, W., Sykes, M.T., Thonicke, K., Venevsky, S. (2003), Evaluation of
24	!! ecosystem dynamics, plant geography and terrestrial carbon cycling in the LPJ Dynamic Global Vegetation
25	!! Model, Global Change Biology, 9, 161-185.\n
26	!! - Zaehle, S. and Friend, A.D. (2010), Carbon and nitrogen cycle dynamics in the O-CN land surface model: 1.
27	!! Model description, site-scale evaluation, and sensitivity to parameter estimates, Global Biogeochemical
28	!! Cycles, 24, GB1005.\n
29	!! - Magnani F., Mencuccini M. & Grace J. 2000. Age-related decline in stand productivity: the role of
30	!! structural acclimation under hydraulic constraints Plant, Cell and Environment 23, 251â263.\n
31	!! - Bloom A.J., Chapin F.S. & Mooney H.A. (1985) Resource limitation in plants. An economic analogy.
32	!! Annual Review Ecology Systematics 16, 363â392.\n
33	!! - Case K.E. & Fair R.C. (1989) Principles of Economics. Prentice Hall, London.\n
34	!! - McDowell, N., Barnard, H., Bond, B.J., Hinckley, T., Hubbard, R.M., Ishii, H., KÃ¶stner, B.,
35	!! Magnani, F. Marshall, J.D., Meinzer, F.C., Phillips, N., Ryan, M.G., Whitehead D. 2002. The
36	!! relationship between tree height and leaf area: sapwood area ratio. Oecologia, 132:12â20.\n
37	!! - Novick, K., Oren, R., Stoy, P., Juang, F.-Y., Siqueira, M., Katul, G. 2009. The relationship between
38	!! reference canopy conductance and simplified hydraulic architecture. Advances in water resources 32,
39	!! 809-819.
40	!!
41	!! SVN :
42	!! $HeadURL$
43	!! $Date$
44	!! $Revision$
45	!! \n
46	!_ ===============================================================================================================================
47
48	MODULE stomate_growth_fun_all
49
50	! Modules used:
51	USE ioipsl_para
52	USE xios_orchidee
53	USE pft_parameters
54	USE stomate_data
55	USE constantes
56	USE constantes_soil
57	USE function_library, ONLY: wood_to_qmdia, wood_to_qmheight, &
58	wood_to_ba_eff, cc_to_lai, lai_to_biomass, &
59	biomass_to_lai, cc_to_biomass, biomass_to_cc, &
60	calculate_c0_alloc, wood_to_volume, wood_to_ba, &
61	check_vegetation_area, check_mass_balance, &
62	wood_to_height, intermediate_mass_balance_check
63
64	IMPLICIT NONE
65
66	! Private & public routines
67
68	PRIVATE
69	PUBLIC growth_fun_all_clear, growth_fun_all
70
71	! Variables shared by all subroutines in this module
72
73	LOGICAL, SAVE :: firstcall_growth_fun_all = .TRUE. !! Is this the first call? (true/false)
74	!$OMP THREADPRIVATE(firstcall_growth_fun_all)
75
76	!+++TEMP+++
77	INTEGER, SAVE :: istep = 0
78	!$OMP THREADPRIVATE(istep)
79	INTEGER(i_std), SAVE :: printlev_loc !! Local level of text output for current module
80	!$OMP THREADPRIVATE(printlev_loc)
81
82	CONTAINS
83
84
85	!! ================================================================================================================================
86	!! SUBROUTINE : growth_fun_all_clear
87	!!
88	!>\BRIEF Set the flag ::firstcall to .TRUE. and as such activate section
89	!! 1.1 of the subroutine alloc (see below).\n
90	!!
91	!_ ================================================================================================================================
92
93	SUBROUTINE growth_fun_all_clear
94	firstcall_growth_fun_all = .TRUE.
95	END SUBROUTINE growth_fun_all_clear
96
97
98
99	!! ================================================================================================================================
100	!! SUBROUTINE : growth_fun_all
101	!!
102	!>\BRIEF Allocate net primary production (= photosynthesis
103	!! minus autothrophic respiration) to: labile carbon pool carbon reserves, aboveground sapwood,
104	!! belowground sapwood, root, fruits and leaves following the pipe model and allometric constraints.
105	!!
106	!! DESCRIPTION : Total maintenance respiration for the whole plant is calculated by summing maintenance
107	!! respiration of the different plant compartments. Maintenance respiration is subtracted
108	!! from whole-plant allocatable biomass (up to a maximum fraction of the total allocatable biomass).
109	!! Growth respiration is then calculated as a prescribed (0.75) fraction of the allocatable
110	!! biomass. Subsequently NPP is calculated by substracting total autotrophic respiration from GPP
111	!! i.e. NPP = GPP - maintenance resp - growth resp.
112	!!
113	!! The pipe model assumes that one unit of leaf mass requires a proportional amount of sapwood to
114	!! transport water from the roots to the leaves. Also a proportional fraction of roots is needed to
115	!! take up the water from the soil. The proportional amounts between leaves, sapwood and roots are
116	!! given by allocation factors. These allocation factors are PFT specific and depend on a parameter
117	!! quantifying the leaf to sapwood area (::k_latosa_target), the specific leaf area (::sla), wood
118	!! density (::pipe_density) and a scaling parameter between leaf and root mass.
119	!!
120	!! Lai is optimised for mean annual radiation use efficiency and the C cost for producing the
121	!! canopy. The cost-benefit ratio is optimised when the marginal gain / marginal cost = 1 lai target
122	!! is used to calculate whether the reserves are used. This approach allows plants to get out of
123	!! senescence and to start developping a canopy in early spring.
124	!!
125	!! As soon as a canopy has emerged, C (b_inc_tot) becomes available at the stand level through
126	!! photosynthesis and, C is allocated at the tree level (b_inc) following both the pipe model and
127	!! allometric constraints. Mass conservation requires:
128	!! (1) Cs_inc + Cr_inc + Cl_inc = b_inc
129	!! (2) sum(b_inc) = b_inc_tot
130	!!
131	!! Wood allocation depends on tree basal area following the rule of Deleuze & Dhote
132	!! delta_ba = gammas(circ - msigmas + sqrt((msigmas + circ).^2 - (4sigmas*circ)))/2
133	!! (3) <=> delta_ba = circ_class_dba*gammas
134	!! Where circ_class_dba = (circ - msigmas + sqrt((msigmas + circ).^2 - (4sigmascirc)))/2
135	!!
136	!! Allometric relationships
137	!! height = pipe_tune2*(dia.^pipe_tune3)
138	!! Re-write this relationship as a function of ba
139	!! (4) height = pipe_tune2 * (4/pi*ba)^(pipe_tune3/2)
140	!! (5a) Cl/Cs = KF/height for trees
141	!! (5b) Cs = Cl / KF
142	!! (6) Cl = Cr * LF
143	!!
144	!! Use a linear approximation to avoid iterations. Given that allocation is calculated daily, a
145	!! local lineair assumption is fair. Eq (4) can thus be rewritten as:
146	!! s = step/(pipe_tune2(4/pi(ba+step)).^(pipe_tune3/2)-pipe_tune2(4/piba).^(pipe_tune3/2))
147	!! Where step is a small but realistic (for the time step) change in ba
148	!! (7) <=> delta_height = delta_ba/s
149	!!
150	!! Calculate Cs_inc from allometric relationships
151	!! Cs_inc = tree_ffpipe_density(ba+delta_ba)*(height+delta_height) - Cs - Ch
152	!! Cs_inc = tree_ffpipe_density(ba+delta_ba)*(height+delta_ba/s) - Cs - Ch
153	!! (8) <=> Cs_inc = tree_ffpipe_density(ba+agammas)(height+(a/s*gammas)) - Cs - Ch
154	!!
155	!! Rewrite (5) as
156	!! Cl_inc = KF*(Cs_inc+Cs)/(height+delta_height) - Cl
157	!! Substitute (7) in (4) and solve for Cl_inc
158	!! Cl_inc = KF(tree_ffpipe_density(ba+circ_class_dbagammas)(height+(circ_class_dba/sgammas)) - Ch)/ &
159	!! (height+(circ_class_dba/s*gammas)) - Cl
160	!! (9) <=> Cl_inc = KFtree_ffpipe_density(ba+circ_class_dbagammas) - &
161	!! (KFCh)/(height+(circ_class_dba/sgammas)) - Cl
162	!!
163	!! Rewrite (6) as
164	!! Cr_inc = (Cl_inc+Cl)/LF - Cr
165	!! Substitute (9) in (6)
166	!! (10) <=> Cr_inc = KF/LFtree_ffpipe_density(ba+circ_class_dbagammas) - &
167	!! (KFCh/LF)/(height+(circ_class_dba/sgammas)) - Cr
168	!!
169	!! Depending on the specific case that needs to be solved equations (1) takes one of the following forms:
170	!! (a) b_inc = Cl_inc + Cr_inc + Cs_inc, (b) b_inc = Cl_inc + Cr_inc, (c) b_inc = Cl_inc + Cs_inc or
171	!! (d) b_inc = Cr_inc + Cs_inc. One of these alternative forms of eq. 1 are then combined with
172	!! eqs 8, 9 and 10 and solved for gammas. The details for the solution of these four cases are given in the
173	!! code. Once gammas is know, eqs 6 - 10 are used to calculate the allocation to leaves (Cl_inc),
174	!! roots (Cr_inc) and sapwood (Cs_inc).
175	!!
176	!! Because of turnover, biomass pools are not all the time in balance according to rules prescribed
177	!! by the pipe model. To test whether biomass pools are balanced, the target biomasses are calculated
178	!! and balance is restored whenever needed up to the level that the biomass pools for leaves, sapwood
179	!! and roots are balanced according to the pipe model. Once the balance is restored C is allocated to
180	!! fruits, leaves, sapwood and roots by making use of the pipe model (below this called ordinary
181	!! allocation).
182	!!
183	!! Although strictly speaking allocation factors are not necessary in this scheme (Cl_inc could simply
184	!! be added to biomass(:,:,ileaf,icarbon), Cr_inc to biomass(:,:,iroot,icarbon), etc.), they are
185	!! nevertheless calculated because using allocation factors facilitates comparison to the resource
186	!! limited allocation scheme (stomate_growth_res_lim.f90) and it comes in handy for model-data comparison.
187	!!
188	!! Effective basal area, height and circumferences are use in the allocation scheme because their
189	!! calculations make use of the total (above and belowground) biomass. In forestry the same measures
190	!! exist (and they are also calculated in ORCHIDEE) but only account for the aboverground biomass.
191	!!
192	!!
193	!! RECENT CHANGE(S): - The code by Sonke Zaehle made use of ::Cl_target that was derived from ::lai_target which in turn
194	!! was a function of ::rue_longterm. Cl_target was then used as a threshold value to decide whether there
195	!! was only phenological growth (just leaves and roots) or whether there was full allometric growth to the
196	!! leaves, roots and sapwood. This approach was inconsistent with the pipe model because full allometric
197	!! growth can only occur if all three biomass pools are in balance. ::lai_target is no longer used as a
198	!! criterion to switch between phenological and full allometric growth. Its use is now restricted to trigger
199	!! the use of reserves in spring.
200	!!
201	!! Early 2019: Nitrogen limitations to growth were added, primarily based on the ratio of carbon
202	!! to nitrogen in the leaf.
203	!!
204	!! MAIN OUTPUT VARIABLE(S): ::npp and :: biomass. Seven different biomass compartments (leaves, roots, above and
205	!! belowground wood, carbohydrate reserves, labile and fruits).
206	!!
207	!! REFERENCE(S) :- Sitch, S., Smith, B., Prentice, I.C., Arneth, A., Bondeau, A., Cramer, W.,
208	!! Kaplan, J.O., Levis, S., Lucht, W., Sykes, M.T., Thonicke, K., Venevsky, S. (2003), Evaluation of
209	!! ecosystem dynamics, plant geography and terrestrial carbon cycling in the LPJ Dynamic Global Vegetation
210	!! Model, Global Change Biology, 9, 161-185.\n
211	!! - Zaehle, S. and Friend, A.D. (2010), Carbon and nitrogen cycle dynamics in the O-CN land surface model: 1.
212	!! Model description, site-scale evaluation, and sensitivity to parameter estimates, Global Biogeochemical
213	!! Cycles, 24, GB1005.\n
214	!! - Magnani F., Mencuccini M. & Grace J. 2000. Age-related decline in stand productivity: the role of
215	!! structural acclimation under hydraulic constraints Plant, Cell and Environment 23, 251â263.
216	!! - Bloom A.J., Chapin F.S. & Mooney H.A. (1985) Resource limitation in plants. An economic analogy. Annual
217	!! Review Ecology Systematics 16, 363â392.
218	!! - Case K.E. & Fair R.C. (1989) Principles of Economics. Prentice Hall, London.
219	!! - McDowell, N., Barnard, H., Bond, B.J., Hinckley, T., Hubbard, R.M., Ishii, H., KÃ¶stner, B.,
220	!! Magnani, F. Marshall, J.D., Meinzer, F.C., Phillips, N., Ryan, M.G., Whitehead D. 2002. The
221	!! relationship between tree height and leaf area: sapwood area ratio. Oecologia, 132:12â20
222	!! - Novick, K., Oren, R., Stoy, P., Juang, F.-Y., Siqueira, M., Katul, G. 2009. The relationship between
223	!! reference canopy conductance and simplified hydraulic architecture. Advances in water resources 32,
224	!! 809-819.
225	!! - Jefferey Amthor. 2000. The McCree-de Wit-Penning de Vries-Thornley Respiration Paradigms: 30 Years Later.
226	!! Annals of Botany 86: 1-20, doi:10.1006/anbo.2000.1175
227	!! - JEFFREY Q. CHAMBERS, EDGARD S. TRIBUZY, LIGIA C. TOLEDO, BIANCA F. CRISPIM, NIRO HIGUCHI, JOAQUIM DOS SANTOS,
228	!! ALESSANDRO C. ARAUÂŽ JO, BART KRUIJT, ANTONIO D. NOBRE, AND SUSAN E. TRUMBORE. 2004. RESPIRATION FROM A TROPICAL
229	!! FOREST ECOSYSTEM: PARTITIONING OF SOURCES AND LOW CARBON USE EFFICIENCY. Ecological Applications, 14(4)
230	!! Supplement, 2004, pp. S72S88
231	!! - Teemu HÃ¶lttÃ€, Anna Lintunen, Tommy Chan, Annikki MÃ€kelÃ€ and Eero Nikinmaa. 2017. A steady-state stomatal
232	!! model of balanced leaf gas exchange, hydraulics and maximal sourcesink flux. Tree Physiology 37, 851-868.
233	!! doi:10.1093/treephys/tpx011
234	!!
235	!! FLOWCHART :
236	!!
237	!_ ================================================================================================================================
238
239	SUBROUTINE growth_fun_all (npts, dt, veget_max, veget, &
240	PFTpresent, plant_status ,when_growthinit, t2m, &
241	nstress_season, vegstress_season, &
242	gpp_daily, gpp_week, resp_maint_part, resp_maint, &
243	resp_growth, npp, bm_alloc, age, &
244	leaf_age, leaf_frac, use_reserve, &
245	lab_fac, rue_longterm, circ_class_n, &
246	circ_class_biomass, KF, sigma, &
247	gammas, longevity_eff_leaf, longevity_eff_sap, &
248	longevity_eff_root, k_latosa_adapt, forest_managed, &
249	circ_class_dist, cn_leaf_min_season, atm_to_bm, &
250	cn_leaf_min_2D, cn_leaf_max_2D, sugar_load, &
251	n_reserve_balance, n_reserve_longterm)
252
253	!! 0. Variable and parameter declaration
254
255	!! 0.1 Input variables
256
257	INTEGER(i_std), INTENT(in) :: npts !! Domain size - number of grid cells
258	!! (unitless)
259	REAL(r_std), INTENT(in) :: dt !! Time step of the simulations for stomate
260	!! (days)
261	REAL(r_std), DIMENSION(:), INTENT(in) :: t2m !! Temperature at 2 meter (K)
262	REAL(r_std), DIMENSION(:,:), INTENT(in) :: veget_max !! PFT "Maximal" coverage fraction of a PFT
263	!! (= ind*cn_ind)
264	!! @tex $(m^2 m^{-2})$ @endtex
265	REAL(r_std), DIMENSION(:,:), INTENT(in) :: veget !! Fraction of forest floor covered by vegetation (unitless, 0-1)
266	REAL(r_std), DIMENSION(:,:), INTENT(in) :: when_growthinit !! Days since beginning of growing season
267	!! (days)
268	REAL(r_std), DIMENSION(:,:), INTENT(in) :: rue_longterm !! Longterm "radiation use efficicency"
269	!! calculated as the ratio of GPP over
270	!! the fraction of radiation absorbed
271	!! by the canopy
272	!! @tex $(gC.m^{-2}day^{-1})$ @endtex
273	REAL(r_std), DIMENSION(:,:), INTENT(in) :: longevity_eff_root !! Effective root turnover time that accounts
274	!! waterstress (days)
275	REAL(r_std), DIMENSION(:,:), INTENT(in) :: longevity_eff_sap !! Effective sapwood turnover time that accounts
276	!! waterstress (days)
277	REAL(r_std), DIMENSION(:,:), INTENT(in) :: longevity_eff_leaf !! Effective leaf turnover time that accounts
278	!! waterstress (days)
279	REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: circ_class_n !! Number of individuals in each circ class
280	!! @tex $(m^{-2})$ @endtex
281	REAL(r_std), DIMENSION(:), INTENT(in) :: circ_class_dist !! The probability distribution of trees
282	!! in a circ class in case of a
283	!! redistribution (unitless).
284	REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: resp_maint_part !! Maintenance respiration of different
285	!! plant parts
286	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
287	REAL(r_std), DIMENSION(:,:), INTENT(in) :: plant_status !! Growth and phenological status of the plant
288
289	LOGICAL, DIMENSION(:,:), INTENT(in) :: PFTpresent !! PFT exists (true/false)
290	REAL(r_std), DIMENSION(:,:), INTENT(in) :: nstress_season !! N-related seasonal stress (used for allocation)
291	REAL(r_std), DIMENSION(:,:), INTENT(in) :: vegstress_season !! mean growing season moisture availability
292	INTEGER(i_std), DIMENSION(:,:), INTENT(in) :: forest_managed !! Forest management flag: 0 = orchidee
293	!! standard, 1= self-thinning only, 2=
294	!! high-stand, 3= high-stand smoothed, 4=
295	!! coppices
296	REAL(r_std), DIMENSION(:,:), INTENT(in) :: gpp_week !! PFT gross primary productivity
297	REAL(r_std),DIMENSION(npts,nvm), INTENT(in) :: cn_leaf_min_2D !! minimal leaf C/N ratio
298	REAL(r_std),DIMENSION(npts,nvm), INTENT(in) :: cn_leaf_max_2D !! maximal leaf C/N ratio
299	REAL(r_std), DIMENSION(:,:), INTENT(in) :: cn_leaf_min_season !! Min leaf nitrogen concentration (C:N) of the growing season
300	!! (gC/gN)
301	REAL(r_std), DIMENSION(:,:), INTENT(in) :: n_reserve_longterm !! "longer term" actual to potential N reserve pool
302	!! (0-1, unitless)
303
304	!! 0.2 Output variables
305
306	REAL(r_std), DIMENSION(:,:), INTENT(out) :: resp_maint !! PFT maintenance respiration
307	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
308	REAL(r_std), DIMENSION(:,:), INTENT(out) :: resp_growth !! PFT growth respiration
309	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
310	REAL(r_std), DIMENSION(:,:), INTENT(out) :: npp !! PFT net primary productivity
311	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
312	REAL(r_std), DIMENSION(:,:,:,:), INTENT(out) :: bm_alloc !! PFT biomass increase, i.e. NPP per plant
313	!! part @tex $(gC.m^{-2}dt^{-1})$ @endtex
314	REAL(r_std), DIMENSION(:,:), INTENT(out) :: lab_fac !! Activity of labile pool factor (units??)
315	REAL(r_std), DIMENSION(:,:), INTENT(out) :: sigma !! Threshold for indivudal tree growth in
316	!! the equation of Deleuze & Dhote (2004)(m).
317	!! Trees whose circumference is smaller than
318	!! sigma don't grow much
319	REAL(r_std), DIMENSION(:,:), INTENT(out) :: gammas !! Slope for individual tree growth in the
320	!! equation of Deleuze & Dhote (2004) (m)
321
322	REAL(r_std), DIMENSION(:,:), INTENT(out) :: sugar_load !! Relative sugar loading of the labile pool (unitless)
323	REAL(r_std), DIMENSION(:,:), INTENT(out) :: n_reserve_balance !! Actual to potential N reserve pool (unitless)
324
325	!! 0.3 Modified variables
326
327	REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_daily !! PFT gross primary productivity
328	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
329	REAL(r_std), DIMENSION(:,:), INTENT(inout) :: use_reserve !! Flag to use the reserves to support
330	!! phenological growth (0 or 1)
331	REAL(r_std), DIMENSION(:,:), INTENT(inout) :: age !! PFT age (days)
332	REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_age !! PFT age of different leaf classes
333	!! (days)
334	REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_frac !! PFT fraction of leaves in leaf age class
335	!! (0-1, unitless)
336	REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: circ_class_biomass !! Biomass components of the model tree
337	!! within a circumference class
338	!! class @tex $(g C ind^{-1})$ @endtex
339	REAL(r_std), DIMENSION(:,:), INTENT(inout) :: KF !! Scaling factor to convert sapwood mass
340	!! into leaf mass (m)
341	REAL(r_std), DIMENSION(:,:), INTENT(inout) :: k_latosa_adapt !! Leaf to sapwood area adapted for long
342	!! term water stress (m)
343	REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: atm_to_bm !! Nitrogen and carbon which is added to the ecosystem to
344	!! support vegetation growth (gC or gN/m2/day)
345
346	!! 0.4 Local variables
347
348	CHARACTER(30) :: var_name !! To store variable names for I/O
349	REAL(r_std), DIMENSION(npts,nvm) :: c0_alloc !! Root to sapwood tradeoff parameter
350	LOGICAL :: grow_wood=.TRUE. !! Flag to grow wood
351	INTEGER(i_std) :: ipts,j,k,l,m !! Indices(unitless)
352	INTEGER(i_std) :: icir,imed,ipool !! Indices(unitless)
353	INTEGER(i_std) :: ifm,icut !! Indices
354	INTEGER(i_std) :: ipar,iele,imbc !! Indices(unitless)
355	INTEGER(i_std) :: ilev !! Indices(unitless)
356	REAL(r_std) :: frac !! No idea??
357	REAL(r_std) :: a,b,c !! Temporary variables to solve a
358	!! quadratic equation (unitless)
359	! Stand level
360	REAL(r_std),DIMENSION(npts,nvm) :: gtemp !! Turnover coefficient of labile C pool
361	!! (0-1)
362	REAL(r_std),DIMENSION(npts,nvm,nelements) :: reserve_target !! Intentional size of the reserve pool
363	!! @tex $(gC/N.m^{-2})$ @endtex
364	REAL(r_std),DIMENSION(npts,nvm,nelements) :: labile_target !! Intentional size of the labile pool
365	!! @tex $(gC/N.m^{-2})$ @endtex
366	REAL(r_std) :: reserve_scal !! Protection of the reserve against
367	!! overuse (unitless)
368	REAL(r_std) :: use_lab !! Availability of labile biomass
369	!! @tex $(gC.m^{-2})$ @endtex
370	REAL(r_std) :: use_res !! Availability of resource biomass
371	!! @tex $(gC.m^{-2})$ @endtex
372	REAL(r_std) :: use_max !! Maximum use of labile and resource pool
373	!! @tex $(gC.m^{-2})$ @endtex
374	REAL(r_std) :: leaf_meanage !! Mean age of the leaves (days?)
375	REAL(r_std) :: reserve_time !! Maximum number of days during which
376	!! carbohydrate reserve may be used (days)
377	REAL(r_std) :: b_inc_tot !! Carbon that needs to allocated in the
378	!! fixed number of trees (gC)
379	REAL(r_std) :: b_inc_temp !! Temporary b_inc at the stand-level
380	!! @tex $(gC.plant^{-1})$ @endtex
381	REAL(r_std), DIMENSION(npts,nvm) :: scal !! Scaling factor between average
382	!! individual and individual plant
383	!! @tex $(plant.m^{-2})$ @endtex
384	REAL(r_std) :: total_inc !! Total biomass increase
385	!! @tex $(gC.plant^{-1})$ @endtex
386	REAL(r_std) :: KF_old !! Scaling factor to convert sapwood mass
387	!! into leaf mass (m) at the previous
388	!! time step
389	REAL(r_std) :: sla_est !! A first estimate of sla in case its calculation is
390	!! dynamic @tex $(m^2.gC^{-1})$ @endtex
391	REAL(r_std), DIMENSION(nvm) :: lai_happy !! Lai threshold below which carbohydrate
392	!! reserve may be used
393	!! @tex $(m^2 m^{-2})$ @endtex
394	REAL(r_std), DIMENSION(nvm) :: deleuze_p !! Percentile of trees that will receive
395	!! photosynthates. The proxy for intra stand
396	!! competition. Depends on the management
397	!! strategy when ncirc < 6
398	REAL(r_std), DIMENSION(npts) :: tl !! Long term annual mean temperature (C)
399	REAL(r_std), DIMENSION(npts) :: bm_add !! Biomass increase
400	!! @tex $(gC.m^{-2})$ @endtex
401	REAL(r_std), DIMENSION(npts) :: bm_new !! New biomass @tex $(gC.m^{-2})$ @endtex
402	REAL(r_std) :: alloc_sap_above !! Fraction allocated to sapwood above
403	!! ground
404	REAL(r_std), DIMENSION(npts,nvm) :: residual !! Copy of b_inc_tot after all C has been
405	!! allocated @tex $(gC.m^{-2})$ @endtex
406	!! if all went well the value should be zero
407	REAL(r_std), DIMENSION(npts,nvm) :: residual_write !! Copy of b_inc_tot after all C has been
408	!! allocated @tex $(gC.m^{-2})$ @endtex
409	!! if all went well the value should be zero. This
410	!! value is written to the history file to better
411	!! monitor the residuals
412	REAL(r_std), DIMENSION(npts,nvm) :: lai_target !! Target LAI @tex $(m^{2}m^{-2})$ @endtex
413	REAL(r_std), DIMENSION(npts,nvm) :: ltor !! Leaf to root ratio (unitless)
414	REAL(r_std), DIMENSION(npts,nvm) :: lstress_fac !! Light stress factor, based on total
415	!! transmitted light (unitless, 0-1)
416	REAL(r_std), DIMENSION(npts,nvm) :: LF !! Scaling factor to convert sapwood mass
417	!! into root mass (unitless)
418	REAL(r_std), DIMENSION(npts,nvm) :: lm_old !! Variable to store leaf biomass from
419	!! previous time step
420	!! @tex $(gC m^{-2})$ @endtex
421	REAL(r_std), DIMENSION(npts,nvm) :: bm_alloc_tot !! Allocatable biomass for the whole plant
422	!! @tex $(gC.m^{-2})$ @endtex
423	REAL(r_std), DIMENSION(npts,nvm) :: temp_bm_alloc_tot !! Allocatable biomass for the whole plant
424	!! @tex $(gC.m^{-2})$ @endtex
425	REAL(r_std), DIMENSION(npts,nvm) :: resid_bm_alloc_tot !! Allocatable biomass for the whole plant
426	!! @tex $(gC.m^{-2})$ @endtex
427	REAL(r_std), DIMENSION(npts,nvm) :: leaf_mass_young !! Leaf biomass in youngest leaf age class
428	!! @tex $(gC m^{-2})$ @endtex
429	REAL(r_std), DIMENSION(npts,nvm) :: lai !! PFT leaf area index
430	!! @tex $(m^2 m^{-2})$ @endtex
431	REAL(r_std), DIMENSION(npts,nvm) :: qm_dia !! Quadratic mean diameter of the stand (m)
432	REAL(r_std), DIMENSION(npts,nvm) :: qm_height !! Height of a tree with the quadratic mean
433	!! diameter (m)
434	REAL(r_std), DIMENSION(npts,nvm) :: ba !! Basal area. variable for histwrite only (m2)
435	REAL(r_std), DIMENSION(npts,nvm) :: wood_volume !! wood_volume (m3 m-2)
436	REAL(r_std), DIMENSION(npts,nvm,nparts) :: f_alloc !! PFT fraction of NPP that is allocated to
437	!! the different components (0-1, unitless)
438	REAL(r_std), DIMENSION(npts,ncirc,nparts) :: f_alloc_circ !! Fraction of that is allocated to each circc_class
439	!! the different components (0-1, unitless)
440	REAL(r_std), DIMENSION(npts,nvm,nparts,nelements) :: tmp_bm !! temporary variable to indicate biomass for each PFT
441	!! over per unit PFT area.
442	!! @tex $(gC m^{-2})$ @endtex
443	REAL(r_std), DIMENSION(npts,nvm,nparts,nelements) :: tmp_init_bm !! temporary variable to use site-level biomass
444	!! @tex $(gC m^{-2})$ @endtex
445
446	! Tree level
447	REAL(r_std), DIMENSION(ncirc) :: step !! Temporary variables to solve a
448	!! quadratic equation (unitless)
449	REAL(r_std), DIMENSION(ncirc) :: s !! tree-level linear relationship between
450	!! basal area and height. This variable is
451	!! used to linearize the allocation scheme
452	REAL(r_std), DIMENSION(ncirc) :: Cs_inc_est !! Initial value estimate for Cs_inc. The
453	!! value is used to linearize the ba~height
454	!! relationship
455	!! @tex $(gC.plant^{-1})$ @endtex
456	REAL(r_std), DIMENSION(ncirc) :: Cl !! Individual plant, leaf compartment
457	!! @tex $(gC.plant^{-1})$ @endtex
458	REAL(r_std), DIMENSION(ncirc) :: Cr !! Individual plant, root compartment
459	!! @tex $(gC.plant^{-1})$ @endtex
460	REAL(r_std), DIMENSION(ncirc) :: Cs !! Individual plant, sapwood compartment
461	!! @tex $(gC.plant^{-1})$ @endtex
462	REAL(r_std), DIMENSION(ncirc) :: Ch !! Individual plant, heartwood compartment
463	!! @tex $(gC.plant^{-1})$ @endtex
464	REAL(r_std), DIMENSION(ncirc) :: Cl_inc !! Individual plant increase in leaf
465	!! compartment
466	!! @tex $(gC.plant^{-1})$ @endtex
467	REAL(r_std), DIMENSION(ncirc) :: Cr_inc !! Individual plant increase in root
468	!! compartment
469	!! @tex $(gC.plant^{-1})$ @endtex
470	REAL(r_std), DIMENSION(ncirc) :: Cs_inc !! Individual plant increase in sapwood
471	!! compartment
472	!! @tex $(gC.plant^{-1})$ @endtex
473	REAL(r_std), DIMENSION(ncirc) :: Cf_inc !! Individual plant increase in fruit
474	!! compartment
475	!! @tex $(gC.plant^{-1})$ @endtex
476	REAL(r_std), DIMENSION(ncirc) :: Cl_incp !! Phenology related individual plant
477	!! increase in leaf compartment
478	!! @tex $(gC.plant^{-1})$ @endtex
479	REAL(r_std), DIMENSION(ncirc) :: Cr_incp !! Phenology related individual plant
480	!! increase in leaf compartment
481	!! @tex $(gC.plant^{-1})$ @endtex
482	REAL(r_std), DIMENSION(ncirc) :: Cs_incp !! Phenology related individual plant
483	!! increase in sapwood compartment
484	!! @tex $(gC.plant^{-1})$ @endtex
485	REAL(r_std), DIMENSION(ncirc) :: Cl_target !! Individual plant maximum leaf mass given
486	!! its current sapwood mass
487	!! @tex $(gC.plant^{-1})$ @endtex
488	REAL(r_std), DIMENSION(ncirc) :: Cr_target !! Individual plant maximum root mass given
489	!! its current sapwood mass
490	!! @tex $(gC.plant^{-1})$ @endtex
491	REAL(r_std), DIMENSION(ncirc) :: Cs_target !! Individual plant maximum sapwood mass
492	!! given its current leaf mass or root mass
493	!! @tex $(gC.plant^{-1})$ @endtex
494	REAL(r_std), DIMENSION(ncirc) :: delta_ba !! Change in basal area for a unit
495	!! investment into sapwood mass (m)
496	REAL(r_std), DIMENSION(ncirc) :: delta_height !! Change in height for a unit
497	!! investment into sapwood mass (m)
498	REAL(r_std), DIMENSION(ncirc) :: circ_class_ba !! Basal area (forestry definition) of the model
499	!! tree in each circ class
500	!! @tex $(m^{2} m^{-2})$ @endtex
501	REAL(r_std), DIMENSION(ncirc) :: circ_class_ba_eff !! Effective basal area of the model tree in each
502	!! circ class @tex $(m^{2} m^{-2})$ @endtex
503	REAL(r_std), DIMENSION(ncirc) :: circ_class_dba !! Share of an individual tree in delta_ba
504	!! thus, circ_class_dba*gammas = delta_ba
505	REAL(r_std), DIMENSION(ncirc) :: circ_class_height_eff !! Effective tree height calculated from allometric
506	!! relationships (m)
507	REAL(r_std), DIMENSION(ncirc) :: circ_class_circ_eff !! Effective circumference of individual trees (m)
508	REAL(r_std) :: woody_biomass !! Woody biomass. Temporary variable to
509	!! calculate wood volume (gC m-2)
510	REAL(r_std), DIMENSION(ncirc) :: share_ncirc !! Temporary variable to store the share
511	!! of biomass of each circumference class
512	!! to the total biomass
513	REAL(r_std) :: temp_share !! Temporary variable to store the share
514	!! of biomass of each circumference class
515	!! to the total biomass
516	REAL(r_std) :: temp_class_biomass !! Biomass across parts for a single circ
517	!! class @tex $(gC m^{-2})$ @endtex
518	REAL(r_std) :: temp_total_biomass !! Biomass across parts and circ classes
519	!! @tex $(gC m^{-2})$ @endtex
520	REAL(r_std), DIMENSION(npts,nvm,ncirc) :: store_delta_ba_eff !! Store effective delta_ba in this variable before writing
521	!! to the output file (m). Adding this variable
522	!! was faster than changing the dimensions
523	!! of delta_ba which would have been the same
524	REAL(r_std), DIMENSION(npts,nvm,ncirc) :: store_delta_ba
525	REAL(r_std), DIMENSION(npts,nvm,ncirc) :: store_circ_class_ba !! Store circ_class_ba in this variable before
526	!! writing to the output file (m). Adding this
527	!! variable was faster than changing the
528	!! dimensions of circ_class_ba_ba which would
529	!! have been the same
530	REAL(r_std), DIMENSION(npts,nvm,ncirc) :: circ_class_ba_init !! Basal area per diameter class before growth
531	REAL(r_std), DIMENSION(npts,nvm,ncirc) :: ring_width !! Increase of radius of trunk. Calculated using
532	!! store_delta_ba which is always positive
533	REAL(r_std), DIMENSION(npts,nvm,ncirc) :: circ_height !! Height of trees per diameter class
534	REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements):: check_intern !! Contains the components of the internal
535	!! mass balance chech for this routine
536	!! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
537	REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements):: check_intern_init !! Contains the components of the internal
538	!! mass balance chech for this routine
539	!! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
540	REAL(r_std), DIMENSION(npts,nvm,nelements) :: closure_intern !! Check closure of internal mass balance
541	!! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
542	REAL(r_std), DIMENSION(npts,nvm,nelements) :: pool_start, pool_end !! Start and end pool of this routine
543	!! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
544	REAL(r_std) :: median_circ !! Median circumference (m)
545	REAL(r_std) :: deficit !! Carbon that needs to be respired in
546	!! excess of todays gpp
547	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
548	REAL(r_std) :: excess !! Carbon that needs to be re-allocated
549	!! after the needs of the reserve and
550	!! labile pool are satisfied
551	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
552	REAL(r_std) :: shortage !! Shortage in the reserves that needs to
553	!! be re-allocated after to minimise the
554	!! tension between required and available
555	!! reserves
556	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
557	INTEGER :: i,tempi ! (temp variables for impose intraseasonal LAI dynamic)
558
559	INTEGER :: month_id !! index of month
560	REAL(r_std) :: ratio_move !! temperal variable to move the allocatable carbon
561	!! from leaf to sapwood
562	REAL(r_std), DIMENSION(13) :: lai_scale !! monthly lai scaling facter
563	REAL(r_std) :: daily_lai !! Daily LAI value interpolated by impose lai & lai_scale
564	CHARACTER(len=256) :: temp_text !! dummy text variable exchange
565
566	! Nitrogen cycle
567	REAL(r_std), DIMENSION(npts,nvm) :: n_alloc_tot !! nitrogen growth (gN/m2/dt)
568	REAL(r_std) , DIMENSION(npts,nvm) :: cn_leaf !! nitrogen concentration in leaves (gC/gN)
569	REAL(r_std) , DIMENSION(npts,nvm) :: transloc !! Transloc variables
570	REAL(r_std), DIMENSION(npts) :: alloc_c,alloc_d,alloc_e!! allocation coefficients of nitrogen to leaves, roots and wood
571	REAL(r_std), DIMENSION(npts) :: sum_sap,sum_oth !! carbon growth of wood and root+fruits (gC/m2)
572	REAL(r_std) :: costf !! nitrogen cost of a unit carbon growth given current C partitioning and nitrogen concentration
573	REAL(r_std) :: deltacn,deltacnmax !! (maximum) change in leaf nitrogen concentration
574	REAL(r_std) :: n_avail !! nitrogen available for growth (dummy)
575	REAL(r_std) :: bm_supply_n !! carbon growth sustainable by n_avail, considering costf
576	CHARACTER(LEN=2), DIMENSION(nelements) :: element_str !! string suffix indicating element
577	REAL(r_std) :: frac_growthresp_dyn !! Fraction of gpp used for growth respiration (-)
578	!! considers the special case at the leaf onset : frac_growthresp_dyn=0
579	REAL(r_std), DIMENSION(npts,nvm) :: veget_max_begin !! temporary storage of veget_max to check area conservation
580	REAL(r_std), DIMENSION(npts,nvm) :: temp
581	REAL(r_std), DIMENSION(ncirc) :: ba1 !! for calculating basal area after phenological
582	REAL(r_std), DIMENSION(ncirc) :: ba2 !! growth
583	REAL(r_std) :: d_mean !! temporal value to calculate deleuze_power
584	REAL(r_std) :: deleuze_power !! denominator of power of delueze-dhote eq.
585	REAL(r_std), DIMENSION(ncirc,nparts) :: temp_mass !! same with ba1, ba2
586	REAL(r_std) :: k_latosa_tmp !! Temporaray variable in the calculation of k_latosa_adapt
587	REAL(r_std) :: optimal_share !! optimal share between the labile and carbres pools (-)
588	REAL(r_std) :: total_reserves !! Temporary variable in the calculation of the labile and carbres pools.
589	REAL(r_std) :: update_sugar_load !! Instantaneous Relative sugar loading of the labile pool (unitless)
590	REAL(r_std) :: n_deficit !! The amount of nitrogen deficiency in labile nitrogen (dummy)
591	!! only used when quantifying the nitrogen limitation before allocation
592	REAL(r_std), DIMENSION(npts,nvm) :: height_rel !! relative height used to make KF dynamic when the stand height increases
593	REAL(r_std), DIMENSION(npts,nvm) :: residual10b !! contains the residual (gC tree-1) for warning 10b
594	!_ ================================================================================================================================
595
596	!! 1. Initialize
597
598	!! 1.1 First call only
599	IF (firstcall_growth_fun_all) THEN
600	!! Initialize local printlev
601	printlev_loc=get_printlev('growth_fun_all')
602	firstcall_growth_fun_all=.FALSE.
603	END IF
604
605	IF (printlev_loc.GE.2) WRITE(numout,*) 'Entering functional allocation growth'
606
607	!! 1.3 Initialize variables at every call
608	bm_alloc(:,:,:,:) = zero
609	n_alloc_tot(:,:) = zero
610	qm_height(:,:) = zero
611	delta_ba = zero
612	lai_target(:,:) = zero
613	resp_maint(:,:) = zero
614	resp_growth(:,:) = zero
615	lstress_fac(:,:) = zero
616	sigma(:,:) = zero
617	gammas(:,:) = zero
618	bm_alloc_tot(:,:) = zero
619	store_circ_class_ba(:,:,:) = zero
620	store_delta_ba_eff(:,:,:) = zero
621	store_delta_ba(:,:,:) = zero
622	check_intern(:,:,:,:) = zero
623	check_intern_init(:,:,:,:) = zero
624	excess = zero
625	residual(:,:) = zero
626	residual_write(:,:) = zero
627	residual10b(:,:) = zero
628	n_reserve_balance(:,:) = un
629	reserve_target(:,:,:) = zero
630	labile_target(:,:,:) = zero
631	gtemp(:,:) = zero
632	circ_class_ba_init(:,:,:) = zero
633	height_rel(:,:)= zero
634
635	! If npp is not initialized, bare soil value is never set.
636	npp(:,:) = zero
637
638	! bare soil never gets set here
639	lab_fac(:,1) = zero
640	c0_alloc(:,1)=zero
641
642	!! 1.4 Initialize check for mass balance closure
643	! The mass balance is calculated at the end of this routine
644	! in section 8
645	IF (err_act.GT.1) THEN
646
647	pool_start(:,:,:) = zero
648	DO iele = 1,nelements
649
650	! atm_to_bm has as intent inout, the variable
651	! accumulates carbon over the course of a day.
652	! Use the difference between start and the end of
653	! this routine
654	check_intern_init(:,:,iatm2land,iele) = - un * &
655	atm_to_bm(:,:,iele) * veget_max(:,:) * dt
656
657	DO ipar = 1,nparts
658	DO icir = 1,ncirc
659	! Initial biomass pool
660	pool_start(:,:,iele) = pool_start(:,:,iele) + &
661	(circ_class_biomass(:,:,icir,ipar,iele) * &
662	circ_class_n(:,:,icir) * veget_max(:,:))
663	ENDDO
664	ENDDO
665
666	ENDDO
667
668	!! 1.5 Initialize check for surface area conservation
669	! Veget_max is a INTENT(in) variable and can therefore
670	! not be changed during the course of this subroutine
671	! Check it anyway, in case the intent get changed.
672	veget_max_begin(:,:) = veget_max(:,:)
673
674	ENDIF ! err_act.GT.1
675
676	!! 1.6 Calculate LAI threshold below which carbohydrate reserve is used.
677	! Lai_max and lai_max_to_happy are PFT-dependent parameter specified in
678	! stomate_constants.f90
679	! +++CHECK+++
680	! Can we make this a function of Cs or rue_longterm? this double prescribed
681	! value does not make too much sense to me. It is not really dynamic.
682	lai_happy(:) = lai_max(:) * lai_max_to_happy(:)
683	! +++++++++++
684
685	!! 1.7 Store the biomass pools at the beginning of allocation
686	! These values will be used to calculate the increment in each pool
687	! at the end of the code. tmp_init_bm should not be changed, updated,
688	! or overwritten in this subroutine
689	tmp_init_bm(:,:,:,:) = cc_to_biomass(npts,nvm,&
690	circ_class_biomass(:,:,:,:,:),&
691	circ_class_n(:,:,:))
692	! Store basal area before the growth to calculate basal area increment.
693	DO j = 2,nvm
694	IF ( is_tree(j) ) THEN
695	DO ipts = 1,npts
696	circ_class_ba_init(ipts,j,:) = wood_to_ba(circ_class_biomass(ipts,j,:,:,icarbon),j)
697	ENDDO
698	ENDIF
699	ENDDO
700
701	!! 1.8 Calculate C/N ratio of the leaves
702	! Nitrogen concentration in leaves as CN. First calculate biomass at the
703	! stand level as that seems quicker than doing these calculations on
704	! circ_class_biomass.
705	tmp_bm = tmp_init_bm
706	WHERE( tmp_bm(:,:,ileaf,initrogen).GT.min_stomate .AND. &
707	tmp_bm(:,:,ileaf,icarbon).GT.min_stomate)
708
709	! Calculate the C:N ratio
710	cn_leaf(:,:)=tmp_bm(:,:,ileaf,icarbon)/tmp_bm(:,:,ileaf,initrogen)
711
712	ELSEWHERE
713
714	! Prescribe the C:N ratio
715	cn_leaf(:,:)=cn_leaf_min_season(:,:)
716
717	ENDWHERE
718
719	!! 1.8 Save old leaf mass
720	! biomass got last updated in stomate_phenology.f90
721	lm_old(:,:)=SUM(circ_class_biomass(:,:,:,ileaf,icarbon)*&
722	circ_class_n(:,:,:),3)
723
724	!! 1.9 Lai for bare soil is by definition zero
725	lai(:,ibare_sechiba) = zero
726
727
728	!! 2. Use carbohydrate reserve to support growth
729
730	DO j = 2, nvm ! Loop over # PFTs
731
732	!! 2.1 Calculate demand for carbohydrate reserve to support leaf and root growth.
733	! Maximum time (days) since start of the growing season during which carbohydrate
734	! may be used
735	IF ( is_tree(j) ) THEN
736
737	reserve_time = reserve_time_tree
738
739	ELSE
740
741	reserve_time = reserve_time_grass
742
743	ENDIF
744
745	!! 2.2 Calculate lai and c0_alloc
746	! The current functions require a loop over npts
747	! Calculate lai
748
749	DO ipts = 1,npts
750
751	lai(ipts,j) = cc_to_lai(circ_class_biomass(ipts,j,:,ileaf,icarbon),&
752	circ_class_n(ipts,j,:),j)
753
754	! We might need the c0_alloc factor, so let's calculate it.
755	c0_alloc(ipts,j) = calculate_c0_alloc(ipts, j, longevity_eff_root(ipts,j), &
756	longevity_eff_sap(ipts,j))
757	ENDDO
758
759	!! 2.3 Can the carbohydrate reserves be used?
760	! Growth is only supported by the use of carbohydrate reserves
761	! if the following conditions are statisfied:\n
762	! - PFT is not senescent;\n
763	! - LAI must be low (i.e. below ::lai_happy) and\n
764	! - Day of year of the simulation is in the beginning of the
765	! growing season.
766
767	! CYmark:
768	! CYclean: if use_reserve is obesolete. Cleanning of codes is needed.
769	! the use_reserve variable causes a lot confusions. Now it becomes useless
770	WHERE ( ( SUM(circ_class_biomass(:,j,:,ileaf,icarbon),2) .GT. min_stomate ) .AND. &
771	( plant_status(:,j) .EQ. ibudbreak .OR. &
772	plant_status(:,j) .EQ. icanopy .OR. &
773	plant_status(:,j) .EQ. ipresenescence).AND. &
774	( lai(:,j) .LT. lai_happy(j) ) .AND. &
775	( when_growthinit(:,j) .LT. reserve_time ) )
776
777	! Tell the labile and resource pool to use its reserve
778	use_reserve(:,j) = 1.0
779
780	ENDWHERE
781
782	ENDDO ! loop over # PFTs
783
784
785	!! 3. Initialize allocation
786
787	DO j = 2, nvm ! Loop over # PFTs
788
789	!! 3.1 Calculate scaling factors, temperature sensitivity, target
790	! lai to decide on reserve use, labile fraction, labile biomass
791	! and total allocatable biomass. Convert temperature from K to C
792	tl(:) = t2m(:) - ZeroCelsius
793
794	DO ipts = 1, npts
795
796	IF (veget_max(ipts,j) .LE. min_stomate .OR. &
797	SUM(circ_class_n(ipts,j,:)) .LE. min_stomate) THEN
798
799	! This vegetation type is not present, so no reason to do the
800	! calculation. CYCLE will take us out of the innermost DO loop
801	CYCLE
802
803	ENDIF
804
805	!! 3.1 Water stress
806	! The waterstress factor varies between 0.1 and 1 and is calculated
807	! from ::vegstress_season. The latter is only used in the allometric
808	! allocation and its time integral is determined by longevity_sap for trees
809	! (see constantes_mtc.f90 for longevity_sap and see pft_constantes.f90 for
810	! the definition of tau_hum_growingseason). The time integral for
811	! grasses and crops is a prescribed constant (see constantes.f90). For
812	! trees KF (and indirecrtly LF) and for grasses LF are multiplied
813	! by wstress. Because the calculated values are too low for its purpose
814	! Sonke Zhaele multiply it by two in the N-branch (see stomate_season.f90).
815	! This approach maintains the physiological basis of KF while combining it
816	! with a simple multiplicative factor for water stress. Clearly after
817	! multiplication with 2, wstress is closer to 1 and will thus result in a
818	! KF values closer to the physiologically expected KF. We did not see the
819	! need to multiply by 2 because the way we now calculate ::vegstress_season
820	! is less volatile than before. Before it ranged between 0 and 1, now the
821	! range is more like 0.4 to 0.9.
822
823	! Veget is now calculated from Pgap to be fully consistent within the model. Hence
824	! dividing by veget_max gives a value between 0 and 1 that denotes the amount of
825	! light reaching the forest floor.
826	IF (veget_max(ipts,j) .GT. min_stomate) THEN
827
828	! Basically recalculate Pgap and use it as the lstress. We do not use
829	! light_tran_to_floor_season here because that variables takes the annual
830	! mean and we want a quicker response here. veget is recalculated daily
831	! starting from Pgap_cumul (in slowproc.f90)
832	lstress_fac(ipts,j) = un - (veget(ipts,j) / veget_max(ipts,j))
833
834	! +++CHECK+++
835	! This is not rocket science so there are a couple
836	! of alternative functions. Some of these functions
837	! try to account for the gaps in the canopy which has
838	! already been taken care of in Pgap and is reflected
839	! in the ORCHIDEE-CAN way of calculating ::veget. I did
840	! follow these changes.
841	! Alternative 1
842	! lstress_fac(ipts,j) = (un - (veget(ipts,j) / veget_max(ipts,j)))**(0.5)
843	! Alternative 2
844	! lai_temp=-LOG(1-veget(ipts,j))/0.5
845	! veget_temp=1-exp(-0.5(lai_temp*1.5))
846	! lstress_fac(ipts,j) = (un - (veget_temp ))**(0.3)
847	! Alternative 3
848	! veget_temp=1-exp(-0.5(lai_temp*3.0))
849	! lstress_fac(ipts,j) = (un - (veget_temp ))**(0.05)
850	! ++++++++++
851
852	ELSE
853
854	lstress_fac(ipts,j) = zero
855
856	ENDIF
857
858	!! 3.2 Initialize scaling factors
859	! Stand level scaling factors
860	LF(ipts,j) = 1._r_std
861
862	! Tree level scaling factors
863	ltor(ipts,j) = 1._r_std
864	circ_class_height_eff(:) = 1._r_std
865
866	!! 3.3 Calculate structural characteristics
867	! Target lai is calculated at the stand level for the tree
868	! height of a virtual tree with the mean basal area or the
869	! so called quadratic mean diameter
870	qm_dia(ipts,j) = &
871	wood_to_qmdia(circ_class_biomass(ipts,j,:,:,icarbon), &
872	circ_class_n(ipts,j,:), j)
873	qm_height(ipts,j) = &
874	wood_to_qmheight(circ_class_biomass(ipts,j,:,:,icarbon), &
875	circ_class_n(ipts,j,:), j)
876
877	!! 3.4 Calculate allocation factors for trees and grasses
878	IF ( SUM(SUM(circ_class_biomass(ipts,j,:,:,icarbon),1)) .GT. min_stomate ) THEN
879
880	! Note that KF may already be calculated in stomate_prescribe.f90 (if called)
881	! it is recalculated because the biomass pools for grasses and crops
882	! may have been changed in stomate_phenology.f90. Trees were added to this
883	! calculation just to be consistent.
884
885	! Scaling factor to convert sapwood mass into leaf mass (KF)
886	! derived from
887	! LA_ind = k1 * SA_ind, k1=latosa (pipe-model)
888	! <=> Cl * vm/ind * sla = k1 * Cs * vm/ind / wooddens / tree_ff / height_new
889	! <=> Cl = Cs * k1 / wooddens / tree_ff/ height_new /sla
890	! <=> Cl = Cs * KF / height_new, where KF = k1 / (wooddens * sla * tree_ff)
891	! (1) Cl = Cs * KF / height_new
892	KF_old = KF(ipts,j)
893
894	! To be fully consistent with the hydraulic limitations and pipe theory,
895	! k_latosa_zero should be calculated from equation (18) in Magnani et al.
896	! To do so, total hydraulic resistance and tree height need to be known. This
897	! poses a problem as the resistance depends on the leaf area and the leaf
898	! area on the resistance. There is no independent equation and equations 12
899	! and 18 depend on each other and substitution would be circular. Hence
900	! prescribed k_latosa_adapt values were obtained from observational records
901	! and are given in mtc_parameters.f90
902
903	! The most simple approach to estimate k_latosa is by prescribing it. Note
904	! that for the moment lstress = 0. We decided to keep k_latosa_min and
905	! k_latosa_max just in case we want to test more complex relationships. Note
906	! as well that in the parameter files k_latosa_max = k_latosa_min.
907	! This approach is not fully able to compensate for the increase in height
908	! Cl = KF*Cs/height. If height increases, KF should increase as well
909	! to maintain the lai. Lstress = Pgap and saturates above an
910	! lai of 4-5. If Lai drops from 7 to 6, this approach does not respond
911	! sufficiently. Part of this drop was found to be due to a quick drop in
912	! N-availability during the spinup (that is the purpose of the spinup). If the
913	! model is resarted after a clear cut (r7250), this big drop in lai largely
914	! disappears and lai decreases 0.5 to 1.5 units over a 200 year long simulation.
915	! That is considered acceptable.
916	k_latosa_tmp = (k_latosa_adapt(ipts,j) + (lstress_fac(ipts,j) * &
917	(k_latosa_max(j)-k_latosa_min(j))))
918
919	!+++ALTERNATIVES+++
920	! At one point it looked like a good idea to take the max of two
921	! options but by doing so we cannot recalculate KF in phenology.
922	! It has not been confirmed that this is really a problem. Use the
923	! simpelest approach but leave the alternative in the code as a
924	! suggestion of a possible solution in case something goes wrong.
925	!!$ k_latosa_tmp = MAX(k_latosa_min(ivm),k_latosa_adapt(ipts,ivm) + &
926	!!$ (lstress_fac(ipts,ivm) * &
927	!!$ (k_latosa_max(ivm)-k_latosa_min(ivm))))
928
929	! The relationship between height and k_latosa as reported in McDowell
930	! et al 2002 and Novick et al 2009 is implemented to adjust k_latosa for
931	! the height of the stand. The slope of the relationship is calculated in
932	! stomate_data.f90 This did NOT result in a realistic model behavior.
933	!!$ k_latosa(ipts,j) = wstress_fac(ipts,j) * &
934	!!$ (k_latosa_max(j) - latosa_height(j) * qm_height(ipts,j))
935	! Another relationship with height was implemented. This resulted in acceptable
936	! model behavior (r7250) but had very little impact on the temporal patterns.
937	! For that reason the most simple formulation was favored over this approach
938	!!$ height_rel(ipts,j) = MAX(MIN((qm_height(ipts,j)/pipe_tune2(j))**
939	!!$ (1/exp_kf),un),zero)
940	!!$ k_latosa_tmp = k_latosa_adapt(ipts,j) + height_rel(ipts,j) * &
941	!!$ (k_latosa_max(j)-k_latosa_min(j))
942
943	! Alternatively, k_latosa is also reported to be a function of diameter
944	! (i.e. stand thinning, Simonin et al 2006, Tree Physiology, 26:493-503).
945	! Here the relationship with thinning was interpreted as a realtionship with
946	! light stress. This is the same formulation as we use now but to make it
947	! function l_stress should be calculated and the parameters for k_latosa_min
948	! and k_latosa_max should differ from each other.
949	! k_latosa(ipts,j) = (k_latosa_adapt(ipts,j) + &
950	! (lstress_fac(ipts,j) * &
951	! (k_latosa_max(j)-k_latosa_min(j))))
952
953	! Also k_latosa has been reported to be a function of CO2 concentration
954	! (Atwell et al. 2003, Tree Physiology, 23:13-21 and Pakati et al. 2000,
955	! Global Change Biology, 6:889-897). This effect is not accounted for in
956	! the current code
957
958	! How dow we want to account for waterstress?
959	!!$ k_latosa(ipts,j) = k_latosa_min(j) + (wstress_fac(ipts,j) * &
960	!!$ lstress_fac(ipts,j) * &
961	!!$ (k_latosa_max(j)-k_latosa_min(j)))
962	!!$ k_latosa(ipts,j) = wstress_fac(ipts,j) * (k_latosa_min(j) + &
963	!!$ (lstress_fac(ipts,j) * &
964	!!$ (k_latosa_max(j)-k_latosa_min(j))))
965	!++++++++++++++++++
966
967	! Calculate the sla for the current amount of leaf biomass. Use a trick.
968	! use biomass_to_lai to calculate the lai with a dynamic or a
969	! static sla calculation. Then divide the lai by the biomass to
970	! obtain the actual value for sla (m2 g-1).
971	IF (sla_dyn) THEN
972	IF (tmp_init_bm(ipts,j,ileaf,icarbon).GT.min_stomate) THEN
973	! Calculate a dynamic sla
974	sla_est = biomass_to_lai(tmp_init_bm(ipts,j,ileaf,icarbon),j) / &
975	tmp_init_bm(ipts,j,ileaf,icarbon)
976	ELSE
977	! Nothing changes, calculate sla_est such that KF will remain
978	! the same in the KF calculation below this IF-statement.
979	sla_est = k_latosa_tmp / &
980	(KF_old * pipe_density(j) * tree_ff(j))
981	ENDIF
982	ELSE
983	! Use the prescribed fixed sla
984	sla_est = sla(j)
985	ENDIF
986
987	! Calculate the actual KF
988	KF(ipts,j) = k_latosa_tmp / &
989	(sla_est * pipe_density(j) * tree_ff(j))
990
991	! KF of the previous time step was stored in ::KF_old to check its absolute
992	! change. If this absolute change is too big the whole allocation will crash
993	! because it will calculate negative increments which are compensated by
994	! positive increments that exceed the available carbon for allocation. This
995	! would suggest that for example the plant destroys leaves and uses the
996	! available carbon to produce more roots. This would represent an unwanted
997	! outcome. Large changes from one time step to another makes it difficult for
998	! the scheme to ever reach allometric balance. This balance is needed for the
999	! allocation scheme to allow 'ordinary allocation', which in turn is needed
1000	! to make use of the allocation rule of Dhote and Deleuze. It needs to be
1001	! avoided that the code spends too much time in phenological growth and the
1002	! if-then statements that help to restore allometric balance. For this reason
1003	! the absolute changes in KF from one time step to another are truncated.
1004	IF (KF_old - KF(ipts,j) .GT. max_delta_KF ) THEN
1005
1006	IF(printlev_loc>=4)THEN
1007	WRITE(numout,*) 'WARNING 2: KF was truncated'
1008	WRITE(numout,*) 'WARNING 2: PFT, ipts: ',j,ipts
1009	WRITE(numout,'(A,3F20.10)') 'WARNING 2: KF_old, KF(ipts,j), '//&
1010	'max_delta_KF: ', KF_old, KF(ipts,j), max_delta_KF
1011	ENDIF
1012
1013	! Add maximum absolute change
1014	KF(ipts,j) = KF_old - max_delta_KF
1015
1016	IF(printlev_loc>=4)THEN
1017	WRITE(numout,'(A,3F20.10)') 'WARNING 2: Reset, KF_old, KF(ipts,j): ',&
1018	KF_old, KF(ipts,j)
1019	ENDIF
1020
1021	ELSEIF (KF_old - KF(ipts,j) .LT. -max_delta_KF) THEN
1022
1023	IF(printlev_loc>=4)THEN
1024	WRITE(numout,*) 'WARNING 3: KF was truncated'
1025	WRITE(numout,*) 'WARNING 3: PFT, ipts: ',j,ipts
1026	WRITE(numout,'(A,3F20.10)') 'WARNING 3: KF_old, KF(ipts,j), '//&
1027	'max_delta_KF: ', KF_old, KF(ipts,j), -max_delta_KF
1028	ENDIF
1029
1030	! Remove maximum absolute change
1031	KF(ipts,j) = KF_old + max_delta_KF
1032
1033	IF(printlev_loc>=4)THEN
1034	WRITE(numout,'(A,3F20.10)') 'WARNING 3: Reset, KF_old, KF(ipts,j): ',&
1035	KF_old, KF(ipts,j)
1036	ENDIF
1037
1038	ELSE
1039
1040	! The change in KF is acceptable no action required
1041
1042	ENDIF
1043
1044	! Scaling factor to convert sapwood mass into root mass (LF)
1045	! derived from
1046	! Cs = c0 * height * Cr (Magnani 2000)
1047	! Cr = Cs / c0 / height_new
1048	! scaling parameter between leaf and root mass, derived from
1049	! Cr = Cs / c0 / height_new
1050	! let Cs = Cl / KF * height_new
1051	! <=> Cr = ( Cl * height_new / KF ) / ( c0 * height_new )
1052	! <=> Cl = Cr * KF * c0
1053	! <=> Cl = Cr * LF, where LF = KF * c0
1054	LF(ipts,j) = c0_alloc(ipts,j) * KF(ipts,j)
1055
1056	! Calculate non-nitrogen stressed leaf to root ratio to calculate the
1057	! allocation to the reserves. Should be multiplied by a nitrogen stress
1058	! have a look in OCN. This code should be considered as a placeholder
1059	ltor(ipts,j) = c0_alloc(ipts,j) * KF(ipts,j)
1060
1061	! Debug
1062	IF (j.EQ.test_pft .AND. printlev_loc.GE.4 .AND. ipts.EQ.test_grid) THEN
1063	WRITE(numout,*) 'Updating KF and related variables'
1064	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
1065	WRITE(numout,*) 'c0_alloc, ', c0_alloc(ipts,j)
1066	WRITE(numout,*) 'longevity_root, longevity_sap, ', longevity_eff_root(ipts,j), &
1067	longevity_eff_sap(ipts,j)
1068	WRITE(numout,*) 'k_belowground, k_sap, ', k_belowground(j), k_sap(j)
1069	WRITE(numout,*) 'ltor, ', ltor(ipts,j)
1070	ENDIF
1071	!-
1072
1073	ENDIF ! SUM(circ_class_biomass) .gt. zero
1074
1075	!+++CHECK+++
1076	!! 3.5 Calculate optimal LAI
1077	! The calculation of the optimal LAI was copied and adjusted from O-CN.
1078	! In O-CN it was also used in the allocation but that seems to be
1079	! inconsistent with the allometric rules that are implemented. Say that
1080	! the actual LAI is below the optimal LAI. Then the O-CN approach will
1081	! keep pumping carbon to grow the optimal LAI. If we would apply
1082	! the same method it means that during this phase the rule of Deleuze
1083	! and Dhote would not be used. For that reason we dropped the use of
1084	! LAI_optimal and replaced it by an allometric-based Cl_target value.
1085	! Initially, lai_target was still calculated as described below and used
1086	! in the calculation of the reserves. Further testing showed that for
1087	! some parameter sets lai_target was over 8 whereas the realized lai was
1088	! close to 4. This leaves us with a frustrated plant that will invest a
1089	! lot in its reserves but can never use them because it is constrained by
1090	! the allometric rules. To grow an LAI of 8 it would need to have a crazy
1091	! sapwoodmass. At a more fundamental level it is clear why the plant's
1092	! LAI should not exceed lai_target because then it costs more to produce
1093	! and maintain the leaf than what the new leaf can produce but there is no
1094	! reason why the plant should try to reach lai_target. For these
1095	! reasons it was decided to abandon this approach to lai_target and simply
1096	! replace lai_target by Cl_target * sla
1097
1098	!! 3.5.1 Scaling factor
1099	! Scaling factor to convert variables to the individual plant
1100	! Different approach between the DGVM and statitic approach
1101	IF (ok_dgvm) THEN
1102
1103	! The DGVM does currently NOT work with the new allocation, consider this as
1104	! placeholder. The original code had two different transformations to
1105	! calculate the scalars. Both could be used but the units will differ.
1106	! When fixing the DGVM check which quantities need to be multiplied by scal
1107	! scal = ind(ipts,j) * cn_ind(ipts,j) / veget_max(ipts,j)
1108	scal(ipts,j) = veget_max(ipts,j) / SUM(circ_class_n(ipts,j,:))
1109
1110	ELSE
1111
1112	! circ_class_biomass contain the data at the tree level
1113	! no conversion required
1114	scal(ipts,j) = 1.
1115
1116	ENDIF
1117
1118	!! 3.5.2 Calculate lai_target based on the allometric rules
1119	IF ( SUM(SUM(circ_class_biomass(ipts,j,:,:,icarbon),1)) .GT. min_stomate ) THEN
1120
1121	IF ( is_tree(j)) THEN
1122
1123	! Basal area at the tree level (m2 tree-1)
1124	circ_class_ba_eff(:) = wood_to_ba_eff(circ_class_biomass(ipts,j,:,:,icarbon),j)
1125
1126	! Current biomass pools per tree (gC tree^-1)
1127	! We will have different trees so this has to be calculated from the
1128	! diameter relationships
1129	Cs(:) = ( circ_class_biomass(ipts,j,:,isapabove,icarbon) + &
1130	circ_class_biomass(ipts,j,:,isapbelow,icarbon) ) * scal(ipts,j)
1131	Cr(:) = circ_class_biomass(ipts,j,:,iroot,icarbon) * scal(ipts,j)
1132	Cl(:) = circ_class_biomass(ipts,j,:,ileaf,icarbon) * scal(ipts,j)
1133	Ch(:) = ( circ_class_biomass(ipts,j,:,iheartabove,icarbon) + &
1134	circ_class_biomass(ipts,j,:,iheartbelow,icarbon) ) * scal(ipts,j)
1135
1136	DO l = 1,ncirc
1137
1138	! Calculate tree height
1139	circ_class_height_eff(l) = pipe_tune2(j)(4/picirc_class_ba_eff(l))**&
1140	(pipe_tune3(j)/2)
1141
1142	! Debug
1143	IF(printlev>=4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft)THEN
1144	WRITE(numout,*) 'circ_class_height, ',circ_class_height_eff(l)
1145	WRITE(numout,*) 'KF, ', KF(ipts,j)
1146	ENDIF
1147	!-
1148
1149	! Do the biomass pools respect the pipe model?
1150	! Do the current leaf, sapwood and root components respect the allometric
1151	! constraints? Due to plant phenology it is possible that we have too much
1152	! sapwood compared to the leaf and root mass (i.e. in early spring).
1153	! Calculate the optimal root and leaf mass, given the current wood mass
1154	! by using the basic allometric relationships. Calculate the optimal sapwood
1155	! mass as a function of the current leaf and root mass.
1156	Cl_target(l) = MAX( KF(ipts,j) * Cs(l) / circ_class_height_eff(l), &
1157	Cr(l) * LF(ipts,j) , Cl(l))
1158	Cs_target(l) = MAX( Cl(l) / KF(ipts,j) * circ_class_height_eff(l), &
1159	Cr(l) * LF(ipts,j) / KF(ipts,j) * circ_class_height_eff(l) , Cs(l))
1160
1161	! Check dimensions of the trees
1162	! If Cs = Cs_target then ba and height are correct, else calculate the
1163	! correct dimensions
1164
1165	IF ( Cs_target(l) - Cs(l) .GT. min_stomate ) THEN
1166
1167	! If Cs = Cs_target then dia and height are correct. However, if
1168	! Cl = Cl_target or Cr = Cr_target then dia and height need to be
1169	! re-estimated. Cs_target should satify the relationship
1170	! Cl/Cs = KF/height where height is a function of Cs_target
1171	! Search Cs needed to sustain the max of Cl or Cr.
1172	! Search max of Cl and Cr first
1173	!
1174	! [UPDATE] After the code passes through turnover or mortality
1175	! we may end up in a situation where we have lost more
1176	! sapwood than leaves and roots (i.e. sapwood turnover).
1177	! The model would then suggest that at time=t+1 the tree
1178	! should be smaller than at time=t0. From a physiological
1179	! standpoint this is not possible for the heartwood. If
1180	! we now calculate Cs_target on the basis of the actual Cl
1181	! or Cr, we find that Cs_target > Cs. The first priority
1182	! of the allocation scheme will be to allocate C to Cs.
1183	! Because we don't know yet whether the actual Cr or Cl is
1184	! what drives the need to allocate to Cs, we calculate
1185	! Cl_target first.
1186	Cl_target(l) = MAX(Cl(l), Cr(l)*LF(ipts,j))
1187
1188	! Debug
1189	IF (ipts.EQ.test_grid .AND. j.EQ.test_pft .AND. printlev_loc.GE.4) THEN
1190	WRITE(numout,*) 'Does the tree need reshaping? ipts, class: ', &
1191	ipts,l
1192	WRITE(numout,*) 'circ_class_height_eff, ', circ_class_height_eff(l)
1193	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
1194	WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(l)-Cl(l), Cl_target(l), Cl(l)
1195	WRITE(numout,*) 'Cs, ', Cs(l)
1196	WRITE(numout,*) 'Cr, ', Cr(l)
1197	WRITE(numout,*) 'Ch, ', Ch(l)
1198	ENDIF
1199	!-
1200
1201	! We now have the Cl_target that we will use to calculate
1202	! Cs_target. Given the allometric relationships we can
1203	! calculate Cs_target as Cl_target*height/KF.
1204	! height is a function of ba, which in turn is a function
1205	! of woodmass (Woodmass = Cs+Ch (sapwood+heartwood) ). We
1206	! therefore substitute the following equations into one
1207	! another:
1208	! (1) Cs_target = Cl_target*height/KF
1209	! (2) height = as a function of ba
1210	! (3) ba = as a function of woodmass_ind
1211	!
1212	! This gives:
1213	! (4) Cl_target = (KFCs_target)/(pipe_tune2(Cs_target+Ch)/ &
1214	! & pi/4)**(pipe_tune3/(2+pipe_tune3))
1215	!
1216	! The function newX searches for the value for Cs_target
1217	! that satisfies this equation (4).
1218	Cs_target(l) = newX(KF(ipts,j), Ch(l),pipe_tune2(j), &
1219	& pipe_tune3(j), Cl_target(l), Cs_target(l),&
1220	& tree_ff(j)pipe_density(j)pi/4*pipe_tune2(j), Cs(l),&
1221	& 2*Cs(l), 2, j, ipts)
1222
1223	! Recalculate height and ba from the correct
1224	! Cs_target
1225	circ_class_height_eff(l) = Cs_target(l)*KF(ipts,j)&
1226	&/Cl_target(l)
1227	circ_class_ba_eff(l) = pi/4*(circ_class_height_eff(l)&
1228	&/pipe_tune2(j))**(2/pipe_tune3(j))
1229	Cl_target(l) = KF(ipts,j) * Cs_target(l) /&
1230	& circ_class_height_eff(l)
1231	Cr_target(l) = Cl_target(l) / LF(ipts,j)
1232
1233	! Debug
1234	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
1235	WRITE(numout,*) 'New Cl_target, ', Cl_target(l)
1236	WRITE(numout,*) 'New Cs_target, ', Cs_target(l)
1237	WRITE(numout,*) 'New Cr_target, ', Cr_target(l)
1238	ENDIF
1239	!-
1240
1241	ENDIF
1242
1243	ENDDO
1244
1245	! Calculate lai_target
1246	lai_target(ipts,j) = cc_to_lai(Cl_target(:),circ_class_n(ipts,j,:),j)
1247
1248	ELSEIF ( .NOT. is_tree(j)) THEN
1249
1250	! Grasses and croplands
1251	! Current biomass pools per grass/crop (gC ind^-1)
1252	! Cs has too many dimensions for grass/crops. To have a consistent
1253	! notation the same variables are used as for trees but the dimension
1254	! of Cs, Cl and Cr i.e. ::ncirc should be ignored
1255	Cs(1) = circ_class_biomass(ipts,j,1,isapabove,icarbon) * scal(ipts,j)
1256	Cr(1) = circ_class_biomass(ipts,j,1,iroot,icarbon) * scal(ipts,j)
1257	Cl(1) = circ_class_biomass(ipts,j,1,ileaf,icarbon) * scal(ipts,j)
1258	Ch(1) = zero
1259
1260	! Do the biomass pools respect the pipe model?
1261	! Do the current leaf, sapwood and root components respect the allometric
1262	! constraints? Calculate the optimal root and leaf mass, given the current
1263	! wood mass by using the basic allometric relationships. Calculate the
1264	! optimal sapwood mass as a function of the current leaf and root mass.
1265	Cl_target(1) = MAX( Cs(1) * KF(ipts,j) , Cr(1) * LF(ipts,j), Cl(1) )
1266	Cs_target(1) = MAX( Cl_target(1) / KF(ipts,j), &
1267	Cr(1) * LF(ipts,j) / KF(ipts,j), Cs(1) )
1268	Cr_target(1) = MAX( Cl_target(1) / LF(ipts,j), &
1269	Cs_target(1) * KF(ipts,j) / LF(ipts,j), Cr(1) )
1270
1271	! Calculate lai_target
1272	lai_target(ipts,j) = cc_to_lai(Cl_target(:),circ_class_n(ipts,j,:), j)
1273
1274	! Debug
1275	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
1276	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
1277	ENDIF
1278	!-
1279
1280	ENDIF
1281
1282	ELSE
1283
1284	! circ_class_biomass is empty
1285	lai_target(ipts,j) = zero
1286
1287	ENDIF ! SUM(circ_class_biomass) .GT. min_stomate
1288
1289	!!$ !! 3.5 Calculate optimum LAI
1290	!!$ ! Lai is optimised for mean annual radiation use efficiency and the C costs
1291	!!$ ! for producing the canopy. The cost-benefit ratio is optimised when the
1292	!!$ ! marginal gain / marginal cost = 1
1293	!!$ ! Investing 1 gC in the canopy comes at a total cost that is composed by the
1294	!!$ ! C required for the canopy in addition to the roots and the sapwood to support
1295	!!$ ! the canopy. The total cost (C) is thus calculated as C:
1296	!!$ ! LAI/sla * ( (one_year/longevity_leaf) + (one_year/longevity_root)/LF + &
1297	!!$ ! (one_year/longevity_sap)*height/KF))
1298	!!$ ! The marginal cost for one unit of LAI is then dC/dLAI :
1299	!!$ ! (one_year/longevity_leaf)/sla + (one_year/longevity_root)/LF/sla + Ã©
1300	!!$ ! (one_year/longevity_sap)*height/KF/sla)
1301	!!$ ! Where, longevity_leaf is given by ::longevity_leaf in days, longevity_root by ::longevity_root in
1302	!!$ ! days and longevity_sap by ::longevity_sap in days. LF is unitless, KF is expressed in meters
1303	!!$ ! and sla in m^2.gC^{-1}. The unit of dC/dLAI is thus gC.m^{-2} but all turnover
1304	!!$ ! times need to be expressed on an annual scale.
1305	!!$ ! Investing 1gC in the canopy enables the plant to assimilate more carbon
1306	!!$ ! The gain (G) can be approximated by using the 'radiation use efficiency' as
1307	!!$ ! follows: RUE * one_year ( 1. - exp (-0.5 * LAI ))
1308	!!$ ! Where, 0.5 is the extinction factor that accounts for the fact the lower parts
1309	!!$ ! of the canopy receive less light. Note that RUE has a peculiar definition
1310	!!$ ! and is calculated as the ratio of GPP over the fraction of radiation
1311	!!$ ! absorbed by the canopy.
1312	!!$ ! Hence the unit of RUE is gC.m^{-2}.day^{-1}. The marginal gain of one
1313	!!$ ! unit of LAI is dG/dLAI:
1314	!!$ ! 0.5 * one_year * RUE * exp (-0.5 * LAI).
1315	!!$ ! Subsequently, the optimal LAI is approximated by
1316	!!$ ! LAI_opt = -2. * log(2(dC/dt)/(RUEone_year))
1317	!!$ ! Added the qm_height requirement since for a grass, it had no biomass
1318	!!$ ! but it did have individuals. This caused qm_height to be zero and a crash
1319	!!$ ! in the calculation of lai_target.
1320	!!$ IF ( (rue_longterm(ipts,j) .GT. min_stomate) .AND. (ind(ipts,j) .NE. zero &
1321	!!$ .AND. qm_height(ipts,j) .NE. 0) ) THEN
1322	!!$
1323	!!$ ! Scheme in line with the documentation
1324	!!$ lai_target(ipts,j) = -deux* log( (deux * (one_year/longevity_leaf(j))/sla(j) + &
1325	!!$ ((one_year/longevity_root(j))/LF(ipts,j))/sla(j) + &
1326	!!$ ((one_year/longevity_sap(j))*qm_height(ipts,j)/KF(ipts,j))/sla(j)) / &
1327	!!$ (rue_longterm(ipts,j)*one_year))
1328	!!$ lai_target(ipts,j) = MAX(MIN(lai_target(ipts,j),12.),.5)
1329	!!$
1330	!!$ ELSE
1331	!!$
1332	!!$ lai_target(ipts,j) = 0.5
1333	!!$
1334	!!$ ENDIF
1335	!++++++++++
1336
1337	!! 3.6 Calculate mean leaf age
1338	leaf_meanage = zero
1339	DO m = 1,nleafages
1340
1341	leaf_meanage = leaf_meanage + &
1342	leaf_age(ipts,j,m) * leaf_frac(ipts,j,m)
1343
1344	ENDDO
1345
1346	!! 3.7 Calculate labile fraction
1347	! +++CHECK+++
1348	! When we have leaf biomass, labile fraction is found to fluctuate
1349	! between ~0.1 and ~0.15. Hence, we do not fully explore the range
1350	! 0.1-0.7 for lab_fac as suggested by the code below. However, we
1351	! do not think this is a problem for now, as lab_fac is mostly used
1352	! to control restoring the reserves and the labile carbon pool.
1353	! Nevertheless the different options below suggest a false level of
1354	! confidence in what is really happening with the labile fraction.
1355	! A simpler solution could be just to use a fixed fraction of the
1356	! labile pool.
1357	IF ( (SUM(circ_class_biomass(ipts,j,:,ileaf,icarbon)) .LE. min_stomate) .AND. &
1358	(use_reserve(ipts,j) .GT. min_stomate) ) THEN
1359
1360	! Use constant labile fraction to initiate on-set of
1361	! leaves in spring. This only happens for crops and
1362	! grasslands on the first day of the growing season.
1363	lab_fac(ipts,j) = 0.7
1364
1365	ELSEIF ( (SUM(circ_class_biomass(ipts,j,:,ileaf,icarbon)) .GT. min_stomate) .AND. &
1366	(lai_target(ipts,j) .GT. min_stomate) .AND. &
1367	( plant_status(ipts,j) .EQ. ibudbreak .OR. &
1368	plant_status(ipts,j) .EQ. icanopy .OR. &
1369	plant_status(ipts,j) .EQ. ipresenescence) ) THEN
1370
1371	! Calculate labile fraction when a canopy is present but its lai
1372	! is below ::lai_target. This function scales lab_fac to a value between
1373	! 0.1 and 0.7. Its scientific basis remains unclear.
1374	IF ( is_tree(j)) THEN
1375
1376	! labile fraction for trees. This is rather fast and thus
1377	! short-lived. Consequently lab_fac is close to 0.1 most of
1378	! the growing season for both evergreen and deciduous trees.
1379	lab_fac(ipts,j) = 0.1 + 0.6 * &
1380	MAX(0.0,1.-MAX(ecureuil(j)*leaf_meanage/45., &
1381	(cc_to_lai(circ_class_biomass(ipts,j,:,ileaf,icarbon),&
1382	circ_class_n(ipts,j,:),j)/&
1383	lai_target(ipts,j))))
1384	ELSE
1385
1386	! labile fraction for grasses. This is much slower than the
1387	! function used for trees. Hence lab_fac may take several weeks
1388	! if not the best part of the growing season to decrease.
1389	lab_fac(ipts,j) = 0.1 + 0.6 * &
1390	MAX(0.0,1.-(ecureuil(j)*when_growthinit(ipts,j)/70.))
1391
1392	ENDIF
1393
1394	ELSE
1395
1396	! If the canopy has reached lai_target or is senescent lab_fac = 0.1
1397	lab_fac(ipts,j) = 0.1
1398
1399	ENDIF ! SUM(circ_class_biomass) .gt. zero and use_reserve .gt. zero
1400	!+++++++++++
1401
1402	!+++HACK+++
1403	! Testing whether we really need lab_fac
1404	lab_fac(ipts,j) = 0.1
1405	!++++++++++
1406
1407	!! 3.8 Calculate total allocatable biomass during this time step determined from GPP.
1408	! It is bit easier to deal with this issue at the stand level because
1409	! gpp_daily, the reserve, and labile pool are calculated at the
1410	! stand level. After making stand level calculations the updated
1411	! pools will have to be converted to the plant level.
1412	! Calculate stand level biomass
1413	tmp_bm(ipts,j,:,:) = cc_to_biomass(npts,j,&
1414	circ_class_biomass(ipts,j,:,:,:),&
1415	circ_class_n(ipts,j,:))
1416
1417	! Debug
1418	IF(printlev_loc.GE.3 .AND. ipts == test_grid .AND. j == test_pft)THEN
1419	WRITE(numout,*) 'Initial labile and carbres pools'
1420	WRITE(numout,*) 'gpp_daily(ipts,j)',gpp_daily(ipts,j)
1421	WRITE(numout,*) 'biomass(ipts,j,ilabile,icarbon)',&
1422	tmp_bm(ipts,j,ilabile,icarbon)
1423	WRITE(numout,*) 'biomass(ipts,j,icarbres,icarbon)',&
1424	tmp_bm(ipts,j,icarbres,icarbon)
1425	WRITE(numout,*) 'biomass(ipts,j,ilabile,initrogen)',&
1426	tmp_bm(ipts,j,ilabile,initrogen)
1427	WRITE(numout,*) 'biomass(ipts,j,icarbres,initrogen)',&
1428	tmp_bm(ipts,j,icarbres,initrogen)
1429	ENDIF
1430	!-
1431
1432	! If plant goes to senescence or ipresenescence, gpp
1433	! goes to reserve pool. This is to make the fresh GPP not readily
1434	! available for allocation, in order to preserve the reserve pool.
1435	IF ( plant_status(ipts,j).EQ.isenescent .OR. &
1436	plant_status(ipts,j).EQ.ipresenescence ) THEN
1437
1438	! The plant is in senescence or pre-senescence: icarbres should be used
1439
1440	! GPP was calculated as CO2 assimilation in enerbil.f90
1441	! Under some exceptional conditions :gpp could be negative when
1442	! the dark respiration exceeds the photosynthesis. When this happens
1443	! the dark respiration is paid for by the labile and carbres pools
1444	! Account for dark respiration if needed
1445	IF ( (tmp_bm(ipts,j,icarbres,icarbon) + &
1446	gpp_daily(ipts,j) * dt) .LT. zero ) THEN
1447
1448	deficit = (tmp_bm(ipts,j,icarbres,icarbon) + gpp_daily(ipts,j) * dt)
1449
1450	! The deficit is less than the carbon reserve
1451	IF (-deficit .LE. tmp_bm(ipts,j,ilabile,icarbon)) THEN
1452
1453	! Pay the deficit from the reserve pool
1454	tmp_bm(ipts,j,ilabile,icarbon) = &
1455	tmp_bm(ipts,j,ilabile,icarbon) + deficit
1456	tmp_bm(ipts,j,icarbres,icarbon) = &
1457	tmp_bm(ipts,j,icarbres,icarbon) - deficit
1458
1459	ELSE
1460
1461	! Not enough carbon to pay the deficit, the individual
1462	! is going to die at the end of this day
1463	tmp_bm(ipts,j,icarbres,icarbon) = &
1464	tmp_bm(ipts,j,ilabile,icarbon) + &
1465	tmp_bm(ipts,j,icarbres,icarbon)
1466	tmp_bm(ipts,j,ilabile,icarbon) = zero
1467
1468	! Truncate the dark respiration to the available carbon. Now we
1469	! should use up all the reserves. If the plant has no leaves, it
1470	! will die quickly after this.
1471	gpp_daily(ipts,j) = - tmp_bm(ipts,j,icarbres,icarbon)/dt
1472
1473	ENDIF
1474
1475	ENDIF ! labile pool is empty
1476
1477	! Not senescent add GPP (irrespective of whether it is positive or
1478	! negativeto labile pool
1479	tmp_bm(ipts,j,icarbres,icarbon) = tmp_bm(ipts,j,icarbres,icarbon) + &
1480	gpp_daily(ipts,j) * dt
1481
1482	ELSE
1483
1484	! The plant is still growing: gpp should go into ilabile
1485
1486	! GPP was calculated as CO2 assimilation in enerbil.f90
1487	! Under some exceptional conditions :gpp could be negative when
1488	! the dark respiration exceeds the photosynthesis. When this happens
1489	! the dark respiration is paid for by the labile and carbres pools
1490	! Account for dark respiration if needed
1491	IF ( (tmp_bm(ipts,j,ilabile,icarbon) + &
1492	gpp_daily(ipts,j) * dt) .LT. zero ) THEN
1493
1494	deficit = (tmp_bm(ipts,j,ilabile,icarbon) + gpp_daily(ipts,j) * dt)
1495
1496	! The deficit is less than the carbon reserve
1497	IF (-deficit .LE. tmp_bm(ipts,j,icarbres,icarbon)) THEN
1498
1499	! Pay the deficit from the reserve pool
1500	tmp_bm(ipts,j,icarbres,icarbon) = &
1501	tmp_bm(ipts,j,icarbres,icarbon) + deficit
1502	tmp_bm(ipts,j,ilabile,icarbon) = &
1503	tmp_bm(ipts,j,ilabile,icarbon) - deficit
1504
1505	ELSE
1506
1507	! Not enough carbon to pay the deficit, the individual
1508	! is going to die at the end of this day
1509	tmp_bm(ipts,j,ilabile,icarbon) = &
1510	tmp_bm(ipts,j,ilabile,icarbon) + &
1511	tmp_bm(ipts,j,icarbres,icarbon)
1512	tmp_bm(ipts,j,icarbres,icarbon) = zero
1513
1514	! Truncate the dark respiration to the available carbon. Now we
1515	! should use up all the reserves. If the plant has no leaves, it
1516	! will die quickly after this.
1517	gpp_daily(ipts,j) = - tmp_bm(ipts,j,ilabile,icarbon)/dt
1518
1519	ENDIF
1520
1521	ENDIF ! labile pool is empty
1522
1523	! Not senescent add GPP (irrespective of whether it is positive or
1524	! negativeto labile pool
1525	tmp_bm(ipts,j,ilabile,icarbon) = tmp_bm(ipts,j,ilabile,icarbon) + &
1526	gpp_daily(ipts,j) * dt
1527
1528	ENDIF ! check plant_status
1529
1530	! This would be a good place to update the plant level
1531	! labile and carbres pool but as it may be subject to
1532	! further modifications in the next block of code, it
1533	! will be done later
1534
1535	! Debug
1536	IF(printlev_loc.GE.3 .AND. ipts == test_grid .AND. j == test_pft)THEN
1537	WRITE(numout,*) 'Added gpp to labile pool'
1538	WRITE(numout,*) 'gpp_daily(ipts,j)',gpp_daily(ipts,j)
1539	WRITE(numout,*) 'biomass(ipts,j,ilabile,icarbon)',&
1540	tmp_bm(ipts,j,ilabile,icarbon)
1541	WRITE(numout,*) 'biomass(ipts,j,ilabile,initrogen)',&
1542	tmp_bm(ipts,j,ilabile,initrogen)
1543	ENDIF
1544	!-
1545
1546	!! 3.9 Calculate activity of labile carbon pool
1547
1548	! Similar relationship as that used for the temperature
1549	! response of maintenance respiration but the parameters were
1550	! tuned to reflect a temperature-growth relationships.
1551	! The parameters have no longer a physiological
1552	! meaning. The parameters in the equation were calibrated to
1553	! give no growth below -2, at 0 degrees only 3% of the labile
1554	! pool can be allocated to growth and at 5 degrees 100% of the
1555	! labile pool can be allocated to growth if there is enough
1556	! nitrogen. This equation partly decouples growth and gpp for
1557	! days that it is warm enough of gpp (above 0 degrees) but
1558	! probably too cold to grow (above 5 degrees). This is our
1559	! partial answer to the sink/source discussion bu Fatichi et al
1560	! 2013 in New Phytologist. Note that this has little effect on
1561	! the evergreen species and results in a couple of sudden
1562	! small dips in for example the LAI in winter in the temperate zone.
1563	! This approach has even less effect on the deciduous species
1564	! because for those species phenology typically happens after
1565	! the 5 degree threshold has been passed. At the time the
1566	! deciduous trees get their leaves, gpp and growth are coupled
1567	! to the extent that there is enough nitrogen to support the
1568	! growth.
1569	IF (tl(ipts) .GT. tmin_labile(j)) THEN
1570	gtemp(ipts,j) = EXP((e0_labile(j))*(1.0/(tref_labile(j)-tmin_labile(j)) - &
1571	1.0/(tl(ipts)-tmin_labile(j))))
1572	ELSE
1573	! Too cold to grow
1574	gtemp(ipts,j) = zero
1575	ENDIF
1576
1577	! If there is a plant, and we are either at the very start or in
1578	! the growing season not during senescences, calculate labile
1579	! pool use for growth.
1580	! CYmark: we allow calculation of bm_alloc_tot as well for ipresenescence
1581	! stage.
1582	IF ( SUM(circ_class_n(ipts,j,:)) .GT. min_stomate .AND. &
1583	( plant_status(ipts,j) .EQ. ibudbreak .OR. &
1584	plant_status(ipts,j) .EQ. icanopy .OR. &
1585	plant_status(ipts,j) .EQ. ipresenescence ) .AND. &
1586	SUM(circ_class_biomass(ipts,j,:,ileaf,icarbon)) .GT. min_stomate ) THEN
1587
1588	IF ( (tmp_bm(ipts,j,ilabile,icarbon) .GT. min_stomate) .OR. &
1589	(tmp_bm(ipts,j,icarbres,icarbon) .GT. min_stomate) ) THEN
1590
1591	! Truncate gtemp between zero and 1. If we set the upper
1592	! bound to one, we may run into numerical (precision) problems
1593	! later caused by very small (10e-15) negative values. Rather
1594	! than dealing with the precision issues it is easier to use
1595	! 0.99 instead. 0.99 may be too high so this parameter was
1596	! externalized and is pft-dependent.
1597	gtemp(ipts,j) = MAX(MIN(gtemp(ipts,j), un-always_labile(j)), zero)
1598
1599	ELSE
1600
1601	! There is nothing to allocate so we could as well set
1602	! gtemp to zero
1603	gtemp(ipts,j) = zero
1604
1605	ENDIF
1606
1607	! Prioritize the use of the carbohydrate pool. Move
1608	! carbohydrates to the labile pool.
1609	! CYmark: Such moving reserve to labile pool is not allowed for
1610	! ipresenescence stage.
1611	IF ( ( plant_status(ipts,j) .EQ. ibudbreak .OR. &
1612	plant_status(ipts,j) .EQ. icanopy ) .AND. &
1613	(tmp_bm(ipts,j,icarbres,icarbon) .GT. min_stomate) ) THEN
1614
1615	tmp_bm(ipts,j,ilabile,icarbon) = &
1616	tmp_bm(ipts,j,ilabile,icarbon) + 0.05 * &
1617	tmp_bm(ipts,j,icarbres,icarbon)
1618	tmp_bm(ipts,j,icarbres,icarbon) = &
1619	tmp_bm(ipts,j,icarbres,icarbon) * 0.95
1620	ENDIF
1621
1622	! This would be a good place to update the plant level
1623	! labile and carbres pool but as it may be subject to
1624	! further modifications in the next block of code, it
1625	! will be done later
1626
1627	ELSE
1628
1629	! The plant is absent, senescent or dead so there will be
1630	! no allocation. Set gtemp to zero to keep the output files
1631	! clean. Due to this line, gtemp will be zero as soon as
1632	! plant_status becomes isenescent or idormant.
1633	gtemp(ipts,j) = zero
1634
1635	ENDIF
1636
1637	! Since the plant is in ipresenescence, we want to stop allocating gpp (i.e.,
1638	! actually allocatable biomass) to tissue growth. This means: that
1639	! if allocatable biomass is higher than Rm, we have to give this
1640	! surplus back to reserve pool.
1641
1642	!! 3.10 Calculate allocatable part of the labile pool
1643	! If there is a plant and not in senescence or dormancy phase,
1644	! we calculate labile pool use for growth.
1645	IF (SUM(circ_class_n(ipts,j,:)) .GT. min_stomate .AND. &
1646	( plant_status(ipts,j) .EQ. ibudbreak .OR. &
1647	plant_status(ipts,j) .EQ. icanopy .OR. &
1648	plant_status(ipts,j) .EQ. ipresenescence) .AND. &
1649	SUM(circ_class_biomass(ipts,j,:,ileaf,icarbon)) .GT. min_stomate ) THEN
1650
1651	! Use carbon from the labile pool to allocate. The allometric (or
1652	! functional) allocation scheme transfers gpp to the labile pool
1653	! (see above) and then uses the labile pool (gpp + labile(t-1)) to sustain
1654	! growth. The fraction of the labile pool that can be used is a
1655	! function is given by gtemp (see above). bm_alloc_tot is in
1656	! gC m-2 dt-1
1657	bm_alloc_tot(ipts,j) = gtemp(ipts,j)*tmp_bm(ipts,j,ilabile,icarbon)
1658
1659	! Avoid issues with small estimates for bm_alloc_tot. Such small
1660	! number issues could result in mass balance problems.
1661	IF (bm_alloc_tot(ipts,j) .LE. min_stomate) THEN
1662
1663	! Not enough C to calculate the allocation. Keep this carbon
1664	! in the labile pool and try again later
1665	bm_alloc_tot(ipts,j) = zero
1666
1667	END IF
1668
1669	! Update the labile carbon pool
1670	tmp_bm(ipts,j,ilabile,icarbon) = tmp_bm(ipts,j,ilabile,icarbon) - &
1671	bm_alloc_tot(ipts,j)
1672
1673	ELSE
1674
1675	! The conditions do not support growth
1676	bm_alloc_tot(ipts,j) = zero
1677
1678	ENDIF
1679
1680	! Debug
1681	IF(printlev_loc.GE.3 .AND. ipts == test_grid .AND. j == test_pft)THEN
1682	WRITE(numout,*) "First bm_alloc_tot ", bm_alloc_tot(ipts,j)
1683	WRITE(numout,*) "plant_status(ipts,j) ", plant_status(ipts,j)
1684	WRITE(numout,*) "gtemp ", gtemp(ipts,j)
1685	WRITE(numout,*) "biomass(ipts,j,ilabile,icarbon) ", &
1686	tmp_bm(ipts,j,ilabile,icarbon)
1687	WRITE(numout,*) "biomass(ipts,j,icarbres,icarbon) ", &
1688	tmp_bm(ipts,j,icarbres,icarbon)
1689	ENDIF
1690	!-
1691
1692	!! 3.11 Maintenance respiration
1693	! First, total maintenance respiration for the whole plant is
1694	! calculated by summing maintenance respiration of the
1695	! different plant compartments. This simply recalculates the
1696	! maintenance respiration from stomate_resp.f90. Maintenance
1697	! respiration of the different plant parts is calculated in
1698	! stomate_resp.f90 as a function of the plant's temperature,
1699	! the long term temperature and plant coefficients:
1700	! The unit of ::resp_maint is gC m-2 dt-1
1701	resp_maint(ipts,j) = resp_maint(ipts,j) + &
1702	SUM(resp_maint_part(ipts,j,:))
1703
1704	! Following the calculation of hourly maintenance respiration,
1705	! verify that the PFT has not been killed after calcul of
1706	! resp_maint_part in stomate. Can this generaly calculated
1707	! ::resp_maint be use under the given conditions? Surpress
1708	! the respiration for deciduous PFTs as long as they haven't
1709	! carried leaves at least once. When starting from scratch
1710	! there is no budburst in the first year because the longterm
1711	! phenological parameters are not initialized yet. If not
1712	! surpressed respiration consumes all the reserves before the
1713	! PFT can start growing. The code would establish a new PFT
1714	! but it was decided to surpress this respiration because
1715	! it has no physiological bases.
1716	IF (SUM(circ_class_n(ipts,j,:)) .GT. min_stomate .AND. &
1717	rue_longterm(ipts,j) .NE. un) THEN
1718
1719	!+++CHECK+++
1720	! Can the calculated maintenance respiration be used ? Or
1721	! does it have to be adjusted for special cases. Maintenance
1722	! respiration should be positive. In case it is very low, use 20%
1723	! (::maint_from_labile) of the active labile carbon pool
1724	! (gC m-2 dt-1)
1725	! resp_maint(ipts,j) = MAX(zero, MAX(maint_from_labile * gtemp *
1726	! tmp_bm(ipts,j,ilabile,icarbon), resp_maint(ipts,j)))
1727	! Calculate resp_maint for the labile pool as well,
1728	! no need to have the above threshold. Make sure resp_maint
1729	! is not zero
1730	resp_maint(ipts,j) = MAX(zero, resp_maint(ipts,j))
1731	!+++++++++++
1732
1733	! Phenological growth makes use of the reserves. Some carbon
1734	! needs to remain to support the growth, hence, respiration
1735	! will be limited. In this case resp_maint ((gC m-2 dt-1)
1736	! should not be more than 80% (::maint_from_gpp) of the GPP
1737	! (gC m-2 s-1)
1738	IF (lab_fac(ipts,j) .GT. 0.3) THEN
1739
1740	resp_maint(ipts,j) = MIN( MAX(zero, &
1741	maint_from_gpp * gpp_daily(ipts,j) * dt), &
1742	resp_maint(ipts,j))
1743
1744	ENDIF
1745
1746	ELSE
1747
1748	! No plants, no respiration
1749	resp_maint(ipts,j) = zero
1750
1751	ENDIF
1752
1753	! The calculation of ::resp_maint is solely based on the demand i.e.
1754	! given the biomass and the condition of the plant, how much should be
1755	! respired. It is not sure that this demand can be satisfied i.e. the
1756	! calculated maintenance respiration may exceed the available carbon.
1757	IF ( bm_alloc_tot(ipts,j) - resp_maint(ipts,j) .LT. zero ) THEN
1758
1759	IF (plant_status(ipts,j) .EQ. isenescent .OR. &
1760	plant_status(ipts,j) .EQ. idormant .OR. &
1761	plant_status(ipts,j) .EQ. ibudsavail) THEN
1762
1763	! Under these conditions, bm_alloc_tot will be zero.
1764	! this line essentially sets resp_maint as zero during these
1765	! stages. This is to not lose the accumulated reserve during
1766	! active growing phase.
1767	resp_maint(ipts,j) = bm_alloc_tot(ipts,j)
1768
1769	ELSE
1770
1771	! the deficit in Rm will be paid by reserve when plant is in stages
1772	! of ibudbreak, icanopy, and ipresenescence.
1773	deficit = bm_alloc_tot(ipts,j) - resp_maint(ipts,j)
1774	! The deficit is less than the carbon reserve
1775	IF (-deficit .LE. tmp_bm(ipts,j,icarbres,icarbon)) THEN
1776
1777	! Pay the deficit from the reserve pool
1778	tmp_bm(ipts,j,icarbres,icarbon) = &
1779	tmp_bm(ipts,j,icarbres,icarbon) + deficit
1780	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - deficit
1781
1782	ELSE
1783
1784	! Not enough carbon to pay the deficit, the individual
1785	! is going to die at the end of this day
1786	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) + &
1787	tmp_bm(ipts,j,icarbres,icarbon)
1788	tmp_bm(ipts,j,icarbres,icarbon) = zero
1789
1790	! Truncate the maintenance respiration to the available carbon
1791	resp_maint(ipts,j) = bm_alloc_tot(ipts,j)
1792	ENDIF
1793
1794	ENDIF
1795	ENDIF
1796
1797	! Final ::resp_maint is known
1798	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - resp_maint(ipts,j)
1799
1800	! CYmark: if plant_status is ipresenescence, we don't
1801	! want any allocation to tissue growth. Therefore we put it back to
1802	! reserve pool.
1803	IF ( plant_status(ipts,j) .EQ. ipresenescence ) THEN
1804	tmp_bm(ipts,j,icarbres,icarbon) = tmp_bm(ipts,j,icarbres,icarbon) + &
1805	bm_alloc_tot(ipts,j)
1806	bm_alloc_tot(ipts,j) = zero
1807	ENDIF
1808
1809	! Debug
1810	IF(printlev_loc.GE.3 .AND. ipts == test_grid .AND. j == test_pft)THEN
1811	WRITE(numout,*) 'remaining bm_alloc_tot, ',bm_alloc_tot(ipts,j)
1812	WRITE(numout,*) "resp_maint ", resp_maint(ipts,j)
1813	ENDIF
1814	!-
1815
1816	!+++CHECK+++
1817	! It is more logical to deal with all the respiration terms at the
1818	! same time (as being done right here) but there are good reason to calculate
1819	! growth respiration in the end. Especialy if in the future we want
1820	! to have different growth respiration factors for different tissues.
1821
1822	! Surpress the respiration for deciduous PFTs as long as they haven't
1823	! carried leaves at least once. If not surpressed respiration consumes
1824	! all the reserves before the PFT can start growing. The code would
1825	! establish a new PFT but it was decided to surpress this respiration
1826	! because it has no physiological bases (in reality the new PFT does
1827	! not start to grow on January 1st as in the model but will be established
1828	! at the beginning of the growing season).
1829	IF (SUM(circ_class_n(ipts,j,:)) .GT. min_stomate .AND. &
1830	rue_longterm(ipts,j) .NE. un) THEN
1831
1832	frac_growthresp_dyn = frac_growthresp(j)
1833
1834	ELSE
1835
1836	frac_growthresp_dyn = zero
1837
1838	ENDIF
1839
1840	!! 3.12 Growth respiration
1841	! Reserve enough carbon to pay for growth respiration in case all
1842	! the available carbon can be allocated. Ideally, growth respiration
1843	! should be included as an additional component in the allocation.
1844	! That way the model could even have different growth respiration
1845	! costs for the different plant organs and/or tissues. The unit of
1846	! resp_growth is gC m-2 dt-1. Calculate resp_growth such that it is
1847	! 28% of bm_alloc_tot after resp_growth has been subtracted from
1848	! bm_alloc_tot.
1849	! resp_growth = (bm_alloc_tot - resp_growth) * frac_growthresp
1850	resp_growth(ipts,j) = MAX(zero, bm_alloc_tot(ipts,j)) * &
1851	(frac_growthresp_dyn / (1 + frac_growthresp_dyn))
1852
1853	!+++CHECK+++
1854	! Set to zero to follow the trunk but it would more straightforward
1855	! to delete this parameter from the equations where it is now used but
1856	! set to zero
1857	frac_growthresp_dyn = 0.
1858	!+++++++++++
1859
1860	! First estimate of ::resp_growth is known. If there is enough
1861	! nitrogen to allocate all the C there is no need to recalculate
1862	! bm_alloc_tot and resp_growth and so this may be the final
1863	! estimate.
1864	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - resp_growth(ipts,j)
1865
1866	! Debug
1867	IF(printlev_loc.GE.3 .AND. ipts == test_grid .AND. j == test_pft)THEN
1868	WRITE(numout,*) 'remaining bm_alloc_tot, ',bm_alloc_tot(ipts,j)
1869	WRITE(numout,*) 'resp_growth ', resp_growth(ipts,j)
1870	IF(bm_alloc_tot(ipts,j).GT.min_stomate)THEN
1871	WRITE(numout,*) 'ratio resp_growth/bm_alloc_tot, ', &
1872	resp_growth(ipts,j)/bm_alloc_tot(ipts,j)
1873	ENDIF
1874	ENDIF
1875	!-
1876
1877	! Occasionally, there is a very special situation which arises, where
1878	! bm_alloc_tot is greater than min_stomate before accounting for growth
1879	! respiration, but not afterwards. This causes a mass balance error
1880	! because growth respiration is non-zero but bm_alloc_tot is too small
1881	! to trigger loops below, so nothing is done with that carbon. In this
1882	! situation, the amout of carbon to allocate is so low that nothing
1883	! really changes. We set the growth respiration to zero in this special
1884	! case to avoid mass imbalance, even though this will not effect the
1885	! trajectory of the plant. It seems to happen on the same day as leaves
1886	! start growing, before any GPP is calculated.
1887	IF(((bm_alloc_tot(ipts,j) + resp_growth(ipts,j)) .GT. min_stomate) &
1888	.AND. (bm_alloc_tot(ipts,j) .LT. min_stomate)) THEN
1889
1890	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) + resp_growth(ipts,j)
1891	resp_growth(ipts,j) = zero
1892
1893	! Debug
1894	IF(printlev_loc.GE.3 .AND. j == test_pft .AND. ipts == test_grid)THEN
1895	WRITE(numout,*) 'stomate_allocation - Hit exception 25'
1896	WRITE(numout,*) 'bm_alloc_tot-resp_growth, ',bm_alloc_tot(ipts,j)
1897	WRITE(numout,*) 'resp_growth ', resp_growth(ipts,j)
1898	IF (bm_alloc_tot(ipts,j).GT.min_stomate)THEN
1899	WRITE(numout,*) 'ratio resp_growth/bm_alloc_tot, ', &
1900	resp_growth(ipts,j)/bm_alloc_tot(ipts,j)
1901	ENDIF
1902	ENDIF
1903	!-
1904
1905	ENDIF
1906
1907	!! 3.13 Distribute stand level ilabile and icarbres at the tree level
1908	! The labile and carbres pools are calculated at the stand level but
1909	! are then redistributed at the tree level. Tree level biomass is the
1910	! prognostic variable in ORCHIDEE. Biomass is here used as a local
1911	! variable to deal with the reserve and labile pools.
1912	circ_class_biomass(ipts,j,:,ilabile,icarbon) = &
1913	biomass_to_cc(tmp_bm(ipts,j,ilabile,icarbon),&
1914	circ_class_biomass(ipts,j,:,ilabile,icarbon),&
1915	circ_class_n(ipts,j,:))
1916	circ_class_biomass(ipts,j,:,icarbres,icarbon) = &
1917	biomass_to_cc(tmp_bm(ipts,j,icarbres,icarbon),&
1918	circ_class_biomass(ipts,j,:,icarbres,icarbon),&
1919	circ_class_n(ipts,j,:))
1920
1921	ENDDO ! npts
1922
1923	! Intermediate mass balance check. Note that this part of
1924	! the code is within a DO-loop over nvm so the ipft check
1925	! should be used.
1926	IF (err_act.EQ.4) THEN
1927
1928	! Reset pool_end
1929	pool_end(:,:,:) = zero
1930
1931	! Add bm_alloc_tot into the pool
1932	pool_end(ipts,j,icarbon) = pool_end(ipts,j,icarbon) + &
1933	bm_alloc_tot(ipts,j) * veget_max(ipts,j)
1934
1935	! Check mass balance closure. The code above intializes many of the
1936	! variables/parameters used in allocation. gpp_daily is allocated
1937	! maintenance respiration is calculated and growth respiration is
1938	! reserved. There has been no allocation to leaves, roots and stems yet.
1939	CALL intermediate_mass_balance_check(pool_start, pool_end, circ_class_biomass, &
1940	circ_class_n, veget_max, bm_alloc_tot, gpp_daily, atm_to_bm, dt, npts, &
1941	resp_maint, resp_growth, check_intern_init, ipts, j, '1', 'ipft')
1942
1943	ENDIF ! err_act.GT.4
1944
1945
1946	!! 5. Allometric allocation
1947
1948	DO ipts = 1, npts
1949
1950	!! 5.1 Initialize allocated biomass pools
1951	f_alloc(ipts,j,:) = zero
1952	f_alloc_circ(ipts,:,:) = zero
1953	Cl_inc(:) = zero
1954	Cs_inc(:) = zero
1955	Cr_inc(:) = zero
1956	Cf_inc(:) = zero
1957	Cl_incp(:) = zero
1958	Cs_incp(:) = zero
1959	Cr_incp(:) = zero
1960	Cs_inc_est(:) = zero
1961	Cl_target(:) = zero
1962	Cr_target(:) = zero
1963	Cs_target(:) = zero
1964	ba1(:) = zero
1965	ba2(:) = zero
1966	b_inc_tot = zero
1967
1968	IF (veget_max(ipts,j) .LE. min_stomate .OR. &
1969	SUM(circ_class_n(ipts,j,:)) .LE. min_stomate) THEN
1970
1971	! This vegetation type is not present, so no reason to do the
1972	! calculation. CYCLE will take us out of the innermost DO loop
1973	CYCLE
1974
1975	ENDIF
1976
1977	!! 5.2 Calculate allocated biomass pools for trees
1978	!! 5.2.1 Stand to tree allocation rule of Deleuze & Dhote
1979	IF ( is_tree(j) .AND. bm_alloc_tot(ipts,j) .GT. min_stomate ) THEN
1980
1981	! Basal area at the tree level (m2 tree-1)
1982	circ_class_ba_eff(:) = wood_to_ba_eff(circ_class_biomass(ipts,j,:,:,icarbon),j)
1983	circ_class_circ_eff(:) = 2 * pi * SQRT(circ_class_ba_eff(:)/pi)
1984
1985	! According to equation (-) in Bellasen et al 2010.
1986	! ln(sigmas) = a_sig * ln(circ_med) + b_sig
1987	! sigmas = exp(a_sig*log(median(circ_med))+b_sig);
1988	! However, in the code (sapiens_forestry.f90) a different expression was used
1989	! sigmas = 0.023+0.58*prctile(circ_med,0.05);
1990	! Any of these implementations could work but seem to be more suited for
1991	! continues or nearly continuous diameter distributions, say n_circ > 10
1992	! For a small number of diameter classes sigma depends on a prescribed
1993	! circumference percentile.
1994	IF (ncirc .GE. 6) THEN
1995
1996	! Calculate the median circumference
1997	DO l = 1,ncirc
1998
1999	IF (SUM(circ_class_n(ipts,j,1:l)) .GE. &
2000	0.5 * SUM(circ_class_n(ipts,j,:))) THEN
2001
2002	median_circ = circ_class_circ_eff(l) - 5 * min_stomate
2003	EXIT
2004
2005	ENDIF
2006
2007	ENDDO
2008
2009	sigma(ipts,j) = deleuze_a(j) + deleuze_b(j) * median_circ
2010
2011	ELSE
2012
2013	! The X percentile of the trees that will receive the photosynthates
2014	! depends on the FM type. In a coppice stand there is a lot of
2015	! competition between the shoots and only the top half of the shoots
2016	! will receive GPP, the other half receives only little GPP. This was
2017	! implemnted to get a reasonable diameter growth of coppice stands.
2018	! If deleuze_p is independent from FM, FM strategies with high densities
2019	! have very slow diameter growth because the GPP has to be distributed
2020	! over a large number of individuals.
2021	IF (forest_managed(ipts,j) == ifm_cop) THEN
2022
2023	deleuze_p(j) = deleuze_p_coppice(j)
2024
2025	ELSEIF (forest_managed(ipts,j) == ifm_none .OR. &
2026	forest_managed(ipts,j) == ifm_thin .OR. &
2027	forest_managed(ipts,j) == ifm_src) THEN
2028
2029	deleuze_p(j) = deleuze_p_all(j)
2030
2031	ELSE
2032
2033	WRITE(numout, *) 'forest management, ',ipts,j,forest_managed(ipts,j)
2034	CALL ipslerr_p (3,'growth_fun_all', &
2035	'Forest management strategy does not exist','','')
2036
2037	ENDIF
2038
2039	! Search for the X percentile, where X is given by ::deleuze_p
2040	! Substract a very small number (5*min_stomate) just to be sure that
2041	! the circ_class will be corectly accounted for in GE or LE statements
2042	DO l = 1,ncirc
2043	IF (SUM(circ_class_n(ipts,j,1:l)) .GE. deleuze_p(j) * &
2044	SUM(circ_class_n(ipts,j,:))) THEN
2045	sigma(ipts,j) = circ_class_circ_eff(l) - 5 * min_stomate
2046	EXIT
2047	ENDIF
2048	ENDDO
2049	ENDIF
2050
2051	!! 5.2 Calculate allocated biomass pools for trees
2052	! Only possible if there is biomass to allocate
2053	! Use sigma and m_dv to calculate a single coefficient that can be
2054	! used in the subsequent allocation scheme.
2055
2056	! In the original deleuze-dhote equation, basal area increment
2057	! linearly increases by the size of trees. But as the diameter and
2058	! crown volume increment have saturation points, it can be hypothesized
2059	! that basal increment has the saturation point, as well.
2060	! Based on this assumption, decreasing power of deleuze-dhote equation
2061	! deleuze-dhote equation is implemented here, the simple function of
2062	! mean-diameter. The range of delueze_power was set empirically.
2063	! Growth diversity between size classes can be highly sensitive to
2064	! deleuze_power_a, which determines a degree of decrease of power
2065	! of deleuze_dhote eq. If deleuze_power_a the equation work as
2066	! its original but if it is bigger than 0 growth diversity will decrease.
2067	d_mean = 0
2068	DO l = 1,ncirc
2069	d_mean = d_mean + ((circ_class_circ_eff(l)/pi)*circ_class_n(ipts,j,l))
2070	ENDDO
2071	d_mean = d_mean/SUM(circ_class_n(ipts,j,:))
2072
2073	deleuze_power = 1.8 + deleuze_power_a(j)*d_mean
2074
2075	IF (deleuze_power .LE. 2.0) THEN
2076	deleuze_power = 2.0
2077	ELSEIF (deleuze_power .GE. 3.5) THEN
2078	deleuze_power = 3.5
2079	ENDIF
2080
2081	circ_class_dba(:) = (circ_class_circ_eff(:) - m_dv(j)*sigma(ipts,j) + &
2082	((m_dv(j)sigma(ipts,j) + circ_class_circ_eff(:))*2 - &
2083	(4sigma(ipts,j)circ_class_circ_eff(:)))**(1/deleuze_power))/ 2
2084
2085	!! 5.2.2 Scaling factor to convert variables to the individual plant
2086	! Allocation is on an individual basis. Stand-level variables need to
2087	! convert to a single individual. Different approach between the DGVM
2088	! and statitic approach
2089	IF (ok_dgvm) THEN
2090
2091	! The DGVM does currently NOT work with the new allocation, consider this as
2092	! placeholder. The original code had two different transformations to
2093	! calculate the scalars. Both could be used but the units will differ.
2094	! When fixing the DGVM check which quantities need to be multiplied by scal
2095	! scal = ind(ipts,j) * cn_ind(ipts,j) / veget_max(ipts,j)
2096	scal(ipts,j) = veget_max(ipts,j) / SUM(circ_class_n(ipts,j,:))
2097
2098	ELSE
2099
2100	! circ_class_biomass contain the data at the tree level
2101	! no conversion required
2102	scal(ipts,j) = 1.
2103
2104	ENDIF
2105
2106	!! 5.2.3 Current biomass pools per tree (gC tree^-1)
2107	! We will have different trees so this has to be calculated from the
2108	! diameter relationships
2109	Cs(:) = ( circ_class_biomass(ipts,j,:,isapabove,icarbon) + &
2110	circ_class_biomass(ipts,j,:,isapbelow,icarbon) ) * scal(ipts,j)
2111	Cr(:) = circ_class_biomass(ipts,j,:,iroot,icarbon) * scal(ipts,j)
2112	Cl(:) = circ_class_biomass(ipts,j,:,ileaf,icarbon) * scal(ipts,j)
2113	Ch(:) = ( circ_class_biomass(ipts,j,:,iheartabove,icarbon) + &
2114	circ_class_biomass(ipts,j,:,iheartbelow,icarbon) ) * scal(ipts,j)
2115
2116	! Make a crude estimate of how much carbon can be allocated given
2117	! the available nitrogen. The same code as in the section 5.4 is used exept
2118	! that we don't use allocation coeff to modulate n_avail. So
2119	! costf=1. It is a strong assumption compared to previous versions.
2120	! It means that ordinary allocation can only happens when phenological
2121	! allocation is ok. In other case no wood growth is allowed.
2122	! In the case of a strong limitation by Nitrogen, the growth period
2123	! for sapwood will be shorten because we reach allometry late in
2124	! the growing season.
2125	n_avail = MAX(tmp_bm(ipts,j,ilabile,initrogen)*0.9,0.0)
2126
2127	! Calculate how much carbon could be allocated with the available nitrogen
2128	bm_supply_n = n_avail / (1.-frac_growthresp_dyn) * &
2129	cn_leaf(ipts,j)
2130
2131	! If there is not enough nitrogen, move nitrogen from the reserve
2132	! as much as needed, keeping 10% of reserve (arbitral portion)
2133	IF(bm_alloc_tot(ipts,j) .GT. bm_supply_n &
2134	.AND. n_avail .GT. zero) THEN
2135
2136	! Calculate the deficit
2137	n_deficit = bm_alloc_tot(ipts,j) * (1.-frac_growthresp_dyn) / &
2138	cn_leaf(ipts,j) - n_avail
2139
2140	IF(n_deficit .LE. tmp_bm(ipts,j,icarbres,initrogen) * 0.9) THEN
2141
2142	! Enougn N in the reserve pools to fill the labile pool
2143	n_avail = n_avail + n_deficit
2144	bm_supply_n = n_avail / (1.-frac_growthresp_dyn) * &
2145	cn_leaf(ipts,j)
2146	tmp_bm(ipts,j,icarbres,initrogen) = tmp_bm(ipts,j,icarbres,initrogen) - &
2147	(n_avail/0.9 - tmp_bm(ipts,j,ilabile,initrogen))
2148	tmp_bm(ipts,j,ilabile,initrogen) = n_avail/0.9
2149
2150	! tmp_bm is a temporary varaiable so the prognostic variable, i.e.,
2151	! circ_class_biomass also needs to be updated.
2152	circ_class_biomass(ipts,j,:,icarbres,initrogen) = &
2153	biomass_to_cc(tmp_bm(ipts,j,icarbres,initrogen),&
2154	circ_class_biomass(ipts,j,:,icarbres,initrogen),&
2155	circ_class_n(ipts,j,:))
2156	circ_class_biomass(ipts,j,:,ilabile,initrogen) = &
2157	biomass_to_cc(tmp_bm(ipts,j,ilabile,initrogen),&
2158	circ_class_biomass(ipts,j,:,ilabile,initrogen),&
2159	circ_class_n(ipts,j,:))
2160
2161	ELSE
2162
2163	! Deficit exceeds 90% of reserve. fill labile as much as
2164	! possible
2165	tmp_bm(ipts,j,ilabile,initrogen) = tmp_bm(ipts,j,ilabile,initrogen) + &
2166	tmp_bm(ipts,j,icarbres,initrogen) * 0.9
2167	tmp_bm(ipts,j,icarbres,initrogen) = tmp_bm(ipts,j,icarbres,initrogen) - &
2168	tmp_bm(ipts,j,icarbres,initrogen) * 0.9
2169
2170	! tmp_bm is a temporary varaiable so the prognostic variable, i.e.,
2171	! circ_class_biomass also needs to be updated.
2172	circ_class_biomass(ipts,j,:,icarbres,initrogen) = &
2173	biomass_to_cc(tmp_bm(ipts,j,icarbres,initrogen),&
2174	circ_class_biomass(ipts,j,:,icarbres,initrogen),&
2175	circ_class_n(ipts,j,:))
2176	circ_class_biomass(ipts,j,:,ilabile,initrogen) = &
2177	biomass_to_cc(tmp_bm(ipts,j,ilabile,initrogen),&
2178	circ_class_biomass(ipts,j,:,ilabile,initrogen),&
2179	circ_class_n(ipts,j,:))
2180
2181	! Update the available nitrogen and the carbon that could be allocated
2182	! with that amount of nitrogen
2183	n_avail = MAX(tmp_bm(ipts,j,ilabile,initrogen)*0.9,0.0)
2184	bm_supply_n = n_avail / (1.-frac_growthresp_dyn) * &
2185	cn_leaf(ipts,j)
2186	ENDIF
2187
2188	ENDIF
2189
2190	deltacnmax = 1. - exp(-((1.6 * MIN((1./cn_leaf(ipts,j))-&
2191	(1./cn_leaf_min_2D(ipts,j)),0.) / &
2192	( (1./(cn_leaf_max_2D(ipts,j))) - &
2193	(1./cn_leaf_min_2D(ipts,j)) ) )**4.1))
2194
2195	IF ( bm_alloc_tot(ipts,j) .GT. bm_supply_n ) THEN
2196
2197	IF (impose_cn) THEN
2198
2199	! Calculate how much nitrogen is missing to allocate all the
2200	! carbon contained in bm_alloc_tot
2201	n_deficit = (bm_alloc_tot(ipts,j)-bm_supply_n) * &
2202	(1.-frac_growthresp_dyn) / cn_leaf(ipts,j)/0.9
2203
2204	! The nitrogen missing to allocate the entire bm_alloc_tot will be taken
2205	! from the atmosphere and put in the labile pool.
2206	atm_to_bm(ipts,j,initrogen) = atm_to_bm(ipts,j,initrogen) + &
2207	n_deficit/dt
2208	tmp_bm(ipts,j,ilabile,initrogen) = &
2209	tmp_bm(ipts,j,ilabile,initrogen) + n_deficit
2210
2211	! tmp_bm is a temporary varaiable so the prognostic variable, i.e.,
2212	! circ_class_biomass also needs to be updated.
2213	circ_class_biomass(ipts,j,:,ilabile,initrogen) = &
2214	biomass_to_cc(tmp_bm(ipts,j,ilabile,initrogen),&
2215	circ_class_biomass(ipts,j,:,ilabile,initrogen),&
2216	circ_class_n(ipts,j,:))
2217
2218	! Estimate the nitrogen pool that is required to allocate all the
2219	! carbon in bm_alloc_tot.
2220	n_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) * &
2221	(1.-frac_growthresp_dyn)/cn_leaf(ipts,j)
2222
2223	ELSE
2224
2225	IF (printlev_loc .GE. 4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
2226	WRITE(numout,*) 'N-limitation before allocation'
2227	ENDIF
2228	deltacnmax = Dmax * (1.-deltacnmax)
2229	deltacn = n_avail / ( bm_alloc_tot(ipts,j) * &
2230	(1.-frac_growthresp_dyn) * 1./cn_leaf(ipts,j) )
2231	deltacn = MIN(MAX(deltacn,1.0-deltacnmax),1.0)
2232
2233	n_alloc_tot(ipts,j) = MIN( n_avail , &
2234	bm_alloc_tot(ipts,j) * (1.-frac_growthresp_dyn) * &
2235	MAX(MIN( 1./cn_leaf(ipts,j)*deltacn, 1./cn_leaf_min_2D(ipts,j)), &
2236	1./cn_leaf_max_2D(ipts,j)) )
2237
2238	tmp_bm(ipts,j,ilabile,icarbon) = &
2239	tmp_bm(ipts,j,ilabile,icarbon) + &
2240	bm_alloc_tot(ipts,j)
2241
2242	bm_alloc_tot(ipts,j) = MIN( bm_alloc_tot(ipts,j) , &
2243	n_alloc_tot(ipts,j) / (1.-frac_growthresp_dyn) / &
2244	MAX(MIN(1./cn_leaf(ipts,j)*deltacn, &
2245	1./cn_leaf_min_2D(ipts,j)), 1./cn_leaf_max_2D(ipts,j)) )
2246
2247	tmp_bm(ipts,j,ilabile,icarbon) = tmp_bm(ipts,j,ilabile,icarbon) - &
2248	bm_alloc_tot(ipts,j)
2249
2250	ENDIF ! if impose_cn
2251
2252	ELSE
2253
2254	IF (printlev_loc .GE. 4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
2255	WRITE(numout,*) 'Sufficient nitrogen before allocation'
2256	ENDIF
2257
2258	deltacnmax=Dmax * deltacnmax
2259	deltacn = n_avail / ( bm_alloc_tot(ipts,j) * &
2260	(1.-frac_growthresp_dyn) * 1./cn_leaf(ipts,j) )
2261	deltacn=MIN(MAX(deltacn,1.0),1.+deltacnmax)
2262
2263	n_alloc_tot(ipts,j) = MIN( n_avail , &
2264	bm_alloc_tot(ipts,j) * (1.-frac_growthresp_dyn) * &
2265	MAX(MIN(1./cn_leaf(ipts,j)*deltacn, &
2266	1./cn_leaf_min_2D(ipts,j)),1./cn_leaf_max_2D(ipts,j)) )
2267
2268	ENDIF
2269
2270	! Total amount of carbon that needs to ba allocated (::bm_alloc_tot).
2271	! bm_alloc_tot is in gC m-2 day-1. At 1 m2 there are ::ind number of
2272	! trees. We calculate the allocation for ::ncirc trees. Hence b_inc_tot
2273	! needs to be scaled in the allocation routines. For all cases were
2274	! allocation takes place for a single circumference class, scaling
2275	! could be done before the allocation. In the ordinary allocation
2276	! allocation takes place to all circumference classes at the same time.
2277	! Hence scaling takes place in that step for consistency we scale during
2278	! allocation. Note that b_inc (the carbon allocated to an individual
2279	! circumference class cannot be estimates at this point.
2280	IF (bm_alloc_tot(ipts,j).GT.min_stomate) THEN
2281
2282	! There is enough carbon to allocate
2283	b_inc_tot = bm_alloc_tot(ipts,j)
2284
2285	ELSE
2286
2287	! There is so little carbon that it is not worth the hassle
2288	! to allocate. Allocating very small amounts increases the
2289	! risk to run into precision errors.
2290	tmp_bm(ipts,j,ilabile,icarbon) = tmp_bm(ipts,j,ilabile,icarbon) + &
2291	bm_alloc_tot(ipts,j)
2292	b_inc_tot = zero
2293
2294	ENDIF
2295
2296	! Labile carbon is updated in consequence
2297	circ_class_biomass(ipts,j,:,ilabile,icarbon) = &
2298	biomass_to_cc(tmp_bm(ipts,j,ilabile,icarbon),&
2299	circ_class_biomass(ipts,j,:,ilabile,icarbon),&
2300	circ_class_n(ipts,j,:))
2301
2302	END IF
2303
2304	! Intermediate mass balance check. Note that this part of
2305	! the code is in DO-loops over nvm and npts so the
2306	! 'ipts' label is used in the mass balance check
2307	IF(err_act.EQ.4 .AND.is_tree(j)) THEN
2308
2309	! Reset pool_end
2310	pool_end(:,:,:) = zero
2311
2312	! Add bm_alloc_tot into the pool
2313	pool_end(ipts,j,icarbon) = pool_end(ipts,j,icarbon) + &
2314	b_inc_tot * veget_max(ipts,j)
2315
2316	! Check mass balance closure. Between intermediate check 1 and 2a
2317	! bm_inc_tot was recalculated by accounting for the available nitrogen
2318	CALL intermediate_mass_balance_check(pool_start, pool_end, circ_class_biomass, &
2319	circ_class_n, veget_max, bm_alloc_tot, gpp_daily, atm_to_bm, dt, npts, &
2320	resp_maint, resp_growth, check_intern_init, ipts, j, '2a', 'ipft')
2321
2322	END IF ! err_act.EQ.4
2323
2324	! The initial estimate of bm_alloc_tot was high enough to consider allocation
2325	! but after accounting for the available nitrogen bm_alloc_tot may have
2326	! dropped below the min_stomate threshold so it needs to be tested again
2327	IF ( is_tree(j) .AND. bm_alloc_tot(ipts,j) .GT. min_stomate ) THEN
2328
2329	!! 5.2.4 C-allocation for trees
2330	! The mass conservation equations are detailed in the header of this subroutine.
2331	! The scheme assumes a functional relationships between leaves, sapwood and
2332	! roots. When carbon is added to the leaf biomass pool, an increase in the root
2333	! biomass is to be expected to sustain water transport from the roots to the
2334	! leaves. Also sapwood is needed to sustain this water transport and to support
2335	! the leaves.
2336	DO l = 1,ncirc
2337
2338	!! 5.2.4.1 Calculate tree height
2339	circ_class_height_eff(l) = pipe_tune2(j)* &
2340	(4/picirc_class_ba_eff(l))*(pipe_tune3(j)/2)
2341
2342	!! 5.2.4.2 Do the biomass pools respect the pipe model?
2343	! Do the current leaf, sapwood and root components respect the allometric
2344	! constraints? Due to plant phenology it is possible that we have too much
2345	! sapwood compared to the leaf and root mass (i.e. in early spring).
2346	! Calculate the optimal root and leaf mass, given the current wood mass
2347	! by using the basic allometric relationships. Calculate the optimal sapwood
2348	! mass as a function of the current leaf and root mass.
2349	Cl_target(l) = MAX( KF(ipts,j) * Cs(l) / circ_class_height_eff(l), &
2350	Cr(l) * LF(ipts,j) , Cl(l))
2351	Cr_target(l) = MAX( Cl_target(l) / LF(ipts,j), &
2352	Cs(l) * KF(ipts,j) / LF(ipts,j) / circ_class_height_eff(l) , Cr(l))
2353	Cs_target(l) = MAX( Cl(l) / KF(ipts,j) * circ_class_height_eff(l), &
2354	Cr(l) * LF(ipts,j) / KF(ipts,j) * circ_class_height_eff(l) , Cs(l))
2355
2356	! Debug
2357	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
2358	WRITE(numout,*) 'bm_alloc_tot, ', bm_alloc_tot(ipts,j)
2359	WRITE(numout,*) 'Does the tree need reshaping? Class: ',l
2360	WRITE(numout,*) 'circ_class_height_eff, ', circ_class_height_eff(l)
2361	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
2362	WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(l)-Cl(l), Cl_target(l), Cl(l)
2363	WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(l)-Cs(l), Cs_target(l), Cs(l)
2364	WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(l)-Cr(l), Cr_target(l), Cr(l)
2365	ENDIF
2366
2367	!-
2368
2369	!! 5.2.4.2 Check dimensions of the trees
2370	! If Cs = Cs_target then ba and height are correct, else calculate
2371	! the correct dimensions
2372	IF ( Cs_target(l) - Cs(l) .GT. min_stomate ) THEN
2373
2374	! If Cs = Cs_target then dia and height are correct. However,
2375	! if Cl = Cl_target or Cr = Cr_target then dia and height
2376	! need to be re-estimated. Cs_target should satify the relationship
2377	! Cl/Cs = KF/height where height is a function of Cs_target
2378	! Search Cs needed to sustain the max of Cl or Cr.
2379	! Search max of Cl and Cr first
2380	!
2381	! [UPDATE] After the code passes through turnover or mortality
2382	! we may end up in a situation where we have lost more sapwood
2383	! than leaves and roots (i.e. sapwood turnover). The model would
2384	! then suggest that at time=t+1 the tree should be smaller than
2385	! at time=t0. From a physiological standpoint this is not
2386	! possible for the heartwood. If we now calculate Cs_target on
2387	! the basis of Cl or Cr, we find that Cs_target > Cs. The first
2388	! priority of the allocation scheme will be to allocate C to Cs.
2389	! Because we don't know yet whether the actual Cr or Cl is what
2390	! drives the need to allocate to Cs, we calculate Cl_target first.
2391	Cl_target(l) = MAX(Cl(l), Cr(l)*LF(ipts,j))
2392
2393	! Debug
2394	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
2395	WRITE(numout,*) 'Does the tree need reshaping? ipts, class:',ipts, l
2396	WRITE(numout,*) 'circ_class_height_eff, ', circ_class_height_eff(l)
2397	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
2398	WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(l)-Cl(l), Cl_target(l), Cl(l)
2399	WRITE(numout,*) 'Cs, ', Cs(l)
2400	WRITE(numout,*) 'Cs_target', Cs_target(l)
2401	WRITE(numout,*) 'Cr, ', Cr(l)
2402	WRITE(numout,*) 'Ch, ', Ch(l)
2403	ENDIF
2404	!-
2405
2406	! We now have the Cl_target that we will use to calculate
2407	! Cs_target. Given the allometric relationships we can
2408	! calculate Cs_target as Cl_target*height/KF.
2409	! height is a function of ba, which in turn is a function
2410	! of woodmass (Woodmass = Cs+Ch (sapwood+heartwood) ). We
2411	! therefore substitute the following equations into one another:
2412	!
2413	! (1) Cs_target = Cl_target*height/KF
2414	! (2) height = as a function of ba
2415	! (3) ba = as a function of woodmass_ind
2416	!
2417	! This gives:
2418	!
2419	! (4) Cl_target = (KFCs_target)/(pipe_tune2(Cs_target+Ch)/ &
2420	! & pi/4)**(pipe_tune3/(2+pipe_tune3))
2421	!
2422	! The function newX searches for the value for Cs_target
2423	! that satisfies this equation (4).
2424	Cs_target(l) = newX(KF(ipts,j), Ch(l), pipe_tune2(j), &
2425	pipe_tune3(j), Cl_target(l), Cs_target(l), &
2426	tree_ff(j)pipe_density(j)pi/4*pipe_tune2(j), &
2427	Cs(l), 2*Cs(l), 2, j, ipts)
2428
2429	! Recalculate height and ba from the correct Cs_target
2430	circ_class_height_eff(l) = Cs_target(l)*KF(ipts,j)/Cl_target(l)
2431	circ_class_ba_eff(l) = pi/4*(circ_class_height_eff(l)/ &
2432	pipe_tune2(j))**(2/pipe_tune3(j))
2433	Cl_target(l) = KF(ipts,j) * Cs_target(l) / circ_class_height_eff(l)
2434	Cr_target(l) = Cl_target(l) / LF(ipts,j)
2435
2436	ENDIF
2437
2438	! Debug
2439	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
2440	WRITE(numout,*) 'Target values were adjusted if needed, ',ipts,j,l
2441	WRITE(numout,*) 'height_fin, ba_fin, ', circ_class_height_eff(l), &
2442	circ_class_ba_eff(l)
2443	WRITE(numout,*) 'Cl_target, Cs_target, Cr_target, ', Cl_target(l), &
2444	Cs_target(l), Cr_target(l)
2445	WRITE(numout,*) 'New target values'
2446	WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(l)-Cl(l), Cl_target(l), Cl(l)
2447	WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(l)-Cs(l), Cs_target(l), Cs(l)
2448	WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(l)-Cr(l), Cr_target(l), Cr(l)
2449	ENDIF
2450	!-
2451
2452	ENDDO !ncirc
2453
2454	! The step estimate is used to linearalize the diameter vs height
2455	! relationship. Use a prior to distribute b_inc_tot over the individual
2456	! trees. The share of the total sapwood mass is used as a prior.
2457	! Subsequently, estimate the change in diameter by assuming all the
2458	! available C for allocation will be used in Cs. Hence, this represents
2459	! the maximum possible diameter increase. It was not tested whether
2460	! this is the best prior but it seems to work OK although it often
2461	! results in very small (1e-8) negative values, with even more rare
2462	! 1e-6 negative values. A C-balance closure check could reveal
2463	! whether this is a real issue and requires to change the prior or not.
2464	! Calculate the linear slope (::s) of the relationship between ba and h as
2465	! (1) s = (ba2-ba)/(height2-height).
2466	! The goal is to approximate the ba2 that is predicted through the
2467	! non-linear ordinary allocation approach, as this will keep the
2468	! trees in allometric balance. In the next time step, allometric
2469	! balance is recalculated and can be corrected through the so-called
2470	! phenological growth; hence, small deviations resulting from the
2471	! linearization will not accumulate with time.
2472	! Note that ba2 = ba + delta_ba and that height and ba are related as
2473	! (2) height = k2(4ba/pi)**(k3/2)
2474	! At this stage the only information we have is that there is b_inc_tot
2475	! (gC m-2) available for allocation. There are two obvious approximations
2476	! both making use of the same assumption, i.e. that for the initial
2477	! estimate of delta_ba height is constant. The first approximation is
2478	! crude and assumes that all the available C is used in Cs_inc
2479	! (thus Cs_inc = b_inc_tot / ind ). The second approximation,
2480	! implemented here, makes use of the allometric rules and thus accounts
2481	! for the knowledge that allocating one unit the sapwood comes with a cost
2482	! in leaves and roots thus:
2483	! b_inc_temp = Cs_inc+Cl_inc+Cr_inc
2484	! (3) <=> b_inc_temp ~= (Cs_inc_est+Cs) + KF*(Cs_inc_est+Cs)/H + ...
2485	! KF/LF*(Cs_inc_est+Cs)/H - Cs - Cl - Cr
2486	! b_inc_temp is the amount of carbon that can be allocated to each diameter
2487	! class. However, only the total amount i.e. b_inc_tot is known. Total
2488	! allocatable carbon is distributed over the different diameter classes
2489	! proportional to their share of the total wood biomass. Divide by
2490	! circ_class_n to get the correct units (gC tree-1)
2491	! (4) b_inc_temp ~= b_inc_tot / circ_class_n * (circ_class_n * ba**(1+k3)) / ...
2492	! sum(circ_class_n * ba**(1+k3))
2493	! By substituting (4) in (3) an expression is obtained to approximate the
2494	! carbon that will be allocated to sapwood growth per diameter class
2495	! ::Cs_inc_est. This estimate is then used to calculate delta_ba
2496	! (called ::step)
2497	! step = (Cs+Ch+Cs_inc_set)/(tree_ffpipe_densityheight) - ba
2498	! where height is calculated from (2) after replacing ba by ba+delta_ba
2499
2500	! Keep it simple - as described in the documentation
2501	! Cs_inc_est(:) = ( b_inc_tot / circ_class_n(ipts,j,:) * &
2502	! (circ_class_n(ipts,j,:) * circ_class_ba_eff(:)**(un+pipe_tune3(j))) / &
2503	! (SUM(circ_class_n(ipts,j,:) * circ_class_ba_eff(:)**(un+pipe_tune3(j)))))
2504
2505	! We implemented a more precise approach following the same principles
2506	Cs_inc_est(:) = ( b_inc_tot / circ_class_n(ipts,j,:) * &
2507	(circ_class_n(ipts,j,:) * circ_class_ba_eff(:)**(un+pipe_tune3(j))) / &
2508	(SUM(circ_class_n(ipts,j,:) * circ_class_ba_eff(:)**(un+pipe_tune3(j)))) + &
2509	Cs(:) + Cl(:) + Cr(:)) * circ_class_height_eff(:) / &
2510	(circ_class_height_eff(:) + KF(ipts,j) + KF(ipts,j)/LF(ipts,j)) - Cs(:)
2511	step(:) = ((Ch(:)+Cs(:)+Cs_inc_est(:)) / (tree_ff(j)pipe_density(j) &
2512	circ_class_height_eff(:))) - circ_class_ba_eff(:)
2513
2514	! Debug
2515	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
2516	WRITE(numout,*) 'ipts, j, ', ipts, j
2517	WRITE(numout,*) 'initial guess for step, ', step(:)
2518	END IF
2519
2520	! It can happen that step is equal to zero sometimes. I'm not sure why, but
2521	! there was a case where it was nonzero for circ classes 1 and 3, and zero
2522	! for 2. This causes s to be zero and provokes a divide by zero error later
2523	! on. What if we make it not zero? This might cause a small mass balance
2524	! error for this timestep, but I would rather have that than getting an
2525	! infinite biomass, which is what happened in the other case. These limits
2526	! are arbitrary and adjusted by hand. If the output file doesn't show this
2527	! warning very often, I think we're okay, since the amount of carbon is really
2528	! small.
2529	DO l=1,ncirc
2530	IF(step(l) .LT. min_stomate*0.01 .AND. step(l) .GE. zero)THEN
2531	step(l)=min_stomate*0.02
2532	IF (printlev_loc.GE.4) THEN
2533	WRITE(numout,*) 'WARNING: Might cause mass balance problems '//&
2534	'in fun_all, position 1'
2535	WRITE(numout,*) 'WARNING: ipts,j ',ipts,j
2536	END IF
2537	ELSEIF(step(l) .GT. -min_stomate*0.01 .AND. step(l) .LT. zero)THEN
2538	step(l)=-min_stomate*0.02
2539	IF (printlev_loc.GE.4) THEN
2540	WRITE(numout,*) 'WARNING: Might cause mass balance problems '//&
2541	'in fun_all, position 2'
2542	WRITE(numout,*) 'WARNING: ipts,j ',ipts,j
2543	END IF
2544	ENDIF
2545	ENDDO
2546	s(:) = step(:)/(pipe_tune2(j)(4.0_r_std/pi(circ_class_ba_eff(:)+step(:)))**&
2547	(pipe_tune3(j)/deux) - &
2548	pipe_tune2(j)(4.0_r_std/picirc_class_ba_eff(:))**(pipe_tune3(j)/deux))
2549
2550	! Debug
2551	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
2552	WRITE(numout,*) 'ipts, j, ', ipts, j
2553	WRITE(numout,*) 'final value for step, ', step(:)
2554	WRITE(numout,*) 's, ', s(:)
2555	END IF
2556
2557	!! 5.2.4.3 Phenological growth
2558	! Phenological growth and reshaping of the tree in line with the pipe model.
2559	! Turnover removes C from the different plant components but at a
2560	! component-specific rate, as such the allometric constraints are distorted
2561	! at every time step and should be restored before ordinary growth can
2562	! take place
2563	l = ncirc
2564	DO WHILE ((l .GT. zero) .AND. (b_inc_tot .GT. min_stomate))
2565
2566	!! 5.2.4.3.1 The available wood can sustain the available leaves and roots
2567	! Calculate whether the wood is in allometric balance. The target values
2568	! should always be larger than the current pools so the use of ABS is
2569	! redundant but was used to be on the safe side (here and in the rest
2570	! of the module) as it could help to find logical flaws.
2571	IF ( ABS(Cs_target(l) - Cs(l)) .LT. min_stomate ) THEN
2572
2573	! Use the difference between the target and the actual to
2574	! ensure mass balance closure because l times a values
2575	! smaller than min_stomate can still add up to a value
2576	! exceeding min_stomate.
2577	Cs_incp(l) = MAX(zero, Cs_target(l) - Cs(l))
2578
2579	! Enough leaves and wood, only grow roots
2580	IF ( ABS(Cl_target(l) - Cl(l)) .LT. min_stomate ) THEN
2581
2582	! Allocate at the tree level to restore allometric balance
2583	! Some carbon may have been used for Cs_incp and Cl_incp
2584	! adjust the total allocatable carbon
2585	Cl_incp(l) = MAX(zero, Cl_target(l) - Cl(l))
2586	Cr_incp(l) = MAX( MIN(b_inc_tot / circ_class_n(ipts,j,l) - &
2587	Cs_incp(l) - Cl_incp(l), Cr_target(l) - Cr(l)), zero )
2588
2589	! Write debug comments to output file
2590	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
2591	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2592	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2593	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
2594	circ_class_n, 1)
2595	ENDIF
2596
2597	! Sufficient wood and roots, allocate C to leaves
2598	ELSEIF ( ABS(Cr_target(l) - Cr(l)) .LT. min_stomate ) THEN
2599
2600	! Allocate at the tree level to restore allometric balance
2601	! Some carbon may have been used for Cs_incp and Cr_incp
2602	! adjust the total allocatable carbon
2603	Cr_incp(l) = MAX(zero, Cr_target(l) - Cr(l))
2604	Cl_incp(l) = MAX( MIN(b_inc_tot / circ_class_n(ipts,j,l) - &
2605	Cs_incp(l) - Cr_incp(l), Cl_target(l) - Cl(l)), zero )
2606
2607	! Write debug comments to output file
2608	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
2609	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2610	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2611	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
2612	grow_wood, circ_class_n, 2)
2613	ENDIF
2614
2615	! Both leaves and roots are needed to restore the allometric relationships
2616	ELSEIF ( ABS(Cl_target(l) - Cl(l)) .GT. min_stomate .AND. &
2617	ABS(Cr_target(l) - Cr(l)) .GT. min_stomate ) THEN
2618
2619	! Allocate at the tree level to restore allometric balance
2620	! The equations can be rearanged and written as
2621	! (i) b_inc = Cl_inc + Cr_inc
2622	! (ii) Cr_inc = (Cl_inc+Cl)/LF - Cr
2623	! Substitue (ii) in (i) and solve for Cl_inc
2624	! <=> Cl_inc = (LF*(b_inc+Cr)-Cl)/(1+LF)
2625	Cl_incp(l) = MIN( ((LF(ipts,j) * ((b_inc_tot/circ_class_n(ipts,j,l) - &
2626	Cs_incp(l)) + Cr(l))) - Cl(l)) / &
2627	(1 + LF(ipts,j)), Cl_target(l) - Cl(l) )
2628	Cr_incp(l) = MIN ( ((Cl_incp(l) + Cl(l)) / LF(ipts,j)) - Cr(l), &
2629	Cr_target(l) - Cr(l))
2630
2631	! The imbalance between Cr and Cl can be so big that (Cl+Cl_inc)/LF
2632	! is still less then the available root carbon (observed!). This would
2633	! result in a negative Cr_incp
2634	IF ( Cr_incp(l) .LT. zero ) THEN
2635
2636	Cl_incp(l) = MIN( b_inc_tot/circ_class_n(ipts,j,l) - Cs_incp(l), &
2637	Cl_target(l) - Cl(l) )
2638	Cr_incp(l) = (b_inc_tot/circ_class_n(ipts,j,l)) - Cs_incp(l) - &
2639	Cl_incp(l)
2640
2641	ELSEIF (Cl_incp(l) .LT. zero) THEN
2642
2643	Cr_incp(l) = MIN( b_inc_tot/circ_class_n(ipts,j,l) - Cs_incp(l), &
2644	Cr_target(l) - Cr(l) )
2645	Cl_incp(l) = (b_inc_tot/circ_class_n(ipts,j,l)) - &
2646	Cs_incp(l) - Cr_incp(l)
2647
2648	ENDIF
2649
2650	! Write debug comments to output file
2651	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
2652	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2653	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2654	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
2655	grow_wood, circ_class_n, 3)
2656	ENDIF
2657
2658	ELSE
2659
2660	WRITE(numout,*) 'Exc 1-3: unexpected exception'
2661	IF(err_act.GT.1)THEN
2662	CALL ipslerr_p (3,'growth_fun_all',&
2663	'Exc 1-3: unexpected exception','','')
2664	ENDIF
2665
2666	ENDIF
2667
2668	!! 5.2.4.3.2 Enough leaves to sustain the wood and roots
2669	ELSEIF ( ABS(Cl_target(l) - Cl(l)) .LT. min_stomate ) THEN
2670
2671	! Use the difference between the target and the actual to
2672	! ensure mass balance closure because l times a values
2673	! smaller than min_stomate can still add up to a value
2674	! exceeding min_stomate.
2675	Cl_incp(l) = MAX(zero, Cl_target(l) - Cl(l))
2676
2677	! Enough leaves and wood, only grow roots
2678	! This duplicates Exc 1 and these lines should never be called
2679	IF ( ABS(Cs_target(l) - Cs(l)) .LT. min_stomate ) THEN
2680
2681	! Allocate at the tree level to restore allometric balance
2682	! Some carbon may have been used for Cs_incp and Cl_incp
2683	! adjust the total allocatable carbon
2684	Cs_incp(l) = MAX(zero, ABS(Cs_target(l) - Cs(l)))
2685	Cr_incp(l) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,l) - &
2686	Cl_incp(l) - Cs_incp(l), Cr_target(l) - Cr(l)), zero )
2687
2688	! Write debug comments to output file
2689	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
2690	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2691	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2692	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
2693	circ_class_n, 4)
2694	ENDIF
2695
2696	! Enough leaves and roots. Need to grow sapwood to support the available
2697	! canopy and roots
2698	ELSEIF ( ABS(Cr_target(l) - Cr(l)) .LT. min_stomate ) THEN
2699
2700	! In truth, there might be a little root carbon to allocate here,
2701	! since min_stomate is not equal to zero. If there is
2702	! enough of this small carbon in every circ class, and there
2703	! are enough circ classes, ordinary allocation will be skipped
2704	! below and we might try to force allocation, which is silly
2705	! if the different in the root masses is around 1e-8. This
2706	! means we will allocate a tiny amount to the roots to make
2707	! sure they are exactly in balance.
2708	Cr_incp(l) = MAX(zero, ABS(Cr_target(l) - Cr(l)))
2709	Cs_incp(l) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,l) - &
2710	Cl_incp(l) - Cr_incp(l), Cs_target(l) - Cs(l)), zero )
2711
2712	! Write debug comments to output file
2713	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
2714	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2715	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2716	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
2717	grow_wood, circ_class_n, 5)
2718	ENDIF
2719
2720	! Need both wood and roots to restore the allometric relationships
2721	ELSEIF ( ABS(Cs_target(l) - Cs(l) ) .GT. min_stomate .AND. &
2722	ABS(Cr_target(l) - Cr(l)) .GT. min_stomate ) THEN
2723
2724	! circ_class_ba_eff and circ_class_height_eff are already calculated
2725	! for a tree in balance. It would be rather complicated to follow
2726	! the allometric rules for wood allocation (implying changes in height
2727	! and basal area) because the tree is not in balance yet. First try
2728	! if we can simply satisfy the allocation needs
2729	IF (Cs_target(l) - Cs(l) + Cr_target(l) - Cr(l) .LE. &
2730	b_inc_tot/circ_class_n(ipts,j,l) - Cl_incp(l)) THEN
2731
2732	Cr_incp(l) = Cr_target(l) - Cr(l)
2733	Cs_incp(l) = Cs_target(l) - Cs(l)
2734
2735	! Try to satisfy the need for roots
2736	ELSEIF (Cr_target(l) - Cr(l) .LE. b_inc_tot/circ_class_n(ipts,j,l) - &
2737	Cl_incp(l)) THEN
2738
2739	Cr_incp(l) = Cr_target(l) - Cr(l)
2740	Cs_incp(l) = b_inc_tot/circ_class_n(ipts,j,l) - &
2741	Cl_incp(l) - Cr_incp(l)
2742
2743	! There is not enough use whatever is available
2744	ELSE
2745
2746	Cr_incp(l) = b_inc_tot/circ_class_n(ipts,j,l) - Cl_incp(l)
2747	Cs_incp(l) = zero
2748
2749	ENDIF
2750
2751	! Write debug comments to output file
2752	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
2753	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2754	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2755	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
2756	circ_class_n, 6)
2757	ENDIF
2758
2759	ELSE
2760
2761	WRITE(numout,*) 'Exc 4-6: unexpected exception'
2762	IF(err_act.GT.1)THEN
2763	CALL ipslerr_p (3,'growth_fun_all',&
2764	'Exc 4-6: unexpected exception','','')
2765	ENDIF
2766
2767	ENDIF
2768
2769	!! 5.2.4.3.3 Enough roots to sustain the wood and leaves
2770	ELSEIF ( ABS(Cr_target(l) - Cr(l)) .LT. min_stomate ) THEN
2771
2772	! Use the difference between the target and the actual to
2773	! ensure mass balance closure because l times a values
2774	! smaller than min_stomate can still add up to a value
2775	! exceeding min_stomate.
2776	Cr_incp(l) = MAX(zero, Cr_target(l) - Cr(l))
2777
2778	! Enough roots and wood, only grow leaves
2779	! This duplicates Exc 2 and these lines should thus never be called
2780	IF ( ABS(Cs_target(l) - Cs(l)) .LT. min_stomate ) THEN
2781
2782	! Allocate at the tree level to restore allometric balance
2783	Cs_incp(l) = MAX(zero, Cs_target(l) - Cs(l))
2784	Cl_incp(l) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,l) - &
2785	Cs_incp(l) - Cr_incp(l), &
2786	Cl_target(l) - Cl(l)), zero )
2787
2788	! Write debug comments to output file
2789	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
2790	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2791	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2792	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
2793	circ_class_n, 7)
2794	ENDIF
2795	! Enough leaves and roots. Need to grow sapwood to support the
2796	! available canopy and roots. Duplicates Exc. 4 and these lines
2797	! should thus never be called
2798	ELSEIF ( ABS(Cl_target(l) - Cl(l)) .LT. min_stomate ) THEN
2799
2800	! Allocate at the tree level to restore allometric balance
2801	Cl_incp(l) = MAX(zero, Cl_target(l) - Cl(l))
2802	Cs_incp(l) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,l) - &
2803	Cr_incp(l) - Cl_incp(l), Cs_target(l) - Cs(l) ), zero )
2804
2805	! Write debug comments to output file
2806	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
2807	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2808	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2809	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
2810	circ_class_n, 8)
2811	ENDIF
2812
2813	! Need both wood and leaves to restore the allometric relationships
2814	ELSEIF ( ABS(Cs_target(l) - Cs(l)) .GT. min_stomate .AND. &
2815	ABS(Cl_target(l) - Cl(l)) .GT. min_stomate ) THEN
2816
2817	! circ_class_ba_eff and circ_class_height_eff are already calculated
2818	! for a tree in balance. It would be rather complicated to follow
2819	! the allometric rules for wood allocation (implying changes in height
2820	! and basal area) because the tree is not in balance.First try if we
2821	! can simply satisfy the allocation needs
2822	IF (Cs_target(l) - Cs(l) + Cl_target(l) - Cl(l) .LE. &
2823	b_inc_tot/circ_class_n(ipts,j,l) - Cr_incp(l)) THEN
2824
2825	Cl_incp(l) = Cl_target(l) - Cl(l)
2826	Cs_incp(l) = Cs_target(l) - Cs(l)
2827
2828	! Try to satisfy the need for leaves
2829	ELSEIF (Cl_target(l) - Cl(l) .LE. b_inc_tot/circ_class_n(ipts,j,l) - &
2830	Cr_incp(l)) THEN
2831
2832	Cl_incp(l) = Cl_target(l) - Cl(l)
2833	Cs_incp(l) = b_inc_tot/circ_class_n(ipts,j,l) - &
2834	Cr_incp(l) - Cl_incp(l)
2835
2836	! There is not enough use whatever is available
2837	ELSE
2838
2839	Cl_incp(l) = b_inc_tot/circ_class_n(ipts,j,l) - Cr_incp(l)
2840	Cs_incp(l) = zero
2841
2842	ENDIF
2843
2844	! Write debug comments to output file
2845	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
2846	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2847	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2848	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
2849	circ_class_n, 9)
2850	ENDIF
2851
2852	ELSE
2853
2854	WRITE(numout,*) 'Exc 7-9: unexpected exception'
2855	IF(err_act.GT.1)THEN
2856	CALL ipslerr_p (3,'growth_fun_all',&
2857	'Exc 7-9: unexpected exception','','')
2858	ENDIF
2859
2860	ENDIF
2861
2862
2863	ELSE
2864
2865	! Either Cl_target, Cs_target or Cr_target should be zero
2866	! Something possibly important was overlooked
2867	WRITE(numout,*) 'WARNING 4: logical flaw in the phenological '//&
2868	'allocation, PFT, class: ', j, l
2869	WRITE(numout,*) 'WARNING 4: PFT, ipts: ',j,ipts
2870	WRITE(numout,*) 'Cs - Cs_target', Cs(l), Cs_target(l)
2871	WRITE(numout,*) 'Cl - Cl_target', Cl(l), Cl_target(l)
2872	WRITE(numout,*) 'Cr - Cr_target', Cr(l), Cr_target(l)
2873	IF(err_act.GT.1)THEN
2874	CALL ipslerr_p (3,'growth_fun_all',&
2875	'WARNING 4: logical flaw in the phenological allocation','','')
2876	ENDIF
2877
2878	ENDIF
2879
2880	IF ( Cl_incp(l) .GE. zero .OR. Cr_incp(l) .GE. zero .OR. &
2881	Cs_incp(l) .GE. zero) THEN
2882
2883	! Prevent overspending for leaves
2884	IF (b_inc_tot - circ_class_n(ipts,j,l) * Cl_incp(l) .LT. zero) THEN
2885	Cl_incp(l) = b_inc_tot/circ_class_n(ipts,j,l)
2886	ENDIF
2887	b_inc_tot = MAX(zero,b_inc_tot - circ_class_n(ipts,j,l) * Cl_incp(l))
2888
2889	! Prevent overspending for roots
2890	IF (b_inc_tot - circ_class_n(ipts,j,l) * Cr_incp(l) .LT. zero) THEN
2891	Cr_incp(l) = b_inc_tot/circ_class_n(ipts,j,l)
2892	ENDIF
2893	b_inc_tot = MAX(zero,b_inc_tot - circ_class_n(ipts,j,l) * Cr_incp(l))
2894
2895	! Prevent overspending for sapwood
2896	IF (b_inc_tot - circ_class_n(ipts,j,l) * Cs_incp(l) .LT. zero) THEN
2897	Cs_incp(l) = b_inc_tot/circ_class_n(ipts,j,l)
2898	ENDIF
2899	b_inc_tot = MAX(zero,b_inc_tot - circ_class_n(ipts,j,l) * Cs_incp(l))
2900
2901	! Fake allocation for less messy equations in next case,
2902	! incp needs to be added to inc at the end.
2903	Cl(l) = Cl(l) + Cl_incp(l)
2904	Cr(l) = Cr(l) + Cr_incp(l)
2905	Cs(l) = Cs(l) + Cs_incp(l)
2906
2907	IF (b_inc_tot .LT. zero) THEN
2908	WRITE(numout,*) 'WARNING 5: numerical problem, '//&
2909	'overspending in phenological allocation'
2910	WRITE(numout,*) 'WARNING 5: PFT, ipts: ',j,ipts
2911	WRITE(numout,*) 'b_inc_tot, ',b_inc_tot
2912	WRITE(numout,*) 'Cl_incp(l), Cr_incp(l), Cs_incp(l), ', &
2913	l, Cl_incp(l), Cr_incp(l), Cs_incp(l)
2914	CALL ipslerr_p (3,'growth_fun_all',&
2915	'WARNING 5: numerical problem, overspending in',&
2916	'phenological allocation','')
2917	ENDIF
2918
2919	ELSE
2920
2921	! The code was written such that the increment pools should be
2922	! greater than or equal to zero. If this is not the case, something
2923	! fundamental is wrong with the if-then constructs under Â§5.2.4.3
2924	WRITE(numout,*) 'WARNING 6: PFT, ipts: ',j,ipts
2925	CALL ipslerr_p (3,'growth_fun_all',&
2926	'WARNING 6: numerical problem,',&
2927	'one of the increment pools is less than zero','')
2928	ENDIF
2929
2930	! Set counter for next circumference class
2931	l = l-1
2932
2933	ENDDO ! DO WHILE l.GE.1 .AND. b_inc_tot .GT. min_stomate
2934
2935	! Intermediate mass balance check. Note that this part of
2936	! the code is in DO-loops over nvm and npts so the
2937	! 'ipts' label is used in the mass balance check
2938	IF(err_act.EQ.4) THEN
2939
2940	! Reset pool_end
2941	pool_end(:,:,:) = zero
2942
2943	! Add allocated pools to pool_end
2944	pool_end(ipts,j,icarbon) = pool_end(ipts,j,icarbon) + &
2945	(SUM((Cl_incp(:) + Cs_incp(:) + Cr_incp(:)) * circ_class_n(ipts,j,:)) + &
2946	b_inc_tot) * veget_max(ipts,j)
2947
2948	! Check mass balance closure. Between intermediate check 2a and 2b
2949	! phenological allocation was accounted for.
2950	CALL intermediate_mass_balance_check(pool_start, pool_end, circ_class_biomass, &
2951	circ_class_n, veget_max, bm_alloc_tot, gpp_daily, atm_to_bm, dt, npts, &
2952	resp_maint, resp_growth, check_intern_init, ipts, j, '2b', 'ipft')
2953
2954	END IF ! err_act.EQ.4
2955
2956	!! 5.2.4 Record basal area growth during phenological growth
2957	! During phenological growth, some carbon may have been allocated
2958	! to the sapwood which then resulted in an increase in basal area
2959	! This increase in basal area has not been recorded yet. This
2960	! is done below. Later in the code, this increase is then added to
2961	! the increase in basal area due to ordinary growth to obtain the
2962	! total increase which is an output variable and is used to
2963	! calculate the tree ring width.
2964	ba1(:) = wood_to_ba_eff(circ_class_biomass(ipts,j,:,:,icarbon),j)
2965	temp_mass(:,:) = circ_class_biomass(ipts,j,:,:,icarbon)
2966	temp_mass(:,isapabove) = temp_mass(:,isapabove) + Cs_incp(:)
2967	ba2(:) = wood_to_ba_eff(temp_mass,j)
2968	store_delta_ba_eff(ipts,j,:) = ba2(:) - ba1(:)
2969
2970	!! 5.2.5 Calculate the expected size of the reserve pool
2971	! Reserve and labile pools are calculated at the stand level so
2972	! first calculate the stand level biomass from the tree level
2973	! biomass and the number of trees. Note that this value might
2974	! be different from the previous values calculated in biomass
2975	! because phenological growth could have increased the
2976	! sapwood biomass.
2977	tmp_bm(ipts,j,:,:) = cc_to_biomass(ipts,j,&
2978	circ_class_biomass(ipts,j,:,:,:),&
2979	circ_class_n(ipts,j,:))
2980
2981	! use the minimum of either (1) 2% of the total sapwood biomass
2982	! or (2) the amount of carbon needed to develop the optimal LAI
2983	! and the roots. This reserve pool estimate is only used to decide
2984	! whether wood should be grown or not. When really dealing with
2985	! the reserves the reserve pool is recalculated (and the fraction
2986	! is 12% rather than the 2% used here). See further below Â§7.1.
2987	reserve_target(ipts,j,icarbon) = &
2988	MIN( 0.02 * ( tmp_bm(ipts,j,isapabove,icarbon) + &
2989	tmp_bm(ipts,j,isapbelow,icarbon)), &
2990	lai_to_biomass(lai_target(ipts,j),j) * &
2991	(1.+root_reserve(j)/ltor(ipts,j)))
2992	grow_wood = .TRUE.
2993
2994	! If the carbohydrate pool is too small, don't grow wood
2995	IF ( (pheno_type(j) .NE. 1) .AND. &
2996	(tmp_bm(ipts,j,icarbres,icarbon) .LE. reserve_target(ipts,j,icarbon)) ) THEN
2997	grow_wood = .FALSE.
2998	! Debug
2999	IF(printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft)THEN
3000	WRITE(numout,*) 'Not enough carbres to develop the optimal LAI ',j,ipts
3001	WRITE(numout,*) 'Reserve pool:',tmp_bm(ipts,j,icarbres,icarbon)
3002	ENDIF
3003	!-
3004	ENDIF
3005
3006	! Write debug comments to output file
3007	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
3008	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
3009	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
3010	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
3011	circ_class_n, 10)
3012	ENDIF
3013
3014	!! 5.2.6 Ordinary growth
3015	! Allometric relationship between components is respected, sustain
3016	! ordinary growth and allocate biomass to leaves, wood, roots and
3017	! fruits.
3018	IF ( (SUM(ABS(Cl_target(:)-Cl(:))) .LE. min_stomate) .AND. &
3019	(SUM(ABS(Cr_target(:)-Cr(:))) .LE. min_stomate) .AND. &
3020	(SUM(ABS(Cs_target(:)-Cs(:))) .LE. min_stomate) .AND. &
3021	grow_wood .AND. b_inc_tot .GT. min_stomate ) THEN
3022
3023	! Allocate fraction of carbon to fruit production (at the tree level)
3024	Cf_inc(:) = b_inc_tot / SUM(circ_class_n(ipts,j,:)) * fruit_alloc(j)
3025
3026	! Residual carbon is allocated to the other components (b_inc_tot is
3027	! at the stand level)
3028	b_inc_tot = b_inc_tot * (un-fruit_alloc(j))
3029
3030	! Substitute (7), (8) and (9) in (1)
3031	! b_inc = tree_ffpipe_density(ba+circ_class_dbagammas)...
3032	! (height+(circ_class_dba/s*gammas)) - Cs - Ch + ...
3033	! KFtree_ffpipe_density(ba+circ_class_dbagammas) - ...
3034	! (KFCh)/(height+(circ_class_dba/sgammas)) - Cl + ...
3035	! KF/LFtree_ffpipe_density(ba+circ_class_dbagammas) - ...
3036	! (KFCh/LF)/(height+(circ_class_dba/sgammas)) - Cr
3037	!
3038	! b_inc+Cs+Ch+Cl+Cr = tree_ffpipe_density(ba+circ_class_dbagammas)...
3039	! (height+(circ_class_dba/s*gammas)) + ...
3040	! KFtree_ffpipe_density(ba+circ_class_dbagammas) - ...
3041	! (KFCh)/(height+(circ_class_dba/sgammas)) + ...
3042	! KF/LFtree_ffpipe_density(ba+circ_class_dbagammas) - ...
3043	! (KFCh/LF)/(height+(circ_class_dba/sgammas))
3044	! <=> b_inc+Cs+Ch+Cl+Cr = circ_class_dba^2/stree_ff...
3045	! pipe_densitygammas^2 + circ_class_dba/sbatree_ff...
3046	! pipe_density*gammas + ...
3047	! circ_class_dbaheighttree_ffpipe_densitygammas + ...
3048	! bcirc_class_dbaheighttree_ff*pipe_density - ...
3049	! (ChKFs)/(circ_class_dbagammas+heights) + ...
3050	! circ_class_dbaKFtree_ffpipe_densitygammas + ...
3051	! baKFtree_ff*pipe_density - ...
3052	! (ChKFs)/(LF(circ_class_dbagammas+height*s)) + ...
3053	! circ_class_dbaKF/LFtree_ffpipe_densitygammas + ...
3054	! baKF/LFtree_ff*pipe_density
3055	! (10) b_inc+Cs+Ch+Cl+Cr = (circ_class_dba^2/stree_ff...
3056	! pipe_density)*gammas^2 + ...
3057	! (circ_class_dba/sbatree_ff*pipe_density + ...
3058	! circ_class_dbaheighttree_ff*pipe_density + ...
3059	! circ_class_dbaKFtree_ff*pipe_density + ...
3060	! circ_class_dbaKF/LFtree_ffpipe_density)gammas - ...
3061	! (ChKFs)(1+1/LF)/(circ_class_dbagammas+heights) + ...
3062	! bcirc_class_dbaheighttree_ff*pipe_density + ...
3063	! baKFtree_ffpipe_density + baKF/LFtree_ffpipe_density
3064	!
3065	! Note that b_inc is not known, only b_inc_tot (= sum(b_inc) is known.
3066	! The above equations are for individual trees, at the stand level we
3067	! have to take the sum over the individuals which is
3068	! equivalant to substituting (10) in (2)
3069	! (11) sum(b_inc) + sum(Cs+Ch+Cl+Cr) = ...
3070	! sum(circ_class_dba^2/stree_ffpipe_density) * gammas^2 + ...
3071	! sum(circ_class_dba/sbatree_ff*pipe_density + ...
3072	! circ_class_dbaheighttree_ff*pipe_density + ...
3073	! circ_class_dbaKFtree_ff*pipe_density + ...
3074	! circ_class_dbaKF/LFtree_ffpipe_density) gammas - ...
3075	! sum[(ChKFs)(1+1/LF)/(circ_class_dbagammas+heights)] + ...
3076	! sum(bcirc_class_dbaheighttree_ff*pipe_density + ...
3077	! baKFtree_ffpipe_density + baKF/LFtree_ffpipe_density)
3078	!
3079	! The term sum[(ChKFs)(1+1/LF)/(circ_class_dbagammas+heights)]
3080	! can be approximated by a series expansion
3081	! (12) sum((ChKFs)(1+1/LF)/(height*s) + ...
3082	! sum((ChKFs)(1+1/LF)circ_class_dba/(heights)^2)*gammas + ...
3083	! sum((ChKFs)(1+1/LF)circ_class_dba^2/(heights)^3)*gammas^2
3084	!
3085	! Substitute (12) in (11)
3086	! sum(b_inc) + sum(Cs+Ch+Cl+Cr) = ...
3087	! sum(circ_class_dba^2/stree_ffpipe_density - ...
3088	! (ChKFs)(1+1/LF)circ_class_dba^2/(heights)^3) gammas^2 + ...
3089	! sum(circ_class_dba/sbatree_ff*pipe_density + ...
3090	! circ_class_dbaheighttree_ff*pipe_density + ...
3091	! circ_class_dbaKFtree_ff*pipe_density + ...
3092	! circ_class_dbaKF/LFtree_ff*pipe_density + ...
3093	! (ChKFs)(1+1/LF)circ_class_dba/(heights)^2) gammas + ...
3094	! sum(bcirc_class_dbaheighttree_ff*pipe_density + ...
3095	! baKFtree_ffpipe_density + baKF/LFtree_ffpipe_density - ...
3096	! (ChKFs)(1+1/LF)/(heights))
3097	!
3098	! Solve this quadratic equation for gammas.
3099	a = SUM( circ_class_n(ipts,j,:) * &
3100	(circ_class_dba(:)*2/s(:)tree_ff(j)*pipe_density(j) - &
3101	(Ch(:)KF(ipts,j)s(:))(1+1/LF(ipts,j))&
3102	(circ_class_dba(:)*2/(circ_class_height_eff(:)s(:))**3)) )
3103	b = SUM( circ_class_n(ipts,j,:) * &
3104	(circ_class_dba(:)/s(:)circ_class_ba_eff(:)tree_ff(j)*pipe_density(j) + &
3105	circ_class_dba(:)circ_class_height_eff(:)tree_ff(j)*pipe_density(j) + &
3106	circ_class_dba(:)KF(ipts,j)tree_ff(j)*pipe_density(j) + &
3107	circ_class_dba(:)KF(ipts,j)/LF(ipts,j)tree_ff(j)*pipe_density(j) + &
3108	(Ch(:)KF(ipts,j)s(:))(1+1/LF(ipts,j))circ_class_dba(:)/&
3109	(circ_class_height_eff(:)s(:))*2) )
3110	c = SUM( circ_class_n(ipts,j,:) * &
3111	(circ_class_ba_eff(:)circ_class_height_eff(:)&
3112	tree_ff(j)*pipe_density(j) + &
3113	circ_class_ba_eff(:)KF(ipts,j)tree_ff(j)*pipe_density(j) + &
3114	circ_class_ba_eff(:)KF(ipts,j)/LF(ipts,j)tree_ff(j)*pipe_density(j) - &
3115	(Ch(:)KF(ipts,j)s(:))*(1+1/LF(ipts,j))/&
3116	(circ_class_height_eff(:)*s(:)) - &
3117	(Cs(:) + Ch(:) + Cl(:) + Cr(:))) ) - b_inc_tot
3118
3119	! Solve the quadratic equation agammas2 + bgammas + c = 0, for gammas.
3120	gammas(ipts,j) = (-b + sqrt(b*2-4ac)) / (2a)
3121
3122	! After thousands of simulation years we had a single pixel where
3123	! some of the three circ_class got a negative growth. This was because
3124	! both roots of the quadratic equation were negative. If both roots are
3125	! negative, we don't allocate and simply leave the carbon in the labile
3126	! pool. We will try again with more carbon the next day.
3127	IF (gammas(ipts,j).LT.zero) THEN
3128
3129	! Move the unallocatable carbon back into the labile
3130	! pool. Update related variables to pass the mass balance
3131	! check. Put the fruit allocation back first. That will give
3132	! more carbon at the next time step.
3133	b_inc_tot = b_inc_tot + SUM(Cf_inc(:) * circ_class_n(ipts,j,:))
3134	Cf_inc(:) = zero
3135	tmp_bm(ipts,j,ilabile,icarbon) = &
3136	tmp_bm(ipts,j,ilabile,icarbon) + b_inc_tot
3137	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - b_inc_tot
3138
3139	! Calculate C that was not allocated (b_inc_tot), the
3140	! equation should read b_inc_tot = b_inc_tot - b_inc_tot
3141	b_inc_tot = zero
3142
3143	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3144	WRITE(numout,*) 'Both roots are negative for PFT, ', j
3145	WRITE(numout,*) 'bm_alloc_tot, ', bm_alloc_tot(ipts,j)
3146	ENDIF
3147
3148	ELSE
3149
3150	! One gammas is positive. The solution for gammas is now used to
3151	! calculate delta_ba (eq. 3), delta_height (eq. 6), Cs_inc (eq. 7),
3152	! Cl_inc (eq. 8) and Cr_inc (eq. 9). See comment on the calculation
3153	! of delta_height and its implications on numerical consistency at
3154	! the similar statement in Â§5.2.4.3.1.
3155	! Tree rings: delta_ba is a sum of phenological and ordinary growth
3156	! but for further calculation, re-calculate delta_ba considering
3157	! only ordinary growth. Note that calculated delta_ba is effectvie
3158	! basal area increment.
3159	delta_ba(:) = circ_class_dba(:) * gammas(ipts,j)
3160	store_delta_ba_eff(ipts,j,:) = store_delta_ba_eff(ipts,j,:) + delta_ba(:)
3161	delta_height(:) = delta_ba(:)/s(:)
3162	Cs_inc(:) = tree_ff(j)pipe_density(j)(circ_class_ba_eff(:) + &
3163	delta_ba(:))*(circ_class_height_eff(:) + &
3164	delta_height(:)) - Cs(:) - Ch(:)
3165	Cl_inc(:) = KF(ipts,j)tree_ff(j)pipe_density(j)*&
3166	(circ_class_ba_eff(:)+delta_ba(:)) - &
3167	(KF(ipts,j)*Ch(:))/(circ_class_height_eff(:)+delta_height(:)) - Cl(:)
3168	Cr_inc(:) = KF(ipts,j)/LF(ipts,j)tree_ff(j)pipe_density(j)*&
3169	(circ_class_ba_eff(:)+delta_ba(:)) - &
3170	(KF(ipts,j)*Ch(:)/LF(ipts,j))/(circ_class_height_eff(:)+&
3171	delta_height(:)) - Cr(:)
3172
3173	! Write the initial residual to the history file to check
3174	! whether all goes well (or to see how often and where it goes
3175	! wrong).
3176	residual_write(ipts,j) = b_inc_tot - SUM(circ_class_n(ipts,j,:)* &
3177	(Cl_inc(:) + Cr_inc(:) + Cs_inc(:)))
3178
3179	! Debug
3180	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3181	WRITE(numout,*) 'One gamma is positive, ', j, gammas(ipts,j)
3182	WRITE(numout,*) 'delta_ba, ', delta_ba(:)
3183	WRITE(numout,*) 'Cl_inc, Cr_inc, Cs_inc, ', &
3184	Cl_inc(:), Cr_inc(:), Cs_inc(:)
3185	ENDIF
3186	!-
3187
3188	! There are two possible problems: (1) one of the Cx_inc is negative or
3189	! (2) all Cx_inc are positive but we are (slightly) overspending.
3190	IF (MINVAL(Cs_inc(:)) .LT. zero .OR. MINVAL(Cr_inc(:)) .LT. zero .OR. &
3191	MINVAL(Cl_inc(:)) .LT. zero) THEN
3192
3193	! The first (rare) problem we need to catch is when one of the increment
3194	! pools is negative. This is an undesired outcome (see comment where
3195	! ::KF_old is calculated in this routine. In that case we write a
3196	! warning, set all increment pools to zero and try it again at the
3197	! next time step. A likely cause of this problem is a too large change
3198	! in KF from one time step to another (note that at this point both
3199	! roots should be positive - so that can no longer be the cause). Try
3200	! decreasing the acceptable value for an absolute increase in KF.
3201
3202	! Do not allocate - save the carbon for the next time step
3203
3204	! Debug
3205	IF(err_act.GT.1) THEN
3206	WRITE(numout,*) 'WARNING 10a: numerical problem, '//&
3207	'one of the increment pools is less than zero'
3208	WRITE(numout,*) 'WARNING 10a: PFT, ipts: ',j,ipts
3209	WRITE(numout,*) 'WARNING 10a: Cl_inc(:): ',Cl_inc(:)
3210	WRITE(numout,*) 'WARNING 10a: Cr_inc(:): ',Cr_inc(:)
3211	WRITE(numout,*) 'WARNING 10a: Cs_inc(:): ',Cs_inc(:)
3212	WRITE(numout,*) 'WARNING 10a: We will revert the allocation'
3213	WRITE(numout,*) ' and save the carbon for the next day'
3214	END IF
3215	!-
3216
3217	! Move the unallocatable carbon back into the labile
3218	! pool. Update related variables to pass the mass balance check.
3219	b_inc_tot = b_inc_tot + SUM(Cf_inc(:) * circ_class_n(ipts,j,:))
3220	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - b_inc_tot
3221	tmp_bm(ipts,j,ilabile,icarbon) = &
3222	tmp_bm(ipts,j,ilabile,icarbon) + b_inc_tot
3223
3224	! Revert the allocation
3225	store_delta_ba_eff(ipts,j,:) = store_delta_ba_eff(ipts,j,:) - delta_ba(:)
3226	delta_ba(:) = zero
3227	delta_height(:) = zero
3228	Cl_inc(:) = zero
3229	Cs_inc(:) = zero
3230	Cr_inc(:) = zero
3231	Cf_inc(:) = zero
3232
3233	! Calculate C that was not allocated (b_inc_tot), the
3234	! equation should read b_inc_tot = b_inc_tot - b_inc_tot
3235	! note that Cf_inc was already accounted for.
3236	b_inc_tot = zero
3237
3238	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3239	WRITE(numout,*) 'Negative increment pools, ', j
3240	WRITE(numout,*) 'Allocation was reverted'
3241	WRITE(numout,*) 'bm_alloc_tot, ', bm_alloc_tot(ipts,j)
3242	ENDIF
3243
3244	ELSEIF (b_inc_tot - SUM(circ_class_n(ipts,j,:)* &
3245	(Cl_inc(:) + Cr_inc(:) + Cs_inc(:))).LT. zero) THEN
3246
3247	! We should only be here if there is a positive root and all
3248	! increment pools are positive. Overspending should thus be
3249	! a numerical issue and is expected to be small (less than 10-8)
3250	! If the residual is larger than expected, reduce gamma a bit and
3251	! recalculate the allocation. The residual is added then back into
3252	! the labile pool. Do not allocate - save the carbon for the next
3253	! time step
3254	residual10b(ipts,j) = b_inc_tot - SUM(circ_class_n(ipts,j,:) * &
3255	(Cl_inc(:) + Cr_inc(:) + Cs_inc(:)))
3256
3257	!!$ ! Debug
3258	!!$ IF(err_act.EQ.3) THEN
3259	!!$ WRITE(numout,*) 'WARNING 10b: numerical problem, '//&
3260	!!$ 'residual is negative we are overspending'
3261	!!$ WRITE(numout,*) 'WARNING 10b: PFT, ipts: ',j,ipts
3262	!!$ WRITE(numout,*) 'WARNING 10b: residual, ', residual10b
3263	!!$ WRITE(numout,*) 'WARNING 10b: allocation is being adjusted'
3264	!!$ ENDIF
3265	!!$ !-
3266
3267	! It is considered too large so we try to reduce the residual with
3268	! some brute force. First revert the previous store_delta_ba_eff
3269	! else we will double count tree ring width growth.
3270	store_delta_ba_eff(ipts,j,:) = store_delta_ba_eff(ipts,j,:)-delta_ba(:)
3271	! Calculate new delta_ba (note the reduction factor 0.99)
3272	! and update the other variables. The reduction factor of 0.99
3273	! could be too large, In that case we won't allocate.
3274	delta_ba(:) = circ_class_dba(:) * gammas(ipts,j) * 0.99
3275	store_delta_ba_eff(ipts,j,:) = store_delta_ba_eff(ipts,j,:)+delta_ba(:)
3276	delta_height(:) = delta_ba(:)/s(:)
3277	Cs_inc(:) = MAX(zero,tree_ff(j)pipe_density(j)(circ_class_ba_eff(:) + &
3278	delta_ba(:))*(circ_class_height_eff(:) + &
3279	delta_height(:)) - Cs(:) - Ch(:))
3280	Cl_inc(:) = MAX(zero,KF(ipts,j)tree_ff(j)pipe_density(j)*&
3281	(circ_class_ba_eff(:)+delta_ba(:)) - &
3282	(KF(ipts,j)*Ch(:)) / &
3283	(circ_class_height_eff(:)+delta_height(:)) - Cl(:))
3284	Cr_inc = MAX(zero,KF(ipts,j)/LF(ipts,j)tree_ff(j)pipe_density(j)*&
3285	(circ_class_ba_eff(:)+delta_ba(:)) - &
3286	(KF(ipts,j)*Ch(:)/LF(ipts,j))/(circ_class_height_eff(:)+&
3287	delta_height(:)) - Cr(:))
3288
3289	! Debug
3290	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3291	WRITE(numout,*) 'adjusted after overspending, ', j
3292	WRITE(numout,*) 'delta_ba, ', delta_ba(:)
3293	WRITE(numout,*) 'Cl_inc, Cr_inc, Cs_inc, ', &
3294	Cl_inc(:), Cr_inc(:), Cs_inc(:)
3295	ENDIF
3296	!-
3297
3298	! Check whether the recalculation worked
3299	IF (b_inc_tot - SUM(circ_class_n(ipts,j,:) * &
3300	(Cl_inc(:) + Cr_inc(:) + Cs_inc(:))) .LT. zero) THEN
3301
3302	! Debug
3303	IF(err_act.GT.1) THEN
3304	WRITE(numout,*) 'WARNING 10c: numerical problem, '//&
3305	'residual is still negative we are still overspending'
3306	WRITE(numout,*) 'WARNING 10c: PFT, ipts: ',j,ipts
3307	WRITE(numout,*) 'WARNING 10c: residual, ',b_inc_tot - &
3308	SUM(circ_class_n(ipts,j,:)* &
3309	(Cl_inc(:) + Cr_inc(:) + Cs_inc(:)))
3310	WRITE(numout,*) 'WARNING 10b: allocation is being adjusted'
3311	ENDIF
3312	!-
3313
3314	! Move the unallocatable carbon back into the labile
3315	! pool. Update related variables to pass the mass balance
3316	! check.
3317	b_inc_tot = b_inc_tot + SUM(Cf_inc(:) * circ_class_n(ipts,j,:))
3318	tmp_bm(ipts,j,ilabile,icarbon) = &
3319	tmp_bm(ipts,j,ilabile,icarbon) + b_inc_tot
3320	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - b_inc_tot
3321
3322	! The residual is still negative. We will give up.
3323	! Revert the allocation
3324	store_delta_ba_eff(ipts,j,:) = store_delta_ba_eff(ipts,j,:) - delta_ba(:)
3325	delta_ba(:) = zero
3326	delta_height(:) = zero
3327	Cl_inc(:) = zero
3328	Cs_inc(:) = zero
3329	Cr_inc(:) = zero
3330	Cf_inc(:) = zero
3331
3332	! Calculate C that was not allocated (b_inc_tot), the
3333	! equation should read b_inc_tot = b_inc_tot - b_inc_tot
3334	! note that Cf_inc was already accounted for.
3335	b_inc_tot = zero
3336
3337	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3338	WRITE(numout,*) 'Initial solution did not work, ', j
3339	WRITE(numout,*) 'Allocation was reverted'
3340	WRITE(numout,*) 'bm_alloc_tot, ', bm_alloc_tot(ipts,j)
3341	ENDIF
3342
3343	ELSE
3344
3345	! Debug
3346	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3347	WRITE(numout,*) 'Initial b_inc_tot, ', j, b_inc_tot
3348	WRITE(numout,*) 'Initial tmp_bm, ', tmp_bm(ipts,j,ilabile,icarbon)
3349	WRITE(numout,*) 'circ_class_n, ',circ_class_n(ipts,j,:)
3350	WRITE(numout,*) 'Cl_inc, Cr_inc, Cs_inc, ', &
3351	Cl_inc(:), Cr_inc(:), Cs_inc(:)
3352	ENDIF
3353	!-
3354
3355	! The adjustment was succesful. Finish the allocation.
3356	! Reduce b_inc_tot and move the difference back into the
3357	! labile pool where it comes from. Thanks to the IF we know
3358	! for sure that the new b_inc_tot (calculated on the next
3359	! line) is positive.
3360	b_inc_tot = b_inc_tot - SUM(circ_class_n(ipts,j,:) * &
3361	(Cl_inc(:) + Cr_inc(:) + Cs_inc(:)))
3362	tmp_bm(ipts,j,ilabile,icarbon) = tmp_bm(ipts,j,ilabile,icarbon) + &
3363	b_inc_tot
3364
3365	! Debug
3366	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3367	WRITE(numout,*) 'Recalculated b_inc_tot, ', j, b_inc_tot
3368	WRITE(numout,*) 'Recalculated tmp_bm, ', tmp_bm(ipts,j,ilabile,icarbon)
3369	WRITE(numout,*) 'Initial bm_alloc_tot, ', bm_alloc_tot(ipts,j)
3370	ENDIF
3371	!-
3372
3373	! What is left in b_inc_tot was not allocated so adjust
3374	! the total allocation.
3375	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - b_inc_tot
3376
3377	! There is nothing left to allocate
3378	b_inc_tot = zero
3379
3380	! Debug
3381	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3382	WRITE(numout,*) 'Recalculated bm_alloc_tot, ', bm_alloc_tot(ipts,j)
3383	ENDIF
3384	!-
3385
3386	END IF
3387
3388	ELSE
3389
3390	! All is well, wrap up the allocation
3391	! Wrap-up ordinary growth calculate C that was not allocated, note
3392	! that Cf_inc was already subtracted. We know from the IF
3393	! loops above that the new b_inc_tot (calculated at the next line
3394	! of code) will be positive
3395	b_inc_tot = b_inc_tot - SUM(circ_class_n(ipts,j,:) * &
3396	(Cl_inc(:) + Cr_inc(:) + Cs_inc(:)))
3397
3398	! If all went well b_inc_tot should now be very close to zero. Due
3399	! to numerical approximations some C may be left. Whatever is
3400	! left is moved back into the labile pool to conserve mass.
3401	tmp_bm(ipts,j,ilabile,icarbon) = tmp_bm(ipts,j,ilabile,icarbon) + &
3402	b_inc_tot
3403	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - b_inc_tot
3404	b_inc_tot = zero
3405
3406	! Debug
3407	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
3408	WRITE(numout,*) 'wrap-up ordinary allocation, left b_in_tot, ', &
3409	b_inc_tot
3410	WRITE(numout,*) 'a, b, c, gammas, ', a, b, c, gammas(ipts,j)
3411	WRITE(numout,*) 'delta_height, ', delta_height(:)
3412	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
3413	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
3414	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
3415	circ_class_n, 11)
3416	ENDIF
3417	!-
3418
3419	END IF
3420
3421	END IF ! postive root for quadratic equation
3422
3423	! Intermediate mass balance check. Note that this part of
3424	! the code is in DO-loops over nvm and npts so the
3425	! 'ipts' label is used in the mass balance check
3426	IF(err_act.EQ.4) THEN
3427
3428	! Update circ_class_biomass
3429	circ_class_biomass(ipts,j,:,ilabile,icarbon) = &
3430	biomass_to_cc(tmp_bm(ipts,j,ilabile,icarbon),&
3431	circ_class_biomass(ipts,j,:,ilabile,icarbon),&
3432	circ_class_n(ipts,j,:))
3433	circ_class_biomass(ipts,j,:,icarbres,icarbon) = &
3434	biomass_to_cc(tmp_bm(ipts,j,icarbres,icarbon),&
3435	circ_class_biomass(ipts,j,:,icarbres,icarbon),&
3436	circ_class_n(ipts,j,:))
3437
3438	! All carbon should have been allocated and the remainder was moved
3439	! back into the labile pool. b_inc_tot should be zero. If not, the
3440	! calculation of pool_end is wrong.
3441	IF(ABS(b_inc_tot).GT.min_stomate)THEN
3442	WRITE(numout,*) 'b_inc_tot differs from zero, ', ipts,j,b_inc_tot
3443	CALL ipslerr_p(3,'stomate_growth_fun_all.f90','intermediate mbcheck 2c',&
3444	'b_inc_tot differs from zero','')
3445	END IF
3446
3447	! Reset pool_end
3448	pool_end(:,:,:) = zero
3449
3450	! Update pool_end
3451	pool_end(ipts,j,icarbon) = pool_end(ipts,j,icarbon) + &
3452	SUM((Cl_incp(:) + Cs_incp(:) + Cr_incp(:) + &
3453	Cl_inc(:) + Cs_inc(:) + Cr_inc(:) + Cf_inc(:)) * circ_class_n(ipts,j,:)) * &
3454	veget_max(ipts,j)
3455
3456	! Check mass balance closure. Between intermediate check 2a and 2b
3457	! phenological allocation was accounted for.
3458	CALL intermediate_mass_balance_check(pool_start, pool_end, circ_class_biomass, &
3459	circ_class_n, veget_max, bm_alloc_tot, gpp_daily, atm_to_bm, dt, npts, &
3460	resp_maint, resp_growth, check_intern_init, ipts, j, '2c', 'ipft')
3461
3462	END IF ! err_act.EQ.4
3463
3464	!! 5.2.7 Don't grow wood, use C to fill labile pool
3465	ELSEIF ( ((.NOT. grow_wood) .AND. (b_inc_tot .GT. min_stomate)) ) THEN
3466
3467	! Calculate the C that needs to be distributed to the
3468	! labile pool. The fraction is proportional to the ratio
3469	! between the total allocatable biomass and the unallocated
3470	! biomass per tree (b_inc now contains the unallocated
3471	! biomass). At the end of the allocation scheme bm_alloc_tot
3472	! is substracted from the labile biomass pool to update the
3473	! biomass pool (tmp_bm(:,:,ilabile) = tmp_bm(:,:,ilabile) -
3474	! bm_alloc_tot(:,:)). At that point, the scheme puts the
3475	! unallocated b_inc into the labile pool. What we
3476	! want is that the unallocated fraction is removed from
3477	! ::bm_alloc_tot such that only the allocated C is removed
3478	! from the labile pool. b_inc_tot will be moved back into
3479	! the labile pool in 5.2.11
3480	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - b_inc_tot
3481	tmp_bm(ipts,j,ilabile,icarbon) = &
3482	tmp_bm(ipts,j,ilabile,icarbon) + b_inc_tot
3483
3484	! Wrap-up ordinary growth
3485	! Calculate C that was not allocated (b_inc_tot), the
3486	! equation should read b_inc_tot = b_inc_tot - b_inc_tot
3487	! note that Cf_inc was already substracted
3488	b_inc_tot = zero
3489
3490	! Debug
3491	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3492	WRITE(numout,*) 'No wood growth, move remaining C to labile pool'
3493	WRITE(numout,*) 'bm_alloc_tot_new, ',bm_alloc_tot(ipts,j)
3494	WRITE(numout,*) 'wrap-up ordinary allocation, left b_inc_tot, ', &
3495	b_inc_tot
3496
3497	ENDIF
3498	!-
3499
3500	!! 5.2.8 Error - the allocation scheme is overspending
3501	ELSEIF (b_inc_tot .LT. min_stomate) THEN
3502
3503	IF (b_inc_tot .LT. -10*EPSILON(zero)) THEN
3504
3505	! Something is wrong with the calculations
3506	WRITE(numout,*) 'WARNING 7: numerical problem overspending '//&
3507	'in ordinary allocation'
3508	WRITE(numout,*) 'WARNING 7: PFT, ipts: ',j,ipts
3509	WRITE(numout,*) 'WARNING 7: b_inc_tot', b_inc_tot
3510	IF(err_act.GT.1)THEN
3511	CALL ipslerr_p (3,'growth_fun_all',&
3512	'WARNING 7: numerical problem',&
3513	'overspending in ordinary allocation','')
3514	ENDIF
3515
3516	ELSE
3517
3518	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3519
3520	! Succesful allocation
3521	WRITE(numout,*) 'Insufficient carbon for ordinary &
3522	allocation'
3523
3524	ENDIF
3525
3526	ENDIF
3527
3528	! Although the biomass components respect the allometric
3529	! relationships, there is no carbon left to allocate
3530	b_inc_tot = zero
3531
3532	ENDIF !End ordinary allocation
3533
3534	! Update circ_class_biomass
3535	circ_class_biomass(ipts,j,:,ilabile,icarbon) = &
3536	biomass_to_cc(tmp_bm(ipts,j,ilabile,icarbon),&
3537	circ_class_biomass(ipts,j,:,ilabile,icarbon),&
3538	circ_class_n(ipts,j,:))
3539	circ_class_biomass(ipts,j,:,icarbres,icarbon) = &
3540	biomass_to_cc(tmp_bm(ipts,j,icarbres,icarbon),&
3541	circ_class_biomass(ipts,j,:,icarbres,icarbon),&
3542	circ_class_n(ipts,j,:))
3543
3544	!! 5.2.9 Error checking
3545	IF ( b_inc_tot .GT. min_stomate) THEN
3546
3547	! Although this should not happen. In case the functional
3548	! allocation did not consume all the allocatable carbon,
3549	! the remaining C is left for the next day. The numerical
3550	! precision of the allocation scheme (i.e. the linearisation)
3551	! is similar to min_stomate (i.e. 10-8) resulting in 'false'
3552	! warnings.
3553	WRITE(numout,*) 'WARNING 8: b_inc_tot greater than min_stomate '//&
3554	'force allocation'
3555	WRITE(numout,*) 'WARNING 8: PFT, ipts: ',j,ipts
3556	WRITE(numout,*) 'WARNING 8: b_inc_tot, ', b_inc_tot
3557	IF(err_act.GT.1)THEN
3558	CALL ipslerr_p (3,'growth_fun_all',&
3559	'WARNING 8: b_inc_tot greater than min_stomate',&
3560	'force allocation','')
3561	ENDIF
3562
3563	ELSEIF ( (b_inc_tot .LT. min_stomate) .AND. (b_inc_tot .GE. zero) ) THEN
3564
3565	! Successful allocation
3566	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3567	WRITE(numout,*) 'Successful allocation'
3568	ENDIF
3569
3570	ELSE
3571
3572	! Something possibly important was overlooked
3573	IF ( (b_inc_tot .LT. zero) .AND. &
3574	(b_inc_tot .GE. -100*min_stomate) ) THEN
3575	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3576	WRITE(numout,*) 'Marginally successful allocation - '//&
3577	'precision better than 5 10-6'
3578	WRITE(numout,*) 'PFT, b_inc_tot', j, b_inc_tot
3579	ENDIF
3580	ELSE
3581	WRITE(numout,*) 'WARNING 9: Logical flaw '//&
3582	'unexpected result in the ordinary allocation'
3583	WRITE(numout,*) 'WARNING 9: b_inc_tot, ',b_inc_tot
3584	WRITE(numout,*) 'WARNING 9: PFT, ipts: ',j,ipts
3585	IF(err_act.GT.1)THEN
3586	CALL ipslerr_p (3,'growth_fun_all',&
3587	'WARNING 9: Logical flaw',&
3588	'unexpected result in the ordinary allocation','')
3589	ENDIF
3590	ENDIF
3591
3592	ENDIF
3593
3594	!Debug
3595	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3596	WRITE(numout,*) 'Final allocation', ipts, j
3597	WRITE(numout,*) 'Cl, Cs, Cr', Cl(:), Cs(:), Cr(:)
3598	WRITE(numout,*) 'Cl_incp, Cs_incp, Cr_incp, ', &
3599	Cl_incp(:), Cs_incp(:), Cr_incp(:)
3600	WRITE(numout,*) 'Cl_inc, Cs_ins, Cr_inc, Cf_inc, ', &
3601	Cl_inc(:), Cs_inc(:), Cr_inc(:), Cf_inc(:)
3602	WRITE(numout,*) 'b_inc_tot, ', b_inc_tot
3603	WRITE(numout,*) 'Old ba, delta_ba, new ba, ', circ_class_ba_eff(:), &
3604	delta_ba(:), circ_class_ba_eff(:)+delta_ba(:)
3605	DO l=1,ncirc
3606	WRITE(numout,*) 'Circ_class_biomass, ', &
3607	circ_class_biomass(ipts,j,l,:,icarbon)
3608	ENDDO
3609	ENDIF
3610	!-
3611
3612	!! 5.2.10 Wrap-up phenological and ordinary allocation
3613	Cl_inc(:) = Cl_inc(:) + Cl_incp(:)
3614	Cr_inc(:) = Cr_inc(:) + Cr_incp(:)
3615	Cs_inc(:) = Cs_inc(:) + Cs_incp(:)
3616	residual(ipts,j) = b_inc_tot
3617
3618	!+++CHECK+++
3619	! All options to leave allocation have a b_inc_tot of zero.
3620	! This code may no longer be needed. As we are working towards
3621	! a dealine it was left in. It should not be harmful, it may
3622	! just complexify the code and slowdown the model a bit.
3623
3624	!! 5.2.11 Account for the residual
3625	! The residual is usually around ::min_stomate but we deal
3626	! with it anyway to make sure the mass balance is closed
3627	! and as a way to detect errors. Move the unallocated carbon
3628	! back into the labile pool
3629	IF (tmp_bm(ipts,j,ilabile,icarbon) + residual(ipts,j) .LE. min_stomate) THEN
3630
3631	deficit = tmp_bm(ipts,j,ilabile,icarbon) + residual(ipts,j)
3632
3633	! The deficit is less than the carbon reserve
3634	IF (-deficit .LE. tmp_bm(ipts,j,icarbres,icarbon)) THEN
3635
3636	! Pay the deficit from the reserve pool
3637	tmp_bm(ipts,j,icarbres,icarbon) = &
3638	tmp_bm(ipts,j,icarbres,icarbon) + deficit
3639	tmp_bm(ipts,j,ilabile,icarbon) = &
3640	tmp_bm(ipts,j,ilabile,icarbon) - deficit
3641
3642	ELSE
3643
3644	! Not enough carbon to pay the deficit
3645	! There is likely a bigger problem somewhere in
3646	! this routine
3647	WRITE(numout,*) 'WARNING 11: PFT, ipts: ',j,ipts
3648	WRITE(numout,*) 'resiudal, labile, deficit, ', &
3649	residual(ipts,j), tmp_bm(ipts,j,ilabile,icarbon), &
3650	deficit, tmp_bm(ipts,j,icarbres,icarbon)
3651	CALL ipslerr_p (3,'growth_fun_all',&
3652	'WARNING 11: numerical problem overspending ',&
3653	'when trying to account for unallocatable C ','')
3654
3655	ENDIF
3656
3657	ELSE
3658
3659	! Move the unallocated carbon back into the labile pool
3660	tmp_bm(ipts,j,ilabile,icarbon) = &
3661	tmp_bm(ipts,j,ilabile,icarbon) + residual(ipts,j)
3662
3663	ENDIF
3664	!+++++++++++
3665
3666	!! 5.2.12 Distribute stand level ilabile and icarbres at the tree level
3667	! The labile and carbres pools are calculated at the stand level but
3668	! have to be redistributed at the tree level. Tree level biomass is the
3669	! prognostic variable in ORCHIDEE. Biomass is sometimes used as a local
3670	! variable mainly to deal with the reserve and labile pools.
3671	circ_class_biomass(ipts,j,:,ilabile,icarbon) = &
3672	biomass_to_cc(tmp_bm(ipts,j,ilabile,icarbon),&
3673	circ_class_biomass(ipts,j,:,ilabile,icarbon),&
3674	circ_class_n(ipts,j,:))
3675	circ_class_biomass(ipts,j,:,icarbres,icarbon) = &
3676	biomass_to_cc(tmp_bm(ipts,j,icarbres,icarbon),&
3677	circ_class_biomass(ipts,j,:,icarbres,icarbon),&
3678	circ_class_n(ipts,j,:))
3679
3680	!! 5.2.13 Standardise allocation factors
3681	! Strictly speaking the allocation factors do not need to be
3682	! calculated because the functional allocation scheme allocates
3683	! absolute amounts of carbon. Hence, Cl_inc could simply be
3684	! added to tmp_bm(:,:,ileaf,icarbon), Cr_inc to
3685	! tmp_bm(:,:,iroot,icarbon), etc. However, using allocation
3686	! factors bears some elegance in respect to distributing the
3687	! growth respiration if this would be required. Further it
3688	! facilitates comparison to the resource limited allocation
3689	! scheme (stomate_growth_res_lim.f90) and it comes in handy
3690	! for model-data comparison. This allocation takes place at
3691	! the tree level - note that ::biomass is the only prognostic
3692	! variable from the tree-based allocation
3693	! WARNING: the reserves pools are ignored when calculating
3694	! the allocation factors. Make sure this is OK for you before
3695	! using these factors.
3696
3697	! Allocation
3698	Cl_inc(:) = MAX(zero, circ_class_n(ipts,j,:) * Cl_inc(:))
3699	Cr_inc(:) = MAX(zero, circ_class_n(ipts,j,:) * Cr_inc(:))
3700	Cs_inc(:) = MAX(zero, circ_class_n(ipts,j,:) * Cs_inc(:))
3701	Cf_inc(:) = MAX(zero, circ_class_n(ipts,j,:) * Cf_inc(:))
3702
3703	! Total_inc is based on the updated Cl_inc, Cr_inc, Cs_inc and
3704	! Cf_inc. Therefore, do not multiply
3705	! circ_class_n(ipts,j,:) again
3706	total_inc = SUM(Cf_inc(:) + Cl_inc(:) + Cs_inc(:) + Cr_inc(:))
3707
3708	! Relative allocation
3709	IF ( total_inc .GT. min_stomate ) THEN
3710
3711	Cl_inc(:) = Cl_inc(:) / total_inc
3712	Cs_inc(:) = Cs_inc(:) / total_inc
3713	Cr_inc(:) = Cr_inc(:) / total_inc
3714	Cf_inc(:) = Cf_inc(:) / total_inc
3715
3716	ELSE
3717
3718	bm_alloc_tot(ipts,j) = zero
3719	Cl_inc(:) = zero
3720	Cs_inc(:) = zero
3721	Cr_inc(:) = zero
3722	Cf_inc(:) = zero
3723
3724	ENDIF
3725
3726	!! 5.2.13 Convert allocation to allocation facors
3727	! Convert allocation of individuals to ORCHIDEE's allocation
3728	! factors - see comment for 5.2.5. Aboveground sapwood
3729	! allocation is age dependent in trees. ::alloc_min and
3730	! ::alloc_max must range between 0 and 1.
3731	alloc_sap_above = alloc_min(j) + ( alloc_max(j) - alloc_min(j) ) * &
3732	( 1. - EXP( -age(ipts,j) / demi_alloc(j) ) )
3733
3734	! Leaf, wood, root and fruit allocation. Note that the X_inc
3735	! are normalized before being used here.
3736	f_alloc(ipts,j,ileaf) = SUM(Cl_inc(:))
3737	f_alloc(ipts,j,isapabove) = SUM(Cs_inc(:)*alloc_sap_above)
3738	f_alloc(ipts,j,isapbelow) = SUM(Cs_inc(:)*(1.-alloc_sap_above))
3739	f_alloc(ipts,j,iroot) = SUM(Cr_inc(:))
3740	f_alloc(ipts,j,ifruit) = SUM(Cf_inc(:))
3741
3742	! Store f_alloc per circ_class to calculate the allocation
3743	! in circ_class_biomass after bm_alloc_tot has been checked
3744	! for the N availability. Note that the X_inc
3745	! are normalized before being used here.
3746	f_alloc_circ(ipts,:,ileaf) = Cl_inc(:)
3747	f_alloc_circ(ipts,:,isapabove) = Cs_inc(:)*alloc_sap_above
3748	f_alloc_circ(ipts,:,isapbelow) = Cs_inc(:)*(1.-alloc_sap_above)
3749	f_alloc_circ(ipts,:,iroot) = Cr_inc(:)
3750	f_alloc_circ(ipts,:,ifruit) = Cf_inc(:)
3751
3752	! Debug
3753	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3754	tempi = zero
3755	DO icir = 1,ncirc
3756	IF (Cl_inc(icir) .LT. zero .OR. &
3757	Cs_inc(icir) * alloc_sap_above .LT. zero .OR. &
3758	Cs_inc(icir) * (un - alloc_sap_above) .LT. zero .OR. &
3759	Cr_inc(icir) .LT. zero .OR. &
3760	Cf_inc(icir) .LT. zero .OR. &
3761	total_inc .LT. zero .OR. &
3762	circ_class_n(ipts,j,icir) .LT. zero) THEN
3763	WRITE(numout,*) 'Cl_inc, ', j, Cl_inc(icir)
3764	WRITE(numout,*) 'Cs_inc aboveground, ', j, &
3765	Cs_inc(icir) * alloc_sap_above
3766	WRITE(numout,*) 'Cs_inc aboveground, ', j, &
3767	Cs_inc(icir) * (un-alloc_sap_above)
3768	WRITE(numout,*) 'Cr_inc, ', j, Cr_inc(icir)
3769	WRITE(numout,*) 'Cf_inc, ', j, Cf_inc(icir)
3770	WRITE(numout,*) 'total_inc, ', j, total_inc
3771	WRITE(numout,*) 'circ_class_n, ', j, circ_class_n(ipts,j,icir)
3772	CALL ipslerr_p (3,'growth_fun_all',&
3773	'WARNING 11bis: the solution has negative values',&
3774	'None of these variables should be negative','')
3775	ENDIF
3776	ENDDO
3777	ENDIF
3778	!-
3779
3780	ELSEIF (is_tree(j)) THEN
3781
3782	! bm_alloc_tot was less than min_stomate. No effort
3783	! to allocate but this little bit of carbon should be
3784	! correctly accounted for.
3785	residual(ipts,j) = bm_alloc_tot(ipts,j)
3786
3787	! Debug
3788	IF(printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) WRITE(numout,*) &
3789	'there is no tree biomass to allocate, PFT, ', j
3790	!-
3791
3792	ENDIF ! Is there biomass to allocate (Â§5.2 - far far up)
3793
3794	!! 5.3 Calculate allocated biomass pools for grasses and crops
3795	! Only possible if there is biomass to allocate
3796	IF ( .NOT. is_tree(j) .AND. bm_alloc_tot(ipts,j) .GT. min_stomate ) THEN
3797
3798	!! 5.3.1 Scaling factor to convert variables to the individual plant
3799	! Allocation is on an individual basis (gC ind-1). Stand-level variables
3800	! need to convert to a single individual. The absence of sapwood makes
3801	! this irrelevant because the allocation reduces to a linear function
3802	! (contrary to the non-linearity of tree allocation). For the
3803	! beauty of consistency, the transformations will be implemented.
3804	! Different approach between the DGVM and statitic approach
3805	IF (ok_dgvm) THEN
3806
3807	! The DGVM does NOT work with the functional allocation. Consider
3808	! this code as a placeholder. The original code had two different
3809	! transformations to calculate the scalars. Both could be used but
3810	! the units will differ. For consistency only one was retained
3811	! scal = ind(ipts,j) * cn_ind(ipts,j) / veget_max(ipts,j)
3812	scal(ipts,j) = veget_max(ipts,j) / circ_class_n(ipts,j,1)
3813
3814	ELSE
3815
3816	! By dividing the actual biomass by the number of individuals
3817	! the biomass of an individual is obtained. Note that a grass/crop
3818	! individual was defined as 1m-2 of vegetation
3819	scal(ipts,j) = 1./ circ_class_n(ipts,j,1)
3820
3821	ENDIF
3822
3823	!! 5.3.2 Current biomass pools per grass/crop (gC ind^-1)
3824	! Cs has too many dimensions for grass/crops. To have a consistent
3825	! notation the same variables are used as for trees but the dimension
3826	! of Cs, Cl and Cr i.e. ::ncirc should be ignored
3827	Cs(:) = circ_class_biomass(ipts,j,1,isapabove,icarbon) * scal(ipts,j)
3828	Cr(:) = circ_class_biomass(ipts,j,1,iroot,icarbon) * scal(ipts,j)
3829	Cl(:) = circ_class_biomass(ipts,j,1,ileaf,icarbon) * scal(ipts,j)
3830	Ch(:) = zero
3831
3832	! Quantify and account for nitrogen limitation on allometric
3833	! allocation. The same code as in the section 5.4 is used exept
3834	! that we don't use allocation coeff to modulate n_avail. So
3835	! costf=1. It is a strong assamption compared to the previous version.
3836	! It means that ordinary allocation can only happens when allometric
3837	! allocation is is ok. In other case no wood growth is allowed.
3838	! In the case of a strong limitation by Nitrogen, the growth period
3839	! for sapwood will be shorten because we reach allometry late in
3840	! the growing season.
3841	n_avail = MAX(tmp_bm(ipts,j,ilabile,initrogen)*0.9,0.0)
3842	bm_supply_n = n_avail / (1.-frac_growthresp_dyn) * &
3843	cn_leaf(ipts,j)
3844
3845	! Calculate how much carbon could be allocated with the available nitrogen
3846	bm_supply_n = n_avail / (1.-frac_growthresp_dyn) * &
3847	cn_leaf(ipts,j)
3848
3849	! If there is not enough nitrogen, move nitrogen from the reserve
3850	! as much as needed, keeping 10% of reserve (arbitral portion)
3851	IF(bm_alloc_tot(ipts,j) .GT. bm_supply_n &
3852	.AND. n_avail .GT. zero) THEN
3853
3854	! Calculate the deficit
3855	n_deficit = bm_alloc_tot(ipts,j) * (1.-frac_growthresp_dyn) / &
3856	cn_leaf(ipts,j) - n_avail
3857
3858	IF(n_deficit .LE. tmp_bm(ipts,j,icarbres,initrogen) * 0.9) THEN
3859
3860	! Enougn N in the reserve pools to fill the labile pool
3861	n_avail = n_avail + n_deficit
3862	bm_supply_n = n_avail / (1.-frac_growthresp_dyn) * &
3863	cn_leaf(ipts,j)
3864	tmp_bm(ipts,j,icarbres,initrogen) = tmp_bm(ipts,j,icarbres,initrogen) - &
3865	(n_avail/0.9 - tmp_bm(ipts,j,ilabile,initrogen))
3866	tmp_bm(ipts,j,ilabile,initrogen) = n_avail/0.9
3867
3868	! tmp_bm is a temporary varaiable so the prognostic variable, i.e.,
3869	! circ_class_biomass also needs to be updated.
3870	circ_class_biomass(ipts,j,:,icarbres,initrogen) = &
3871	biomass_to_cc(tmp_bm(ipts,j,icarbres,initrogen),&
3872	circ_class_biomass(ipts,j,:,icarbres,initrogen),&
3873	circ_class_n(ipts,j,:))
3874	circ_class_biomass(ipts,j,:,ilabile,initrogen) = &
3875	biomass_to_cc(tmp_bm(ipts,j,ilabile,initrogen),&
3876	circ_class_biomass(ipts,j,:,ilabile,initrogen),&
3877	circ_class_n(ipts,j,:))
3878
3879	ELSE
3880
3881	! Deficit exceeds 90% of reserve. fill labile as much as
3882	! possible
3883	tmp_bm(ipts,j,ilabile,initrogen) = tmp_bm(ipts,j,ilabile,initrogen) + &
3884	tmp_bm(ipts,j,icarbres,initrogen) * 0.9
3885	tmp_bm(ipts,j,icarbres,initrogen) = tmp_bm(ipts,j,icarbres,initrogen) - &
3886	tmp_bm(ipts,j,icarbres,initrogen) * 0.9
3887
3888	! tmp_bm is a temporary varaiable so the prognostic variable, i.e.,
3889	! circ_class_biomass also needs to be updated.
3890	circ_class_biomass(ipts,j,:,icarbres,initrogen) = &
3891	biomass_to_cc(tmp_bm(ipts,j,icarbres,initrogen),&
3892	circ_class_biomass(ipts,j,:,icarbres,initrogen),&
3893	circ_class_n(ipts,j,:))
3894	circ_class_biomass(ipts,j,:,ilabile,initrogen) = &
3895	biomass_to_cc(tmp_bm(ipts,j,ilabile,initrogen),&
3896	circ_class_biomass(ipts,j,:,ilabile,initrogen),&
3897	circ_class_n(ipts,j,:))
3898
3899	! Update the available nitrogen and the carbon that could be allocated
3900	! with that amount of nitrogen
3901	n_avail = MAX(tmp_bm(ipts,j,ilabile,initrogen)*0.9,0.0)
3902	bm_supply_n = n_avail / (1.-frac_growthresp_dyn) * &
3903	cn_leaf(ipts,j)
3904	ENDIF
3905
3906	ENDIF
3907
3908	deltacnmax = 1. - exp(-((1.6 * MIN((1./cn_leaf(ipts,j))-&
3909	(1./cn_leaf_min_2D(ipts,j)),0.) / &
3910	( (1./(cn_leaf_max_2D(ipts,j))) - &
3911	(1./cn_leaf_min_2D(ipts,j)) ) )**4.1))
3912
3913	IF ( bm_alloc_tot(ipts,j) .GT. bm_supply_n ) THEN
3914
3915	IF (impose_cn) THEN
3916
3917	! Calculate how much nitrogen is missing to allocate all the
3918	! carbon contained in bm_alloc_tot
3919	n_deficit = (bm_alloc_tot(ipts,j)-bm_supply_n) * &
3920	(1.-frac_growthresp_dyn) / cn_leaf(ipts,j)/0.9
3921
3922	! The nitrogen missing to allocate the entire bm_alloc_tot will be taken
3923	! from the atmosphere and put in the labile pool.
3924	atm_to_bm(ipts,j,initrogen) = atm_to_bm(ipts,j,initrogen) + &
3925	n_deficit/dt
3926	tmp_bm(ipts,j,ilabile,initrogen) = &
3927	tmp_bm(ipts,j,ilabile,initrogen) + n_deficit
3928
3929	! tmp_bm is a temporary varaiable so the prognostic variable, i.e.,
3930	! circ_class_biomass also needs to be updated.
3931	circ_class_biomass(ipts,j,:,ilabile,initrogen) = &
3932	biomass_to_cc(tmp_bm(ipts,j,ilabile,initrogen),&
3933	circ_class_biomass(ipts,j,:,ilabile,initrogen),&
3934	circ_class_n(ipts,j,:))
3935
3936	! Estimate the nitrogen pool that is required to allocate all the
3937	! carbon in bm_alloc_tot.
3938	n_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) * &
3939	(1.-frac_growthresp_dyn)/cn_leaf(ipts,j)
3940
3941	ELSE
3942
3943	IF (printlev_loc .GE. 4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
3944	WRITE(numout,*) 'N-limitation before allocation'
3945	ENDIF
3946	deltacnmax = Dmax * (1.-deltacnmax)
3947	deltacn = n_avail / ( bm_alloc_tot(ipts,j) * &
3948	(1.-frac_growthresp_dyn) * 1./cn_leaf(ipts,j) )
3949	deltacn = MIN(MAX(deltacn,1.0-deltacnmax),1.0)
3950
3951	n_alloc_tot(ipts,j) = MIN( n_avail , &
3952	bm_alloc_tot(ipts,j) * (1.-frac_growthresp_dyn) * &
3953	MAX(MIN( 1./cn_leaf(ipts,j)*deltacn, 1./cn_leaf_min_2D(ipts,j)), &
3954	1./cn_leaf_max_2D(ipts,j)) )
3955
3956	tmp_bm(ipts,j,ilabile,icarbon) = &
3957	tmp_bm(ipts,j,ilabile,icarbon) + &
3958	bm_alloc_tot(ipts,j)
3959
3960	bm_alloc_tot(ipts,j) = MIN( bm_alloc_tot(ipts,j) , &
3961	n_alloc_tot(ipts,j) / (1.-frac_growthresp_dyn) / &
3962	MAX(MIN(1./cn_leaf(ipts,j)*deltacn, &
3963	1./cn_leaf_min_2D(ipts,j)), 1./cn_leaf_max_2D(ipts,j)) )
3964
3965	tmp_bm(ipts,j,ilabile,icarbon) = tmp_bm(ipts,j,ilabile,icarbon) - &
3966	bm_alloc_tot(ipts,j)
3967
3968	ENDIF ! if impose_cn
3969
3970	ELSE
3971
3972	deltacnmax=Dmax * deltacnmax
3973	deltacn = n_avail / ( bm_alloc_tot(ipts,j) * &
3974	(1.-frac_growthresp_dyn) * 1./cn_leaf(ipts,j) )
3975	deltacn=MIN(MAX(deltacn,1.0),1.+deltacnmax)
3976
3977	n_alloc_tot(ipts,j) = MIN( n_avail , &
3978	bm_alloc_tot(ipts,j) * (1.-frac_growthresp_dyn) * &
3979	MAX(MIN(1./cn_leaf(ipts,j)*deltacn, &
3980	1./cn_leaf_min_2D(ipts,j)),1./cn_leaf_max_2D(ipts,j)) )
3981
3982	ENDIF
3983
3984	! Total amount of carbon that needs to ba allocated (::bm_alloc_tot).
3985	! bm_alloc_tot is in gC m-2 day-1. At 1 m2 there are ::ind number of
3986	! trees. We calculate the allocation for ::ncirc trees. Hence b_inc_tot
3987	! needs to be scaled in the allocation routines. For all cases were
3988	! allocation takes place for a single circumference class, scaling
3989	! could be done before the allocation. In the ordinary allocation
3990	! allocation takes place to all circumference classes at the same time.
3991	! Hence scaling takes place in that step for consistency we scale during
3992	! allocation. Note that b_inc (the carbon allocated to an individual
3993	! circumference class cannot be estimates at this point.
3994	IF (bm_alloc_tot(ipts,j).GT.min_stomate) THEN
3995
3996	! There is enough carbon to allocate
3997	b_inc_tot = bm_alloc_tot(ipts,j)
3998
3999	ELSE
4000
4001	! There is so little carbon that it is not worth the hassle
4002	! to allocate. Allocating very small amounts increases the
4003	! risk to run into precision errors.
4004	tmp_bm(ipts,j,ilabile,icarbon) = tmp_bm(ipts,j,ilabile,icarbon) + &
4005	bm_alloc_tot(ipts,j)
4006	b_inc_tot = zero
4007
4008	ENDIF
4009
4010	! Labile carbon is updated in consequence
4011	circ_class_biomass(ipts,j,:,ilabile,icarbon) = &
4012	biomass_to_cc(tmp_bm(ipts,j,ilabile,icarbon),&
4013	circ_class_biomass(ipts,j,:,ilabile,icarbon),&
4014	circ_class_n(ipts,j,:))
4015
4016	END IF
4017
4018	! Intermediate mass balance check
4019	IF (err_act.EQ.4 .AND. .NOT.is_tree(j)) THEN
4020
4021	! Reset entire array to zero to calculate mass balance for each
4022	! pixel x pft separatly
4023	pool_end(:,:,:) = zero
4024
4025	! Add bm_alloc_tot into the pool
4026	pool_end(ipts,j,icarbon) = pool_end(ipts,j,icarbon) + &
4027	b_inc_tot * veget_max(ipts,j)
4028
4029	! Check mass balance closure. Between intermediate check 1 and 3a
4030	! bm_inc_tot was recalculated by accounting for the available nitrogen
4031	CALL intermediate_mass_balance_check(pool_start, pool_end, circ_class_biomass, &
4032	circ_class_n, veget_max, bm_alloc_tot, gpp_daily, atm_to_bm, dt, npts, &
4033	resp_maint, resp_growth, check_intern_init, ipts, j, '3a', 'ipft')
4034
4035	ENDIF ! err_act.EQ.4
4036
4037	! The initial estimate of bm_alloc_tot was high enough to consider allocation
4038	! but after accounting for the available nitrogen bm_alloc_tot may have
4039	! dropped below the min_stomate threshold so it needs to be tested again
4040	IF ( .NOT. is_tree(j) .AND. bm_alloc_tot(ipts,j) .GT. min_stomate ) THEN
4041
4042	!! 5.3.3 C-allocation for crops and grasses
4043	! The mass conservation equations are detailed in the header of
4044	! this subroutine. The scheme assumes a functional relationships
4045	! between leaves and roots for grasses and crops. When carbon is
4046	! added to the leaf biomass pool, an increase in the root biomass
4047	! is to be expected to sustain water transport from the roots to
4048	! the leaves.
4049
4050	!! 5.3.3.1 Do the biomass pools respect the pipe model?
4051	! Do the current leaf, sapwood and root components respect the
4052	! allometric constraints? Calculate the optimal root and leaf mass,
4053	! given the current wood mass by using the basic allometric
4054	! relationships. Calculate the optimal sapwood mass as a function
4055	! of the current leaf and root mass.
4056	Cl_target(1) = MAX( Cs(1) * KF(ipts,j) , Cr(1) * LF(ipts,j), Cl(1) )
4057	Cs_target(1) = MAX( Cl_target(1) / KF(ipts,j), &
4058	Cr(1) * LF(ipts,j) / KF(ipts,j), Cs(1) )
4059	Cr_target(1) = MAX( Cl_target(1) / LF(ipts,j), &
4060	Cs_target(1) * KF(ipts,j) / LF(ipts,j), Cr(1) )
4061
4062	! Debug
4063	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
4064	WRITE(numout,*) 'bm_alloc_tot, ',bm_alloc_tot(ipts,j)
4065	WRITE(numout,*) 'Does the grass/crop needs reshaping?'
4066	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
4067	WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(1)-Cl(1), Cl_target(1), Cl(1)
4068	WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(1)-Cs(1), Cs_target(1), Cs(1)
4069	WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(1)-Cr(1), Cr_target(1), Cr(1)
4070	ENDIF
4071	!-
4072
4073	!! 5.3.3.2 Phenological growth
4074	! Phenological growth and reshaping of the grass/crop in line with
4075	! the pipe model. Turnover removes C from the different plant components
4076	! but at a component-specific rate, as such the allometric constraints
4077	! are distorted at every time step and should be restored before ordinary
4078	! growth can take place
4079
4080	!! 5.3.3.2.1 The available C can sustain the present leaves and roots
4081	! Calculate whether the structural c is in allometric balance. The target
4082	! values should always be larger than the current pools so the use of ABS
4083	! is redundant but was used to be on the safe side (here and in the rest
4084	! of the module) as it could help to find logical flaws.
4085	IF ( ABS(Cs_target(1) - Cs(1)) .LT. min_stomate ) THEN
4086
4087	Cs_incp(1) = MAX(zero, Cs_target(1) - Cs(1))
4088
4089	! Enough leaves and structural biomass, only grow roots
4090	IF ( ABS(Cl_target(1) - Cl(1)) .LT. min_stomate ) THEN
4091
4092	! Allocate at the tree level to restore allometric balance
4093	Cl_incp(1) = MAX(zero, Cl_target(1) - Cl(1))
4094	Cr_incp(1) = MAX( MIN(b_inc_tot / circ_class_n(ipts,j,1) - &
4095	Cs_incp(1) - Cl_incp(1), Cr_target(1) - Cr(1)), zero )
4096
4097	! Write debug comments to output file
4098	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
4099	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
4100	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
4101	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
4102	circ_class_n, 12)
4103	ENDIF
4104
4105	! Sufficient structural C and roots, allocate C to leaves
4106	ELSEIF ( ABS(Cr_target(1) - Cr(1)) .LT. min_stomate ) THEN
4107
4108	! Allocate at the tree level to restore allometric balance
4109	Cr_incp(1) = MAX(zero, Cr_target(1) - Cr(1))
4110	Cl_incp(1) = MAX( MIN(b_inc_tot / circ_class_n(ipts,j,1) - &
4111	Cs_incp(1) - Cr_incp(1), Cl_target(1) - Cl(1)), zero )
4112
4113	! Update vegetation height
4114	qm_height = biomass_to_lai(Cl(1) + Cl_incp(1),j) * lai_to_height(j)
4115
4116	! Write debug comments to output file
4117	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
4118	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
4119	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
4120	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
4121	circ_class_n, 13)
4122	ENDIF
4123
4124	! Both leaves and roots are needed to restore the allometric relationships
4125	ELSEIF ( ABS(Cl_target(1) - Cl(1)) .GT. min_stomate .AND. &
4126	ABS(Cr_target(1) - Cr(1)) .GT. min_stomate ) THEN
4127
4128	! Allocate at the tree level to restore allometric balance
4129	! The equations can be rearanged and written as
4130	! (i) b_inc = Cl_inc + Cr_inc
4131	! (ii) Cr_inc = (Cl_inc+Cl)/LF - Cr
4132	! Substitue (ii) in (i) and solve for Cl_inc
4133	! <=> Cl_inc = (LF*(b_inc+Cr)-Cl)/(1+LF)
4134	Cl_incp(1) = MIN( ((LF(ipts,j) * ((b_inc_tot/circ_class_n(ipts,j,1)) - &
4135	Cs_incp(1) + Cr(1))) - Cl(1)) / (1 + LF(ipts,j)), &
4136	Cl_target(1) - Cl(1) )
4137	Cr_incp(1) = MIN ( ((Cl_incp(1) + Cl(1)) / LF(ipts,j)) - Cr(1), &
4138	Cr_target(1) - Cr(1))
4139
4140	! The imbalance between Cr and Cl can be so big that (Cl+Cl_inc)/LF
4141	! is still less then the available root carbon (observed!). This
4142	! would result in a negative Cr_incp
4143	IF ( Cr_incp(1) .LT. zero ) THEN
4144
4145	Cl_incp(1) = MIN( b_inc_tot/circ_class_n(ipts,j,1) - &
4146	Cs_incp(1), Cl_target(1) - Cl(1) )
4147	Cr_incp(1) = b_inc_tot/circ_class_n(ipts,j,1) - &
4148	Cs_incp(1) - Cl_incp(1)
4149
4150	ELSEIF (Cl_incp(1) .LT. zero) THEN
4151
4152	Cr_incp(1) = MIN( b_inc_tot/circ_class_n(ipts,j,1) - &
4153	Cs_incp(1), Cr_target(1) - Cr(1) )
4154	Cl_incp(1) = (b_inc_tot/circ_class_n(ipts,j,1)) - &
4155	Cs_incp(1) - Cr_incp(1)
4156
4157	ENDIF
4158
4159	! Update vegetation height
4160	qm_height = biomass_to_lai(Cl(1) + Cl_incp(1),j) * lai_to_height(j)
4161
4162	! Write debug comments to output file
4163	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
4164	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
4165	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
4166	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
4167	circ_class_n, 14)
4168	ENDIF
4169
4170	ELSE
4171
4172	WRITE(numout,*) 'WARNING 12: Exc 1-3 unexpected exception'
4173	WRITE(numout,*) 'WARNING 12: PFT, ipts: ',j,ipts
4174	IF(err_act.GT.1)THEN
4175	CALL ipslerr_p (3,'growth_fun_all',&
4176	'WARNING 12: Exc 1-3 unexpected exception','','')
4177	ENDIF
4178
4179	ENDIF
4180
4181	!! 5.3.3.3.2 Enough leaves to sustain the structural C and roots
4182	ELSEIF ( ABS(Cl_target(1) - Cl(1)) .LT. min_stomate ) THEN
4183
4184	Cl_incp(1) = MAX(zero, Cl_target(1) - Cl(1))
4185
4186	! Enough leaves and structural C, only grow roots
4187	! This duplicates Exc 1 and these lines should never be called
4188	IF ( ABS(Cs_target(1) - Cs(1)) .LT. min_stomate ) THEN
4189
4190	! Allocate at the tree level to restore allometric balance
4191	Cs_incp(1) = MAX(zero, Cs_target(1) - Cs(1))
4192	Cr_incp(1) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,1) - &
4193	Cl_incp(1) - Cs_incp(1), Cr_target(1) - Cr(1)), zero )
4194
4195	! Write debug comments to output file
4196	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
4197	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
4198	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
4199	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
4200	circ_class_n, 15)
4201	ENDIF
4202
4203	! Enough leaves and roots. Need to grow structural C to support
4204	! the available canopy and roots
4205	ELSEIF ( ABS(Cr_target(1) - Cr(1)) .LT. min_stomate ) THEN
4206
4207	Cr_incp(1) = MAX(zero, Cr_target(1) - Cr(1))
4208	Cs_incp(1) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,1) - &
4209	Cr_incp(1) - Cl_incp(1), Cs_target(1) - Cs(1)), zero )
4210
4211	! Write debug comments to output file
4212	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
4213	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
4214	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
4215	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
4216	circ_class_n, 16)
4217	ENDIF
4218
4219	! Need both structural C and roots to restore the allometric relationships
4220	ELSEIF ( ABS(Cs_target(1) - Cs(1) ) .GT. min_stomate .AND. &
4221	ABS(Cr_target(1) - Cr(1)) .GT. min_stomate ) THEN
4222
4223	! First try if we can simply satisfy the allocation needs
4224	IF (Cs_target(1) - Cs(1) + Cr_target(1) - Cr(1) .LE. &
4225	b_inc_tot/circ_class_n(ipts,j,1) - Cl_incp(1)) THEN
4226
4227	Cr_incp(1) = Cr_target(1) - Cr(1)
4228	Cs_incp(1) = Cs_target(1) - Cs(1)
4229
4230	! Try to satisfy the need for the roots
4231	ELSEIF (Cr_target(1) - Cr(1) .LE. &
4232	b_inc_tot/circ_class_n(ipts,j,1) - Cl_incp(1)) THEN
4233
4234	Cr_incp(1) = Cr_target(1) - Cr(1)
4235	Cs_incp(1) = b_inc_tot/circ_class_n(ipts,j,1) - &
4236	Cl_incp(1) - Cr_incp(1)
4237
4238
4239	! There is not enough use whatever is available
4240	ELSE
4241
4242	Cr_incp(1) = b_inc_tot/circ_class_n(ipts,j,1) - Cl_incp(1)
4243	Cs_incp(1) = zero
4244
4245	ENDIF
4246
4247	! Write debug comments to output file
4248	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
4249	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
4250	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
4251	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
4252	circ_class_n, 17)
4253	ENDIF
4254
4255	ELSE
4256
4257	WRITE(numout,*) 'WARNING 13: Exc 4-6 unexpected exception'
4258	WRITE(numout,*) 'WARNING 13: PFT, ipts: ',j,ipts
4259	IF(err_act.GT.1)THEN
4260	CALL ipslerr_p (3,'growth_fun_all',&
4261	'WARNING 13: Exc 4-6 unexpected exception','','')
4262	ENDIF
4263
4264	ENDIF
4265
4266	!! 5.3.3.3.3 Enough roots to sustain the wood and leaves
4267	ELSEIF ( ABS(Cr_target(1) - Cr(1)) .LT. min_stomate ) THEN
4268
4269	Cr_incp(1) = MAX(zero, Cr_target(1) - Cr(1))
4270
4271	! Enough roots and wood, only grow leaves
4272	! This duplicates Exc 2 and these lines should thus never be called
4273	IF ( ABS(Cs_target(1) - Cs(1)) .LT. min_stomate ) THEN
4274
4275	! Allocate at the tree level to restore allometric balance
4276	Cs_incp(1) = MAX(zero, Cs_target(1) - Cs(1))
4277	Cl_incp(1) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,1) - &
4278	Cr_incp(1) - Cs_incp(1), Cl_target(1) - Cl(1)), zero )
4279
4280	! Update vegetation height
4281	qm_height = biomass_to_lai(Cl(1) + Cl_incp(1),j) * lai_to_height(j)
4282
4283	! Write debug comments to output file
4284	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
4285	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
4286	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
4287	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
4288	circ_class_n, 18)
4289	ENDIF
4290
4291	! Enough leaves and roots. Need to grow sapwood to support the
4292	! available canopy and roots. Duplicates Exc. 4 and these lines
4293	! should thus never be called
4294	ELSEIF ( ABS(Cl_target(1) - Cl(1)) .LT. min_stomate ) THEN
4295
4296	! Allocate at the tree level to restore allometric balance
4297	Cl_incp(1) = MAX(zero, Cl_target(1) - Cl(1))
4298	Cs_incp(1) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,1) - &
4299	Cr_incp(1) - Cl_incp(1), Cs_target(1) - Cs(1) ), zero )
4300
4301	! Write debug comments to output file
4302	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
4303	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
4304	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
4305	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
4306	circ_class_n, 19)
4307	ENDIF
4308
4309	! Need both wood and leaves to restore the allometric relationships
4310	ELSEIF ( ABS(Cs_target(1) - Cs(1)) .GT. min_stomate .AND. &
4311	ABS(Cl_target(1) - Cl(1)) .GT. min_stomate ) THEN
4312
4313	! circ_class_ba_eff and circ_class_height_eff are already calculated
4314	! for a tree in balance. It would be rather complicated to follow
4315	! the allometric rules for wood allocation (implying changes in height
4316	! and basal area) because the tree is not in balance.First try if we
4317	! can simply satisfy the allocation needs
4318	IF (Cs_target(1) - Cs(1) + Cl_target(1) - Cl(1) .LE. &
4319	b_inc_tot/circ_class_n(ipts,j,1) - Cr_incp(1)) THEN
4320
4321	Cl_incp(1) = Cl_target(1) - Cl(1)
4322	Cs_incp(1) = Cs_target(1) - Cs(1)
4323
4324	! Try to satisfy the need for leaves
4325	ELSEIF (Cl_target(1) - Cl(1) .LE. &
4326	b_inc_tot/circ_class_n(ipts,j,1) - Cr_incp(1)) THEN
4327
4328	Cl_incp(1) = Cl_target(1) - Cl(1)
4329	Cs_incp(1) = b_inc_tot/circ_class_n(ipts,j,1) - &
4330	Cr_incp(1) - Cl_incp(1)
4331
4332	! There is not enough use whatever is available
4333	ELSE
4334
4335	Cl_incp(1) = b_inc_tot/circ_class_n(ipts,j,1) - Cr_incp(1)
4336	Cs_incp(1) = zero
4337
4338	ENDIF
4339
4340	! Calculate the height of the expanded canopy
4341	qm_height(ipts,j) = biomass_to_lai(Cl(1) + Cl_inc(1),j) * lai_to_height(j)
4342
4343	! Write debug comments to output file
4344	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
4345	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
4346	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
4347	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
4348	circ_class_n, 20)
4349	ENDIF
4350
4351	ELSE
4352
4353	WRITE(numout,*) 'WARNING 14: Exc 7-9 unexpected exception'
4354	WRITE(numout,*) 'WARNING 14: PFT, ipts: ',j, ipts
4355	IF(err_act.GT.1)THEN
4356	CALL ipslerr_p (3,'growth_fun_all',&
4357	'WARNING 14: Exc 7-9 unexpected exception','','')
4358	ENDIF
4359
4360	ENDIF
4361
4362	! Either Cl_target, Cs_target or Cr_target should be zero
4363	ELSE
4364
4365	! Something possibly important was overlooked
4366	WRITE(numout,*) 'WARNING 15: Logical flaw in phenological allocation '
4367	WRITE(numout,*) 'WARNING 15: PFT, ipts: ',j, ipts
4368	WRITE(numout,*) 'Cs - Cs_target', Cs(1), Cs_target(1)
4369	WRITE(numout,*) 'Cl - Cl_target', Cl(1), Cl_target(1)
4370	WRITE(numout,*) 'Cr - Cr_target', Cr(1), Cr_target(1)
4371	IF(err_act.GT.1)THEN
4372	CALL ipslerr_p (3,'growth_fun_all',&
4373	'WARNING 15: Logical flaw in phenological allocation','','')
4374	ENDIF
4375
4376	ENDIF
4377
4378	!! 5.3.4 Wrap-up phenological allocation
4379	IF ( Cl_incp(1) .GE. zero .OR. Cr_incp(1) .GE. zero .OR. &
4380	Cs_incp(1) .GE. zero) THEN
4381
4382	! Prevent overspending for leaves
4383	IF (b_inc_tot - circ_class_n(ipts,j,1) * Cl_incp(1) .LT. zero) THEN
4384	Cl_incp(1) = b_inc_tot/circ_class_n(ipts,j,1)
4385	ENDIF
4386	b_inc_tot = MAX(zero,b_inc_tot - circ_class_n(ipts,j,1) * Cl_incp(1))
4387
4388	! Prevent overspending for roots
4389	IF (b_inc_tot - circ_class_n(ipts,j,1) * Cr_incp(1) .LT. zero) THEN
4390	Cr_incp(1) = b_inc_tot/circ_class_n(ipts,j,1)
4391	ENDIF
4392	b_inc_tot = MAX(zero,b_inc_tot - circ_class_n(ipts,j,1) * Cr_incp(1))
4393
4394	! Prevent overspending for sapwood
4395	IF (b_inc_tot - circ_class_n(ipts,j,1) * Cs_incp(1) .LT. zero) THEN
4396	Cs_incp(1) = b_inc_tot/circ_class_n(ipts,j,1)
4397	ENDIF
4398	b_inc_tot = MAX(zero,b_inc_tot - circ_class_n(ipts,j,1) * Cs_incp(1))
4399
4400	! Fake allocation for less messy equations in next case,
4401	! incp needs to be added to inc at the end.
4402	Cl(1) = Cl(1) + Cl_incp(1)
4403	Cr(1) = Cr(1) + Cr_incp(1)
4404	Cs(1) = Cs(1) + Cs_incp(1)
4405
4406	ELSE
4407
4408	! The code was written such that the increment pools should be greater
4409	! than or equal to zero. If this is not the case, something fundamental
4410	! is wrong with the if-then constructs under Â§5.3.3.2
4411	WRITE(numout,*) 'WARNING 16: numerical problem, '//&
4412	'one of the increment pools is less than zero'
4413	WRITE(numout,*) 'WARNING 16: Cl_incp(1), Cr_incp(1), Cs_incp(1), j, ipts',&
4414	Cl_incp(1), Cr_incp(1), Cs_incp(1), j, ipts
4415	IF(err_act.GT.1)THEN
4416	CALL ipslerr_p (3,'growth_fun_all',&
4417	'WARNING 16: numerical problem',&
4418	'one of the increment pools is less than zero','')
4419	ENDIF
4420
4421	ENDIF
4422
4423	! Something is wrong with the calculations
4424	IF (b_inc_tot .LT. zero) THEN
4425
4426	WRITE(numout,*) 'WARNING 17: numerical problem overspending '//&
4427	'in the phenological allocation'
4428	WRITE(numout,*) 'WARNING 17: b_inc_tot, j, ipts',b_inc_tot, j, ipts
4429	WRITE(numout,*) 'WARNING 17: Cl_incp, Cr_incp, Cs_incp, ', &
4430	Cl_incp(1), Cr_incp(1), Cs_incp(1)
4431	IF(err_act.GT.1)THEN
4432	CALL ipslerr_p (3,'growth_fun_all',&
4433	'WARNING 17: numerical problem',&
4434	'overspending in the phenological allocation','')
4435	ENDIF
4436
4437	ENDIF
4438
4439	! Intermediate mass balance check. Note that this part of
4440	! the code is in DO-loops over nvm and npts so the
4441	! 'ipts' label is used in the mass balance check
4442	IF(err_act.EQ.4) THEN
4443
4444	! Reset pool_end
4445	pool_end(:,:,:) = zero
4446
4447	! Add bm_alloc_tot into the pool
4448	pool_end(ipts,j,icarbon) = pool_end(ipts,j,icarbon) + &
4449	(SUM((Cl_incp(1) + Cs_incp(1) + Cr_incp(1)) * circ_class_n(ipts,j,:)) + &
4450	b_inc_tot) * veget_max(ipts,j)
4451
4452	! Check mass balance closure. Between intermediate check 2b and 3b
4453	CALL intermediate_mass_balance_check(pool_start, pool_end, circ_class_biomass, &
4454	circ_class_n, veget_max, bm_alloc_tot, gpp_daily, atm_to_bm, dt, npts, &
4455	resp_maint, resp_growth, check_intern_init, ipts, j, '3b', 'ipft')
4456
4457	END IF ! err_act.EQ.4
4458
4459	! Height depends on Cl, so update height when Cl gets updated
4460	qm_height(ipts,j) = biomass_to_lai(Cl(1),j) * lai_to_height(j)
4461	grow_wood = .TRUE.
4462
4463	! Write debug comments to output file
4464	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
4465	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
4466	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
4467	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
4468	circ_class_n, 21)
4469	ENDIF
4470
4471	!! 5.3.6 Ordinary growth
4472	! Allometric relationship between components is respected, sustain
4473	! ordinary growth and allocate biomass to leaves, wood, roots and fruits.
4474	IF ( (ABS(Cl_target(1) - Cl(1) ) .LE. min_stomate) .AND. &
4475	(ABS(Cs_target(1) - Cs(1) ) .LE. min_stomate) .AND. &
4476	(ABS(Cr_target(1) - Cr(1) ) .LE. min_stomate) .AND. &
4477	(grow_wood) .AND. &
4478	(b_inc_tot .GT. min_stomate) ) THEN
4479
4480	! Allocate fraction of carbon to fruit production (at the plant level)
4481	Cf_inc(1) = b_inc_tot * fruit_alloc(j)/circ_class_n(ipts,j,1)
4482
4483	! Residual carbon is allocated to the other components (b_inc_tot is
4484	! at the stand level)
4485	b_inc_tot = b_inc_tot * (1-fruit_alloc(j))
4486
4487	! Following allometric allocation
4488	! (i) b_inc = Cl_inc + Cr_inc + Cs_inc
4489	! (ii) Cr_inc = (Cl + Cl_inc)/LF - Cr
4490	! (iii) Cs_inc = (Cl + Cl_inc) / KF - Cs
4491	! Substitue (ii) and (iii) in (i) and solve for Cl_inc
4492	! <=> b_inc = Cl_inc + ( Cl_inc + Cl ) / KF - Cs + ( Cl_inc + Cl ) / LF - Cr
4493	! <=> b_inc = Cl_inc * ( 1.+ 1/KF + 1./LF ) + Cl/LF - Cs - Cr
4494	! <=> Cl_inc = ( b_inc - Cl/LF + Cs + Cr ) / ( 1.+ 1/KF + 1./LF )
4495	Cl_inc(1) = MAX( (b_inc_tot/circ_class_n(ipts,j,1) - Cl(1)/LF(ipts,j) - &
4496	Cl(1)/KF(ipts,j) + Cs(1) + Cr(1)) / &
4497	(1. + 1./KF(ipts,j) + 1./LF(ipts,j)), zero)
4498
4499	IF (Cl_inc(1) .LE. zero) THEN
4500
4501	Cr_inc(:) = zero
4502	Cs_inc(:) = zero
4503
4504	ELSE
4505
4506	! Wrap-up ordinary growth. Calculate C that was not allocated, note
4507	! that Cf_inc was already substracted
4508	! Prevent overspending for leaves
4509	IF (b_inc_tot - circ_class_n(ipts,j,1) * Cl_inc(1) .LT. zero) THEN
4510
4511	Cl_inc(1) = b_inc_tot/circ_class_n(ipts,j,1)
4512	b_inc_tot = MAX(zero,b_inc_tot - circ_class_n(ipts,j,1) * Cl_inc(1))
4513
4514	! All carbon was used for leaves. No new growth for the roots and the stems
4515	Cs_inc(1) = zero
4516	Cr_inc(1) = zero
4517
4518	ELSE
4519
4520	! If we end up here we can allocate the calculated Cl_inc
4521	b_inc_tot = b_inc_tot - circ_class_n(ipts,j,1) * Cl_inc(1)
4522
4523	! Calculate the height of the expanded canopy
4524	qm_height(ipts,j) = biomass_to_lai(Cl(1) + Cl_inc(1),j) * &
4525	lai_to_height(j)
4526
4527	! Use the solution for Cl_inc to calculate Cr_inc and
4528	! Cs_inc according to (ii) and (iii)
4529	Cr_inc(1) = (Cl(1) + Cl_inc(1)) / LF(ipts,j) - Cr(1)
4530
4531	IF (b_inc_tot - circ_class_n(ipts,j,1) * Cr_inc(1) .LT. zero) THEN
4532
4533	Cr_inc(1) = b_inc_tot/circ_class_n(ipts,j,1)
4534	b_inc_tot = MAX(zero, b_inc_tot - circ_class_n(ipts,j,1) * Cr_inc(1))
4535
4536	! No C left to grow new stems
4537	Cs_inc(1) = zero
4538
4539	ELSE
4540
4541	! If we end up here we can allocate the calculated Cr_inc
4542	b_inc_tot = b_inc_tot - circ_class_n(ipts,j,1) * Cr_inc(1)
4543
4544	! Still carbon left so allocate it to the stems
4545	! Cs_inc(1) can be calculated as follows
4546	! Cs_inc(1) = (Cl(1) + Cl_inc(1)) / KF(ipts,j) - Cs(1)
4547	! It is easier and better for the mass balance closure to move
4548	! all the remaining b_inc_tot in the Cs_inc. Should be the
4549	! same except for the rounding and precision issues
4550	Cs_inc(1) = MAX(zero,b_inc_tot/circ_class_n(ipts,j,1))
4551	b_inc_tot = zero
4552
4553	END IF
4554
4555	END IF
4556
4557	END IF ! Cl_inc(1). LE. zero
4558
4559	! Write debug comments to output file
4560	IF ((j.EQ.test_pft .AND. ipts.EQ.test_grid .AND. printlev_loc.GE.4) .OR. printlev_loc>=5) THEN
4561	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
4562	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
4563	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
4564	circ_class_n, 22)
4565	ENDIF
4566
4567	! Debug
4568	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
4569	WRITE(numout,*) 'wrap-up ordinary allocation, left b_in_tot, ', &
4570	b_inc_tot
4571	ENDIF
4572	!-
4573
4574	! Intermediate mass balance check. Note that this part of
4575	! the code is in DO-loops over nvm and one over npts so the
4576	! 'ipts' label is used in the mass balance check
4577	IF (err_act.EQ.4) THEN
4578
4579	! All carbon should have been allocated and the remainder was moved
4580	! back into the labile pool. b_inc_tot should be zero. If not, the
4581	! calculation of pool_end is wrong.
4582	IF(ABS(b_inc_tot).GT.min_stomate)THEN
4583	WRITE(numout,*) 'b_inc_tot differs from zero, ', ipts,j,b_inc_tot
4584	CALL ipslerr_p(3,'stomate_growth_fun_all.f90','intermediate mbcheck 3c',&
4585	'b_inc_tot differs from zero','')
4586	END IF
4587
4588	! Reset pool_end
4589	pool_end(:,:,:) = zero
4590	WRITE(numout,) 'Cl, ', Cl_incp(1)circ_class_n(ipts,j,1)veget_max(ipts,j), Cl_inc(1)circ_class_n(ipts,j,1)*veget_max(ipts,j)
4591	WRITE(numout,) 'Cs, ', Cs_incp(1)circ_class_n(ipts,j,1)veget_max(ipts,j), Cs_inc(1)circ_class_n(ipts,j,1)*veget_max(ipts,j)
4592	WRITE(numout,) 'Cr, ', Cr_incp(1)circ_class_n(ipts,j,1)veget_max(ipts,j), Cr_inc(1)circ_class_n(ipts,j,1)*veget_max(ipts,j)
4593	WRITE(numout,) 'Cf, ', Cf_inc(1)circ_class_n(ipts,j,1)
4594	! Add bm_alloc_tot into the pool
4595	pool_end(ipts,j,icarbon) = ((Cl_incp(1) + Cr_incp(1) + Cs_incp(1) + &
4596	Cl_inc(1) + Cs_inc(1) + Cr_inc(1) + Cf_inc(1)) * &
4597	circ_class_n(ipts,j,1)) * veget_max(ipts,j)
4598
4599	! Check mass balance closure. Between intermediate check 3b and 3c ordinary
4600	! allocation was accounted for. However, ordinary allocation was calculated in
4601	! temporary variables but has not been accounted for yet. This check comes at
4602	! the end of the allocation for grasses and crops.
4603	CALL intermediate_mass_balance_check(pool_start, pool_end, circ_class_biomass, &
4604	circ_class_n, veget_max, bm_alloc_tot, gpp_daily, atm_to_bm, dt, npts, &
4605	resp_maint, resp_growth, check_intern_init, ipts, j, '3c', 'ipft')
4606
4607	ENDIF ! err_act.EQ.4
4608
4609	!! 5.3.7 Don't grow wood, use C to fill labile pool
4610	ELSEIF ( (.NOT. grow_wood) .AND. (b_inc_tot .GT. min_stomate) ) THEN
4611
4612	! grow_wood is always .TRUE. see 5.3.5 around line 3652. Is this
4613	! intended or did we delete an if-statement?
4614	! Calculate the C that needs to be distributed to the
4615	! labile pool. The fraction is proportional to the ratio
4616	! between the total allocatable biomass and the unallocated
4617	! biomass per tree (b_inc now contains the unallocated
4618	! biomass). At the end of the allocation scheme bm_alloc_tot
4619	! is substracted from the labile biomass pool to update the
4620	! biomass pool (tmp_bm(:,:,ilabile) = tmp_bm(:,:,ilabile) -
4621	! bm_alloc_tot(:,:)). At that point, the scheme puts the
4622	! unallocated b_inc into the labile pool. What we
4623	! want is that the unallocated fraction is removed from
4624	! ::bm_alloc_tot such that only the allocated C is removed
4625	! from the labile pool. b_inc_tot will be moved back into
4626	! the labile pool in 5.2.11. resp_growth will be adjusted
4627	! later in the code.
4628	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - b_inc_tot
4629	circ_class_biomass(ipts,j,1,ilabile,icarbon) = &
4630	circ_class_biomass(ipts,j,1,ilabile,icarbon) + &
4631	b_inc_tot
4632
4633	! Wrap-up ordinary growth
4634	! Calculate C that was not allocated (b_inc_tot), the
4635	! equation should read b_inc_tot = b_inc_tot - b_inc_tot
4636	! note that Cf_inc was already substracted
4637	b_inc_tot = zero
4638
4639
4640	! Debug
4641	IF (printlev_loc.GE.3 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
4642	WRITE(numout,*) 'No wood growth, move remaining C to labile pool'
4643	WRITE(numout,*) 'bm_alloc_tot, ',bm_alloc_tot(ipts,j)
4644	WRITE(numout,*) 'wrap-up ordinary allocation, left b_inc_tot, ', &
4645	b_inc_tot
4646	ENDIF
4647	!-
4648
4649	!! 5.3.8 Error - the allocation scheme is overspending
4650	ELSEIF (b_inc_tot .LE. min_stomate) THEN
4651
4652	IF (b_inc_tot .LT. zero) THEN
4653
4654	! Something is wrong with the calculations
4655	WRITE(numout,*) 'WARNING 18: numerical problem'//&
4656	'overspending in ordinary allocation'
4657	WRITE(numout,*) 'WARNING 18: PFT, ipts, b_inc_tot: ', &
4658	j, ipts,b_inc_tot
4659	IF(err_act.GT.1)THEN
4660	CALL ipslerr_p (3,'growth_fun_all',&
4661	'WARNING 18: numerical problem',&
4662	'overspending in ordinary allocation','')
4663	ENDIF
4664
4665	ELSE
4666
4667	IF (j .EQ. test_pft .AND. printlev_loc.GE.4) THEN
4668
4669	! Succesful allocation
4670	WRITE(numout,*) 'Successful allocation'
4671
4672	ENDIF
4673
4674	ENDIF
4675
4676	! Althought the biomass components respect the allometric
4677	! relationships, there is less than min_stomate carbon left
4678	! to allocate. Put this little carbon in the leaves to
4679	! preserve mass balance closure.
4680	Cl_inc(1) = Cl_inc(1) + b_inc_tot/circ_class_n(ipts,j,1)
4681	b_inc_tot = zero
4682	Cs_inc(1) = zero
4683	Cr_inc(1) = zero
4684	Cf_inc(1) = zero
4685
4686	ELSE
4687
4688	WRITE(numout,*) 'WARNING 19: Logical flaw'//&
4689	'unexpected result in ordinary allocation'
4690	WRITE(numout,*) 'WARNING 19: PFT, ipts: ', j, ipts
4691	WRITE(numout,*) 'WARNING 19: ',ABS(Cl_target(1) - Cl(1) ) , Cl(1)
4692	WRITE(numout,*) 'WARNING 19: ',ABS(Cs_target(1) - Cs(1) ) , Cs(1)
4693	WRITE(numout,*) 'WARNING 19: ',ABS(Cr_target(1) - Cr(1) ) , Cr(1)
4694	WRITE(numout,*) 'WARNING 19: ',grow_wood
4695	WRITE(numout,*) 'WARNING 19: ',b_inc_tot,circ_class_n(ipts,j,1),&
4696	b_inc_tot/circ_class_n(ipts,j,1)
4697	IF(err_act.GT.1)THEN
4698	CALL ipslerr_p (3,'growth_fun_all',&
4699	'WARNING 19: Logical flaw',&
4700	'unexpected result in ordinary allocation','')
4701	ENDIF
4702
4703	ENDIF ! Ordinary allocation
4704
4705	!! 5.3.9 Error checking
4706	IF ( b_inc_tot .GT. min_stomate ) THEN
4707
4708	! This should not happen, in case the functional allocation
4709	! did not consume all the allocatable carbon, the remaining C
4710	! is left for the next day.
4711	WRITE(numout,*) 'WARNING 20: unexpected outcome force allocation'
4712	WRITE(numout,*) 'WARNING 20: grow_wood, b_inc_tot: ', grow_wood, b_inc_tot
4713	WRITE(numout,*) 'WARNING 20: PFT, ipts: ',j,ipts
4714	IF(err_act.GT.1)THEN
4715	CALL ipslerr_p (3,'growth_fun_all',&
4716	'WARNING 20: unexpected outcome force allocation','','')
4717	ENDIF
4718
4719	ELSEIF ( (b_inc_tot .LT. min_stomate) .AND. &
4720	(b_inc_tot .GE. zero) ) THEN
4721
4722	! Successful allocation
4723	! Debug
4724	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
4725	WRITE(numout,*) 'Successful allocation'
4726	ENDIF
4727	!----------
4728
4729	ELSE
4730
4731	! Something possibly important was overlooked
4732	IF ( (b_inc_tot .LT. zero) .AND. &
4733	(b_inc_tot .GE. -100*min_stomate) ) THEN
4734	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
4735	WRITE(numout,*) 'Marginally successful allocation - '//&
4736	'precision is better than 10-6', j
4737	ENDIF
4738	ELSE
4739	WRITE(numout,*) 'WARNING 21: Logical flaw '//&
4740	'unexpected result in ordinary allocation'
4741	WRITE(numout,*) 'WARNING 21: b_inc_tot',b_inc_tot
4742	WRITE(numout,*) 'WARNING 21: PFT, ipts: ',j,ipts
4743	CALL ipslerr_p (3,'growth_fun_all',&
4744	'WARNING 21: Logical flaw unexpected result',&
4745	'in ordinary allocation','')
4746	ENDIF
4747
4748	ENDIF
4749
4750	! The second problem we need to catch is when one of the increment
4751	! pools is negative. This is an undesired outcome (see comment where
4752	! ::KF_old is calculated in this routine. In that case we write a
4753	! warning, set all increment pools to zero and try it again at the
4754	! next time step. A likely cause of this problem is a too large change
4755	! in KF from one time step to another. Try decreasing the acceptable
4756	! value for an absolute increase in KF.
4757	IF (Cs_inc(1) .LT. zero .OR. &
4758	Cr_inc(1) .LT. zero .OR. &
4759	Cs_inc(1) .LT. zero) THEN
4760
4761	! Do not allocate - save the carbon for the next time step
4762	Cl_inc(1) = zero
4763	Cr_inc(1) = zero
4764	Cs_inc(1) = zero
4765	WRITE(numout,*) 'WARNING 22: numerical problem, one of the increment '//&
4766	'pools is less than zero'
4767	WRITE(numout,*) 'WARNING 22: PFT, ipts: ',j,ipts
4768
4769	ENDIF
4770
4771	!! 5.3.10 Wrap-up phenological and ordinary allocation
4772	Cl_inc(1) = Cl_inc(1) + Cl_incp(1)
4773	Cr_inc(1) = Cr_inc(1) + Cr_incp(1)
4774	Cs_inc(1) = Cs_inc(1) + Cs_incp(1)
4775	residual(ipts,j) = b_inc_tot
4776
4777	! Debug
4778	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
4779	WRITE(numout,*) 'Final allocation', ipts, j
4780	WRITE(numout,*) 'Cl, Cs, Cr', Cl(1), Cs(1), Cr(1)
4781	WRITE(numout,*) 'Cl_incp, Cs_incp, Cr_incp, ', &
4782	Cl_incp(1), Cs_incp(1), Cr_incp(1)
4783	WRITE(numout,*) 'Cl_inc, Cs_ins, Cr_inc, Cf_inc, ', &
4784	Cl_inc(1), Cs_inc(1), Cr_inc(1), Cf_inc(1)
4785	WRITE(numout,*) 'unallocated/residual, ', b_inc_tot
4786	ENDIF
4787	!-
4788
4789	!! 5.3.11 Account for the residual
4790	! The residual is usually around ::min_stomate but we deal
4791	! with it anyway to make sure the mass balance is closed
4792	! and as a way to detect errors. Move the unallocated carbon
4793	! back into the labile pool
4794	IF (circ_class_biomass(ipts,j,1,ilabile,icarbon) + &
4795	residual(ipts,j) .LE. min_stomate) THEN
4796
4797	deficit = circ_class_biomass(ipts,j,1,ilabile,icarbon) + residual(ipts,j)
4798
4799	! The deficit is less than the carbon reserve
4800	IF (-deficit .LE. circ_class_biomass(ipts,j,1,icarbres,icarbon)) THEN
4801
4802	! Pay the deficit from the reserve pool
4803	circ_class_biomass(ipts,j,1,icarbres,icarbon) = &
4804	circ_class_biomass(ipts,j,1,icarbres,icarbon) + deficit
4805	circ_class_biomass(ipts,j,1,ilabile,icarbon) = &
4806	circ_class_biomass(ipts,j,1,ilabile,icarbon) - deficit
4807
4808	ELSE
4809
4810	! Not enough carbon to pay the deficit
4811	! There is likely a bigger problem somewhere in
4812	! this routine
4813	WRITE(numout,*) 'WARNING 23: PFT, ipts: ',j,ipts
4814	CALL ipslerr_p (3,'growth_fun_all',&
4815	'WARNING 23: numerical problem overspending ',&
4816	'when trying to account for unallocatable C ','')
4817
4818	ENDIF
4819
4820	ELSE
4821
4822	! Move the unallocated carbon back into the labile pool
4823	circ_class_biomass(ipts,j,1,ilabile,icarbon) = &
4824	circ_class_biomass(ipts,j,1,ilabile,icarbon) + residual(ipts,j)
4825
4826	ENDIF
4827
4828
4829	!! 5.3.12 Standardise allocation factors
4830	! Strictly speaking the allocation factors do not need to be
4831	! calculated because the functional allocation scheme allocates
4832	! absolute amounts of carbon. Hence, Cl_inc could simply be added to
4833	! tmp_bm(:,:,ileaf,icarbon), Cr_inc to tmp_bm(:,:,iroot,icarbon),
4834	! etc. However, using allocation factors bears some elegance in
4835	! respect to distributing the growth respiration if this would be
4836	! required. Further it facilitates comparison to the resource
4837	! limited allocation scheme (stomate_growth_res_lim.f90) and it
4838	! comes in handy for model-data comparison. This allocation
4839	! takes place at the tree level - note that ::biomass is the only
4840	! prognostic variable from the tree-based allocation
4841
4842	! Allocation
4843	Cl_inc(1) = MAX(zero, circ_class_n(ipts,j,1) * Cl_inc(1))
4844	Cr_inc(1) = MAX(zero, circ_class_n(ipts,j,1) * Cr_inc(1))
4845	Cs_inc(1) = MAX(zero, circ_class_n(ipts,j,1) * Cs_inc(1))
4846	Cf_inc(1) = MAX(zero, circ_class_n(ipts,j,1) * Cf_inc(1))
4847
4848	! Total_inc is based on the updated Cl_inc, Cr_inc,
4849	! Cs_inc and Cf_inc. Therefore, do not multiply
4850	! ind(ipts,j) again
4851	total_inc = (Cf_inc(1) + Cl_inc(1) + Cs_inc(1) + Cr_inc(1))
4852
4853	! Relative allocation
4854	IF ( total_inc .GT. min_stomate ) THEN
4855
4856	Cl_inc(1) = Cl_inc(1) / total_inc
4857	Cs_inc(1) = Cs_inc(1) / total_inc
4858	Cr_inc(1) = Cr_inc(1) / total_inc
4859	Cf_inc(1) = Cf_inc(1) / total_inc
4860
4861	ELSE
4862
4863	bm_alloc_tot(ipts,j) = zero
4864	Cl_inc(1) = zero
4865	Cs_inc(1) = zero
4866	Cr_inc(1) = zero
4867	Cf_inc(1) = zero
4868
4869	ENDIF
4870
4871	!! 5.3.13 Convert allocation to allocation facors
4872	! Convert allocation of individuals to ORCHIDEE's allocation
4873	! factors - see comment for 5.2.5
4874	! Aboveground sapwood allocation is age dependent in trees,
4875	! but there is only aboveground allocation in grasses
4876	alloc_sap_above = un
4877
4878	! Leaf, wood, root and fruit allocation. Note that the X_inc
4879	! are normalized before being used here. Calculate f_alloc(fruit)
4880	! as the residual to enhance mass balance closure
4881	f_alloc(ipts,j,ileaf) = Cl_inc(1)
4882	f_alloc(ipts,j,isapabove) = Cs_inc(1)*alloc_sap_above
4883	f_alloc(ipts,j,isapbelow) = Cs_inc(1)*(1.-alloc_sap_above)
4884	f_alloc(ipts,j,iroot) = Cr_inc(1)
4885	f_alloc(ipts,j,ifruit) = Cf_inc(1)
4886
4887	! Store f_alloc per circ_class to calculate the allocation
4888	! in circ_class_biomass after bm_alloc_tot has been checked
4889	! for the N availability. Note that the X_inc
4890	! are normalized before being used here. Calculate f_alloc_circ(fruit)
4891	! as the residual to enhance mass balance closure
4892	f_alloc_circ(ipts,1,ileaf) = Cl_inc(1)
4893	f_alloc_circ(ipts,1,isapabove) = Cs_inc(1)*alloc_sap_above
4894	f_alloc_circ(ipts,1,isapbelow) = Cs_inc(1)*(1.-alloc_sap_above)
4895	f_alloc_circ(ipts,1,iroot) = Cr_inc(1)
4896	f_alloc_circ(ipts,1,ifruit) = Cf_inc(1)
4897
4898	ELSEIF (.NOT. is_tree(j)) THEN
4899
4900	! The first option is IF ( .NOT. is_tree(j) .AND. &
4901	! bm_alloc_tot(ipts,j) .GT. min_stomate ) THEN
4902	! If we end up here there is not enough biomass to allocate
4903	f_alloc(ipts,j,ileaf) = zero
4904	f_alloc(ipts,j,isapabove) = zero
4905	f_alloc(ipts,j,isapbelow) = zero
4906	f_alloc(ipts,j,iroot) = zero
4907	f_alloc(ipts,j,ifruit) = zero
4908	residual(ipts,j) = zero
4909
4910	! Debug
4911	IF(printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) WRITE(numout,*) &
4912	'there is no non-tree biomass '//&
4913	'to allocate, PFT, ', ipts, j
4914	!-
4915
4916	ENDIF ! .NOT. is_tree(j) and there is biomass to allocate (Â§5.3 - far far up)
4917
4918	! Intermediate mass balance check. Note that this part of
4919	! the code is in DO-loops over nvm and npts so the
4920	! 'ipts' label is used in the mass balance check
4921	IF(err_act.EQ.4) THEN
4922
4923	! Reset pool_end
4924	pool_end(:,:,:) = zero
4925
4926	! The error check makes use of Cx_inc and Cx_incp so it should be
4927	! done in the DO-loop for npts.
4928	pool_end(ipts,j,icarbon) = pool_end(ipts,j,icarbon) + &
4929	bm_alloc_tot(ipts,j) * veget_max(ipts,j)
4930
4931	! Check mass balance closure. Between intermediate check 3a/b and 4
4932	! allocation factors were calculated but not used. Residuals
4933	! was moved back into the labile pool.
4934	CALL intermediate_mass_balance_check(pool_start, pool_end, circ_class_biomass, &
4935	circ_class_n, veget_max, bm_alloc_tot, gpp_daily, atm_to_bm, dt, npts, &
4936	resp_maint, resp_growth, check_intern_init, ipts, j, '4', 'ipft')
4937
4938	END IF ! err_act.EQ.4
4939
4940	ENDDO ! npts
4941
4942	! Account for the residual (carbon that could not be allocated
4943	! during phenological or ordinary growth) before using bm_alloc_tot.
4944	bm_alloc_tot(:,j)= bm_alloc_tot(:,j) - residual(:,j)
4945
4946	! Debug
4947	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
4948	WRITE(numout,*) 'Accounted for residual'
4949	WRITE(numout,*) 'bm_alloc_tot_new, ',ipts, j, bm_alloc_tot(test_grid,j)
4950	ENDIF
4951	!-
4952
4953	!! 5.4 Quantify and account for nitrogen limitation on growth
4954	DO ipts = 1 , npts
4955
4956	! This far we calculated how we would like to allocate the available
4957	! carbon (::f_alloc) and how much carbon of the available carbon we
4958	! can allocate (typically except for some exceptional cases and numerical
4959	! residuals). Nothing has yet been allocated. Allocation itself, meaning
4960	! the updating of biomass pools is taken care off in the subsequent parts
4961	! of the code. circ_class_biomass contains the latest information for
4962	! all the biomass pools. The next section is generic for trees, grasses and
4963	! crops so we first have to update the information in the biomass variable
4964	! so it can be used later
4965	!+++CHECK+++
4966	! replace by biomass_to_cc_2d
4967	!!$ tmp_bm(:,:,:,:) = cc_to_biomass(npts,nvm,&
4968	!!$ circ_class_biomass(:,:,:,:,:),&
4969	!!$ circ_class_n(:,:,:))
4970	DO iele = 1,nelements
4971	DO ipar = 1,nparts
4972	tmp_bm(ipts,j,ipar,iele) = &
4973	SUM(circ_class_biomass(ipts,j,:,ipar,iele)*&
4974	circ_class_n(ipts,j,:))
4975	ENDDO
4976	ENDDO
4977
4978	!++++++++++++
4979
4980	! Initialize
4981	deltacn=1.0
4982
4983	! Nitrogen cost, given required N for a given allocatable
4984	! biomass C, and an intended leaf CN as N = C * costf / C:N
4985	! Note that fcn is not a classic c/n ratio but is the c/n ratio
4986	! compared to the c/n ratio for leaves. When bm_supply_n is
4987	! calculated this is accounted for through multiplying
4988	! with cn_leaf. The unit of costf is gN required per gN in the leaf
4989	costf = f_alloc(ipts,j,ileaf) + fcn_wood(j) * &
4990	(f_alloc(ipts,j,isapabove)+f_alloc(ipts,j,isapbelow)) + &
4991	fcn_root(j) * ( f_alloc(ipts,j,iroot) + f_alloc(ipts,j,ifruit))
4992
4993	! Debug
4994	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
4995	WRITE(numout,*) 'costf, ', ipts,j, costf
4996	WRITE(numout,*) 'bm_alloc_tot, ',bm_alloc_tot(ipts,j)
4997	WRITE(numout,*) 'f_alloc, ', f_alloc(ipts,j,ileaf),&
4998	f_alloc(ipts,j,isapabove), f_alloc(ipts,j,isapbelow),&
4999	f_alloc(ipts,j,iroot),f_alloc(ipts,j,ifruit)
5000	WRITE(numout,*) 'fcn, ',fcn_wood(j), fcn_root(j)
5001	ENDIF
5002	!-
5003
5004	! Only check if there is biomass growth
5005	IF ( costf.GT.min_stomate ) THEN
5006
5007	! fraction of labile N allocatable for growth
5008	! no growth respiration calculated here!
5009	n_avail = MAX(tmp_bm(ipts,j,ilabile,initrogen)*0.9,0.0)
5010
5011	! carbon growth possible given nitrogen availability and
5012	! current nitrogen concentration
5013	bm_supply_n = n_avail / costf / (1.-frac_growthresp_dyn) * &
5014	cn_leaf(ipts,j)
5015
5016	! elasticity of leaf nitrogen concentration
5017	! deltacnmax=exp(-(1./(cn_leaf(ipts,j)0.5(1./cn_leaf_max(j)+1./&
5018	! cn_leaf_min(j))))**8)
5019	deltacnmax = 1. - exp(-((1.6 * MIN((1./cn_leaf(ipts,j))-(1./cn_leaf_min_2D(ipts,j)),0.) / &
5020	( (1./(cn_leaf_max_2D(ipts,j))) - (1./cn_leaf_min_2D(ipts,j)) ) )**4.1))
5021
5022	! Debug
5023	IF (printlev_loc.GE.3) THEN
5024	IF((test_grid == ipts).AND.(test_pft==j)) THEN
5025	WRITE(numout,*) 'cn_leaf: ', cn_leaf(ipts,j)
5026	WRITE(numout,*) 'bm_supply_n: ', bm_supply_n
5027	WRITE(numout,*) 'bm_alloc_tot: ', bm_alloc_tot(ipts,j)
5028	ENDIF
5029	ENDIF
5030	!-
5031
5032	! Check whether we can allocate all the carbon or whether we
5033	! have N-limitation.
5034	IF ( bm_alloc_tot(ipts,j) .GT. bm_supply_n ) THEN
5035
5036	IF (impose_cn) THEN
5037
5038	! Debug
5039	IF (printlev_loc.GT.4) THEN
5040	IF((test_grid == ipts) .AND. (test_pft==j)) THEN
5041	WRITE(numout,*) "atm_to_bm(initrogen)",atm_to_bm(ipts,j,initrogen)
5042	WRITE(numout,*) 'bm_alloc_tot, ',bm_alloc_tot(ipts,j)
5043	WRITE(numout,*) "bm_supply_n:",bm_supply_n
5044	WRITE(numout,*) 'frac_growthresp_dyn, ', &
5045	1.-frac_growthresp_dyn
5046	WRITE(numout,*) 'biomass ilabile N L4090, ', j,test_pft, &
5047	tmp_bm(test_grid,test_pft,ilabile,initrogen)
5048	ENDIF
5049	ENDIF
5050	!-
5051
5052	! Impose_cn = y so just take the required nitrogen from
5053	! the atmosphere and add it to the labile pool of the plant
5054	atm_to_bm(ipts,j,initrogen) = atm_to_bm(ipts,j,initrogen) + &
5055	((bm_alloc_tot(ipts,j)-bm_supply_n)&
5056	costf(1.-frac_growthresp_dyn) / &
5057	cn_leaf(ipts,j)/0.9)/dt
5058	tmp_bm(ipts,j,ilabile,initrogen) = &
5059	tmp_bm(ipts,j,ilabile,initrogen) + &
5060	(bm_alloc_tot(ipts,j)-bm_supply_n)&
5061	costf(1.-frac_growthresp_dyn) / &
5062	cn_leaf(ipts,j)/0.9
5063
5064	! tmp_bm(ilabile) has changed, update circ_class_biomass
5065	circ_class_biomass(ipts,j,:,ilabile,initrogen) = &
5066	biomass_to_cc(tmp_bm(ipts,j,ilabile,initrogen),&
5067	circ_class_biomass(ipts,j,:,ilabile,initrogen),&
5068	circ_class_n(ipts,j,:))
5069
5070	n_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) * &
5071	(1.-frac_growthresp_dyn) * costf / cn_leaf(ipts,j)
5072
5073	! Debug
5074	IF (printlev_loc.GT.4) THEN
5075	IF((test_grid == ipts).AND.(test_pft==j)) THEN
5076	WRITE(numout,*) "atm_to_bm(nitrogen)",atm_to_bm(ipts,j,initrogen)
5077	WRITE(numout,*) 'biomass ilabile N L4121, ', j,test_pft, &
5078	tmp_bm(test_grid,test_pft,ilabile,initrogen)
5079	ENDIF
5080	ENDIF
5081
5082	ELSE
5083
5084	!Do not impose_cn thus use the dynamic N-cycle
5085	IF (printlev_loc .GE. 4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
5086	WRITE(numout,*) 'N-limitation is a fact'
5087	ENDIF
5088
5089	! case of not enough nitrogen to sustain intended growth,
5090	! reduce carbon allocation to meet nitrogen availability
5091	! taking into account the maximal change of nitrogen
5092	! concentrations. delta of nitrogen concentrations in
5093	! response to nitrogen deficit
5094	deltacnmax=Dmax * (1.-deltacnmax)
5095	deltacn = n_avail / ( bm_alloc_tot(ipts,j) * &
5096	(1.-frac_growthresp_dyn) * costf * &
5097	1./cn_leaf(ipts,j) )
5098	deltacn=MIN(MAX(deltacn,1.0-deltacnmax),1.0)
5099
5100	! nitrogen demand given possible nitrogen concentration change
5101	n_alloc_tot(ipts,j) = MIN( n_avail , &
5102	bm_alloc_tot(ipts,j) * (1.-frac_growthresp_dyn) * costf * &
5103	MAX(MIN( 1./cn_leaf(ipts,j)*deltacn, 1./cn_leaf_min_2D(ipts,j)), &
5104	1./cn_leaf_max_2D(ipts,j)) )
5105
5106	! if not successful, reduce growth
5107	! constrain carbon used for growth dependent on available
5108	! nitrogen under the assumption that the f_allocs are
5109	! piecewise linear with bm_alloc_tot, which is first-order
5110	! correct. Remember that at the start of this module we
5111	! took bm_alloc_tot from the labile pool. Put it back,
5112	! recalculate bm_alloc_tot and than take it back from the
5113	! labile pool.
5114	tmp_bm(ipts,j,ilabile,icarbon) = &
5115	tmp_bm(ipts,j,ilabile,icarbon) + &
5116	bm_alloc_tot(ipts,j)
5117	bm_alloc_tot(ipts,j) = MIN( bm_alloc_tot(ipts,j) , &
5118	n_alloc_tot(ipts,j) / costf / (1.-frac_growthresp_dyn) / &
5119	MAX(MIN(1./cn_leaf(ipts,j)*deltacn, &
5120	1./cn_leaf_min_2D(ipts,j)), 1./cn_leaf_max_2D(ipts,j)) )
5121
5122	! If bm_alloc_tot did not change, the labile pool will not
5123	! have changed either. In case bm_alloc_tot was adjusted in
5124	! line with n_alloc_tot (line above), then the excess
5125	! carbon is stored in the labile pool
5126	tmp_bm(ipts,j,ilabile,icarbon) = &
5127	tmp_bm(ipts,j,ilabile,icarbon) - &
5128	bm_alloc_tot(ipts,j)
5129
5130	ENDIF !impose_cn
5131
5132	ELSE
5133
5134	IF (printlev_loc .GE. 4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
5135	WRITE(numout,*) 'Sufficient nitrogen'
5136	ENDIF
5137	! Sufficient nitrogen, increase of leaf nitrogen concentration
5138	! dependent on distance to maximal leaf nitrogen concentration
5139	! cannot change leaf C:N in bud burst period nitrogen
5140	! constrained such that nitrogen concentration can only
5141	! increase 1% per day
5142	deltacnmax=Dmax * deltacnmax
5143	deltacn = n_avail / &
5144	( bm_alloc_tot(ipts,j) * (1.-frac_growthresp_dyn) * costf * 1./cn_leaf(ipts,j) )
5145
5146	deltacn=MIN(MAX(deltacn,1.0),1.+deltacnmax)
5147
5148	! Debug
5149	IF((printlev_loc.GT.4) .AND. &
5150	(test_grid == ipts).AND.(test_pft==j)) THEN
5151	WRITE(numout,*) 'biomass ilabile N L4028, ', j,test_pft, &
5152	tmp_bm(test_grid,test_pft,ilabile,initrogen)
5153	ENDIF
5154	!-
5155
5156	n_alloc_tot(ipts,j) = MIN( n_avail , &
5157	bm_alloc_tot(ipts,j) * (1.-frac_growthresp_dyn) * &
5158	costf * MAX(MIN(1./cn_leaf(ipts,j)*deltacn, &
5159	1./cn_leaf_min_2D(ipts,j)),1./cn_leaf_max_2D(ipts,j)) )
5160
5161	ENDIF
5162
5163	ENDIF ! costf.GT.min_stomate
5164
5165	!! 5.X Calculate final growth respiration
5166	! Since growth respiration was estimated at the start
5167	! of this routine, bm_alloc_tot and thus the respiration
5168	! associated to the growth may have changed. Here
5169	! growth respiration is recalculated. This is the final
5170	! calculation. Move the initial estimate back into the
5171	! labile pool. Then recalculate resp_growth and finally
5172	! take it out of the labile pool again. The labile pool
5173	! may have changed so it needs to be updated.
5174	tmp_bm(ipts,j,ilabile,icarbon) = tmp_bm(ipts,j,ilabile,icarbon) + &
5175	resp_growth(ipts,j)
5176
5177	! Resp_growth may have been set to zero (see exception 25). So use
5178	! the lowest estimate for resp_growth
5179	resp_growth(ipts,j) = MIN(resp_growth(ipts,j), &
5180	frac_growthresp(j) * bm_alloc_tot(ipts,j))
5181
5182	! Take resp_growth from the labile pool
5183	tmp_bm(ipts,j,ilabile,icarbon) = tmp_bm(ipts,j,ilabile,icarbon) - &
5184	resp_growth(ipts,j)
5185
5186	! tmp_bm(ilabile) has changed, update circ_class_biomass
5187	circ_class_biomass(ipts,j,:,ilabile,icarbon) = &
5188	biomass_to_cc(tmp_bm(ipts,j,ilabile,icarbon),&
5189	circ_class_biomass(ipts,j,:,ilabile,icarbon),&
5190	circ_class_n(ipts,j,:))
5191
5192	ENDDO ! # domain npts
5193
5194	! Debug
5195	IF(printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
5196	WRITE(numout,*) 'stomate_allocation - bm_alloc_tot may have been adjusted'
5197	WRITE(numout,*) 'bm_alloc_tot, ',bm_alloc_tot(test_grid,j)
5198	WRITE(numout,*) 'resp_growth ', resp_growth(test_grid,j)
5199	IF(bm_alloc_tot(test_grid,j).GT.min_stomate)THEN
5200	WRITE(numout,*) 'ratio resp_growth/bm_alloc_tot, ', &
5201	resp_growth(test_grid,j)/bm_alloc_tot(test_grid,j)
5202	ENDIF
5203	ENDIF
5204	!-
5205
5206	!! 5.5 Allocate allocatable biomass to different plant compartments
5207	! Absolute allocation at the tree level and for an individual tree (gC tree-1)
5208	! The labile and reserve pools are not allocated at the tree level. However,
5209	! stand level ilabile and icarbres biomass will be redistributed at the tree
5210	! level later in this subroutine. This is done after the relative allocation
5211	! beacuse now ::alloc_sap_above is known
5212	DO ipts = 1,npts
5213	DO icir = 1,ncirc
5214	DO ipar = 1,nparts
5215	IF (ipar.EQ.ileaf .OR. ipar.EQ.isapabove .OR. &
5216	ipar.EQ.isapbelow .OR. ipar.EQ.iroot .OR. &
5217	ipar.EQ.ifruit) THEN
5218
5219	! Check whether the allocation factor is defined
5220	! and whether there are trees in this circ_class
5221	IF (f_alloc_circ(ipts,icir,ipar).GE.zero .AND. &
5222	f_alloc_circ(ipts,icir,ipar).LE.un .AND. &
5223	circ_class_n(ipts,j,icir).GT.min_stomate) THEN
5224
5225	! Calculate circ_class biomass with the latest and
5226	! final bm_alloc_tot
5227	circ_class_biomass(ipts,j,icir,ipar,icarbon) = &
5228	circ_class_biomass(ipts,j,icir,ipar,icarbon) + &
5229	( f_alloc_circ(ipts,icir,ipar) * bm_alloc_tot(ipts,j) / &
5230	circ_class_n(ipts,j,icir) )
5231
5232	ENDIF ! f_alloc is defined
5233	ENDIF ! select plant parts
5234	ENDDO ! ipar
5235	ENDDO ! icir
5236	ENDDO ! ipts
5237
5238	! The amount of allocatable carbon biomass to each compartment is a
5239	! fraction ::f_alloc of the total allocatable biomass
5240	DO k = 1, nparts
5241
5242	bm_alloc(:,j,k,icarbon) = f_alloc(:,j,k) * bm_alloc_tot(:,j)
5243
5244	ENDDO
5245
5246	! All the carbon contained in bm_alloc_tot has been allocated
5247	bm_alloc_tot(:,j) = zero
5248
5249	! Zero the array for PFT 1, since it has not been calculated but it
5250	! is used in implict loops below
5251	bm_alloc_tot(:,1) = zero
5252	bm_alloc(:,1,:,:) = zero
5253
5254	ENDDO ! # End Loop over # of PFTs
5255
5256
5257	! Intermediate mass balance check. N has not been allocated yet. It is
5258	! tested but the test is not very informative.
5259	IF (err_act.EQ.4) THEN
5260
5261	! Reset pool_end
5262	pool_end(:,:,:) = zero
5263
5264	! Check mass balance closure. Between intermediate check 4 and 5
5265	! the carbon allocation was checked against the available nitrogen
5266	! and was finally allocated.
5267	CALL intermediate_mass_balance_check(pool_start, pool_end, circ_class_biomass, &
5268	circ_class_n, veget_max, bm_alloc_tot, gpp_daily, atm_to_bm, dt, npts, &
5269	resp_maint, resp_growth, check_intern_init, ipts, j, '5', 'pft')
5270
5271	ENDIF ! err_act.EQ.4
5272
5273	!! 6. Calculate nitrogen fluxes associated with biomass growth
5274
5275	! this is the case of dynamic allocation of nitrogen taken up from the soil
5276	! The principles of this allocation are
5277	! 1) nitrogen allocated to the plant tissue is dependent on the
5278	! labile nitrogen/carbon ratio i.e. carbon_alloc*(N/C)_labile
5279	! 2) the proportions of C/N ratios between different compartments
5280	! are prescribed as in Hybrid 3
5281	! 3) since different to Hybrid, grasses have sapwood (...) the
5282	! proportions have be adjusted for grasses, since their tillers
5283	! are not lignified...
5284	DO j = 2, nvm
5285
5286	DO ipts = 1, npts
5287
5288	IF (veget_max(ipts,j) .LE. min_stomate) THEN
5289
5290	! This vegetation type is not present, so no reason to do the
5291	! calculation. CYCLE will take us out of the innermost DO loop
5292	CYCLE
5293
5294	ENDIF
5295
5296	! only allocate nitrogen when there is construction of new biomass
5297	IF(SUM(bm_alloc(ipts,j,:,icarbon)).GT.min_stomate) THEN
5298
5299	alloc_c(ipts)=0.0
5300	alloc_d(ipts)=0.0
5301	alloc_e(ipts)=0.0
5302
5303	! pool sapwood and roots+fruits into each on pool
5304	sum_sap(ipts) = bm_alloc(ipts,j,isapabove,icarbon) + &
5305	bm_alloc(ipts,j,isapbelow,icarbon)
5306	sum_oth(ipts) = bm_alloc(ipts,j,iroot,icarbon) + &
5307	bm_alloc(ipts,j,ifruit,icarbon)
5308
5309	IF((sum_sap(ipts)+sum_oth(ipts)).GT.min_stomate) THEN
5310
5311	IF(bm_alloc(ipts,j,ileaf,icarbon).GT.min_stomate) THEN
5312
5313	! in case there is new allocation to leaves
5314	alloc_c(ipts) = 1./(1.+(fcn_wood(j)*sum_sap(ipts) + &
5315	fcn_root(j)*sum_oth(ipts))/bm_alloc(ipts,j,ileaf,icarbon))
5316	alloc_d(ipts) = fcn_wood(j)*sum_sap(ipts) / &
5317	bm_alloc(ipts,j,ileaf,icarbon)*alloc_c(ipts)
5318	alloc_e(ipts) = fcn_root(j)*sum_oth(ipts) / &
5319	bm_alloc(ipts,j,ileaf,icarbon)*alloc_c(ipts)
5320
5321	ELSE
5322
5323	! otherwise add no nitrogen to leaves and alocate the N
5324	! to whatever is constructed
5325	alloc_c(ipts)=0.0
5326	alloc_d(ipts)=sum_sap(ipts)/(sum_sap(ipts)+fcn_root(j) / &
5327	fcn_wood(j)*sum_oth(ipts))
5328	alloc_e(ipts)=1.-alloc_d(ipts)
5329
5330	ENDIF
5331
5332	ELSEIF(bm_alloc(ipts,j,ileaf,icarbon).GT.min_stomate)THEN
5333
5334	! case of only allocation to leaves!
5335	alloc_c(ipts)=1.0
5336
5337	ENDIF
5338
5339	!calculate allocation
5340	bm_alloc(ipts,j,ileaf,initrogen) = alloc_c(ipts)*n_alloc_tot(ipts,j)
5341
5342	! Debug
5343	IF((test_grid == ipts).AND.(test_pft==j).AND. printlev_loc.GE.4)THEN
5344	WRITE(numout,*) 'alloc_c(ipts)=',alloc_c(ipts)
5345	WRITE(numout,*) 'n_alloc_tot(ipts,j)=',n_alloc_tot(ipts,j)
5346	WRITE(numout,*) 'bm_alloc(ipts,j,ileaf,initrogen)=', &
5347	bm_alloc(ipts,j,ileaf,initrogen)
5348	WRITE(numout,*) 'bm_alloc(ipts,j,ileaf,icarbon)=', &
5349	bm_alloc(ipts,j,ileaf,icarbon)
5350	WRITE(numout,*) 'bm_alloc(ipts,j,:,icarbon)=',&
5351	SUM(bm_alloc(ipts,j,:,icarbon))
5352	IF (bm_alloc(ipts,j,ileaf,initrogen).GT.zero) THEN
5353	WRITE(numout,*) "((bm_alloc(ipts,j,ileaf,icarbon)/'//&
5354	'bm_alloc(ipts,j,ileaf,initrogen)):",&
5355	(bm_alloc(ipts,j,ileaf,icarbon)/&
5356	bm_alloc(ipts,j,ileaf,initrogen))
5357	ENDIF
5358	ENDIF
5359	!-
5360
5361	IF(sum_sap(ipts).GT.min_stomate) THEN
5362	bm_alloc(ipts,j,isapabove,initrogen)=alloc_d(ipts)* &
5363	bm_alloc(ipts,j,isapabove,icarbon)/sum_sap(ipts)* &
5364	n_alloc_tot(ipts,j)
5365	bm_alloc(ipts,j,isapbelow,initrogen) = alloc_d(ipts)* &
5366	bm_alloc(ipts,j,isapbelow,icarbon)/sum_sap(ipts)* &
5367	n_alloc_tot(ipts,j)
5368	ENDIF
5369	IF(sum_oth(ipts).GT.min_stomate) THEN
5370	bm_alloc(ipts,j,iroot,initrogen) = alloc_e(ipts) * &
5371	bm_alloc(ipts,j,iroot,icarbon)/sum_oth(ipts) * &
5372	n_alloc_tot(ipts,j)
5373	bm_alloc(ipts,j,ifruit,initrogen) = alloc_e(ipts) * &
5374	bm_alloc(ipts,j,ifruit,icarbon)/sum_oth(ipts) * &
5375	n_alloc_tot(ipts,j)
5376	ENDIF
5377
5378	! Necessary because bm_alloc_tot can be positive in deciduous,
5379	! but all C is put into the reserve in this case, all fractions
5380	! are set to zero, thus no nitrogen is allocated alternatively
5381	! formulation is minus (c+d+e)*n_alloc_tot
5382	n_alloc_tot(ipts,j) = (alloc_c(ipts) + &
5383	alloc_d(ipts) + alloc_e(ipts)) * &
5384	n_alloc_tot(ipts,j)
5385
5386	ELSE !IF bm_alloc carbon > min_stomate
5387
5388	n_alloc_tot(ipts,j) = zero
5389
5390	ENDIF
5391
5392	ENDDO ! # npts
5393
5394	ENDDO ! #PFT
5395
5396
5397	!! 6.3 Retrieve allocated biomass from labile pool
5398	! Only now the allocatable nitrogen is known
5399	! so we will take it from the labile pool.
5400	tmp_bm(:,:,ilabile,initrogen) = tmp_bm(:,:,ilabile,initrogen) - &
5401	n_alloc_tot(:,:)
5402
5403	! Some temporary variables to simplify the calculations
5404	tmp_bm(:,:,ileaf,:) = zero
5405	DO icir = 1,ncirc
5406	DO iele = 1,nelements
5407	tmp_bm(:,:,ileaf,iele) = tmp_bm(:,:,ileaf,iele) + &
5408	circ_class_biomass(:,:,icir,ileaf,iele) * &
5409	circ_class_n(:,:,icir)
5410	tmp_bm(:,:,iroot,iele) = tmp_bm(:,:,iroot,iele) + &
5411	circ_class_biomass(:,:,icir,iroot,iele) * &
5412	circ_class_n(:,:,icir)
5413	ENDDO
5414	ENDDO
5415
5416	! Nitrogen allocation is now accounted for in tmp_bm(ilabile,initrogen)
5417	! n_alloc_tot should be set to zero
5418	n_alloc_tot(:,:) = zero
5419
5420	! Calculate the nitrogen that is being translocated from the leaves
5421	! back to the labile pool. If ORCHIDEE can allocate more than the
5422	! current N/C ratio it will irrespective of whether we are below
5423	! or above the optimal C/N ratio. If leaf N/C is already low but
5424	! bm_all_N/bm_alloc_C is even lower we will take N out of the leaves
5425	! and make the N-limitation even worse. Although seems counterintuitive
5426	! it will decrease NUE, Vcmax and thus the GPP at the next time step.
5427	! transloc is thus a short term control of N-allocation reflecting the
5428	! higher reactivity of nitrogen compared to carbon. As a test transloc
5429	! was set to zero after it was calculated. This resulted in 0 to 5%
5430	! changes in GPP for all PFTs except PFT5 and PFT15. Without transloc
5431	! PFT5 did not grow very well. For PFT15 the effect of transloc was
5432	! mixed showing pixels where the PFT grew better as well as pixel where
5433	! it grew worse than with transloc. transloc seems to be a more
5434	! short term response that is more or less trying to do the same as
5435	! sugar_load. sugar_load is much slower but also much more intrusive.
5436	! Although it appears that this block of code is intended to represent
5437	! a real process (and was unlikely added as a fix afterward), it is
5438	! explicitly described in Zaehle et al 2010 (incl the SI).
5439
5440	! Set to zero for ileaf
5441	transloc(:,:) = zero
5442
5443	WHERE((tmp_bm(:,:,ileaf,icarbon).GT.min_stomate).AND.&
5444	(bm_alloc(:,:,ileaf,icarbon).GT.min_stomate))
5445
5446	transloc(:,:) = tmp_bm(:,:,ileaf,icarbon) * 0.05 * &
5447	(bm_alloc(:,:,ileaf,initrogen)/bm_alloc(:,:,ileaf,icarbon) - &
5448	tmp_bm(:,:,ileaf,initrogen) / &
5449	tmp_bm(:,:,ileaf,icarbon))
5450	transloc(:,:) = MAX(MIN(tmp_bm(:,:,ilabile,initrogen)*0.7,&
5451	transloc(:,:)), -bm_alloc(:,:,ileaf,initrogen))
5452	tmp_bm(:,:,ilabile,initrogen) = tmp_bm(:,:,ilabile,initrogen) - &
5453	transloc(:,:)
5454	bm_alloc(:,:,ileaf,initrogen) = bm_alloc(:,:,ileaf,initrogen) + &
5455	transloc(:,:)
5456
5457	ENDWHERE
5458
5459	! Set to zero for iroot
5460	transloc(:,:) = zero
5461
5462	WHERE((tmp_bm(:,:,iroot,icarbon).GT.min_stomate).AND. &
5463	(bm_alloc(:,:,iroot,icarbon).GT.min_stomate))
5464
5465	transloc(:,:) = tmp_bm(:,:,iroot,icarbon) * 0.05 * &
5466	(bm_alloc(:,:,iroot,initrogen)/bm_alloc(:,:,iroot,icarbon) - &
5467	tmp_bm(:,:,iroot,initrogen) / &
5468	tmp_bm(:,:,iroot,icarbon))
5469	transloc(:,:) = MAX(MIN(tmp_bm(:,:,ilabile,initrogen)*0.7,&
5470	transloc(:,:)), -bm_alloc(:,:,iroot,initrogen))
5471	tmp_bm(:,:,ilabile,initrogen) = tmp_bm(:,:,ilabile,initrogen) - &
5472	transloc(:,:)
5473	bm_alloc(:,:,iroot,initrogen) = bm_alloc(:,:,iroot,initrogen) + &
5474	transloc(:,:)
5475	ENDWHERE
5476
5477	!! 7. Update the biomass with newly allocated nitrogen biomass
5478
5479	! For icarbon, circ_class_biomass contains the latest information
5480	! for all its pools, For nitrogen this is also the case except for
5481	! the labile pool. Account for the latest changes in tmp_bm(ilabile)
5482	! and update circ_class_biomass so it contains the latest values
5483	! for all pools for both elements.
5484	circ_class_biomass(:,:,:,ilabile,initrogen) = &
5485	biomass_to_cc(tmp_bm(:,:,ilabile,initrogen),&
5486	circ_class_biomass(:,:,:,ilabile,initrogen),&
5487	circ_class_n(:,:,:),npts,nvm)
5488
5489	! Now convert circ_class_biomass to biomass to do all subsequent
5490	! calculations. This needs to recalculated because it is possible
5491	! that circ_class_biomass has changed since the last time we
5492	! calculated biomass (see 5.4)
5493	tmp_bm(:,:,:,:) = cc_to_biomass(npts,nvm,&
5494	circ_class_biomass(:,:,:,:,:),&
5495	circ_class_n(:,:,:))
5496
5497	! circ_class_biomass has not changed since the last time biomass
5498	! was calculated so there is no need to recalculate it
5499	tmp_bm(:,:,:,initrogen) = tmp_bm(:,:,:,initrogen) + bm_alloc(:,:,:,initrogen)
5500
5501	! All the biomass pools may have increased for nitrogen so update
5502	! circ_class_biomass. After this operation circ_class_biomass and
5503	! biomass are in sync for carbon and nitrogen
5504	DO ipar = 1,nparts
5505	circ_class_biomass(:,:,:,ipar,initrogen) = &
5506	biomass_to_cc(tmp_bm(:,:,ipar,initrogen),&
5507	circ_class_biomass(:,:,:,ipar,initrogen),&
5508	circ_class_n(:,:,:),npts,nvm)
5509	ENDDO
5510
5511
5512	! Intermediate mass balance check. Both C and N can be checked.
5513	IF (err_act.EQ.4) THEN
5514
5515	! calculate pool_end
5516	pool_end(:,:,:) = zero
5517
5518	! Check mass balance closure. Between intermediate check 5 and 6
5519	! n has been allocated to the different pools. Both C and N are now
5520	! really being checked.
5521	CALL intermediate_mass_balance_check(pool_start, pool_end, circ_class_biomass, &
5522	circ_class_n, veget_max, bm_alloc_tot, gpp_daily, atm_to_bm, dt, npts, &
5523	resp_maint, resp_growth, check_intern_init, ipts, j, '6', 'pft')
5524
5525	ENDIF ! err_act.EQ.4
5526
5527	!! 8. Use or fill reserve pools depending on relative size of the labile and reserve C pool
5528
5529	! +++ CHECK +++
5530	! Externalize all the hard coded values i.e. 0.3
5531	! Calculate the labile pool for all plants and also the reserve pool for trees
5532	DO j = 2,nvm
5533
5534	DO ipts = 1,npts
5535
5536	! Initialize
5537	labile_target(ipts,j,:) = zero
5538	reserve_target(ipts,j,:) = zero
5539
5540	IF ( (veget_max(ipts,j) .LE. min_stomate) .OR. &
5541	(SUM(tmp_bm(ipts,j,:,icarbon)) .LT. min_stomate) ) THEN
5542
5543	! This vegetation type is not present, so no reason to do the
5544	! calculation. CYCLE will take us out of the innermost DO loop
5545	CYCLE
5546
5547	ENDIF
5548
5549	!! 8.2 Calculate the reserves
5550	! There is vegetation present and it has started growing. The second and
5551	! third condition required to make the PFT survive the first year during
5552	! which the long term climate variables are initialized for the phenology.
5553	! If these conditions are not added, the reserves are respired well
5554	! before growth ever starts
5555	IF ( veget_max(ipts,j) .GT. min_stomate .AND. &
5556	rue_longterm(ipts,j) .GE. zero .AND. &
5557	rue_longterm(ipts,j) .NE. un) THEN
5558
5559	!! 8.3 Calculate the optimal size of the pools
5560	! We had an endless series of problems which were often difficult to
5561	! understand but which always seemed to be related to a sudden drop
5562	! in tmp_bm(ilabile). This drop was often the result of a sudden
5563	! change in labile_target. Given that there is not much science behind
5564	! this approach it seems a good idea to remove this max statement to
5565	! avoid sudden changes. Rather than using the actual biomass we propose
5566	! to use the target biomass. This assumes that the tree would like to
5567	! fill its labile pool to be optimal when it would be in allometric
5568	! balance.
5569	IF (is_tree(j)) THEN
5570
5571	! We will make use of the actual sapwood, heartwood and effective height
5572	! and then calculate the target leaves and roots. This approach gives
5573	! us a target for a labile_target of a tree in allometric balance.
5574	! Basal area at the tree level (m2 tree-1)
5575	circ_class_ba_eff(:) = &
5576	wood_to_ba_eff(circ_class_biomass(ipts,j,:,:,icarbon),j)
5577
5578	! Current biomass pools per tree (gC tree^-1)
5579	! We will have different trees so this has to be calculated from the
5580	! diameter relationships
5581	Cs(:) = (circ_class_biomass(ipts,j,:,isapabove,icarbon) + &
5582	circ_class_biomass(ipts,j,:,isapbelow,icarbon)) * scal(ipts,j)
5583	Cr(:) = (circ_class_biomass(ipts,j,:,iroot,icarbon)) * scal(ipts,j)
5584	Cl(:) = (circ_class_biomass(ipts,j,:,ileaf,icarbon)) * scal(ipts,j)
5585
5586	DO l = 1,ncirc
5587
5588	! Calculate tree height
5589	circ_class_height_eff(l) = pipe_tune2(j) * &
5590	(4/picirc_class_ba_eff(l))*(pipe_tune3(j)/2)
5591
5592	ENDDO
5593
5594	! Use the pipe model to calculate the target leaf and root
5595	! biomasses
5596	DO l = 1,ncirc
5597	IF(circ_class_height_eff(l) .GT. min_stomate) THEN
5598	Cl_target(l) = KF(ipts,j) * Cs(l) / circ_class_height_eff(l)
5599
5600	ELSE
5601	Cl_target(l) = MAX((KF(ipts,j) * Cs(l) / circ_class_height_eff(l)), &
5602	(MAX(Cs(1)KF(ipts,j), Cr(1)LF(ipts,j), Cl(1))))
5603
5604	ENDIF
5605	ENDDO
5606
5607	DO l = 1,ncirc
5608	Cr_target(l) = Cl_target(l) / LF(ipts,j)
5609	ENDDO
5610
5611	ELSEIF ( .NOT. is_tree(j)) THEN
5612
5613	! grasses and crops
5614	! Initialize
5615	Cs(:) = zero
5616	Cl_target(:) = zero
5617	Cr_target(:) = zero
5618
5619	! Current biomass pools per grass/crop (gC ind^-1)
5620	! Cs has too many dimensions for grass/crops. To have a consistent
5621	! notation the same variables are used as for trees but the dimension
5622	! of Cs, Cl and Cr i.e. ::ncirc should be ignored
5623	Cs(1) = tmp_bm(ipts,j,isapabove,icarbon) * scal(ipts,j)
5624
5625	! Use the pipe model to calculate the target leaf and root
5626	! biomasses
5627	Cl_target(1) = Cs(1) * KF(ipts,j)
5628	Cr_target(1) = Cl_target(1) / LF(ipts,j)
5629
5630	ENDIF !is_tree
5631
5632	! Accounting for the N-concentration of the tissue as a proxy
5633	! of tissue activity. There were some problems for the deciduous trees, when the
5634	! targeted labile pool was calculated based on the targeted values from the allometric
5635	! allocation (see previous versions). There was an inconsistency in the units, Therefore
5636	! a corrected approach has been introduced. With the corrected approach the labile_target
5637	! typically exceeds 10*gpp_week during the growing season. With a too low labile_target
5638	! the feedback through sugar_load was way too strong.
5639	labile_target(ipts,j,icarbon)=gtemp(ipts,j)labile_reserve(j)(tmp_bm(ipts,j,ileaf,initrogen)+ &
5640	tmp_bm(ipts,j,iroot,initrogen) + tmp_bm(ipts,j,ifruit,initrogen) + &
5641	tmp_bm(ipts,j,isapabove,initrogen)+ tmp_bm(ipts,j,isapbelow,initrogen))
5642	labile_target(ipts,j,icarbon) = MAX ( labile_target(ipts,j,icarbon), 10. * gpp_week(ipts,j) )
5643
5644	! Debug
5645	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
5646	WRITE(numout,*) 'circ_class_biomass(ipts,j,:,isapbelow,icarbon)=', &
5647	circ_class_biomass(ipts,j,:,isapbelow,icarbon)
5648	WRITE(numout,*) 'circ_class_biomass(ipts,j,:,isapabove,icarbon)=', &
5649	circ_class_biomass(ipts,j,:,isapabove,icarbon)
5650	WRITE(numout,*) 'scal=',scal(ipts,j)
5651	WRITE(numout,*) 'labile_reserve(j)=',labile_reserve(j)
5652	WRITE(numout,*) 'Cl_target(:)=',Cl_target(:)
5653	WRITE(numout,*) 'Cr_target(:)=',Cr_target(:)
5654	WRITE(numout,*) 'Cs(:)=',Cs(:)
5655	WRITE(numout,*) 'fcn_root(j)=',fcn_root(j)
5656	WRITE(numout,*) 'fcn_wood(j)=',fcn_wood(j)
5657	WRITE(numout,*) 'cn_leaf(ipts,j)=',cn_leaf(ipts,j)
5658	WRITE(numout,*) 'lab_fac, labile_target, ', lab_fac(ipts,j), labile_target(ipts,j,icarbon)
5659	ENDIF
5660	!-
5661
5662	! The max size of reserve pool is proportional to the size of the
5663	! storage organ (the sapwood) and a the leaf functional trait of the
5664	! PFT (::phene_type_tab). The reserve pool is constrained by the mass
5665	! needed to replace foliage and roots. This constraint prevents the
5666	! scheme from putting too much reserves in big trees (which have a lot
5667	! of sapwood compared to small trees). Exessive storage would hamper
5668	! tree growth and would make mortality less likely.
5669	IF(is_tree(j)) THEN
5670
5671	IF (pheno_type(j).EQ.1) THEN
5672
5673	! Evergreen trees are not very conservative with respect to
5674	! C-storage. Therefore, only 5% of their sapwood mass is stored
5675	! in their reserve pool.
5676	reserve_target(ipts,j,icarbon) = MIN(evergreen_reserve(j) * &
5677	( tmp_bm(ipts,j,isapabove,icarbon) + &
5678	tmp_bm(ipts,j,isapbelow,icarbon)), &
5679	lai_to_biomass(lai_target(ipts,j),j)*&
5680	(1.+root_reserve(j)/ltor(ipts,j)))
5681
5682	! Debug
5683	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
5684	WRITE(numout,*) 'What happens to the reserve and labile &
5685	& pools? Evergreen'
5686	WRITE(numout,*) 'carbres, reserve_target: ',&
5687	tmp_bm(ipts,j,icarbres,icarbon),reserve_target(ipts,j,icarbon)
5688	WRITE(numout,*) 'ilabile, labile_target: ',&
5689	tmp_bm(ipts,j,ilabile,icarbon),labile_target(ipts,j,icarbon)
5690	WRITE(numout,*) 'evergreen_reserve(j): ',&
5691	evergreen_reserve(j)
5692	WRITE(numout,*) 'isapabove,isapbelow: ',&
5693	tmp_bm(ipts,j,isapabove,icarbon), &
5694	tmp_bm(ipts,j,isapbelow,icarbon)
5695	ENDIF
5696	!-
5697
5698	ELSE
5699
5700	! Deciduous trees are more conservative and 12% of their sapwood mass
5701	! is stored in the reserve pool. The scheme avoids that during the
5702	! growing season too much reserve are accumulated (which would hamper
5703	! growth), therefore, the reduced rate of 12% is used until scenecence.
5704	IF (SUM(bm_alloc(ipts,j,:,icarbon)) .GT. min_stomate) THEN
5705
5706	reserve_target(ipts,j,icarbon) = deciduous_reserve(j) * &
5707	( tmp_bm(ipts,j,isapabove,icarbon) + &
5708	tmp_bm(ipts,j,isapbelow,icarbon) )
5709
5710	! Debug
5711	IF (printlev_loc.GE.4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
5712	WRITE(numout,*) 'What happens to the reserve and '//&
5713	'labile pools? Deciduous'
5714	WRITE(numout,*) 'carbres, reserve_target: ',&
5715	tmp_bm(ipts,j,icarbres,icarbon),reserve_target(ipts,j,icarbon)
5716	WRITE(numout,*) 'deciduous_reserve: ',&
5717	deciduous_reserve(j)
5718	WRITE(numout,*) 'isapabove,isapbelow: ',&
5719	tmp_bm(ipts,j,isapabove,icarbon), &
5720	tmp_bm(ipts,j,isapbelow,icarbon)
5721	ENDIF
5722	!-
5723
5724	ELSE
5725
5726	! If the plant is senescent, allow for a higher reserve mass. Plants
5727	! can then use the excess labile C, that is no longer used for growth
5728	! and would be respired otherwise, to regrow leaves after the dormant
5729	! period. This code is a more stable alternative by Nicolas
5730	reserve_target(ipts,j,icarbon) = senescense_reserve(j) * &
5731	( tmp_bm(ipts,j,isapabove,icarbon) + &
5732	tmp_bm(ipts,j,isapbelow,icarbon))
5733
5734	! Debug
5735	IF (j .EQ. test_pft .AND. printlev_loc.GE.4 .AND. &
5736	ipts == test_grid) THEN
5737	WRITE(numout,*) 'What happens to the reserve and labile pools? '//&
5738	'Senescent'
5739	WRITE(numout,*) 'carbres, reserve_target: ',&
5740	tmp_bm(ipts,j,icarbres,icarbon),reserve_target(ipts,j,icarbon)
5741	WRITE(numout,*) 'senescense_reserve(j): ',&
5742	senescense_reserve(j)
5743	WRITE(numout,*) 'isapabove,isapbelow: ',&
5744	tmp_bm(ipts,j,isapabove,icarbon), &
5745	tmp_bm(ipts,j,isapbelow,icarbon)
5746	ENDIF
5747
5748	ENDIF ! Scenecent
5749
5750	ENDIF ! Phenology type
5751
5752
5753	ELSE
5754
5755	! Grasses
5756	! The min criterion results in the reserves being zero because
5757	! isapabove goes to zero when the reserves are most needed. Use
5758	! lai_to_biomass to account for a dynamic sla. Some high latitude
5759	! pixels were found to have very low biomasses which result in
5760	! a zero lai_target (10e-15) which in turn results for a reserve_target
5761	! of zero. This may cause problems later on.
5762	reserve_target(ipts,j,icarbon) = &
5763	MIN(deciduous_reserve(j) * (tmp_bm(ipts,j,iroot,icarbon) + &
5764	tmp_bm(ipts,j,isapabove,icarbon) + &
5765	tmp_bm(ipts,j,isapbelow,icarbon)), &
5766	lai_to_biomass(lai_target(ipts,j),j) * &
5767	(1.+root_reserve(j)/ltor(ipts,j)))
5768
5769	! Debug
5770	IF (j .EQ. test_pft .AND. printlev_loc.GE.4 .AND. ipts == test_grid) THEN
5771	WRITE(numout,*) 'reserve target, ', reserve_target(ipts,j,icarbon)
5772	ENDIF
5773	!-
5774
5775	ENDIF
5776
5777	!! 8.5 Move carbon between the reserve and labile pools
5778	! Fill the reserve pools up to their optimal level or until the min/max
5779	! limits are reached. The original approach in OCN resulted in
5780	! instabilities and sometimes oscilations. For this reason a more
5781	! simple and straightforward transfer between the pools has been
5782	! implemented. After sugar loading was implemeted this simplified
5783	! approach was found to come with some sudden regime switches because
5784	! C was only transfered from one pool to another if one pool was full.
5785	! The latest approach tries to fill both pools at the same time but
5786	! with a different (arbitrary speed). At present there are only two
5787	! important differences between the reserve and the labile pool in
5788	! ORCHIDEE: (1) only the labile pool is used in the allocation (hence,
5789	! we should try to store as much carbon as possible in the labile pool)
5790	! and (2) the reserve pool comes without autotrophic respiration (hence,
5791	! we should try to store as much carbon in the reserve pool as possible
5792	! because that will enable us to grow more leaves in spring). These
5793	! conflicting considerations were translated in the idea that
5794	! reserve_target X**2 + labile_target X = total reserves. Where X is the share
5795	! of the labile pool in the total reserves (= labile + reservers) In other
5796	! words the labile pool gets priority over the reserve pool but the model
5797	! will try to fill both pools at the same time. The optimal pools can
5798	! therefore be calculated by solving a simple quadratic eaqutions:
5799	! X = -b - sqrt(bÂ² - 4ac)/(2a) where b = labile_target, and
5800	! c = tmp_bm(labile+reserve).
5801	! Another way of looking at this approach is assuming that the labile pool
5802	! fills up linearly and the reserve pool quadratically. As long as the labile
5803	! pool is below its optimal, it will thus have priority. As soon as the labile
5804	! pool is reached up to its target value (=considered the optimum) the reserve
5805	! pool will start taking in more carbon. For simplicity it was assumed that
5806	! carbon can move freely between both pools.
5807	total_reserves = tmp_bm(ipts,j,icarbres,icarbon) + tmp_bm(ipts,j,ilabile,icarbon)
5808	optimal_share = zero
5809
5810	! Only calculate a solution if there is carbon in the reserve pool
5811	IF (total_reserves.GT.min_stomate) THEN
5812
5813	! Avoid divide by zero in case the reserve_target = zero
5814	IF (reserve_target(ipts,j,icarbon).GT.min_stomate) THEN
5815
5816	! First solution of a quadratic equation. Note: the quadratic solution
5817	! is based on aX2+bX+c=0. c is thus -total_reserves
5818	optimal_share =(-labile_target(ipts,j,icarbon) + SQRT(labile_target(ipts,j,icarbon)**2 + &
5819	4reserve_target(ipts,j,icarbon)total_reserves)) / (2*reserve_target(ipts,j,icarbon))
5820
5821	IF (optimal_share.LT.zero) THEN
5822
5823	! Second solution of a quadartic equation in case the first solution
5824	! turned out to be the negative solution which we don want.
5825	optimal_share =(-labile_target(ipts,j,icarbon) - SQRT(labile_target(ipts,j,icarbon)**2 + &
5826	4reserve_target(ipts,j,icarbon)total_reserves)) / (2*reserve_target(ipts,j,icarbon))
5827	ENDIF
5828
5829	END IF
5830
5831	END IF
5832
5833	! Error checking
5834	IF (optimal_share.LT.zero) THEN
5835	WRITE(numout,*) 'Tried both roots of the quadratic equation and both were negative', &
5836	optimal_share
5837	CALL ipslerr_p(3,'growth_fun_all', 'Both solutions are negative',&
5838	'something must be wrong with the calculation of the labile', &
5839	'and reserve pools')
5840	END IF
5841	!-
5842
5843	! Calculate the optimal distribution between the reserve and the
5844	! labile pool. Assume full mobility between both pools and ignore
5845	! possible constraints during dormacy. Calculate ilabile as the
5846	! residual term to avoid mass balance problems (the alternative way
5847	! to calculate it is tmp_bm(ilabile) = labile_target*optimal_share.
5848	! Optimal share was calculated with the equation above.
5849	! This solution can result in precision issues and it can deplete the
5850	! carbres pool. Add a safety valve.
5851	tmp_bm(ipts,j,icarbres,icarbon) = MAX(total_reserves * 0.1, &
5852	MIN(reserve_target(ipts,j,icarbon)(optimal_share2), 0.9 total_reserves))
5853	tmp_bm(ipts,j,ilabile,icarbon) = MAX(zero,total_reserves - &
5854	tmp_bm(ipts,j,icarbres,icarbon))
5855
5856	! For evergreen PFTs with total reserves well below the optimal the code
5857	! above may results in reducing the reserves pools every day. If this
5858	! happens, the labile carbon becomes e-68 within 3 years and soon after
5859	! causes an overflow error with e-302. The lines below should avoid this
5860	! to happen.
5861	total_reserves = tmp_bm(ipts,j,icarbres,icarbon) + tmp_bm(ipts,j,ilabile,icarbon)
5862	IF (total_reserves .LT. 1000 * EPSILON(zero)) THEN
5863	tmp_bm(ipts,j,icarbres,icarbon) = zero
5864	tmp_bm(ipts,j,ilabile,icarbon) = zero
5865	circ_class_biomass(ipts,j,1,isapabove,icarbon) = &
5866	circ_class_biomass(ipts,j,1,isapabove,icarbon) + &
5867	total_reserves
5868	END IF
5869
5870	! Error checking
5871	IF (tmp_bm(ipts,j,ilabile,icarbon).LT.zero .OR. &
5872	tmp_bm(ipts,j,icarbres,icarbon).LT.zero) THEN
5873	WRITE(numout,*) 'The reserve pool is negative after &
5874	& re-allocation. Not good!'
5875	WRITE(numout,*) 'tmp_bm(ipts,j,icarbres,icarbon): ',&
5876	tmp_bm(ipts,j,icarbres,icarbon)
5877	WRITE(numout,*) 'ipts,j : ',ipts,j
5878	WRITE(numout,*) 'total_reserves : ',total_reserves
5879	WRITE(numout,*) 'optimal_share : ',optimal_share
5880	CALL ipslerr_p(3,'growth_fun_all', 'Negative reserves after re-distruting',&
5881	'carbon between the labile and reserve pools. Not sure', &
5882	'how this happened.')
5883	ENDIF
5884	!-
5885
5886	ELSEIF ( veget_max(ipts,j) .GT. min_stomate .AND. &
5887	rue_longterm(ipts,j) .EQ. un) THEN
5888
5889	! There hasn't been any photosynthesis yet. This happens when a
5890	! new vegetation is prescribed and the longterm phenology variables
5891	! are not initialized yet. These conditions happen when the model is
5892	! started from scratch (no restart files). Because the plants are
5893	! very small, they contain little reserves. We increased the amount
5894	! of reserves by a factor ::tune_r_in_sapling where r stands for
5895	! reserves. However, this amount gets simply respired before it is
5896	! needed because the reserve_target is calculated as a function of the
5897	! sapwood biomass which is very low because the plants are really
5898	! small. Here we skip recalculating the reserve_target until the day
5899	! we start using it.
5900
5901	ELSE
5902
5903	! No reason to be here
5904	WRITE(numout,*) 'Error: unexpected condition for the reserve pools, pft, ',j
5905	WRITE(numout,*) 'veget_max, rue_longterm, ', veget_max(ipts,j), &
5906	rue_longterm(ipts,j)
5907
5908	ENDIF ! rue_longterm
5909
5910	! The model code does not control the C/N ratio of the labile pool hence,
5911	! even if there is a strong N-limitation, the model can accumulate lots
5912	! of carbon in the labile pool. The first CN-version was indeed doing this
5913	! the plant could easily store several 1000 gC m-2. As this was considered
5914	! unrealistic the excess C in the labile pool was burned-off by some excess
5915	! respiration. Although this luxury/wastage respiration has been suggested
5916	! in the literature (see Amthor et al 2000 and Chamber et al 2004) it is
5917	! not confirmed by many observations. We first tried to control the C/N ratio
5918	! of the labile pool but ran into several numerical issues with small numbers
5919	! and some of the dynamics of the pool during phenology and senescence
5920	! (N-resorption). It was then decided to simply control the size of the
5921	! labile pool. The model already had an estimate of the optimal pool size of
5922	! the labile and carbres pools. If the plant has more labile carbon than the
5923	! optimal, GPP is downregulated (too much sugars in the leaves will increase
5924	! the viscosity and hamper the sapflow in the phloem. The viscosity can be
5925	! decreased again by closing the stomata and transpiring less of the sapflow
5926	! in the xylem. By closing the stomata, GPP will be downregulated. See Holtta
5927	! et al 2017). Because ORCHIDEE has no sapflow, turgor and viscosity yet, we
5928	! used a simple ratio to downregulate NUE. The regulation is smoothened by
5929	! setting boundaries to avoid sudden decreases in GPP (which are not apparent
5930	! in the data). Smoothing is taken care of in stomate_vmax.f90. If the plant
5931	! has less carbon in its labile and carbres pools than wanted, the NUE is
5932	! upregulated. Up regulation is also capped to avoid crazy NUE values and high
5933	! frequency changes between up and downregulation. Up and downregulation are
5934	! done in stomate_vmax.f90.
5935	! CYmark: we think the active regulation of sugar load only occurs in active growth
5936	! stage, i.e., when plant_status is equal to icanopy.
5937	IF (tmp_bm(ipts,j,ilabile,icarbon)+tmp_bm(ipts,j,icarbres,icarbon).GT.zero .AND.&
5938	plant_status(ipts,j).EQ.icanopy) THEN
5939
5940	! First priority: too much sugar in the labile pool-> downregulate
5941	update_sugar_load = (labile_target(ipts,j,icarbon)+reserve_target(ipts,j,icarbon)) / &
5942	(tmp_bm(ipts,j,ilabile,icarbon) + tmp_bm(ipts,j,icarbres,icarbon))
5943
5944	sugar_load(ipts,j) = (sugar_load(ipts,j) * (tau_sugarload_week - dt ) + &
5945	max(sugar_load_min,min(update_sugar_load,sugar_load_max)) &
5946	* dt) /tau_sugarload_week
5947
5948	ELSEIF (tmp_bm(ipts,j,ileaf,icarbon).GT.zero) THEN
5949	sugar_load(ipts,j) = (sugar_load(ipts,j) * (tau_sugarload_week - dt ) + &
5950	sugar_load_max * dt) /tau_sugarload_week
5951	ELSE
5952	! Out of growing season, too much labile but not enough reserves, etc
5953	! -> do nothing
5954	sugar_load(ipts,j) = un
5955	ENDIF
5956
5957
5958	!! 8.1 Calculate NPP
5959	! Calculate the NPP @tex $(gC.m^{-2}dt^{-1})$ @endtex as the difference
5960	! between GPP and the two components of autotrophic respiration
5961	! (maintenance and growth respiration). GPP, R_maint and R_growth
5962	! are prognostic variables, NPP is calculated as the residuals and is
5963	! thus a diagnostic variable. Note that NPP is not used in the
5964	! allocation scheme, instead bm_alloc_tot is allocated. The
5965	! physiological difference between both is that bm_alloc_tot does no
5966	! longer contain the reserves and labile pools and is only the carbon
5967	! that needs to go into the biomass pools. NPP contains the reserves
5968	! and labile carbon. Note that GPP is in gC m-2 s-1 whereas the
5969	! respiration terms were calculated in gC m-2 dt-1
5970	npp(ipts,j) = gpp_daily(ipts,j) - resp_growth(ipts,j)/dt - &
5971	resp_maint(ipts,j)/dt
5972
5973	!! 8.6 Use or fill reserve pools depending on relative size of the
5974	! labile and reserve N pool
5975	IF(veget_max(ipts,j) .GT. min_stomate) THEN
5976
5977	costf = f_alloc(ipts,j,ileaf) + fcn_wood(j) * &
5978	(f_alloc(ipts,j,isapabove)+f_alloc(ipts,j,isapbelow)) + &
5979	fcn_root(j) * ( f_alloc(ipts,j,iroot) + f_alloc(ipts,j,ifruit) )
5980
5981	IF (costf.EQ.0.0) costf=1.
5982
5983	!+++CHECK+++
5984	! Should we calculate the target for labile nitrogen based on the
5985	! target labile carbon or the actual labile carbon?
5986	!!$ labile_target(ipts,j,initrogen) = tmp_bm(ipts,j,ilabile,icarbon) / &
5987	!!$ cn_leaf(ipts,j) * costf
5988	labile_target(ipts,j,initrogen) = labile_target(ipts,j,icarbon) / &
5989	cn_leaf(ipts,j) * costf
5990	!+++++++++++
5991
5992	! excess or deficit of nitrogen in the labile pool
5993	use_lab = tmp_bm(ipts,j,ilabile,initrogen) - labile_target(ipts,j,initrogen)
5994
5995	!+++CHECK+++
5996	! CN-CAN proposed a simplified approach that seems more consistent.
5997	! Rather than recalculating the carbres pool the calculation starts
5998	! from the the carbon that is in carbres pool.
5999	!!$ IF(is_tree(j))THEN
6000	!!$ reserve_target = 0.12 * ( tmp_bm(ipts,j,isapabove,icarbon) + &
6001	!!$ tmp_bm(ipts,j,isapbelow,icarbon))/cn_leaf(ipts,j) * &
6002	!!$ (1.+fcn_root(j)/ltor(ipts,j))/(1.+0.3/ltor(ipts,j))
6003	!!$ ELSE
6004	!!$ reserve_target = 0.3 * ( tmp_bm(ipts,j,iroot,icarbon) + &
6005	!!$ tmp_bm(ipts,j,isapabove,icarbon) + &
6006	!!$ tmp_bm(ipts,j,isapbelow,icarbon))/cn_leaf(ipts,j) * &
6007	!!$ (1.+fcn_root(j)/ltor(ipts,j))/(1.+0.3/ltor(ipts,j))
6008	!!$ ENDIF
6009
6010	!+++CHECK+++
6011	! Should we calculate the target for reserve nitrogen based on the
6012	! target reserve carbon or the actual reserve carbon?
6013	!!$ reserve_target(ipts,j,initrogen) = tmp_bm(ipts,j,icarbres,icarbon)/cn_leaf(ipts,j) * &
6014	!!$ (1.+fcn_root(j)/ltor(ipts,j))/(1.+root_reserve(j)/ltor(ipts,j))
6015	reserve_target(ipts,j,initrogen) = reserve_target(ipts,j,icarbon)/cn_leaf(ipts,j) * &
6016	(1.+fcn_root(j)/ltor(ipts,j))/(1.+root_reserve(j)/ltor(ipts,j))
6017	!+++++++++++
6018
6019	! It needs to be avoided that the labile N can increase during the
6020	! dormancy (which includes the period that the buds are available
6021	! but still closed). If labile N increases, nitrogen uptake from
6022	! plant can be zero followed by unrealistic peak because it is the
6023	! function of labile nitrogen and carbon. Since this issue was fixed,
6024	! the code does no longer allow the labile N to exceed the reserve
6025	! nitrogen during dormancy. This avoids earlier on in the code that
6026	! the labile pool can increase. This code is no longer needed and
6027	! was therefore commented out but it was left as a reminder of the issue.
6028	! IF(plant_status(ipts,j) .EQ. idormant .OR. &
6029	! plant_status(ipts,j) .EQ. ibudsavail) THEN
6030	! use_max=-use_lab
6031	! ENDIF
6032
6033	! Sudden growth in diameter can occur if all of the following conditions
6034	! are satisfied: 1) leaf C:N ratio and little allocation to root decreased
6035	! the estimated N targets for labileN and reserveN; 2) high reserveN;
6036	! 3) then both labileN and reserveN were above the target; 4) no N
6037	! movement between pools; 5) extra N accumulates in labile; 6) n_alloc_tot
6038	! increases; and 7) a lot of growth. To solve the problem the following
6039	! approach was implemented: 1) IF labileN is over the target, move extra
6040	! labileN to reserve. Because N Growth is a lot dependent on the labile
6041	! pool in the current version so it is better to be cleaned. At a single
6042	! test site, remaining labile N as just much as the target pool resulted
6043	! in a slower initial increase in GPP but differences in endpoints were
6044	! negligible 2) IF labileN is under the target, move from reserve pool as
6045	! much as extra N the reserve pool has. Move N from
6046	! reserve pool much as needed but less than 90% of total reserve nitrogen.
6047	! Note that as there is a weak scientific basis for the movement of
6048	! non-structural nitrogen, this redistribution of N is a numerical
6049	! solution that aims at stabilizing the model.
6050	IF(use_lab .GT. 0.0) THEN
6051	! Enough N in labile: move N from labile to reserve
6052	use_max = -use_lab
6053	ELSE
6054	! depleted N in labile
6055	! Fill the labile N as much as needed unless it acceeds 90% of
6056	! reserveN. Before r6825 there is no N mobility when either
6057	! labile and nitrogen are depleted. This change was made to use
6058	! reserve N and reduce N limitation when the plant has nitrogen
6059	! in its reserves
6060	use_max = MIN(-use_lab,0.9*tmp_bm(ipts,j,icarbres,initrogen))
6061	ENDIF
6062
6063	tmp_bm(ipts,j,icarbres,initrogen) = tmp_bm(ipts,j,icarbres,initrogen)-use_max
6064	tmp_bm(ipts,j,ilabile,initrogen) = tmp_bm(ipts,j,ilabile,initrogen)+use_max
6065	bm_alloc(ipts,j,icarbres,initrogen) = bm_alloc(ipts,j,icarbres,initrogen)-use_max
6066
6067	! We need to keep the reserve nitrogen pool filled according to
6068	! the filling status of the carbon reserve to allow decidiuous PFTs
6069	! to grow when we initialize an impose_cn=n run with the restarts
6070	! from an impose_cn=y simulation; if we don't ensure that there is
6071	! enough reserve N the PFT will get extinct.
6072	IF(is_tree(j)) THEN
6073	IF (pheno_type(j).NE.1) THEN
6074	IF (impose_cn) THEN
6075
6076	! take what is needed to keep nitrogen reserves optimal
6077	atm_to_bm(ipts,j,initrogen) = atm_to_bm(ipts,j,initrogen) + &
6078	MAX((tmp_bm(ipts,j,icarbres,icarbon)/cn_leaf(ipts,j) * &
6079	(1.+fcn_root(j)/ltor(ipts,j)) / &
6080	(1.+root_reserve(j)/ltor(ipts,j))) - &
6081	tmp_bm(ipts,j,icarbres,initrogen),zero)
6082
6083	! fill the pool
6084	tmp_bm(ipts,j,icarbres,initrogen) = &
6085	MAX(tmp_bm(ipts,j,icarbres,initrogen), &
6086	tmp_bm(ipts,j,icarbres,icarbon)/cn_leaf(ipts,j) * &
6087	(1.+fcn_root(j)/ltor(ipts,j))/(1.+root_reserve(j)/ltor(ipts,j)))
6088
6089	! tmp_bm(icarbres) has changed, circ_class_biomass needs to be updated
6090	circ_class_biomass(ipts,j,:,icarbres,initrogen) = &
6091	biomass_to_cc(tmp_bm(ipts,j,icarbres,initrogen),&
6092	circ_class_biomass(ipts,j,:,icarbres,initrogen),&
6093	circ_class_n(ipts,j,:))
6094
6095	ENDIF !impose_cn
6096	ENDIF
6097	ENDIF !is_tree
6098
6099	ENDIF !IF_vegetmax
6100
6101	! Calculate demand or excess of nitrogen in the reserve
6102	! reserve_target is the amount of nitrogen that is being targeted,
6103	! icrabes is the actual amount of nitrogen. The balance is the
6104	! ratio between the actual and the target and its long-term mean is
6105	! used to modulate n-uptake by the roots.
6106	IF (reserve_target(ipts,j,initrogen) .GT. min_stomate) THEN
6107	n_reserve_balance(ipts,j) = tmp_bm(ipts,j,icarbres,initrogen) / &
6108	reserve_target(ipts,j,initrogen)
6109	ELSE
6110	! If the reserver pool is zero the model might just be at an
6111	! early time step. In that case n_reserve_balance should
6112	! probably be neutral (thus 1). If this happens later in the
6113	! simulation, the model might be really short of nitrogen so
6114	! stimulating root uptake (n_reserve_balance << 1) is probably
6115	! what is needed. Unless reserve_target suddenly dropped to zero,
6116	! n_reserve_longeterm should be adjusted and is likley a good
6117	! estimate for n_reserve_balance.
6118	n_reserve_balance(ipts,j) = n_reserve_longterm(ipts,j)
6119	! As an alternative: compromise between the two options described
6120	! above but chose in favor of n-uptake
6121	!n_reserve_balance(ipts,j) = 0.5
6122	ENDIF
6123
6124	! tmp_bm can be very low. Truncate the distribution of n_reserve_balance
6125	n_reserve_balance(ipts,j) = MAX(zero, MIN(2.,n_reserve_balance(ipts,j)))
6126
6127	! biomass has changed so update circ_class_biomass
6128	DO ipar = 1,nparts
6129	circ_class_biomass(ipts,j,:,ipar,icarbon) = &
6130	biomass_to_cc(tmp_bm(ipts,j,ipar,icarbon),&
6131	circ_class_biomass(ipts,j,:,ipar,icarbon),&
6132	circ_class_n(ipts,j,:))
6133	circ_class_biomass(ipts,j,:,ipar,initrogen) = &
6134	biomass_to_cc(tmp_bm(ipts,j,ipar,initrogen),&
6135	circ_class_biomass(ipts,j,:,ipar,initrogen),&
6136	circ_class_n(ipts,j,:))
6137	ENDDO
6138
6139	ENDDO ! npts
6140
6141	ENDDO ! PFTs
6142
6143
6144	!! 9. Check mass balance closure
6145
6146	IF (err_act.GT.1) THEN
6147
6148	! 9.2 Check surface area
6149	CALL check_vegetation_area("stomate_allocation", npts, veget_max_begin, &
6150	veget_max,'pft')
6151
6152	! 9.3 Mass balance closure
6153	! 9.3.1 Calculate final biomass
6154	pool_end(:,:,:) = zero
6155	DO ipar = 1,nparts
6156	DO iele = 1,nelements
6157	DO icir = 1,ncirc
6158	pool_end(:,:,iele) = pool_end(:,:,iele) + &
6159	(circ_class_biomass(:,:,icir,ipar,iele) * &
6160	circ_class_n(:,:,icir) * veget_max(:,:))
6161	ENDDO
6162	ENDDO
6163	ENDDO
6164
6165	! 9.3.2 Calculate mass balance
6166	! Specific processes for carbon
6167	check_intern(:,:,:,:) = zero
6168	check_intern(:,:,iatm2land,icarbon) = &
6169	check_intern_init(:,:,iatm2land,icarbon) + &
6170	(gpp_daily(:,:) + atm_to_bm(:,:,icarbon)) * dt * veget_max(:,:)
6171	check_intern(:,:,iatm2land,initrogen) = &
6172	check_intern_init(:,:,iatm2land,initrogen) + &
6173	atm_to_bm(:,:,initrogen) * dt * veget_max(:,:)
6174	check_intern(:,:,iland2atm,icarbon) = -un * &
6175	(resp_maint(:,:) + resp_growth(:,:)) * &
6176	veget_max(:,:)
6177
6178	! Common processes for icarbon and initrogen
6179	DO iele=1,nelements
6180	check_intern(:,:,ipoolchange,iele) = -un * (pool_end(:,:,iele) - &
6181	pool_start(:,:,iele))
6182	ENDDO
6183
6184	closure_intern = zero
6185
6186	DO imbc = 1,nmbcomp
6187	DO iele=1,nelements
6188	! Debug
6189	IF (printlev_loc>=4 .AND. ipts.EQ.test_grid .AND. j.EQ.test_pft) THEN
6190	WRITE(numout,*) 'check_intern, imbc, iele, ', imbc, &
6191	iele, check_intern(:,test_pft,imbc,iele)
6192	ENDIF
6193	!-
6194	closure_intern(:,:,iele) = closure_intern(:,:,iele) + &
6195	check_intern(:,:,imbc,iele)
6196	ENDDO
6197	ENDDO
6198
6199	! 9.3.3 Check mass balance closure
6200	CALL check_mass_balance("stomate_allocation", closure_intern, npts, pool_end, &
6201	pool_start, veget_max, 'pft')
6202
6203	ENDIF ! err_act.GT.1
6204
6205
6206	!! 10. Update leaf age
6207	! Leaf age is needed to calculate the turnover and vmax in the
6208	! stomate_turnover.f90 and stomate_vmax.f90 routines. Leaf biomass
6209	! is distributed according to its age into several "age classes"
6210	! with age class=1 representing the youngest class, and consisting
6211	! of the most newly allocated leaf biomass.
6212
6213	! Update biomass first
6214	tmp_bm(:,:,:,:) = cc_to_biomass(npts,nvm,circ_class_biomass(:,:,:,:,:),&
6215	circ_class_n(:,:,:))
6216
6217	!! 9.1 Update quantity and age of the leaf biomass in the youngest class
6218	! The new amount of leaf biomass in the youngest age class
6219	! (leaf_mass_young) is the sum of :
6220	! - the leaf biomass that was already in the youngest age class
6221	! (leaf_frac(:,j,1) * lm_old(:,j)) with the leaf age given in
6222	! leaf_age(:,j,1)
6223	! - and the new biomass allocated to leaves
6224	! (bm_alloc(:,j,ileaf,icarbon)) with a leaf age of zero.
6225	leaf_mass_young(:,:) = leaf_frac(:,:,1) * lm_old(:,:) + bm_alloc(:,:,ileaf,icarbon)
6226
6227	! The age of the updated youngest age class is the average of the ages of
6228	! its 2 components: bm_alloc(leaf) of age '0', and leaf_frac * &
6229	! lm_old(=leaf_mass_young-bm_alloc) of age 'leaf_age(:,:,1)'
6230	DO ipts=1,npts
6231
6232	DO j=1,nvm
6233
6234	! IF(veget_max(ipts,j) == zero)THEN
6235	! ! this vegetation type is not present, so no reason to do the
6236	! ! calculation
6237	! CYCLE
6238	! ENDIF
6239
6240	IF( (bm_alloc(ipts,j,ileaf,icarbon) .GT. min_stomate ) .AND. &
6241	( leaf_mass_young(ipts,j) .GT. min_stomate ) )THEN
6242
6243	leaf_age(ipts,j,1) = MAX ( zero, leaf_age(ipts,j,1) * &
6244	( leaf_mass_young(ipts,j) - bm_alloc(ipts,j,ileaf,icarbon) ) / &
6245	& leaf_mass_young(ipts,j) )
6246
6247	ENDIF
6248
6249	ENDDO
6250
6251	ENDDO
6252
6253	!! 11 Update leaf age
6254	! Update fractions of leaf biomass in each age class (fraction
6255	! in youngest class increases)
6256
6257	!! 11.1 Update age of youngest leaves
6258	! For age class 1 (youngest class), because we have added biomass
6259	! to the youngest class, we need to update the fraction of total
6260	! leaf biomass that belongs to the youngest age class : updated mass
6261	! in class divided by new total leaf mass
6262	WHERE ( tmp_bm(:,:,ileaf,icarbon) .GT. min_stomate )
6263
6264	leaf_frac(:,:,1) = leaf_mass_young(:,:) / tmp_bm(:,:,ileaf,icarbon)
6265
6266	ENDWHERE
6267
6268
6269	!! 11.2 Update age of other age classes
6270	! Because the total leaf biomass has changed, we need to update the
6271	! fraction of leaves in each age class: mass in leaf age class (from
6272	! previous fraction of leaves in this class and previous total leaf
6273	! biomass) divided by new total mass
6274	DO m = 2, nleafages ! Loop over # leaf age classes
6275
6276	WHERE ( tmp_bm(:,:,ileaf,icarbon) .GT. min_stomate )
6277
6278	leaf_frac(:,:,m) = leaf_frac(:,:,m) * lm_old(:,:) / tmp_bm(:,:,ileaf,icarbon)
6279
6280	ENDWHERE
6281
6282	ENDDO ! Loop over # leaf age classes
6283	!-----
6284
6285
6286	!! 12. Update whole-plant age
6287	!! 12.1 PFT age
6288	! At every time step, increase age of the biomass that was already
6289	! present at previous time step. Age is expressed in years, and
6290	! the time step 'dt' in days so age increase is: dt divided by number
6291	! of days in a year.
6292	WHERE ( PFTpresent(:,:) )
6293
6294	age(:,:) = age(:,:) + dt/one_year
6295
6296	ELSEWHERE
6297
6298	age(:,:) = zero
6299
6300	ENDWHERE
6301
6302
6303	!! 12.2 Age of grasses and crops
6304	! For grasses and crops, biomass with age 0 has been added to the
6305	! whole plant with age 'age'. New biomass is the sum of the current
6306	! total biomass in all plant parts (bm_new), bm_new(:) =
6307	! SUM( tmp_bm(:,j,:), DIM=2 ). The biomass that has just been added
6308	! is the sum of the allocatable biomass of all plant parts (bm_add),
6309	! its age is zero. bm_add(:) = SUM( bm_alloc(:,j,:,icarbon), DIM=2 ).
6310	! Before allocation, the plant biomass is bm_new-bm_add, its age is
6311	! "age(:,j)". The age of the new biomass is the average of the ages
6312	! of previous and added biomass. For trees, age is treated in
6313	! "establish" if vegetation is dynamic, and in turnover routines if
6314	! it is static (in this case, only the age of the heartwood is
6315	! accounted for).
6316	DO j = 2,nvm
6317
6318	IF ( .NOT. is_tree(j) ) THEN
6319
6320	bm_new(:) = tmp_bm(:,j,ileaf,icarbon) + tmp_bm(:,j,isapabove,icarbon) + &
6321	tmp_bm(:,j,iroot,icarbon) + tmp_bm(:,j,ifruit,icarbon)
6322	bm_add(:) = bm_alloc(:,j,ileaf,icarbon) + bm_alloc(:,j,isapabove,icarbon) + &
6323	bm_alloc(:,j,iroot,icarbon) + bm_alloc(:,j,ifruit,icarbon)
6324
6325	WHERE ( ( bm_new(:) .GT. min_stomate ) .AND. ( bm_add(:) .GT. min_stomate ) )
6326
6327	age(:,j) = age(:,j) * ( bm_new(:) - bm_add(:) ) / bm_new(:)
6328
6329	ENDWHERE
6330
6331	ENDIF ! is .NOT. tree
6332
6333	ENDDO ! Loop over #PFTs
6334
6335	!! 13. Write history files
6336
6337	! Save in history file the variables describing the biomass allocated to the plant parts
6338	! Calculate the change in biomass at the end of the routine
6339	tmp_bm(:,:,:,:) = cc_to_biomass(npts,nvm,circ_class_biomass(:,:,:,:,:),&
6340	circ_class_n(:,:,:)) - tmp_init_bm(:,:,:,:)
6341
6342	DO l=1,nelements
6343	IF (l == icarbon) THEN
6344	element_str(l) = '_c'
6345	ELSEIF (l == initrogen) THEN
6346	element_str(l) = '_n'
6347	ELSE
6348	STOP 'Define element_str'
6349	ENDIF
6350
6351	CALL histwrite_p (hist_id_stomate, 'BM_ALLOC_LEAF'//TRIM(element_str(l)), itime, &
6352	tmp_bm(:,:,ileaf,l), npts*nvm, horipft_index)
6353	CALL histwrite_p (hist_id_stomate, 'BM_ALLOC_SAP_AB'//TRIM(element_str(l)), itime, &
6354	tmp_bm(:,:,isapabove,l), npts*nvm, horipft_index)
6355	CALL histwrite_p (hist_id_stomate, 'BM_ALLOC_SAP_BE'//TRIM(element_str(l)), itime, &
6356	tmp_bm(:,:,isapbelow,l), npts*nvm, horipft_index)
6357	CALL histwrite_p (hist_id_stomate, 'BM_ALLOC_ROOT'//TRIM(element_str(l)), itime, &
6358	tmp_bm(:,:,iroot,l), npts*nvm, horipft_index)
6359	CALL histwrite_p (hist_id_stomate, 'BM_ALLOC_FRUIT'//TRIM(element_str(l)), itime, &
6360	tmp_bm(:,:,ifruit,l), npts*nvm, horipft_index)
6361	CALL histwrite_p (hist_id_stomate, 'BM_ALLOC_RES'//TRIM(element_str(l)), itime, &
6362	tmp_bm(:,:,icarbres,l), npts*nvm, horipft_index)
6363	CALL histwrite_p (hist_id_stomate, 'BM_ALLOC_LABILE'//TRIM(element_str(l)), itime, &
6364	tmp_bm(:,:,ilabile,l), npts*nvm, horipft_index)
6365
6366	CALL xios_orchidee_send_field('BM_ALLOC_LEAF'//TRIM(element_str(l)), tmp_bm(:,:,ileaf,l))
6367	CALL xios_orchidee_send_field('BM_ALLOC_SAP_AB'//TRIM(element_str(l)), tmp_bm(:,:,isapabove,l))
6368	CALL xios_orchidee_send_field('BM_ALLOC_SAP_BE'//TRIM(element_str(l)), tmp_bm(:,:,isapbelow,l))
6369	CALL xios_orchidee_send_field('BM_ALLOC_ROOT'//TRIM(element_str(l)), tmp_bm(:,:,iroot,l))
6370	CALL xios_orchidee_send_field('BM_ALLOC_FRUIT'//TRIM(element_str(l)), tmp_bm(:,:,ifruit,l))
6371	CALL xios_orchidee_send_field('BM_ALLOC_RES'//TRIM(element_str(l)), tmp_bm(:,:,icarbres,l))
6372	CALL xios_orchidee_send_field('BM_ALLOC_LABILE'//TRIM(element_str(l)), tmp_bm(:,:,ilabile,l))
6373
6374	ENDDO
6375
6376	CALL histwrite_p (hist_id_stomate, 'RUE_LONGTERM', itime, &
6377	rue_longterm(:,:), npts*nvm, horipft_index)
6378	CALL histwrite_p (hist_id_stomate, 'KF', itime, &
6379	KF(:,:), npts*nvm, horipft_index)
6380	CALL histwrite_p (hist_id_stomate, 'LAB_FAC' , itime, &
6381	lab_fac(:,:), npts*nvm, horipft_index)
6382
6383	CALL xios_orchidee_send_field('RUE_LONGTERM', rue_longterm(:,:))
6384	CALL xios_orchidee_send_field('KF', KF(:,:))
6385	CALL xios_orchidee_send_field('REL_HEIGHT', height_rel(:,:))
6386	CALL xios_orchidee_send_field('C0_ALLOC', c0_alloc(:,:))
6387	CALL xios_orchidee_send_field('LAB_FAC', lab_fac(:,:))
6388	CALL xios_orchidee_send_field('RESERVE_TARGET_c', reserve_target(:,:,icarbon))
6389	CALL xios_orchidee_send_field('LABILE_TARGET_c', labile_target(:,:,icarbon))
6390	CALL xios_orchidee_send_field('RESERVE_TARGET_n', reserve_target(:,:,initrogen))
6391	CALL xios_orchidee_send_field('LABILE_TARGET_n', labile_target(:,:,initrogen))
6392	CALL xios_orchidee_send_field('GTEMP_ALLOC', gtemp(:,:))
6393	CALL xios_orchidee_send_field('N_RESERVE_BALANCE',n_reserve_balance(:,:))
6394
6395	! Initilaize
6396	ring_width(:,:,:) = zero
6397	circ_height(:,:,:) = zero
6398
6399	DO ipts = 1,npts
6400	DO j = 1,nvm
6401	IF(is_tree(j))THEN
6402
6403	! Calculate the forestry basal area (thus NOT the effective ba)
6404	circ_class_ba(:) = wood_to_ba(circ_class_biomass(ipts,j,:,:,icarbon),j)
6405	ba(ipts,j) = SUM(circ_class_ba(:)circ_class_n(ipts,j,:)) m2_to_ha
6406	wood_volume(ipts,j) = wood_to_volume(npts,circ_class_biomass(ipts,j,:,:,:),&
6407	circ_class_n(ipts,j,:),j,branch_ratio(j),0)
6408	store_circ_class_ba(ipts,j,:) = circ_class_ba(:)
6409	store_delta_ba(ipts,j,:) = circ_class_ba(:) - circ_class_ba_init(ipts,j,:)
6410
6411	! Calculate radius increment using store_delta_ba (which is alway
6412	! positive)
6413	ring_width(ipts,j,:) = SQRT(circ_class_ba(:)/pi) - SQRT(circ_class_ba_init(ipts,j,:)/pi)
6414
6415	! Calculate height per diameter class (above ground, not eff)
6416	circ_height(ipts,j,:) = wood_to_height(circ_class_biomass(ipts,j,:,:,icarbon),j)
6417
6418	ELSE
6419	ba(ipts,j) = val_exp
6420	wood_volume(ipts,j) = val_exp
6421	store_circ_class_ba(ipts,j,:) = val_exp
6422	ENDIF
6423	ENDDO
6424	ENDDO
6425
6426
6427	CALL histwrite_p (hist_id_stomate, 'BA', itime, &
6428	ba(:,:), npts*nvm, horipft_index)
6429	CALL histwrite_p (hist_id_stomate, 'WOOD_VOL', itime, &
6430	wood_volume(:,:), npts*nvm, horipft_index)
6431	CALL histwrite_p (hist_id_stomate, 'RESIDUAL', itime, &
6432	residual_write(:,:), npts*nvm, horipft_index)
6433
6434	! Some of these variables should only be used when the model
6435	! does not account for land cover changes and does not make
6436	! use of age classes. When using land cover changes and
6437	! age classes the biomass pool may get diluted which results
6438	! in shrinking trees. This doesn't make sense at the tree
6439	! level but is an acceptable approach at the landscape
6440	! level.
6441	DO icir = 1,ncirc
6442	WRITE(var_name,'(A,I3.3)') 'CCBA_',icir
6443	CALL histwrite_p (hist_id_stomate, var_name, itime, &
6444	store_circ_class_ba(:,:,icir), npts*nvm, horipft_index)
6445	WRITE(var_name,'(A,I3.3)') 'CCDELTABA_',icir
6446	CALL histwrite_p (hist_id_stomate, VAR_NAME, itime, &
6447	store_delta_ba(:,:,icir), npts*nvm, horipft_index)
6448	WRITE(var_name,'(A,I3.3)') 'CCN_',icir
6449	CALL histwrite_p (hist_id_stomate, VAR_NAME, itime, &
6450	circ_class_n(:,:,icir), npts*nvm, horipft_index)
6451	WRITE(var_name,'(A,I3.3)') 'CCTRW_',icir
6452	CALL histwrite_p (hist_id_stomate, VAR_NAME, itime, &
6453	ring_width(:,:,icir), npts*nvm, horipft_index)
6454	WRITE(var_name,'(A,I3.3)') 'CCH_',icir
6455	CALL histwrite_p (hist_id_stomate, VAR_NAME, itime, &
6456	circ_height(:,:,icir), npts*nvm, horipft_index)
6457	ENDDO
6458
6459	CALL xios_orchidee_send_field('WOOD_VOL',wood_volume(:,:))
6460	CALL xios_orchidee_send_field('BA',ba(:,:))
6461	CALL xios_orchidee_send_field('RESIDUAL',residual_write(:,:))
6462	CALL xios_orchidee_send_field('CCBA', store_circ_class_ba(:,:,:))
6463	CALL xios_orchidee_send_field('CCDELTABA', store_delta_ba(:,:,:))
6464	CALL xios_orchidee_send_field('CCIND', circ_class_n(:,:,:))
6465	CALL xios_orchidee_send_field('CCTRW', ring_width(:,:,:))
6466	CALL xios_orchidee_send_field('CCHEIGHT', circ_height(:,:,:))
6467	CALL xios_orchidee_send_field('CCDIAMETER', SQRT(4/pi*store_circ_class_ba(:,:,:)))
6468	CALL xios_orchidee_send_field('CCSAP_M_AB_c', circ_class_biomass(:,:,:,isapabove,icarbon))
6469	CALL xios_orchidee_send_field('CCSAP_M_BE_c', circ_class_biomass(:,:,:,isapbelow,icarbon))
6470	CALL xios_orchidee_send_field('CCTOTAL_M_c', SUM(circ_class_biomass(:,:,:,:,icarbon),DIM=4))
6471
6472	! Send value that caused a warning to xios
6473	CALL xios_orchidee_send_field('MBC_alloc10b_c', residual10b(:,:))
6474
6475	! Debug
6476	IF (printlev_loc.GE.4) THEN
6477	WRITE(numout,*) 'leaf_biomass C:', tmp_bm(test_grid,test_pft,ileaf,icarbon)
6478	WRITE(numout,*) 'leaf_biomass N:', tmp_bm(test_grid,test_pft,ileaf,initrogen)
6479	WRITE(numout,*) 'reserve_biomass C:', tmp_bm(test_grid,test_pft,icarbres,icarbon)
6480	WRITE(numout,*) 'reserve_biomass N:', tmp_bm(test_grid,test_pft,icarbres,initrogen)
6481	ENDIF
6482	!-
6483
6484	IF (printlev.GE.3) WRITE(numout,*) 'Leaving functional allocation growth'
6485
6486
6487	END SUBROUTINE growth_fun_all
6488
6489
6490
6491	!! ================================================================================================================================
6492	!! FUNCTION : func_derfunc
6493	!!
6494	!>\BRIEF Calculate value for a function and its derivative
6495	!!
6496	!!
6497	!! DESCRIPTION : the routine describes the function and its derivative. Both function and derivative are used
6498	!! by the optimisation scheme. Hence, this function is part of the optimisation scheme and is only
6499	!! called by the optimisation
6500	!!
6501	!! RECENT CHANGE(S):
6502	!!
6503	!! MAIN OUTPUT VARIABLE(S): f, df
6504	!!
6505	!! REFERENCE(S) : Numerical recipies in Fortran 77
6506	!!
6507	!! FLOWCHART :
6508	!! \n
6509	!_ ================================================================================================================================
6510
6511	SUBROUTINE func_derfunc(x, n, o, p, q, r, t, eq_num, f, df)
6512
6513	!! 0. Variable and parameter declaration
6514
6515	!! 0.1 Input variables
6516	REAL(r_std), INTENT(in) :: x !! x value for which the function f(x) will be evaluated
6517	REAL(r_std), INTENT(in) :: n,o,p,q,r,t !! Coefficients of the equation. Not all equations use all coefficients
6518	INTEGER(i_std), INTENT(in) :: eq_num !! Function i.e. f(x), g(x), ...
6519
6520	!! 0.2 Output variables
6521	REAL(r_std), INTENT(out) :: f !! Value y for f(x)
6522	REAL(r_std), INTENT(out) :: df !! Value y for derivative[f(x)]
6523
6524	!! 0.3 Modified variables
6525
6526	!! 0.4 Local variables
6527	!_ ================================================================================================================================
6528
6529	!! 1. Calculate f(x) and df(x)
6530
6531	IF (eq_num .EQ. 1) THEN
6532
6533	!f = nx4 + ox*3 + px*2 + qx + r
6534	!df = 4nx*3 + 3ox2 + 2p*x + q
6535
6536	ELSEIF (eq_num .EQ. 2) THEN
6537
6538	f = ( (nx)/(p((x+o)/t)**(q/(2+q))) ) - r
6539	df = ( n(o(q+2)+2x)((o+x)/t)*(-q/(q+2)) ) / ( p(q+2)*(o+x) )
6540
6541	ENDIF
6542
6543	END SUBROUTINE func_derfunc
6544
6545
6546	!! ================================================================================================================================
6547	!! FUNCTION : iterative_solver
6548	!!
6549	!>\BRIEF find best fitting x for f(x)
6550	!!
6551	!!
6552	!! DESCRIPTION : The function makes use of an iterative approach to optimise the value for X. The solver
6553	!! splits the search region in two but there is an additional check to ensure that bounds are not
6554	!! exceeded.
6555	!!
6556	!! Use the derivative (df) of the function (f) calculated in func_derfunc to narrow down the
6557	!! search range for X using the Newton-Raphson method for convergence as described in Numerical
6558	!! Recipes in Fortran 77 (page 355-360).
6559	!!
6560	!! RECENT CHANGE(S):
6561	!!
6562	!! MAIN OUTPUT VARIABLE(S): x
6563	!!
6564	!! REFERENCE(S) : Numerical recipies in Fortran 77
6565	!!
6566	!! FLOWCHART :
6567	!! \n
6568	!_ ================================================================================================================================
6569
6570	FUNCTION newX(n, o, p, q, r, s, t, x1, x2, eq_num, j, ipts)
6571
6572	!! 0. Variable and parameter declaration
6573
6574	!! 0.1 Input variables
6575	REAL(r_std), INTENT(in) :: n,o,p,q,r,s,t !! Coefficients of the equation. Not all
6576	!! equations use all coefficients
6577	REAL(r_std), INTENT(in) :: x1 !! Lower boundary off search range
6578	REAL(r_std), INTENT(in) :: x2 !! Upper boundary off search range
6579	INTEGER(i_std), INTENT(in) :: eq_num !! Function for which an iterative solution is
6580	!! searched
6581	INTEGER(i_std), INTENT(in) :: j !! Number of PFT
6582	INTEGER(i_std), INTENT(in) :: ipts !! Number of grdi square...for debugging
6583
6584	!! 0.2 Output variables
6585
6586	!! 0.3 Modified variables
6587
6588	!! 0.4 Local variables
6589	INTEGER(i_std), PARAMETER :: maxit = 20 !! Maximum number of iterations
6590	INTEGER(i_std), PARAMETER :: max_attempt = 5 !! Maximum number of iterations
6591	INTEGER(i_std) :: i, attempt !! Index
6592	REAL(r_std) :: newX !! New estimate for X
6593	REAL(r_std) :: fl, fh, f !! Value of the function for the lower bound (x1),
6594	!! upper bound (x2) and the new value (newX)
6595	REAL(r_std) :: xh, xl !! Checked lower and upper bounds
6596	REAL(r_std) :: df !! Value of the derivative of the function for newX
6597	REAL(r_std) :: dx, dxold !! Slope of improvement
6598	REAL(r_std) :: temp !! Dummy variable for value swaps
6599	REAL(r_std) :: low, high !! temporary variables for x1 and x2 to avoid
6600	!! intent in/out conflicts with Cs
6601	LOGICAL :: found_range !! Flag indicating whether the range in which
6602	!! a solution exists was identified.
6603
6604
6605	!_ ================================================================================================================================
6606
6607	!! 1. Find solution for X
6608
6609	! Not sure whether our initial range is large enough. We will
6610	! start with a narrow range so we are more likely to find the
6611	! solution witin ::maxit iterations. If there is no solution
6612	! in the initial range we will expand the range and try again
6613
6614	! Initilaze flags and counters
6615	attempt = 1
6616	found_range = .FALSE.
6617	low = x1
6618	high = x2
6619
6620	! Calculate y for the upper and lower bound
6621	DO WHILE (.NOT. found_range .AND. attempt .LE. max_attempt)
6622
6623	CALL func_derfunc(low, n, o, p, q, r, t, eq_num, fl, df)
6624	CALL func_derfunc(high, n, o, p, q, r, t, eq_num, fh, df)
6625
6626	IF ((fl .GT. 0.0 .AND. fh .GT. 0.0) .OR. &
6627	(fl .LT. 0.0 .AND. fh .LT. 0.0)) THEN
6628
6629	! Update counter
6630	attempt = attempt + 1
6631
6632	IF (attempt .GT. max_attempt) THEN
6633
6634	! If the sign of y does not changes between the upper
6635	! and lower bound there no solution with the specified range
6636	found_range = .FALSE.
6637
6638	ELSE
6639
6640	IF (fl.GE.zero) THEN
6641
6642	! Both values are positive
6643	IF (fh.GT.fl) THEN
6644
6645	! the only option to get a difference in sign
6646	! is by decreasing the lower boundary such that
6647	! fl can become negative. Both fh and fl are too
6648	! large so the current lower boundary could be
6649	! used as the upper boundary in the next attampt.
6650	temp = low
6651	low = low / 2
6652	high = temp
6653
6654	ELSE
6655
6656	! Strange. We should decrease the higher bound
6657	! to find a solution. the uper bound will thus approach
6658	! the lower bound. The solution should alreday be in the
6659	! initial range. Unless we are searching for a local
6660	! minimum in the range. This is possible when the initial
6661	! range is too large. Try swapping the values and hope
6662	! that the next attempt will be more logic.
6663	temp = low
6664	low = high
6665	high = temp
6666
6667	ENDIF
6668
6669	ELSEIF (fl.LT.zero) THEN
6670
6671	IF (fh.GT.fl) THEN
6672
6673	! the only option to get a difference in sign
6674	! is by increasing the upper boundary such that
6675	! fh can become psitive. Both boundaries were
6676	! too low so it is safe to give the lower boundary
6677	! the value of the higher boundary and to
6678	! increase the higher boundary. Increase the
6679	! higher boundary by a factor of 10.
6680	temp = high
6681	high = high * 10
6682	low = temp
6683
6684	ELSE
6685
6686	! Srange. Swap the values. See above for more
6687	! details on the reasoning.
6688	temp = low
6689	low = high
6690	high = temp
6691
6692	ENDIF
6693
6694	ELSE
6695
6696	! Overlooked something
6697	CALL ipslerr(3,'logical flaw in an IF-statement', &
6698	'case 1 in newX', '','')
6699	ENDIF ! fl.GE.zero
6700
6701	! Enlarge the search range
6702	IF(printlev_loc.GE.4)THEN
6703	WRITE(numout,*) 'Iterative procedure - enlarge the search range'
6704	WRITE(numout,*) 'New range: ', low, high
6705	WRITE(numout,*) 'PFT, grid square, range: ',j,ipts,attempt
6706	ENDIF
6707
6708	ENDIF ! attempt.GT.max_attempt
6709
6710	ELSE
6711
6712	found_range = .TRUE.
6713
6714	ENDIF ! fl and fh have the same sign
6715
6716	ENDDO ! .NOT. found_range .AND. attempt .LE. max_attempt
6717
6718	! Only when we found a range we will search for the solution
6719	IF (found_range) THEN
6720
6721	! If the sign of y changes between the upper and lower bound there is a solution
6722	IF ( ABS(fl) .LT. min_stomate ) THEN
6723
6724	! The lower bound is the solution
6725	newX = low
6726	RETURN
6727
6728	ELSEIF ( ABS(fh) .LT. min_stomate ) THEN
6729
6730	! The upper bound is the solution
6731	newX = high
6732	RETURN
6733
6734	ELSEIF (fl .LT. 0.0) THEN
6735
6736	! Accept the lower and upper bounds as specified
6737	xl = low
6738	xh = high
6739
6740	ELSE
6741
6742	! Lower and upper bounds were swapped, correct their ranking
6743	xh = low
6744	xl = high
6745
6746	ENDIF
6747
6748	! Estimate the initial newX value
6749	newX = 0.5 * (low+high)
6750	dxold = ABS(high-low)
6751	dx = dxold
6752
6753	! Calculate y=f(x) and df(x) for initial guess of newX
6754	CALL func_derfunc(newX, n, o, p, q, r, t, eq_num, f, df)
6755
6756	! Evaluate for the maximum number of iterations
6757	DO i = 1,maxit
6758
6759	IF ( ((newX-xh)df-f)((newX-xl)df-f) .GT. 0.0 .OR. ABS(deuxf) > ABS(dxold*df) ) THEN
6760
6761	! Bisection
6762	dxold = dx
6763	dx = 0.5 * (xh-xl)
6764	newX = xl+dx
6765	IF (xl .EQ. newX) RETURN
6766
6767	ELSE
6768
6769	! Newton
6770	dxold = dx
6771	dx = f/df
6772	temp = newX
6773	newX = newX-dx
6774	IF (temp .EQ. newX) RETURN
6775
6776	ENDIF
6777
6778	! Precision reached
6779	IF ( ABS(dx) .LT. min_stomate) RETURN
6780
6781	! Precision was not reached calculate f(x) and df(x) for newX
6782	CALL func_derfunc(newX, n, o, p, q, r, t, eq_num, f, df)
6783
6784	! Narrow down the range
6785	IF (f .LT. 0.0) then
6786	xl = newX
6787	ELSE
6788	xh = newX
6789	ENDIF
6790
6791	ENDDO ! maximum number of iterations
6792
6793	ELSE
6794
6795	! The fact that we did not find a solution in the initial range or
6796	! a slightly adjusted range suggests that the new value of X (= Cs)
6797	! is very different from its current value. That is a bit strange;
6798	! something crazy may have happened with Cs. No optimal solution was
6799	! found but we will just adjust newX to our first guess of Cl_target.
6800	! Note that if we get too many suboptimal solution in a row, the error
6801	! will propagate in the code resulting in unrealistic biomasses. At one
6802	! point LAIs of 5000 were observed. It is important that this suboptimal
6803	! solution is as realistic as possible.
6804	IF (fl.GT.zero .AND. fh.GT.fl) THEN
6805	newX = s
6806	ELSEIF (fl.GT.zero .AND. fh.LE.fl) THEN
6807	newX = s
6808	ELSEIF (fl.LT.zero .AND. fh.LE.fl) THEN
6809	newX = s
6810	ELSEIF (fl.LT.zero .AND. fh.GT.fl) THEN
6811	newX = s
6812	ELSE
6813	! Overlooked something
6814	CALL ipslerr(3,'logical flaw in an IF-statement', &
6815	'case 1 in newX', '','')
6816	ENDIF
6817
6818	WRITE(numout,*) 'PFT, grid square: ',j,ipts
6819	CALL ipslerr_p (2,'growth_fun_all','newX',&
6820	'Iterative procedure - tried really hard but failed',&
6821	'had to use a suboptimal solution instead')
6822
6823	ENDIF
6824
6825	END FUNCTION newX
6826
6827
6828	!! ================================================================================================================================
6829	!! SUBROUTINE : comments
6830	!!
6831	!>\BRIEF Contains all comments to check the code
6832	!!
6833	!!
6834	!! DESCRIPTION : contains all comments to check the code. By setting pft_test to 0, this routine is not called
6835	!!
6836	!! RECENT CHANGE(S):
6837	!!
6838	!! MAIN OUTPUT VARIABLE(S): none
6839	!!
6840	!! REFERENCE(S) : none
6841	!!
6842	!! FLOWCHART :
6843	!! \n
6844	!_ ================================================================================================================================
6845
6846	SUBROUTINE comment(npts, Cl_target, Cl, Cs_target, &
6847	Cs, Cr_target, Cr, delta_ba, &
6848	ipts, j, l, b_inc_tot, &
6849	Cl_incp, Cs_incp, Cr_incp, KF, LF, &
6850	Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
6851	grow_wood, circ_class_n, n_comment)
6852
6853	!! 0. Variable and parameter declaration
6854
6855	!! 0.1 Input variables
6856	INTEGER(i_std), INTENT(in) :: npts !! Defined in stomate_growth_fun_all
6857	REAL(r_std), DIMENSION(:), INTENT(in) :: Cl_target, Cs_target, Cr_target !! Defined in stomate_growth_fun_all
6858	REAL(r_std), DIMENSION(:), INTENT(in) :: Cl_incp, Cs_incp, Cr_incp !! Defined in stomate_growth_fun_all
6859	REAL(r_std), DIMENSION(:), INTENT(in) :: Cl_inc, Cs_inc, Cr_inc, Cf_inc !! Defined in stomate_growth_fun_all
6860	REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: circ_class_n !! Defined in stomate_growth_fun_all
6861	REAL(r_std), DIMENSION(:), INTENT(in) :: Cl, Cs, Cr !! Defined in stomate_growth_fun_all
6862	REAL(r_std), DIMENSION(:), INTENT(in) :: delta_ba !! Defined in stomate_growth_fun_all
6863	REAL(r_std), DIMENSION(:,:), INTENT(in) :: KF, LF !! Defined in stomate_growth_fun_all
6864	REAL(r_std), INTENT(in) :: b_inc_tot !! Defined in stomate_growth_fun_all
6865	INTEGER(i_std), INTENT(in) :: ipts, j, l !! Defined in stomate_growth_fun_all
6866	LOGICAL, INTENT(in) :: grow_wood !! Defined in stomate_growth_fun_all
6867
6868	!! 0.2 Output variables
6869
6870	!! 0.3 Modified variables
6871
6872	!! 0.4 Local variables
6873	INTEGER(i_std) :: n_comment !! Comment number
6874	!_ ================================================================================================================================
6875
6876	SELECT CASE (n_comment)
6877	CASE (1)
6878	! Enough leaves and wood, grow roots
6879	WRITE(numout,*) 'Exc 1: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, class, '
6880	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
6881	b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
6882	IF (b_inc_tot - (circ_class_n(ipts,j,l)(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -10EPSILON(zero)) THEN
6883	WRITE(numout,*) 'Exc 1.1: unallocated less then 0: overspending, ', b_inc_tot - &
6884	(circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
6885	ELSE
6886	IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. -10EPSILON(zero)) .AND. &
6887	((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .LE. min_stomate) ) THEN
6888	WRITE(numout,*) 'Exc 1.2: unallocated <>= 0 but tree is in good shape: successful allocation'
6889	ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
6890	.LE. min_stomate) .AND. &
6891	(circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l)) .GT. min_stomate) ) THEN
6892	WRITE(numout,*) 'Exc 1.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
6893	ELSE
6894	WRITE(numout,*) 'WARNING 24: Exc 1.4 unexpected result'
6895	WRITE(numout,*) 'WARNING 24: PFT, ipts: ',j,ipts
6896	ENDIF
6897	ENDIF
6898
6899	CASE (2)
6900	! Enough wood and roots, grow leaves
6901	WRITE(numout,*) 'Exc 2: Cl_incp(<>0), Cs_incp (=0), Cr_incp (=0), unallocated, class, '
6902	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
6903	b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
6904	IF (b_inc_tot - (circ_class_n(ipts,j,l)(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -10EPSILON(zero)) THEN
6905	WRITE(numout,*) 'Exc 2.1: unallocated less then 0: overspending, ', b_inc_tot - &
6906	(circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
6907	ELSE
6908	IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. -10EPSILON(zero)) .AND. &
6909	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .LE. min_stomate) ) THEN
6910	WRITE(numout,*) 'Exc 2.2: unallocated <>= 0 but tree is in good shape: successful allocation'
6911	ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
6912	.LE. min_stomate) .AND. &
6913	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .GT. min_stomate) ) THEN
6914	WRITE(numout,*) 'Exc 2.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
6915	ELSE
6916	WRITE(numout,*) 'WARNING 25: Exc 2.4 unexpected result'
6917	WRITE(numout,*) 'WARNING 25: PFT, ipts: ',j,ipts
6918	ENDIF
6919	ENDIF
6920
6921
6922	CASE (3)
6923
6924	! Enough wood, grow leaves and roots
6925	WRITE(numout,*) 'Exc 3: Cl_incp(<>0), Cs_incp(=0), Cr_incp(<>0), unallocated, class, '
6926	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), b_inc_tot - &
6927	(circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))), l
6928	IF (b_inc_tot - circ_class_n(ipts,j,l) * (Cl_incp(l) + Cs_incp(l) + Cr_incp(l)) &
6929	.LT. -10*EPSILON(zero)) THEN
6930	WRITE(numout,*) 'Exc 3.1: unallocated less then 0: overspending, ', b_inc_tot - &
6931	(circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) )
6932	ELSE
6933	IF ( (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) &
6934	.GE. min_stomate) .AND. &
6935	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l)) ) .LE. min_stomate) .AND. &
6936	((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l)) ) .LE. min_stomate) ) THEN
6937	WRITE(numout,*) 'Exc 3.2: unallocated <>= 0 but tree is in good shape: successful allocation'
6938	ELSEIF ( (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
6939	.LE. min_stomate) .AND. &
6940	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l)) ) .GT. min_stomate) .AND. &
6941	((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l)) ) .GT. min_stomate) ) THEN
6942	WRITE(numout,*) 'Exc 3.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
6943	ELSE
6944	WRITE(numout,*) 'WARNING 26: Exc 3.4 unexpected result'
6945	WRITE(numout,*) 'WARNING 26: PFT, ipts: ',j,ipts
6946	ENDIF
6947	ENDIF
6948
6949	CASE(4)
6950	! Enough leaves and wood, grow roots
6951	WRITE(numout,*) 'Exc 4: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, class, '
6952	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
6953	b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
6954	IF (b_inc_tot - (circ_class_n(ipts,j,l)(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -10EPSILON(zero)) THEN
6955	WRITE(numout,*) 'Exc 4.1: unallocated less then 0: overspending, ', b_inc_tot - &
6956	(circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
6957	ELSE
6958	IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. -10EPSILON(zero)) .AND. &
6959	((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .LE. min_stomate) ) THEN
6960	WRITE(numout,*) 'Exc 4.2: unallocated <>= 0 but tree is in good shape: successful allocation'
6961	ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
6962	.LE. min_stomate) .AND. &
6963	((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .GT. min_stomate) ) THEN
6964	WRITE(numout,*) 'Exc 4.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
6965	ELSE
6966	WRITE(numout,*) 'WARNING 27: Exc 4.4 unexpected result'
6967	WRITE(numout,*) 'WARNING 27: PFT, ipts: ',j,ipts
6968	ENDIF
6969	ENDIF
6970
6971	CASE(5)
6972	! Enough leaves and roots, grow wood
6973	WRITE(numout,*) 'Exc 5: Cl_incp(=0), Cs_incp (<>0), Cr_incp (=0), unallocated, class, '
6974	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
6975	b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
6976	IF (b_inc_tot - (circ_class_n(ipts,j,l)(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -10EPSILON(zero)) THEN
6977	WRITE(numout,*) 'Exc 5.1: unallocated less then 0: overspending, ', b_inc_tot - &
6978	(circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
6979	ELSE
6980	IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. -10EPSILON(zero)) .AND. &
6981	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .LE. min_stomate) ) THEN
6982	WRITE(numout,*) 'Exc 5.2: unallocated <>= 0 but tree is in good shape: successful allocation'
6983	ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
6984	.LE. min_stomate) .AND. &
6985	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .GT. min_stomate) ) THEN
6986	WRITE(numout,*) 'Exc 5.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
6987	ELSE
6988	WRITE(numout,*) 'WARNING 28: Exc 5.4 unexpected result'
6989	WRITE(numout,*) 'WARNING 28: PFT, ipts: ',j,ipts
6990	ENDIF
6991	ENDIF
6992
6993	CASE(6)
6994	! Enough leaves, grow wood and roots
6995	WRITE(numout,*) 'Exc 6: Cl_incp(=0), Cs_incp(<>0), Cr_incp(<>0), unallocated'
6996	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
6997	b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
6998	IF (b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .LT. -10*EPSILON(zero)) THEN
6999	WRITE(numout,*) 'Exc 6.1: unallocated less then 0: overspending, ', &
7000	b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
7001	ELSE
7002	IF ( (b_inc_tot - (circ_class_n(ipts,j,l)(Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .GE. -10EPSILON(zero)) .AND. &
7003	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .LE. min_stomate) .AND. &
7004	((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .LE. min_stomate) ) THEN
7005	WRITE(numout,*) 'Exc 6.2: unallocated <>= 0 but tree is in good shape: successful allocation'
7006	ELSEIF ( (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .LE. min_stomate) .AND. &
7007	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .GT. min_stomate) .OR. &
7008	((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .GT. min_stomate) ) THEN
7009	WRITE(numout,*) &
7010	'Exc 6.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
7011	ELSE
7012	WRITE(numout,*) 'WARNING 29: Exc 6.4 unexpected result'
7013	WRITE(numout,*) 'WARNING 29: PFT, ipts: ',j,ipts
7014	ENDIF
7015	ENDIF
7016
7017	CASE(7)
7018	! Enough leaves and wood, grow roots
7019	WRITE(numout,*) 'Exc 7: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, class, '
7020	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
7021	b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
7022	IF (b_inc_tot - (circ_class_n(ipts,j,l)(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -10EPSILON(zero)) THEN
7023	WRITE(numout,*) 'Exc 7.1: unallocated less then 0: overspending, ', b_inc_tot - &
7024	(circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
7025	ELSE
7026	IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. -10EPSILON(zero)) .AND. &
7027	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .LE. min_stomate) ) THEN
7028	WRITE(numout,*) 'Exc 7.2: unallocated <>= 0 but tree is in good shape: successful allocation'
7029	ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
7030	.LE. min_stomate) .AND. &
7031	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .GT. min_stomate) ) THEN
7032	WRITE(numout,*) 'Exc 7.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
7033	ELSE
7034	WRITE(numout,*) 'WARNING 30: Exc 7.4 unexpected result'
7035	WRITE(numout,*) 'WARNING 30: PFT, ipts: ',j,ipts
7036	ENDIF
7037	ENDIF
7038
7039	CASE(8)
7040	! Enough leaves and roots, grow wood
7041	WRITE(numout,*) 'Exc 8: Cl_incp(=0), Cs_incp (<>0), Cr_incp (=0), unallocated, class, '
7042	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
7043	b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
7044	IF (b_inc_tot - (circ_class_n(ipts,j,l)(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -10EPSILON(zero)) THEN
7045	WRITE(numout,*) 'Exc 8.1: unallocated less then 0: overspending, ', b_inc_tot - &
7046	(circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
7047	ELSE
7048	IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. -10EPSILON(zero)) .AND. &
7049	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .LE. min_stomate) ) THEN
7050	WRITE(numout,*) 'Exc 8.2: unallocated <>= 0 but tree is in good shape: successful allocation'
7051	ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
7052	.LE. min_stomate) .AND. &
7053	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .GT. min_stomate) ) THEN
7054	WRITE(numout,*) 'Exc 8.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
7055	ELSE
7056	WRITE(numout,*) 'WARNING 31: Exc 8.4 unexpected result'
7057	WRITE(numout,*) 'WARNING 31: PFT, ipts: ',j,ipts
7058	ENDIF
7059	ENDIF
7060
7061	CASE(9)
7062	! Enough roots, grow leaves and wood
7063	WRITE(numout,*) 'Exc 9: delta_ba, Cl_incp(<>0), Cs_incp(<>0), Cr_incp(=0), unallocated, class, '
7064	WRITE(numout,*) delta_ba(:), Cl_incp(l), Cs_incp(l), Cr_incp(l), &
7065	b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))), l
7066	IF (b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .LT. -10*EPSILON(zero)) THEN
7067	WRITE(numout,*) 'Exc 9.1: unallocated less then 0: overspending, ', &
7068	b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
7069	ELSE
7070	IF ( (b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .GE. -10*EPSILON(zero)) .AND. &
7071	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .LE. min_stomate) .AND. &
7072	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .LE. min_stomate) ) THEN
7073	WRITE(numout,*) 'Exc 9.2: unallocated <>= 0 but tree is in good shape: successful allocation'
7074	ELSEIF ( (b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) &
7075	.LE. min_stomate) .AND. &
7076	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .GT. min_stomate) .OR. &
7077	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .GT. min_stomate) ) THEN
7078	WRITE(numout,*) 'Exc 9.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
7079	ELSE
7080	WRITE(numout,*) 'WARNING 32: Exc 9.4 unexpected result'
7081	WRITE(numout,*) 'WARNING 32: PFT, ipts: ',j,ipts
7082	ENDIF
7083	ENDIF
7084
7085	CASE(10)
7086	! Ready for ordinary allocation
7087	WRITE(numout,*) 'Ready for ordinary allocation?'
7088	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
7089	WRITE(numout,*) 'b_inc_tot, ', b_inc_tot
7090	WRITE(numout,*) 'Cl, Cs, Cr', Cl(:), Cs(:), Cr(:)
7091	WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(:)-Cl(:)
7092	WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(:)-Cs(:)
7093	WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(:)-Cr(:)
7094	IF (b_inc_tot .GT. min_stomate) THEN
7095	IF (SUM(ABS(Cl_target(:)-Cl(:))) .LE. min_stomate) THEN
7096	IF (SUM(ABS(Cs_target(:)-Cs(:))) .LE. min_stomate) THEN
7097	IF (SUM(ABS(Cr_target(:)-Cr(:))) .LE. min_stomate) THEN
7098	IF (grow_wood) THEN
7099	WRITE(numout,*) 'should result in exc 10.1 or 10.2'
7100	ELSE
7101	WRITE(numout,*) 'No wood growth. Not a problem! Just an observation.'
7102	ENDIF
7103	ELSE
7104	WRITE(numout,*) 'WARNING 34: problem with Cr_target'
7105	WRITE(numout,*) 'WARNING 34: PFT, ipts: ',j,ipts
7106	ENDIF
7107	ELSE
7108	WRITE(numout,*) 'WARNING 35: problem with Cs_target'
7109	WRITE(numout,*) 'WARNING 35: PFT, ipts: ',j,ipts
7110	ENDIF
7111	ELSE
7112	WRITE(numout,*) 'WARNING 36: problem with Cl_target'
7113	WRITE(numout,*) 'WARNING 36: PFT, ipts: ',j,ipts
7114	ENDIF
7115	ELSEIF(b_inc_tot .LT. -min_stomate) THEN
7116	WRITE(numout,*) 'WARNING 37: problem with b_inc_tot'
7117	WRITE(numout,*) 'WARNING 37: PFT, ipts: ',j,ipts
7118	ELSE
7119	WRITE(numout,*) 'no unallocated fraction'
7120	ENDIF
7121
7122	CASE(11)
7123	! Ordinary allocation
7124	WRITE(numout,*) 'delta_ba, ', delta_ba
7125	IF ( (SUM(Cl_inc(:)) .GE. zero) .AND. (SUM(Cs_inc(:)) .GE. zero) .AND. &
7126	(SUM(Cr_inc(:)) .GE. zero) .AND. &
7127	( b_inc_tot - SUM(circ_class_n(ipts,j,:) * (Cl_inc(:)+Cs_inc(:)+Cr_inc(:))) .GT. -1*min_stomate) .AND. &
7128	( b_inc_tot - SUM(circ_class_n(ipts,j,:) * (Cl_inc(:)+Cs_inc(:)+Cr_inc(:))) .LT. min_stomate ) ) THEN
7129	WRITE(numout,*) 'Exc 10.1: Ordinary allocation was succesful'
7130	WRITE(numout,*) 'Cl_inc, Cs_inc, Cr_inc, unallocated', Cl_inc(:), Cs_inc(:), Cr_inc(:), &
7131	b_inc_tot - SUM(circ_class_n(ipts,j,:) * (Cl_inc(:)+Cs_inc(:)+Cr_inc(:)))
7132	ELSE
7133	WRITE(numout,*) 'WARNING 38: Exc 10.2 problem with ordinary allocation'
7134	WRITE(numout,*) 'WARNING 38: PFT, ipts: ',j,ipts
7135	WRITE(numout,*) 'Cl_inc, Cs_inc, Cr_inc, unallocated', Cl_inc(:), Cs_inc(:), Cr_inc(:), &
7136	b_inc_tot - SUM(circ_class_n(ipts,j,:) * (Cl_inc(:)+Cs_inc(:)+Cr_inc(:)))
7137	ENDIF
7138
7139	CASE(12)
7140	! Enough leaves and structure, grow roots
7141	WRITE(numout,*) 'Exc 1: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, '
7142	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
7143	b_inc_tot - (SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
7144	IF (b_inc_tot - (SUM(circ_class_n(ipts,j,:))(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -10EPSILON(zero)) THEN
7145	WRITE(numout,*) 'Exc 1.1: unallocated less then 0: overspending, ', b_inc_tot - &
7146	(SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
7147	ELSE
7148	IF ( (b_inc_tot - ( SUM(circ_class_n(ipts,j,:))(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. -10EPSILON(zero)) .AND. &
7149	((SUM(circ_class_n(ipts,j,:)) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .LE. min_stomate) ) THEN
7150	WRITE(numout,*) 'Exc 1.2: unallocated <>= 0 but tree is in good shape: successful allocation'
7151	ELSEIF ( (b_inc_tot - ( SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
7152	.LE. min_stomate) .AND. &
7153	(SUM(circ_class_n(ipts,j,:)) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1)) .GT. min_stomate) ) THEN
7154	WRITE(numout,*) 'Exc 1.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
7155	ELSE
7156	WRITE(numout,*) 'WARNING 39: Exc 1.4 unexpected result'
7157	WRITE(numout,*) 'WARNING 39: PFT, ipts: ',j,ipts
7158	ENDIF
7159	ENDIF
7160
7161	CASE(13)
7162	! Enough structural C and roots, grow leaves
7163	WRITE(numout,*) 'Exc 2: Cl_incp(<>0), Cs_incp (=0), Cr_incp (=0), unallocated, '
7164	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
7165	b_inc_tot - (SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
7166	IF (b_inc_tot - (SUM(circ_class_n(ipts,j,:))(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -10EPSILON(zero)) THEN
7167	WRITE(numout,*) 'Exc 2.1: unallocated less then 0: overspending, ', b_inc_tot - &
7168	(SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
7169	ELSE
7170	IF ( (b_inc_tot - ( SUM(circ_class_n(ipts,j,:))(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. -10EPSILON(zero)) .AND. &
7171	((SUM(circ_class_n(ipts,j,:)) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .LE. min_stomate) ) THEN
7172	WRITE(numout,*) 'Exc 2.2: unallocated <>= 0 but tree is in good shape: successful allocation'
7173	ELSEIF ( (b_inc_tot - ( SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
7174	.LE. min_stomate) .AND. &
7175	((SUM(circ_class_n(ipts,j,:)) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .GT. min_stomate) ) THEN
7176	WRITE(numout,*) 'Exc 2.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
7177	ELSE
7178	WRITE(numout,*) 'WARNING 40: Exc l.4 unexpected result'
7179	WRITE(numout,*) 'WARNING 40: PFT, ipts: ',j,ipts
7180	ENDIF
7181	ENDIF
7182
7183	CASE(14)
7184	! Enough structural C and root, grow leaves
7185	WRITE(numout,*) 'Exc 3: Cl_incp(<>0), Cs_incp(=0), Cr_incp(<>0), unallocated, '
7186	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), b_inc_tot - &
7187	(SUM(circ_class_n(ipts,j,:)) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
7188	IF (b_inc_tot - SUM(circ_class_n(ipts,j,:)) * (Cl_incp(1) + Cs_incp(1) + Cr_incp(1)) &
7189	.LT. -10*EPSILON(zero)) THEN
7190	WRITE(numout,*) 'Exc 3.1: unallocated less then 0: overspending, ', b_inc_tot - &
7191	(SUM(circ_class_n(ipts,j,:)) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
7192	ELSE
7193	IF ( (b_inc_tot - (SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) &
7194	.GE. min_stomate) .AND. &
7195	((SUM(circ_class_n(ipts,j,:)) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1)) ) .LE. min_stomate) .AND. &
7196	((SUM(circ_class_n(ipts,j,:)) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1)) ) .LE. min_stomate) ) THEN
7197	WRITE(numout,*) 'Exc 3.2: unallocated <>= 0 but tree is in good shape: successful allocation'
7198	ELSEIF ( (b_inc_tot - (SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
7199	.LE. min_stomate) .AND. &
7200	((SUM(circ_class_n(ipts,j,:)) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1)) ) .GT. min_stomate) .AND. &
7201	((SUM(circ_class_n(ipts,j,:)) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1)) ) .GT. min_stomate) ) THEN
7202	WRITE(numout,*) 'Exc 3.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
7203	ELSE
7204	WRITE(numout,*) 'WARNING 41: Exc 3.4 unexpected result'
7205	WRITE(numout,*) 'WARNING 41: PFT, ipts: ',j,ipts
7206	ENDIF
7207	ENDIF
7208
7209	CASE(15)
7210	! Enough leaves and structural C, grow roots
7211	WRITE(numout,*) 'Exc 4: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, '
7212	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
7213	b_inc_tot - (SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
7214	IF (b_inc_tot - (SUM(circ_class_n(ipts,j,:))(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -10EPSILON(zero)) THEN
7215	WRITE(numout,*) 'Exc 4.1: unallocated less then 0: overspending, ', b_inc_tot - &
7216	(SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
7217	ELSE
7218	IF ( (b_inc_tot - ( SUM(circ_class_n(ipts,j,:))(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. -10EPSILON(zero)) .AND. &
7219	((SUM(circ_class_n(ipts,j,:)) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .LE. min_stomate) ) THEN
7220	WRITE(numout,*) 'Exc 4.2: unallocated <>= 0 but tree is in good shape: successful allocation'
7221	ELSEIF ( (b_inc_tot - ( SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
7222	.LE. min_stomate) .AND. &
7223	((SUM(circ_class_n(ipts,j,:)) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .GT. min_stomate) ) THEN
7224	WRITE(numout,*) 'Exc 4.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
7225	ELSE
7226	WRITE(numout,*) 'WARNING 42: Exc 4.4 unexpected result'
7227	WRITE(numout,*) 'WARNING 42: PFT, ipts: ',j,ipts
7228	ENDIF
7229	ENDIF
7230
7231	CASE(16)
7232	! Enough leaves and roots, grow structural C
7233	WRITE(numout,*) 'Exc 5: Cl_incp(=0), Cs_incp (<>0), Cr_incp (=0), unallocated, '
7234	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
7235	b_inc_tot - (SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
7236	IF (b_inc_tot - (SUM(circ_class_n(ipts,j,:))(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -10EPSILON(zero)) THEN
7237	WRITE(numout,*) 'Exc 5.1: unallocated less then 0: overspending, ', b_inc_tot - &
7238	(SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
7239	ELSE
7240	IF ( (b_inc_tot - ( SUM(circ_class_n(ipts,j,:))(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. -10EPSILON(zero)) .AND. &
7241	((SUM(circ_class_n(ipts,j,:)) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .LE. min_stomate) ) THEN
7242	WRITE(numout,*) 'Exc 5.2: unallocated <>= 0 but tree is in good shape: successful allocation'
7243	ELSEIF ( (b_inc_tot - ( SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
7244	.LE. min_stomate) .AND. &
7245	((SUM(circ_class_n(ipts,j,:)) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .GT. min_stomate) ) THEN
7246	WRITE(numout,*) 'Exc 5.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
7247	ELSE
7248	WRITE(numout,*) 'WARNING 43: Exc 5.4 unexpected result'
7249	WRITE(numout,*) 'WARNING 43: PFT, ipts: ',j,ipts
7250	ENDIF
7251	ENDIF
7252
7253	CASE(17)
7254	! Enough leaves, grow structural C and roots
7255	WRITE(numout,*) 'Exc 6: Cl_incp(=0), Cs_incp(<>0), Cr_incp(<>0), unallocated'
7256	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
7257	b_inc_tot - (SUM(circ_class_n(ipts,j,:)) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
7258	IF (b_inc_tot - (SUM(circ_class_n(ipts,j,:)) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) .LT. -10*EPSILON(zero)) THEN
7259	WRITE(numout,*) 'Exc 6.1: unallocated less then 0: overspending, ', &
7260	b_inc_tot - (SUM(circ_class_n(ipts,j,:)) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
7261	ELSE
7262	IF ( (b_inc_tot - SUM(circ_class_n(ipts,j,:))(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) .GE. -10EPSILON(zero)) .AND. &
7263	((SUM(circ_class_n(ipts,j,:)) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .LE. min_stomate) .AND. &
7264	((SUM(circ_class_n(ipts,j,:)) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .LE. min_stomate) ) THEN
7265	WRITE(numout,*) 'Exc 6.2: unallocated <>= 0 but tree is in good shape: successful allocation'
7266	ELSEIF ( (b_inc_tot - SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) .LE. min_stomate) .AND. &
7267	((SUM(circ_class_n(ipts,j,:)) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .GT. min_stomate) .AND. &
7268	((SUM(circ_class_n(ipts,j,:)) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .GT. min_stomate) ) THEN
7269	WRITE(numout,*) &
7270	'Exc 6.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
7271	ELSE
7272	WRITE(numout,*) 'WARNING 44: Exc 6.4 unexpected result'
7273	WRITE(numout,*) 'WARNING 44: PFT, ipts: ',j,ipts
7274	ENDIF
7275	ENDIF
7276
7277	CASE(18)
7278	! Enough leaves and structural C, grow roots
7279	WRITE(numout,*) 'Exc 7: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, '
7280	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
7281	b_inc_tot - (SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
7282	IF (b_inc_tot - (SUM(circ_class_n(ipts,j,:))(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -10EPSILON(zero)) THEN
7283	WRITE(numout,*) 'Exc 7.1: unallocated less then 0: overspending, ', b_inc_tot - &
7284	(SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
7285	ELSE
7286	IF ( (b_inc_tot - ( SUM(circ_class_n(ipts,j,:))(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. -10EPSILON(zero)) .AND. &
7287	((SUM(circ_class_n(ipts,j,:)) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .LE. min_stomate) ) THEN
7288	WRITE(numout,*) 'Exc 7.2: unallocated <>= 0 but tree is in good shape: successful allocation'
7289	ELSEIF ( (b_inc_tot - ( SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
7290	.LE. min_stomate) .AND. &
7291	((SUM(circ_class_n(ipts,j,:)) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .GT. min_stomate) ) THEN
7292	WRITE(numout,*) 'Exc 7.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
7293	ELSE
7294	WRITE(numout,*) 'WARNING 45: Exc 7.4 unexpected result'
7295	WRITE(numout,*) 'WARNING 45: PFT, ipts: ',j,ipts
7296	ENDIF
7297	ENDIF
7298
7299	CASE(19)
7300	! Enough leaves and roots, grow structural C
7301	WRITE(numout,*) 'Exc 8: Cl_incp(=0), Cs_incp (<>0), Cr_incp (=0), unallocated, '
7302	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
7303	b_inc_tot - (SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
7304	IF (b_inc_tot - (SUM(circ_class_n(ipts,j,:))(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -10EPSILON(zero)) THEN
7305	WRITE(numout,*) 'Exc 8.1: unallocated less then 0: overspending, ', b_inc_tot - &
7306	(SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
7307	ELSE
7308	IF ( (b_inc_tot - ( SUM(circ_class_n(ipts,j,:))(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. -10EPSILON(zero)) .AND. &
7309	((SUM(circ_class_n(ipts,j,:)) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .LE. min_stomate) ) THEN
7310	WRITE(numout,*) 'Exc 8.2: unallocated <>= 0 but tree is in good shape: successful allocation'
7311	ELSEIF ( (b_inc_tot - ( SUM(circ_class_n(ipts,j,:))*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
7312	.LE. min_stomate) .AND. &
7313	((SUM(circ_class_n(ipts,j,:)) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .GT. min_stomate) ) THEN
7314	WRITE(numout,*) 'Exc 8.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
7315	ELSE
7316	WRITE(numout,*) 'WARNING 46: Exc 8.4 unexpected result'
7317	WRITE(numout,*) 'WARNING 46: PFT, ipts: ',j,ipts
7318	ENDIF
7319	ENDIF
7320
7321	CASE(20)
7322	! Enough roots, grow structural C and leaves
7323	WRITE(numout,*) 'Exc 9: Cl_incp(<>0), Cs_incp(<>0), Cr_incp(=0), unallocated, '
7324	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
7325	b_inc_tot - (SUM(circ_class_n(ipts,j,:)) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
7326	WRITE(numout,) 'term 1', b_inc_tot - (SUM(circ_class_n(ipts,j,:)) (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
7327	WRITE(numout,) 'term 2', (SUM(circ_class_n(ipts,j,:)) ABS(Cl_target(1)-Cl(1)-Cl_incp(1)))
7328	WRITE(numout,) 'term 3', (SUM(circ_class_n(ipts,j,:)) ABS(Cs_target(1)-Cs(1)-Cs_incp(1)))
7329	IF (b_inc_tot - (SUM(circ_class_n(ipts,j,:)) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) .LT. -10*EPSILON(zero)) THEN
7330	WRITE(numout,*) 'Exc 9.1: unallocated less then 0: overspending, ', &
7331	b_inc_tot - (SUM(circ_class_n(ipts,j,:)) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
7332	ELSE
7333	IF ( (b_inc_tot - (SUM(circ_class_n(ipts,j,:)) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) .GE. -10*EPSILON(zero)) .AND. &
7334	((SUM(circ_class_n(ipts,j,:)) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .LE. min_stomate) .AND. &
7335	((SUM(circ_class_n(ipts,j,:)) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .LE. min_stomate) ) THEN
7336	WRITE(numout,*) 'Exc 9.2: unallocated <>= 0 but tree is in good shape: successful allocation'
7337	ELSEIF ( (b_inc_tot - (SUM(circ_class_n(ipts,j,:)) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) .LE. min_stomate) .AND. &
7338	(((SUM(circ_class_n(ipts,j,:)) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .GT. min_stomate) .OR. &
7339	((SUM(circ_class_n(ipts,j,:)) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .GT. min_stomate) ) ) THEN
7340	WRITE(numout,*) 'Exc 9.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
7341	ELSE
7342	WRITE(numout,*) 'WARNING 47: Exc 9.4 unexpected result'
7343	WRITE(numout,*) 'WARNING 47: PFT, ipts: ',j,ipts
7344	ENDIF
7345	ENDIF
7346
7347	CASE(21)
7348	! Ready for ordinary allocation
7349	WRITE(numout,*) 'Ready for ordinary allocation?'
7350	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
7351	WRITE(numout,*) 'b_inc_tot, ', b_inc_tot
7352	WRITE(numout,*) 'Cl, Cs, Cr', Cl(1), Cs(1), Cr(1)
7353	WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(1)-Cl(1)
7354	WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(1)-Cs(1)
7355	WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(1)-Cr(1)
7356	IF (b_inc_tot .GT. min_stomate) THEN
7357	IF (ABS(Cl_target(1)-Cl(1)) .LE. min_stomate) THEN
7358	IF (ABS(Cs_target(1)-Cs(1)) .LE. min_stomate) THEN
7359	IF (ABS(Cr_target(1)-Cr(1)) .LE. min_stomate) THEN
7360	IF (b_inc_tot .GT. min_stomate) THEN
7361	IF (grow_wood) THEN
7362	WRITE(numout,*) 'should result in exc 10.1 or 10.2'
7363	ELSE
7364	WRITE(numout,*) 'WARNING 48: no wood growth'
7365	WRITE(numout,*) 'WARNING 48: PFT, ipts: ',j,ipts
7366	ENDIF
7367	ENDIF
7368	ELSE
7369	WRITE(numout,*) 'WARNING 49: problem with Cr_target'
7370	WRITE(numout,*) 'WARNING 49: PFT, ipts: ',j,ipts
7371	ENDIF
7372	ELSE
7373	WRITE(numout,*) 'WARNING 50: problem with Cs_target'
7374	WRITE(numout,*) 'WARNING 50: PFT, ipts: ',j,ipts
7375	ENDIF
7376	ELSE
7377	WRITE(numout,*) 'WARNING 51: problem with Cl_target'
7378	WRITE(numout,*) 'WARNING 51: PFT, ipts: ',j,ipts
7379	ENDIF
7380	ELSEIF(b_inc_tot .LT. -min_stomate) THEN
7381	WRITE(numout,*) 'WARNING 52: problem with b_inc_tot'
7382	WRITE(numout,*) 'WARNING 52: PFT, ipts: ',j,ipts
7383	ELSE
7384	WRITE(numout,*) 'no unallocated fraction'
7385	ENDIF
7386
7387	CASE(22)
7388	! Ordinary allocation
7389	IF ( ((Cl_inc(1)) .GE. zero) .AND. ((Cs_inc(1)) .GE. zero) .AND. &
7390	((Cr_inc(1)) .GE. zero) .AND. &
7391	( b_inc_tot - (SUM(circ_class_n(ipts,j,:)) * (Cl_inc(1)+Cs_inc(1)+Cr_inc(1))) .LT. min_stomate ) ) THEN
7392	WRITE(numout,*) 'Exc 10.1: Ordinary allocation was succesful'
7393	WRITE(numout,*) 'Cl_inc, Cs_inc, Cr_inc, unallocated', Cl_inc(1), Cs_inc(1), Cr_inc(1), &
7394	b_inc_tot - (SUM(circ_class_n(ipts,j,:)) * (Cl_inc(1)+Cs_inc(1)+Cr_inc(1)))
7395	ELSE
7396	WRITE(numout,*) 'WARNING 53: Exc 10.2 problem with ordinary allocation'
7397	WRITE(numout,*) 'WARNING 53: PFT, ipts: ',j,ipts
7398	WRITE(numout,*) 'Cl_inc, Cs_inc, Cr_inc, unallocated', Cl_inc(1), Cs_inc(1), Cr_inc(1), &
7399	b_inc_tot - (SUM(circ_class_n(ipts,j,:)) * (Cl_inc(1)+Cs_inc(1)+Cr_inc(1)))
7400	ENDIF
7401
7402	END SELECT
7403
7404	END SUBROUTINE comment
7405
7406	END MODULE stomate_growth_fun_all

Note: See TracBrowser for help on using the repository browser.

Download in other formats: