Context Navigation

source: branches/publications/ORCHIDEE_CAN_r3069/src_stomate/stomate_growth_fun_all.f90 @ 7475

Last change on this file since 7475 was 2945, checked in by sebastiaan.luyssaert, 9 years ago
DEV: tested 1 year global. This code contains the latest version for anthropogenic tree species channges, several bug fixes to forest management as well as the code for the fully integrated multi-layer energy budget. This implies that the multi-layer energy budget makes use Pinty's albedo scheme, the rognostic canopy structure as well as a vertical profile for stomatal conductance. This is an intermediate version because species change code is not complete as some management changes have not been implemented yet. Further the multi-layer albedo code needs more work in terms of calculating average fluxes at the pixel rather than the PFT level
Property svn:executable set to ``*
File size: 295.0 KB

Line
1	!=================================================================================================================================
2	! MODULE : stomate_growth_fun_all
3	!
4	! CONTACT : orchidee-help _at_ ipsl.jussieu.fr
5	!
6	! LICENCE : IPSL (2006)
7	! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
8	!
9	!>\BRIEF 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	MODULE stomate_growth_fun_all
48
49	! Modules used:
50	USE ioipsl_para
51	USE pft_parameters
52	USE stomate_data
53	USE constantes
54	USE constantes_soil
55	USE function_library, ONLY: wood_to_qmdia, wood_to_qmheight, wood_to_ba_eff, biomass_to_lai,&
56	calculate_c0_alloc, wood_to_volume, wood_to_ba
57
58	IMPLICIT NONE
59
60	! Private & public routines
61
62	PRIVATE
63	PUBLIC growth_fun_all_clear, growth_fun_all
64
65	! Variables shared by all subroutines in this module
66
67	LOGICAL, SAVE :: firstcall = .TRUE. !! Is this the first call? (true/false)
68
69	!!$ !+++TEMP+++
70	INTEGER, SAVE :: istep = 0
71
72	CONTAINS
73
74
75
76	!! ================================================================================================================================
77	!! SUBROUTINE : growth_fun_all_clear
78	!!
79	!>\BRIEF Set the flag ::firstcall to .TRUE. and as such activate section
80	!! 1.1 of the subroutine alloc (see below).\n
81	!!
82	!_ ================================================================================================================================
83
84	SUBROUTINE growth_fun_all_clear
85	firstcall = .TRUE.
86	END SUBROUTINE growth_fun_all_clear
87
88
89
90	!! ================================================================================================================================
91	!! SUBROUTINE : growth_fun_all
92	!!
93	!>\BRIEF Allocate net primary production (= photosynthesis
94	!! minus autothrophic respiration) to: labile carbon pool carbon reserves, aboveground sapwood,
95	!! belowground sapwood, root, fruits and leaves following the pipe model and allometric constraints.
96	!!
97	!! DESCRIPTION : Total maintenance respiration for the whole plant is calculated by summing maintenance
98	!! respiration of the different plant compartments. Maintenance respiration is subtracted
99	!! from whole-plant allocatable biomass (up to a maximum fraction of the total allocatable biomass).
100	!! Growth respiration is then calculated as a prescribed (0.75) fraction of the allocatable
101	!! biomass. Subsequently NPP is calculated by substracting total autotrophic respiration from GPP
102	!! i.e. NPP = GPP - maintenance resp - growth resp.
103	!!
104	!! The pipe model assumes that one unit of leaf mass requires a proportional amount of sapwood to
105	!! transport water from the roots to the leaves. Also a proportional fraction of roots is needed to
106	!! take up the water from the soil. The proportional amounts between leaves, sapwood and roots are
107	!! given by allocation factors. These allocation factors are PFT specific and depend on a parameter
108	!! quantifying the leaf to sapwood area (::k_latosa_target), the specific laeaf area (::sla), wood
109	!! density (::pipe_density) and a scaling parameter between leaf and root mass.
110	!!
111	!! Lai is optimised for mean annual radiation use efficiency and the C cost for producing the
112	!! canopy. The cost-benefit ratio is optimised when the marginal gain / marginal cost = 1 lai target
113	!! is used to calculate whether the reserves are used. This approach allows plants to get out of
114	!! senescence and to start developping a canopy in early spring.
115	!!
116	!! As soon as a canopy has emerged, C (b_inc_tot) becomes available at the stand level through
117	!! photosynthesis and, C is allocated at the tree level (b_inc) following both the pipe model and
118	!! allometric constraints. Mass conservation requires:
119	!! (1) Cs_inc + Cr_inc + Cl_inc = b_inc
120	!! (2) sum(b_inc) = b_inc_tot
121	!!
122	!! Wood allocation depends on tree basal area following the rule of Deleuze & Dhote
123	!! delta_ba = gammas(circ - msigmas + sqrt((msigmas + circ).^2 - (4sigmas*circ)))/2
124	!! (3) <=> delta_ba = circ_class_dba*gammas
125	!! Where circ_class_dba = (circ - msigmas + sqrt((msigmas + circ).^2 - (4sigmascirc)))/2
126	!!
127	!! Allometric relationships
128	!! height = pipe_tune2*(dia.^pipe_tune3)
129	!! Re-write this relationship as a function of ba
130	!! (4) height = pipe_tune2 * (4/pi*ba)^(pipe_tune3/2)
131	!! (5a) Cl/Cs = KF/height for trees
132	!! (5b) Cs = Cl / KF
133	!! (6) Cl = Cr * LF
134	!!
135	!! Use a linear approximation to avoid iterations. Given that allocation is calculated daily, a
136	!! local lineair assumption is fair. Eq (4) can thus be rewritten as:
137	!! s = step/(pipe_tune2(4/pi(ba+step)).^(pipe_tune3/2)-pipe_tune2(4/piba).^(pipe_tune3/2))
138	!! Where step is a small but realistic (for the time step) change in ba
139	!! (7) <=> delta_height = delta_ba/s
140	!!
141	!! Calculate Cs_inc from allometric relationships
142	!! Cs_inc = tree_ffpipe_density(ba+delta_ba)*(height+delta_height) - Cs - Ch
143	!! Cs_inc = tree_ffpipe_density(ba+delta_ba)*(height+delta_ba/s) - Cs - Ch
144	!! (8) <=> Cs_inc = tree_ffpipe_density(ba+agammas)(height+(a/s*gammas)) - Cs - Ch
145	!!
146	!! Rewrite (5) as
147	!! Cl_inc = KF*(Cs_inc+Cs)/(height+delta_height) - Cl
148	!! Substitute (7) in (4) and solve for Cl_inc
149	!! Cl_inc = KF(tree_ffpipe_density(ba+circ_class_dbagammas)(height+(circ_class_dba/sgammas)) - Ch)/ &
150	!! (height+(circ_class_dba/s*gammas)) - Cl
151	!! (9) <=> Cl_inc = KFtree_ffpipe_density(ba+circ_class_dbagammas) - &
152	!! (KFCh)/(height+(circ_class_dba/sgammas)) - Cl
153	!!
154	!! Rewrite (6) as
155	!! Cr_inc = (Cl_inc+Cl)/LF - Cr
156	!! Substitute (9) in (6)
157	!! (10) <=> Cr_inc = KF/LFtree_ffpipe_density(ba+circ_class_dbagammas) - &
158	!! (KFCh/LF)/(height+(circ_class_dba/sgammas)) - Cr
159	!!
160	!! Depending on the specific case that needs to be solved equations (1) takes one of the following forms:
161	!! (a) b_inc = Cl_inc + Cr_inc + Cs_inc, (b) b_inc = Cl_inc + Cr_inc, (c) b_inc = Cl_inc + Cs_inc or
162	!! (d) b_inc = Cr_inc + Cs_inc. One of these alternative forms of eq. 1 are then combined with
163	!! eqs 8, 9 and 10 and solved for gammas. The details for the solution of these four cases are given in the
164	!! code. Once gammas is know, eqs 6 - 10 are used to calculate the allocation to leaves (Cl_inc),
165	!! roots (Cr_inc) and sapwood (Cs_inc).
166	!!
167	!! Because of turnover, biomass pools are not all the time in balance according to rules prescribed
168	!! by the pipe model. To test whether biomass pools are balanced, the target biomasses are calculated
169	!! and balance is restored whenever needed up to the level that the biomass pools for leaves, sapwood
170	!! and roots are balanced according to the pipe model. Once the balance is restored C is allocated to
171	!! fruits, leaves, sapwood and roots by making use of the pipe model (below this called ordinary
172	!! allocation).
173	!!
174	!! Although strictly speaking allocation factors are not necessary in this scheme (Cl_inc could simply
175	!! be added to biomass(:,:,ileaf,icarbon), Cr_inc to biomass(:,:,iroot,icarbon), etc.), they are
176	!! nevertheless calculated because using allocation factors facilitates comparison to the resource
177	!! limited allocation scheme (stomate_growth_res_lim.f90) and it comes in handy for model-data comparison.
178	!!
179	!! Effective basal area, height and circumferences are use in the allocation scheme because their
180	!! calculations make use of the total (above and belowground) biomass. In forestry the same measures
181	!! exist (and they are also calculated in ORCHIDEE) but only account for the aboverground biomass.
182	!!
183	!!
184	!! RECENT CHANGE(S): - The code by Sonke Zaehle made use of ::Cl_target that was derived from ::lai_target which in turn
185	!! was a function of ::rue_longterm. Cl_target was then used as a threshold value to decide whether there
186	!! was only phenological growth (just leaves and roots) or whether there was full allometric growth to the
187	!! leaves, roots and sapwood. This approach was inconsistent with the pipe model because full allometric
188	!! growth can only occur if all three biomass pools are in balance. ::lai_target is no longer used as a
189	!! criterion to switch between phenological and full allometric growth. Its use is now restricted to trigger
190	!! the use of reserves in spring.
191	!!
192	!! MAIN OUTPUT VARIABLE(S): ::npp and :: biomass. Seven different biomass compartments (leaves, roots, above and
193	!! belowground wood, carbohydrate reserves, labile and fruits).
194	!!
195	!! REFERENCE(S) :- Sitch, S., Smith, B., Prentice, I.C., Arneth, A., Bondeau, A., Cramer, W.,
196	!! Kaplan, J.O., Levis, S., Lucht, W., Sykes, M.T., Thonicke, K., Venevsky, S. (2003), Evaluation of
197	!! ecosystem dynamics, plant geography and terrestrial carbon cycling in the LPJ Dynamic Global Vegetation
198	!! Model, Global Change Biology, 9, 161-185.\n
199	!! - Zaehle, S. and Friend, A.D. (2010), Carbon and nitrogen cycle dynamics in the O-CN land surface model: 1.
200	!! Model description, site-scale evaluation, and sensitivity to parameter estimates, Global Biogeochemical
201	!! Cycles, 24, GB1005.\n
202	!! - Magnani F., Mencuccini M. & Grace J. 2000. Age-related decline in stand productivity: the role of
203	!! structural acclimation under hydraulic constraints Plant, Cell and Environment 23, 251â263.
204	!! - Bloom A.J., Chapin F.S. & Mooney H.A. (1985) Resource limitation in plants. An economic analogy. Annual
205	!! Review Ecology Systematics 16, 363â392.
206	!! - Case K.E. & Fair R.C. (1989) Principles of Economics. Prentice Hall, London.
207	!! - McDowell, N., Barnard, H., Bond, B.J., Hinckley, T., Hubbard, R.M., Ishii, H., KÃ¶stner, B.,
208	!! Magnani, F. Marshall, J.D., Meinzer, F.C., Phillips, N., Ryan, M.G., Whitehead D. 2002. The
209	!! relationship between tree height and leaf area: sapwood area ratio. Oecologia, 132:12â20
210	!! - Novick, K., Oren, R., Stoy, P., Juang, F.-Y., Siqueira, M., Katul, G. 2009. The relationship between
211	!! reference canopy conductance and simplified hydraulic architecture. Advances in water resources 32,
212	!! 809-819.
213	!!
214	!! +++++++++++++++++++++
215	!! MAKE A NEW FLOW CHART
216	!! +++++++++++++++++++++
217	!! FLOWCHART :
218	!!
219	!_ ================================================================================================================================
220
221	SUBROUTINE growth_fun_all (npts, dt, veget_max, veget, PFTpresent, &
222	senescence, when_growthinit, t2m, &
223	gpp_daily, gpp_week, resp_maint_part, resp_maint, &
224	resp_growth, npp, biomass, age, &
225	leaf_age, leaf_frac, use_reserve, &
226	lab_fac, ind, rue_longterm, circ_class_n, &
227	circ_class_biomass, KF, bm_sync, sigma, &
228	gammas, tau_eff_leaf, tau_eff_sap, tau_eff_root, &
229	k_latosa_adapt, forest_managed, circ_class_dist)
230
231
232	!! 0. Variable and parameter declaration
233
234	!! 0.1 Input variables
235
236	INTEGER(i_std), INTENT(in) :: npts !! Domain size - number of grid cells
237	!! (unitless)
238	REAL(r_std), INTENT(in) :: dt !! Time step of the simulations for stomate
239	!! (days)
240	REAL(r_std), DIMENSION(:), INTENT(in) :: t2m !! Temperature at 2 meter (K)
241	REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ind !! Number of individuals at the stand level
242	!! @tex $(m^{-2})$ @endtex
243	REAL(r_std), DIMENSION(:,:), INTENT(in) :: veget_max !! PFT "Maximal" coverage fraction of a PFT
244	!! (= ind*cn_ind)
245	!! @tex $(m^2 m^{-2})$ @endtex
246	REAL(r_std), DIMENSION(:,:), INTENT(in) :: veget !! Fraction of vegetation type including
247	!! non-biological fraction (unitless)
248	REAL(r_std), DIMENSION(:,:), INTENT(in) :: when_growthinit !! Days since beginning of growing season
249	!! (days)
250	REAL(r_std), DIMENSION(:,:), INTENT(in) :: gpp_week !! "weekly" (default 7-day) gross primary
251	!! productivity
252	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
253	REAL(r_std), DIMENSION(:,:), INTENT(in) :: rue_longterm !! Longterm "radiation use efficicency"
254	!! calculated as the ratio of GPP over
255	!! the fraction of radiation absorbed
256	!! by the canopy
257	!! @tex $(gC.m^{-2}day^{-1})$ @endtex
258	REAL(r_std), DIMENSION(:,:), INTENT(in) :: tau_eff_root !! Effective root turnover time that accounts
259	!! waterstress (days)
260	REAL(r_std), DIMENSION(:,:), INTENT(in) :: tau_eff_sap !! Effective sapwood turnover time that accounts
261	!! waterstress (days)
262	REAL(r_std), DIMENSION(:,:), INTENT(in) :: tau_eff_leaf !! Effective leaf turnover time that accounts
263	!! waterstress (days)
264	REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: circ_class_n !! Number of individuals in each circ class
265	REAL(r_std), DIMENSION(:), INTENT(in) :: circ_class_dist !! The probability distribution of trees
266	!! in a circ class in case of a
267	!! redistribution (unitless).
268	REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: resp_maint_part !! Maintenance respiration of different
269	!! plant parts
270	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
271	LOGICAL, DIMENSION(:,:), INTENT(in) :: senescence !! Is the PFT senescent? - only for
272	!! deciduous trees (true/false)
273	LOGICAL, DIMENSION(:,:), INTENT(in) :: PFTpresent !! PFT exists (true/false)
274	INTEGER(i_std), DIMENSION(:,:), INTENT(in) :: forest_managed !! Forest management flag: 0 = orchidee
275	!! standard, 1= self-thinning only, 2=
276	!! high-stand, 3= high-stand smoothed, 4=
277	!! coppices
278
279
280
281	!! 0.2 Output variables
282
283	REAL(r_std), DIMENSION(:,:), INTENT(out) :: resp_maint !! PFT maintenance respiration
284	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
285	REAL(r_std), DIMENSION(:,:), INTENT(out) :: resp_growth !! PFT growth respiration
286	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
287	REAL(r_std), DIMENSION(:,:), INTENT(out) :: npp !! PFT net primary productivity
288	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
289	REAL(r_std), DIMENSION(:,:), INTENT(out) :: lab_fac !! Activity of labile pool factor (units??)
290	REAL(r_std), DIMENSION(:,:), INTENT(out) :: sigma !! Threshold for indivudal tree growth in
291	!! the equation of Deleuze & Dhote (2004)(m).
292	!! Trees whose circumference is smaller than
293	!! sigma don't grow much
294	REAL(r_std), DIMENSION(:,:), INTENT(out) :: gammas !! Slope for individual tree growth in the
295	!! equation of Deleuze & Dhote (2004) (m)
296	!! 0.3 Modified variables
297
298	REAL(r_std), DIMENSION(:,:), INTENT(inout) :: gpp_daily !! PFT gross primary productivity
299	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
300	REAL(r_std), DIMENSION(:,:), INTENT(inout) :: use_reserve !! Flag to use the reserves to support
301	!! phenological growth (0 or 1)
302	REAL(r_std), DIMENSION(:,:), INTENT(inout) :: age !! PFT age (days)
303	REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout) :: biomass !! PFT total biomass
304	!! @tex $(gC m^{-2})$ @endtex
305	REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_age !! PFT age of different leaf classes
306	!! (days)
307	REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: leaf_frac !! PFT fraction of leaves in leaf age class
308	!! (0-1, unitless)
309	REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: circ_class_biomass !! Biomass components of the model tree
310	!! within a circumference class
311	!! class @tex $(g C ind^{-1})$ @endtex
312	REAL(r_std), DIMENSION(:,:), INTENT(inout) :: KF !! Scaling factor to convert sapwood mass
313	!! into leaf mass (m)
314	REAL(r_std), DIMENSION(:,:), INTENT(inout) :: k_latosa_adapt !! Leaf to sapwood area adapted for long
315	!! term water stress (m)
316	REAL(r_std), DIMENSION(:,:,:),INTENT(inout) :: bm_sync !! The difference betweeen the
317	!! biomass in the circ_classes and
318	!! the total biomass
319	!! @tex $(gC m^{-2})$ @endtex
320
321	!!$ !+++HACK+++
322	!!$ ! This is a hack to prescribe a stand structure to the model
323	!!$ ! this feature was introduced to parameterize and validate the
324	!!$ ! energy budget. When using this hack comment out the declaration
325	!!$ ! of ::ind and ::circ_class_n above.
326	!!$ ! the "ind" will be prescribed from the run.def
327	!!$ REAL(r_std), DIMENSION(:,:), INTENT(inout) :: ind !! Number of individuals at the stand level
328	!!$ !! @tex $(m^{-2})$ @endtex
329	!!$ ! (temp for hardwired values) REAL(r_std), DIMENSION(:), INTENT(in) :: circ_class_dist
330	!!$ REAL(r_std), DIMENSION(:), INTENT(inout) :: circ_class_dist !! The probability distribution of trees
331	!!$ !! in a circ class in case of a
332	!!$ !! redistribution (unitless).
333	!!$ ! (temp for hardwired values) REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: circ_class_n
334	!!$ REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: circ_class_n !! Number of individuals in each circ class
335	!!$ !! @tex $(ind m^{-2})$ @endtex
336	!!$ !+++++++++++
337
338
339	!! 0.4 Local variables
340
341	CHARACTER(30) :: var_name !! To store variable names for I/O
342	REAL(r_std), DIMENSION(npts,nvm) :: c0_alloc !! Root to sapwood tradeoff parameter
343	LOGICAL :: grow_wood=.TRUE. !! Flag to grow wood
344	INTEGER(i_std) :: ipts,j,k,l,m,icirc,imed!! Indeces(unitless)
345	INTEGER(i_std) :: ipar, iele, imbc !! Indeces(unitless)
346	INTEGER(i_std) :: ilev !! Indeces(unitless)
347	REAL(r_std) :: frac !! No idea??
348	REAL(r_std) :: a,b,c !! Temporary variables to solve a
349	!! quadratic equation (unitless)
350	! Stand level
351	REAL(r_std) :: gtemp !! Turnover coefficient of labile C pool
352	!! (0-1??, units??)
353	REAL(r_std) :: reserve_pool !! Intentional size of the reserve pool
354	!! @tex $(gC.m^{-2})$ @endtex
355	REAL(r_std) :: labile_pool !! Intentional size of the labile apool
356	!! @tex $(gC.m^{-2})$ @endtex
357	REAL(r_std) :: reserve_scal !! Protection of the reserve against
358	!! overuse (unitless)
359	REAL(r_std) :: use_lab !! Availability of labile biomass
360	!! @tex $(gC.m^{-2})$ @endtex
361	REAL(r_std) :: use_res !! Availability of resource biomass
362	!! @tex $(gC.m^{-2})$ @endtex
363	REAL(r_std) :: use_max !! Maximum use of labile and resource pool
364	!! @tex $(gC.m^{-2})$ @endtex
365	REAL(r_std) :: leaf_meanage !! Mean age of the leaves (days?)
366	REAL(r_std) :: reserve_time !! Maximum number of days during which
367	!! carbohydrate reserve may be used (days)
368	REAL(r_std) :: b_inc_tot !! Carbon that needs to allocated in the
369	!! fixed number of trees (gC)
370	REAL(r_std) :: b_inc_temp !! Temporary b_inc at the stand-level
371	!! @tex $(gC.plant^{-1})$ @endtex
372	REAL(r_std) :: scal !! Scaling factor between average
373	!! individual and individual plant
374	!! @tex $(plant.m^{-2})$ @endtex
375	REAL(r_std) :: total_inc !! Total biomass increase
376	!! @tex $(gC.plant^{-1})$ @endtex
377	REAL(r_std) :: KF_old !! Scaling factor to convert sapwood mass
378	!! into leaf mass (m) at the previous
379	!! time step
380	REAL(r_std), DIMENSION(nvm) :: lai_happy !! Lai threshold below which carbohydrate
381	!! reserve may be used
382	!! @tex $(m^2 m^{-2})$ @endtex
383	REAL(r_std), DIMENSION(nvm) :: deleuze_p !! Percentile of trees that will receive
384	!! photosynthates. The proxy for intra stand
385	!! competition. Depends on the management
386	!! strategy when ncirc < 6
387	REAL(r_std), DIMENSION(npts) :: tl !! Long term annual mean temperature (C)
388	REAL(r_std), DIMENSION(npts) :: bm_add !! Biomass increase
389	!! @tex $(gC.m^{-2})$ @endtex
390	REAL(r_std), DIMENSION(npts) :: bm_new !! New biomass @tex $(gC.m^{-2})$ @endtex
391	REAL(r_std) :: alloc_sap_above !! Fraction allocated to sapwood above
392	!! ground
393	REAL(r_std), DIMENSION(npts,nvm) :: residual !! Copy of b_inc_tot after all C has been
394	!! allocated @tex $(gC.m^{-2})$ @endtex
395	!! if all went well the value should be zero
396	REAL(r_std), DIMENSION(npts,nvm) :: lai_target !! Target LAI @tex $(m^{2}m^{-2})$ @endtex
397	REAL(r_std), DIMENSION(npts,nvm) :: ltor !! Leaf to root ratio (unitless)
398	REAL(r_std), DIMENSION(npts,nvm) :: lstress_fac !! Light stress factor, based on total
399	!! transmitted light (unitless, 0-1)
400	REAL(r_std), DIMENSION(npts,nvm) :: k_latosa !! Target leaf to sapwood area ratio
401	REAL(r_std), DIMENSION(npts,nvm) :: LF !! Scaling factor to convert sapwood mass
402	!! into root mass (unitless)
403	REAL(r_std), DIMENSION(npts,nvm) :: lm_old !! Variable to store leaf biomass from
404	!! previous time step
405	!! @tex $(gC m^{-2})$ @endtex
406	REAL(r_std), DIMENSION(npts,nvm) :: bm_alloc_tot !! Allocatable biomass for the whole plant
407	!! @tex $(gC.m^{-2})$ @endtex
408	REAL(r_std), DIMENSION(npts,nvm) :: leaf_mass_young !! Leaf biomass in youngest leaf age class
409	!! @tex $(gC m^{-2})$ @endtex
410	REAL(r_std), DIMENSION(npts,nvm) :: lai !! PFT leaf area index
411	!! @tex $(m^2 m^{-2})$ @endtex
412	REAL(r_std), DIMENSION(npts,nvm) :: qm_dia !! Quadratic mean diameter of the stand (m)
413	REAL(r_std), DIMENSION(npts,nvm) :: qm_height !! Height of a tree with the quadratic mean
414	!! diameter (m)
415	REAL(r_std), DIMENSION(npts,nvm) :: ba !! Basal area. variable for histwrite only (m2)
416	REAL(r_std), DIMENSION(npts,nvm) :: wood_volume !! wood_volume (m3 m-2)
417	REAL(r_std), DIMENSION(npts,nvm,nparts) :: f_alloc !! PFT fraction of NPP that is allocated to
418	!! the different components (0-1, unitless)
419	REAL(r_std), DIMENSION(npts,nvm,nparts,nelements) :: bm_alloc !! PFT biomass increase, i.e. NPP per plant
420	!! part @tex $(gC.m^{-2}dt^{-1})$ @endtex
421
422	! Tree level
423	REAL(r_std), DIMENSION(ncirc) :: step !! Temporary variables to solve a
424	!! quadratic equation (unitless)
425	REAL(r_std), DIMENSION(ncirc) :: s !! tree-level linear relationship between
426	!! basal area and height. This variable is
427	!! used to linearize the allocation scheme
428	REAL(r_std), DIMENSION(ncirc) :: Cs_inc_est !! Initial value estimate for Cs_inc. The
429	!! value is used to linearize the ba~height
430	!! relationship
431	!! @tex $(gC.plant^{-1})$ @endtex
432	REAL(r_std), DIMENSION(ncirc) :: Cl !! Individual plant, leaf compartment
433	!! @tex $(gC.plant^{-1})$ @endtex
434	REAL(r_std), DIMENSION(ncirc) :: Cr !! Individual plant, root compartment
435	!! @tex $(gC.plant^{-1})$ @endtex
436	REAL(r_std), DIMENSION(ncirc) :: Cs !! Individual plant, sapwood compartment
437	!! @tex $(gC.plant^{-1})$ @endtex
438	REAL(r_std), DIMENSION(ncirc) :: Ch !! Individual plant, heartwood compartment
439	!! @tex $(gC.plant^{-1})$ @endtex
440	REAL(r_std), DIMENSION(ncirc) :: Cl_inc !! Individual plant increase in leaf
441	!! compartment
442	!! @tex $(gC.plant^{-1})$ @endtex
443	REAL(r_std), DIMENSION(ncirc) :: Cr_inc !! Individual plant increase in root
444	!! compartment
445	!! @tex $(gC.plant^{-1})$ @endtex
446	REAL(r_std), DIMENSION(ncirc) :: Cs_inc !! Individual plant increase in sapwood
447	!! compartment
448	!! @tex $(gC.plant^{-1})$ @endtex
449	REAL(r_std), DIMENSION(ncirc) :: Cf_inc !! Individual plant increase in fruit
450	!! compartment
451	!! @tex $(gC.plant^{-1})$ @endtex
452	REAL(r_std), DIMENSION(ncirc) :: Cl_incp !! Phenology related individual plant
453	!! increase in leaf compartment
454	!! @tex $(gC.plant^{-1})$ @endtex
455	REAL(r_std), DIMENSION(ncirc) :: Cr_incp !! Phenology related individual plant
456	!! increase in leaf compartment
457	!! @tex $(gC.plant^{-1})$ @endtex
458	REAL(r_std), DIMENSION(ncirc) :: Cs_incp !! Phenology related individual plant
459	!! increase in sapwood compartment
460	!! @tex $(gC.plant^{-1})$ @endtex
461	REAL(r_std), DIMENSION(ncirc) :: Cl_target !! Individual plant maximum leaf mass given
462	!! its current sapwood mass
463	!! @tex $(gC.plant^{-1})$ @endtex
464	REAL(r_std), DIMENSION(ncirc) :: Cr_target !! Individual plant maximum root mass given
465	!! its current sapwood mass
466	!! @tex $(gC.plant^{-1})$ @endtex
467	REAL(r_std), DIMENSION(ncirc) :: Cs_target !! Individual plant maximum sapwood mass
468	!! given its current leaf mass or root mass
469	!! @tex $(gC.plant^{-1})$ @endtex
470	REAL(r_std), DIMENSION(ncirc) :: delta_ba !! Change in basal area for a unit
471	!! investment into sapwood mass (m)
472	REAL(r_std), DIMENSION(ncirc) :: delta_height !! Change in height for a unit
473	!! investment into sapwood mass (m)
474	REAL(r_std), DIMENSION(ncirc) :: circ_class_ba !! Basal area (forestry definition) of the model
475	!! tree in each circ class
476	!! @tex $(m^{2} m^{-2})$ @endtex
477	REAL(r_std), DIMENSION(ncirc) :: circ_class_ba_eff !! Effective basal area of the model tree in each
478	!! circ class @tex $(m^{2} m^{-2})$ @endtex
479	REAL(r_std), DIMENSION(ncirc) :: circ_class_dba !! Share of an individual tree in delta_ba
480	!! thus, circ_class_dba*gammas = delta_ba
481	REAL(r_std), DIMENSION(ncirc) :: circ_class_height_eff !! Effective tree height calculated from allometric
482	!! relationships (m)
483	REAL(r_std), DIMENSION(ncirc) :: circ_class_circ_eff !! Effective circumference of individual trees (m)
484	REAL(r_std) :: woody_biomass !! Woody biomass. Temporary variable to
485	!! calculate wood volume (gC m-2)
486	REAL(r_std) :: temp_share !! Temporary variable to store the share
487	!! of biomass of each circumference class
488	!! to the total biomass
489	REAL(r_std) :: temp_class_biomass !! Biomass across parts for a single circ
490	!! class @tex $(gC m^{-2})$ @endtex
491	REAL(r_std) :: temp_total_biomass !! Biomass across parts and circ classes
492	!! @tex $(gC m^{-2})$ @endtex
493	REAL(r_std), DIMENSION(npts,nvm,ncirc) :: store_delta_ba !! Store delta_ba in this variable before writing
494	!! to the output file (m). Adding this variable
495	!! was faster than changing the dimensions
496	!! of delta_ba which would have been the same
497	REAL(r_std), DIMENSION(npts,nvm,ncirc) :: store_circ_class_ba !! Store circ_class_ba in this variable before
498	!! writing to the output file (m). Adding this
499	!! variable was faster than changing the
500	!! dimensions of circ_class_ba_ba which would
501	!! have been the same
502	REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements):: check_intern !! Contains the components of the internal
503	!! mass balance chech for this routine
504	!! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
505	REAL(r_std), DIMENSION(npts,nvm,nelements) :: closure_intern !! Check closure of internal mass balance
506	!! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
507	REAL(r_std), DIMENSION(npts,nvm,nelements) :: pool_start, pool_end !! Start and end pool of this routine
508	!! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
509	REAL(r_std) :: median_circ !! Median circumference (m)
510	REAL(r_std) :: deficit !! Carbon that needs to be respired in
511	!! excess of todays gpp
512	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
513	REAL(r_std) :: excess !! Carbon that needs to be re-allocated
514	!! after the needs of the reserve and
515	!! labile pool are satisfied
516	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
517	REAL(r_std) :: shortage !! Shortage in the reserves that needs to
518	!! be re-allocated after to minimise the
519	!! tension between required and available
520	!! reserves
521	!! @tex $(gC.m^{-2}dt^{-1})$ @endtex
522
523	INTEGER :: i,tempi
524	! (temp variables for impose intraseasonal LAI dynamic)
525	INTEGER :: month_id !! index of month
526	REAL(r_std) :: ratio_move !! tmperal variable to move the allocatable carbon
527	!! from leaf to sapwood
528	REAL(r_std) :: impose_lai !! get value of impose maximun LAI
529	REAL(r_std) :: lai_fac !! LAI agjust coefficient
530	REAL(r_std), DIMENSION(13) :: lai_scale !! monthly lai scaling facter
531	REAL(r_std) :: daily_lai !! Daily LAI value interpolated by impose lai & lai_scale
532	CHARACTER(len=256) :: temp_text !! dummy text variable exchange
533	!_ ================================================================================================================================
534
535	IF (bavard.GE.3) WRITE(numout,*) 'Entering functional allocation growth'
536
537	!! 1. Initialize
538
539	!! 1.1 First call only
540	IF ( firstcall ) THEN
541
542	firstcall = .FALSE.
543
544	ENDIF ! first call
545
546
547	!! 1.2 Initialize variables at every call
548	qm_height(:,:) = zero
549	delta_ba = zero
550	lai_target(:,:) = zero
551	resp_maint(:,:) = zero
552	resp_growth(:,:) = zero
553	lstress_fac(:,:) = zero
554	sigma(:,:) = zero
555	gammas(:,:) = zero
556	bm_alloc_tot(:,:) = zero
557	k_latosa(:,:) = zero
558	bm_alloc(:,:,:,:) = zero
559	store_circ_class_ba(:,:,:) = zero
560	store_delta_ba(:,:,:) = zero
561
562	! If npp is not initialized, bare soil value is never set.
563	npp(:,:) = zero
564
565	! Not having this results in an unitilized error
566	! with valgrid, but I can't figure out why. It always
567	! seems to be set before being used.
568	residual(:,:) = val_exp
569
570	! bare soil never gets set here
571	lab_fac(:,1) = zero
572
573	!! 1.2.2 Initialize check for mass balance closure
574	! The mass balance is calculated at the end of this routine
575	! in section 8
576	pool_start = zero
577	DO ipar = 1,nparts
578	DO iele = 1,nelements
579	! Initial biomass pool
580	pool_start(:,:,iele) = pool_start(:,:,iele) + &
581	(biomass(:,:,ipar,iele) * veget_max(:,:))
582	ENDDO
583	ENDDO
584
585	!! 1.2.3 Initialize check for surface area conservation
586	! Veget_max is a INTENT(in) variable and can therefore
587	! not be changed during the course of this subroutine
588	! No need to check whether the subroutine preserves the
589	! total surface area of the pixel.
590
591	!! 1.2.4 Calculate LAI threshold below which carbohydrate reserve is used.
592	! Lai_max is a PFT-dependent parameter specified in stomate_constants.f90
593	! +++CHECK+++
594	! Can we make this a function of Cs or rue_longterm? this double prescribed value does not make
595	! to much sense to me. It is not really dynamic.
596	lai_happy(:) = lai_max(:) * lai_max_to_happy(:)
597	! +++++++++++
598
599
600	!! 2. Use carbohydrate reserve to support growth
601
602	! Save old leaf mass, biomass got last updated in stomate_phenology.f90
603	lm_old(:,:) = biomass(:,:,ileaf,icarbon)
604
605	! lai for bare soil is by definition zero
606	lai(:,ibare_sechiba) = zero
607
608	DO j = 2, nvm ! Loop over # PFTs
609
610	!! 2.1 Calculate demand for carbohydrate reserve to support leaf and root growth.
611	! Maximum time (days) since start of the growing season during which carbohydrate
612	! may be used
613	IF ( is_tree(j) ) THEN
614
615	reserve_time = reserve_time_tree
616
617	ELSE
618
619	reserve_time = reserve_time_grass
620
621	ENDIF
622
623	! Growth is only supported by the use of carbohydrate reserves if the following
624	! conditions are statisfied:\n
625	! - PFT is not senescent;\n
626	! - LAI must be low (i.e. below ::lai_happy) and\n
627	! - Day of year of the simulation is in the beginning of the growing season.
628
629	DO ipts = 1,npts
630
631	! Calculate lai
632	lai(ipts,j) = biomass_to_lai(biomass(ipts,j,ileaf,icarbon),j)
633
634	! We might need the c0_alloc factor, so let's calculate it.
635	c0_alloc(ipts,j) = calculate_c0_alloc(ipts, j, tau_eff_root(ipts,j), &
636	tau_eff_sap(ipts,j))
637
638	ENDDO
639
640	WHERE ( ( biomass(:,j,ileaf,icarbon) .GT. min_stomate ) .AND. &
641	( .NOT. senescence(:,j) ) .AND. &
642	( lai(:,j) .LT. lai_happy(j) ) .AND. &
643	( when_growthinit(:,j) .LT. reserve_time ) )
644
645	! Tell the labile and resource pool to use its reserve
646	use_reserve(:,j) = 1.0
647
648	ENDWHERE
649
650	ENDDO ! loop over # PFTs
651
652
653
654
655	!! 3. Initialize allocation
656
657	DO j = 2, nvm ! Loop over # PFTs
658
659	!! 3.1 Calculate scaling factors, temperature sensitivity, target lai to decide on
660	!! reserve use, labile fraction, labile biomass and total allocatable biomass
661
662	! Convert long term temperature from K to C
663	tl(:) = t2m(:) - ZeroCelsius
664
665	DO ipts = 1, npts
666
667	IF (veget_max(ipts,j) .LE. min_stomate) THEN
668
669	! this vegetation type is not present, so no reason to do the
670	! calculation. CYCLE will take us out of the innermost DO loop
671	CYCLE
672
673	ENDIF
674
675	!! 3.1 Water stress
676	! The waterstress factor varies between 0.1 and 1 and is calculated
677	! from ::moiavail_growingseason. The latter is only used in the allometric
678	! allocation and its time integral is determined by tau_sap for trees
679	! (see constantes_mtc.f90 for tau_sap and see pft_constantes.f90 for
680	! the definition of tau_hum_growingseason). The time integral for
681	! grasses and crops is a prescribed constant (see constantes.f90). For
682	! trees KF (and indirecrtly LF) and for grasses LF are multiplied
683	! by wstress. Because the calculated values are too low for its purpose
684	! Sonke Zhaele multiply it by two in the N-branch (see stomate_season.f90).
685	! This approach maintains the physiological basis of KF while combining it
686	! with a simple multiplicative factor for water stress. Clearly after
687	! multiplication with 2, wstress is closer to 1 and will thus result in a
688	! KF values closer to the physiologically expected KF. We did not see the
689	! need to multiply by 2 because the way we now calculate ::moiavail_growingseason
690	! is less volatile than before. Before it ranged between 0 and 1, now the
691	! range is more like 0.4 to 0.9.
692
693	! Veget is now calculated from Pgap to be fully consistent within the model. Hence
694	! dividing by veget_max gives a value between 0 and 1 that denotes the amount of
695	! light reaching the forest floor.
696	IF (veget_max(ipts,j) .GT. min_stomate) THEN
697
698	lstress_fac(ipts,j) = un - (veget(ipts,j) / veget_max(ipts,j))
699
700	ELSE
701
702	lstress_fac(ipts,j) = zero
703
704	ENDIF
705
706	!+++TEMP+++
707	!!$ IF( j == test_pft .AND. ipts == test_grid) &
708	!!$ WRITE(numout,'(A,I5,2F16.8)') 'lightstress, lstress_fac, j, ', &
709	!!$ j, lstress_fac(ipts,j), veget(ipts,j)
710	!++++++++++
711
712	!! 3.2 Initialize scaling factors
713	! Stand level scaling factors
714	LF(ipts,j) = 1._r_std
715
716	! Tree level scaling factors
717	ltor(ipts,j) = 1._r_std
718	circ_class_height_eff(:) = 1._r_std
719
720
721	!! 3.3 Calculate structural characteristics
722
723	! Target lai is calculated at the stand level for the tree height of a
724	! virtual tree with the mean basal area or the so called quadratic mean diameter
725	qm_dia(ipts,j) = wood_to_qmdia(circ_class_biomass(ipts,j,:,:,icarbon), &
726	circ_class_n(ipts,j,:), j)
727	qm_height(ipts,j) = wood_to_qmheight(circ_class_biomass(ipts,j,:,:,icarbon), &
728	circ_class_n(ipts,j,:), j)
729
730
731	!! 3.4 Calculate allocation factors for trees and grasses
732	IF ( SUM(biomass(ipts,j,:,icarbon)) .GT. min_stomate ) THEN
733
734	! Trees
735	IF (is_tree(j)) THEN
736
737	! Note that KF may already be calculated in stomate_prescribe.f90 (if called)
738	! it is recalculated because the biomass pools for grasses and crops
739	! may have been changed in stomate_phenology.f90. Trees were added to this
740	! calculation just to be consistent.
741
742	! To be fully consistent with the hydraulic limitations and pipe theory,
743	! k_latosa_zero should be calculated from equation (18) in Magnani et al.
744	! To do so, total hydraulic resistance and tree height need to known. This
745	! poses a problem as the resistance depends on the leaf area and the leaf
746	! area on the resistance. There is no independent equation and equations 12
747	! and 18 depend on each other and substitution would be circular. Hence
748	! prescribed k_latosa_zero values were obtained from observational records
749	! and are given in mtc_parameters.f90.
750
751	! The relationship between height and k_latosa as reported in McDowell
752	! et al 2002 and Novick et al 2009 is implemented to adjust k_latosa for
753	! the height of the stand. The slope of the relationship is calculated in
754	! stomate_data.f90 This did NOT result in a realistic model behavior.
755	!!$ k_latosa(ipts,j) = wstress_fac(ipts,j) * &
756	!!$ (k_latosa_max(j) - latosa_height(j) * qm_height(ipts,j))
757
758	! Alternatively, k_latosa is also reported to be a function of diameter
759	! (i.e. stand thinning, Simonin et al 2006, Tree Physiology, 26:493-503).
760	! Here the relationship with thinning was interpreted as a realtionship with
761	! light stress.
762	! +++CHECK+++
763	! How dow we want to account for waterstress?
764	!!$ k_latosa(ipts,j) = k_latosa_min(j) + (wstress_fac(ipts,j) * lstress_fac(ipts,j) * &
765	!!$ (k_latosa_max(j)-k_latosa_min(j)))
766	!!$ k_latosa(ipts,j) = wstress_fac(ipts,j) * (k_latosa_min(j) + (lstress_fac(ipts,j) * &
767	!!$ (k_latosa_max(j)-k_latosa_min(j))))
768	k_latosa(ipts,j) = (k_latosa_adapt(ipts,j) + (lstress_fac(ipts,j) * &
769	(k_latosa_max(j)-k_latosa_min(j))))
770	! +++++++++++
771
772	! Also k_latosa has been reported to be a function of CO2 concentration
773	! (Atwell et al. 2003, Tree Physiology, 23:13-21 and Pakati et al. 2000,
774	! Global Change Biology, 6:889-897). This effect is not accounted for in
775	! the current code
776
777	! Scaling factor to convert sapwood mass into leaf mass (KF)
778	! derived from
779	! LA_ind = k1 * SA_ind, k1=latosa (pipe-model)
780	! <=> Cl * vm/ind * sla = k1 * Cs * vm/ind / wooddens / tree_ff / height_new
781	! <=> Cl = Cs * k1 / wooddens / tree_ff/ height_new /sla
782	! <=> Cl = Cs * KF / height_new, where KF = k1 / (wooddens * sla * tree_ff)
783	! (1) Cl = Cs * KF / height_new
784	KF_old = KF(ipts,j)
785	KF(ipts,j) = k_latosa(ipts,j) / (sla(j) * pipe_density(j) * tree_ff(j))
786
787	! KF of the previous time step was stored in ::KF_old to check its absolute
788	! change. If this absolute change is too big the whole allocation will crash
789	! because it will calculate negative increments which are compensated by
790	! positive increments that exceed the available carbon for allocation. This
791	! would suggest that for examples the plant destructs leaves and uses the
792	! available carbon to produce more roots. This is would repesent an unwanted
793	! outcome. Large changes from time step to another makes its difficult for
794	! the scheme to ever reach allometric balance. This balance is needed for the
795	! allocation scheme to allow 'ordinary allocation', which in turn is needed
796	! to make use of the allocation rule of Dhote and Deleuze. It needs to be
797	! avoided that the code spends too much time in phenological growth and the
798	! if-then statements that help to restore allometric balance. For this reason
799	! the absolute change in KF from one time step to another are truncated.
800	IF (KF_old - KF(ipts,j) .GT. max_delta_KF ) THEN
801
802	IF(ld_warn)THEN
803	WRITE(numout,*) 'WARNING 2: KF was truncated'
804	WRITE(numout,*) 'WARNING 2: PFT, ipts: ',j,ipts
805	WRITE(numout,'(A,3F20.10)') 'WARNING 2: KF_old, KF(ipts,j), max_delta_KF: ',&
806	KF_old, KF(ipts,j), max_delta_KF
807	ENDIF
808
809	! Add maximum absolute change
810	KF(ipts,j) = KF_old - max_delta_KF
811
812	IF(ld_warn)THEN
813	WRITE(numout,'(A,3F20.10)') 'WARNING 2: Reset, KF_old, KF(ipts,j): ',&
814	KF_old, KF(ipts,j)
815	ENDIF
816	ELSEIF (KF_old - KF(ipts,j) .LT. -max_delta_KF) THEN
817
818	IF(ld_warn)THEN
819	WRITE(numout,*) 'WARNING 3: KF was truncated'
820	WRITE(numout,*) 'WARNING 3: PFT, ipts: ',j,ipts
821	WRITE(numout,'(A,3F20.10)') 'WARNING 3: KF_old, KF(ipts,j), max_delta_KF: ',&
822	KF_old, KF(ipts,j), -max_delta_KF
823	ENDIF
824
825	! Remove maximum absolute change
826	KF(ipts,j) = KF_old + max_delta_KF
827
828	IF(ld_warn)THEN
829	WRITE(numout,'(A,3F20.10)') 'WARNING 3: Reset, KF_old, KF(ipts,j): ',&
830	KF_old, KF(ipts,j)
831	ENDIF
832	ELSE
833	! The change in KF is acceptable no action required
834	ENDIF
835
836	! Scaling factor to convert sapwood mass into root mass (LF)
837	! derived from
838	! Cs = c0 * height * Cr (Magnani 2000)
839	! Cr = Cs / c0 / height_new
840	! scaling parameter between leaf and root mass, derived from
841	! Cr = Cs / c0 / height_new
842	! let Cs = Cl / KF * height_new
843	! <=> Cr = ( Cl * height_new / KF ) / ( c0 * height_new )
844	! <=> Cl = Cr * KF * c0
845	! <=> Cl = Cr * LF, where LF = KF * c0
846	! (2) Cl = Cr * LF
847	! +++CHECK+++
848	! How do we want to account for waterstress? wstress is accounted for in c0_alloc
849	LF(ipts,j) = c0_alloc(ipts,j) * KF(ipts,j)
850	!!$ LF(ipts,j) = c0_alloc(ipts,j) * KF(ipts,j) * wstress_fac(ipts,j)
851	! +++++++++++
852
853	! Calculate non-nitrogen stressed leaf to root ratio to calculate the
854	! allocation to the reserves. Should be multiplied by a nitrogen stress
855	! have a look in OCN. This code should be considered as a placeholder
856	ltor(ipts,j) = c0_alloc(ipts,j) * KF(ipts,j)
857
858	!---TEMP---
859	IF (j.EQ.test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
860	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
861	WRITE(numout,*) 'c0_alloc, ', c0_alloc(ipts,j)
862	WRITE(numout,*) 'tau_root, tau_sap, ', tau_eff_root(ipts,j), tau_eff_sap(ipts,j)
863	WRITE(numout,*) 'k_root, k_sap, ', k_root(j), k_sap(j)
864	WRITE(numout,*) 'ltor, ', ltor(ipts,j)
865
866	ENDIF
867	!----------
868
869	! Grasses and crops
870	ELSEIF (.NOT. is_tree(j)) THEN
871
872	!+++CHECK+++
873	! Similar to ::k_latosa for trees we defined it for grasses. Note that for trees
874	! the definition is supported by some observations. For grasses we didn't look very
875	! hard to check the literature. Someone interested in grasses should invest some
876	! time in this issue and replace this code by a parameter that can be derived
877	! from observations. In the end it was decided to use the same variable name for
878	! grasses, crops and trees as that allowed us to optimize this parameter.
879	k_latosa(ipts,j) = (k_latosa_adapt(ipts,j) + (lstress_fac(ipts,j) * &
880	(k_latosa_max(j)-k_latosa_min(j))))
881
882	! The mass of the structural carbon relates to the mass of the leaves through
883	! a prescribed parameter ::k_latosa
884	KF(ipts,j) = k_latosa(ipts,j)
885	!++++++++++
886
887	! Stressed root allocation, wstress is accounted for in c0_alloc
888	LF(ipts,j) = c0_alloc(ipts,j) * KF(ipts,j)
889
890	! Calculate non-nitrogen stressed leaf to root ratio to calculate the
891	! allocation to the reserves
892	ltor(ipts,j) = c0_alloc(ipts,j) * KF(ipts,j)
893
894	!---TEMP---
895	IF (j.EQ.test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
896	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
897	WRITE(numout,*) 'c0_alloc, ', c0_alloc(ipts,j)
898	WRITE(numout,*) 'tau_root, tau_sap, ', tau_eff_root(ipts,j), tau_eff_sap(ipts,j)
899	WRITE(numout,*) 'k_root, k_sap, ', k_root(j), k_sap(j)
900	WRITE(numout,*) 'ltor, ', ltor(ipts,j)
901
902	ENDIF
903	!----------
904
905	ENDIF
906
907	ENDIF
908
909	!+++CHECK+++
910	!! 3.5 Calculate optimal LAI
911	! The calculation of the optimal LAI was copied and adjusted from O-CN. In O-CN it
912	! was also used in the allocation but that seems to be inconsistent with the allometric
913	! rules that are implemented. Say that the actual LAI is below the optimal LAI then
914	! the O-CN approach will keep pumping carbon to grow the optimal LAI. If we would apply
915	! the same method it means that during this phase the rule of Deleuze and Dhote would
916	! not be used. For that reason we dropped the use of LAI_optimal and replaced it by
917	! an allometric-based Cl_target value. Initially, lai_target was still calculated as
918	! described below and used in the calculation of the reserves.
919	! Further testing showed that for some parameter sets lai_target was over 8 whereas the
920	! realized lai was close to 4. This leaves us with a frustrated plant that will invest a
921	! lot in its reserves but can never use them because it is constrained by the allometric
922	! rules. To grow an LAI of 8 it would need to have a crazy sapwoodmass.
923	! At a more fundamental level it is clear why the plant's LAI should not exceed lai_target
924	! because then it costs more to produce and maintain the leaf than that the new leaf can
925	! produce but there is no reason why the plant should try to reach lai_target. For these
926	! reasons it was decided to abandon this approach to lai_target and simply replace
927	! lai_target by Cl_target * sla
928
929	!! 3.5.1 Scaling factor
930	! Scaling factor to convert variables to the individual plant
931	! Different approach between the DGVM and statitic approach
932	IF (control%ok_dgvm) THEN
933
934	! The DGVM does currently NOT work with the new allocation, consider this as
935	! placeholder. The original code had two different transformations to
936	! calculate the scalars. Both could be used but the units will differ.
937	! When fixing the DGVM check which quantities need to be multiplied by scal
938	! scal = ind(ipts,j) * cn_ind(ipts,j) / veget_max(ipts,j)
939	scal = veget_max(ipts,j) / ind(ipts,j)
940
941	ELSE
942
943	! circ_class_biomass contain the data at the tree level
944	! no conversion required
945	scal = 1.
946
947	ENDIF
948
949	!! 3.5.2 Calculate lai_target based on the allometric rules
950	IF ( is_tree(j)) THEN
951
952	! Basal area at the tree level (m2 tree-1)
953	circ_class_ba_eff(:) = wood_to_ba_eff(circ_class_biomass(ipts,j,:,:,icarbon),j)
954
955	! Current biomass pools per tree (gC tree^-1)
956	! We will have different trees so this has to be calculated from the diameter relationships
957	Cs(:) = ( circ_class_biomass(ipts,j,:,isapabove,icarbon) + &
958	circ_class_biomass(ipts,j,:,isapbelow,icarbon) ) * scal
959	Cr(:) = circ_class_biomass(ipts,j,:,iroot,icarbon) * scal
960	Cl(:) = circ_class_biomass(ipts,j,:,ileaf,icarbon) * scal
961	Ch(:) = ( circ_class_biomass(ipts,j,:,iheartabove,icarbon) + &
962	circ_class_biomass(ipts,j,:,iheartbelow,icarbon) ) * scal
963
964	DO l = 1,ncirc
965
966	! Calculate tree height
967	circ_class_height_eff(l) = pipe_tune2(j)(4/picirc_class_ba_eff(l))**(pipe_tune3(j)/2)
968
969	! Do the biomass pools respect the pipe model?
970	! Do the current leaf, sapwood and root components respect the allometric
971	! constraints? Due to plant phenology it is possible that we have too much
972	! sapwood compared to the leaf and root mass (i.e. in early spring).
973	! Calculate the optimal root and leaf mass, given the current wood mass
974	! by using the basic allometric relationships. Calculate the optimal sapwood
975	! mass as a function of the current leaf and root mass.
976	Cl_target(l) = MAX( KF(ipts,j) * Cs(l) / circ_class_height_eff(l), &
977	Cr(l) * LF(ipts,j) , Cl(l))
978	Cs_target(l) = MAX( Cl(l) / KF(ipts,j) * circ_class_height_eff(l), &
979	Cr(l) * LF(ipts,j) / KF(ipts,j) * circ_class_height_eff(l) , Cs(l))
980
981	! Check dimensions of the trees
982	! If Cs = Cs_target then ba and height are correct, else calculate the correct dimensions
983	IF ( Cs_target(l) - Cs(l) .GT. min_stomate ) THEN
984
985	! If Cs = Cs_target then dia and height are correct. However, if Cl = Cl_target
986	! or Cr = Cr_target then dia and height need to be re-estimated. Cs_target should
987	! satify the relationship Cl/Cs = KF/height where height is a function of Cs_target
988	! <=> (KFCs_target)/(pipe_tune2(Cs_target+Ch)/pi
989	! /4)**(pipe_tune3/(2+pipe_tune3)) = Cl_target
990	! Search Cs needed to sustain the max of Cl or Cr.
991	! Search max of Cl and Cr first
992	Cl_target(l) = MAX(Cl(l), Cr(l)*LF(ipts,j))
993
994	!---TEMP---
995	IF (j.EQ.test_pft .AND. ld_alloc) THEN
996	WRITE(numout,*) 'Does the tree needs reshaping? Class: ',l
997	WRITE(numout,*) 'circ_class_height_eff, ', circ_class_height_eff(l)
998	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
999	WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(l)-Cl(l), Cl_target(l), Cl(l)
1000	WRITE(numout,*) 'Cs, ', Cs(l)
1001	WRITE(numout,*) 'Cr, ', Cr(l)
1002	WRITE(numout,*) 'Ch, ', Ch(l)
1003	ENDIF
1004	!----------
1005
1006	Cs_target(l) = newX(KF(ipts,j), Ch(l),&
1007	& pipe_tune2(j), pipe_tune3(j), Cl_target(l),&
1008	& tree_ff(j)pipe_density(j)pi/4*pipe_tune2(j), Cs(l),&
1009	& 2*Cs(l), 2, j, ipts)
1010
1011	! Recalculate height and ba from the correct
1012	! Cs_target
1013	circ_class_height_eff(l) = Cs_target(l)*KF(ipts,j)&
1014	&/Cl_target(l)
1015	circ_class_ba_eff(l) = pi/4*(circ_class_height_eff(l)&
1016	&/pipe_tune2(j))**(2/pipe_tune3(j))
1017	Cl_target(l) = KF(ipts,j) * Cs_target(l) /&
1018	& circ_class_height_eff(l)
1019	Cr_target(l) = Cl_target(l) / LF(ipts,j)
1020
1021	!---TEMP---
1022	IF (j.EQ.test_pft .AND. ld_alloc) THEN
1023	WRITE(numout,*) 'New Cl_target, ', Cl_target(l)
1024	WRITE(numout,*) 'New Cs_target, ', Cs_target(l)
1025	WRITE(numout,*) 'New Cr_target, ', Cr_target(l)
1026	ENDIF
1027	!----------
1028
1029	ENDIF
1030
1031	ENDDO
1032
1033	! Calculate lai_target
1034	lai_target(ipts,j) = SUM(Cl_target(:)circ_class_n(ipts,j,:)) sla(j)
1035
1036	! Grasses and croplands
1037	ELSEIF ( .NOT. is_tree(j)) THEN
1038
1039	! Current biomass pools per grass/crop (gC ind^-1)
1040	! Cs has too many dimensions for grass/crops. To have a consistent notation the same variables
1041	! are used as for trees but the dimension of Cs, Cl and Cr i.e. ::ncirc should be ignored
1042	Cs(1) = biomass(ipts,j,isapabove,icarbon) * scal
1043	Cr(1) = biomass(ipts,j,iroot,icarbon) * scal
1044	Cl(1) = biomass(ipts,j,ileaf,icarbon) * scal
1045	Ch(1) = zero
1046
1047	! Do the biomass pools respect the pipe model?
1048	! Do the current leaf, sapwood and root components respect the allometric
1049	! constraints? Calculate the optimal root and leaf mass, given the current wood mass
1050	! by using the basic allometric relationships. Calculate the optimal sapwood
1051	! mass as a function of the current leaf and root mass.
1052	Cl_target(1) = MAX( Cs(1) * KF(ipts,j) , Cr(1) * LF(ipts,j), Cl(1) )
1053	Cs_target(1) = MAX( Cl_target(1) / KF(ipts,j), Cr(1) * LF(ipts,j) / KF(ipts,j), Cs(1) )
1054	Cr_target(1) = MAX( Cl_target(1) / LF(ipts,j), Cs_target(1) * KF(ipts,j) / LF(ipts,j), Cr(1) )
1055
1056	! Calculate lai_target
1057	lai_target(ipts,j) = Cl_target(1) * circ_class_n(ipts,j,1) * sla(j)
1058
1059	!---TEMP---
1060	IF (j.EQ.test_pft .AND. ld_alloc) THEN
1061	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
1062	ENDIF
1063	!----------
1064
1065	ENDIF
1066
1067	!!$ !! 3.5 Calculate optimum LAI
1068	!!$ ! Lai is optimised for mean annual radiation use efficiency and the C costs
1069	!!$ ! for producing the canopy. The cost-benefit ratio is optimised when the
1070	!!$ ! marginal gain / marginal cost = 1
1071	!!$ ! Investing 1 gC in the canopy comes at a total cost that is composed by the
1072	!!$ ! C required for the canopy in addition to the roots and the sapwood to support
1073	!!$ ! the canopy. The total cost (C) is thus calculated as C:
1074	!!$ ! LAI/sla * ( (one_year/tau_leaf) + (one_year/tau_root)/LF + (one_year/tau_sap)*height/KF))
1075	!!$ ! The marginal cost for one unit of LAI is then dC/dLAI :
1076	!!$ ! (one_year/tau_leaf)/sla + (one_year/tau_root)/LF/sla + (one_year/tau_sap)*height/KF/sla)
1077	!!$ ! Where, tau_leaf is given by ::tau_leaf in days, tau_root by ::tau_root in
1078	!!$ ! days and tau_sap by ::tau_sap in days. LF is unitless, KF is expressed in meters
1079	!!$ ! and sla in m^2.gC^{-1}. The unit of dC/dLAI is thus gC.m^{-2} but all turnover
1080	!!$ ! times need to be expressed on an annual scale.
1081	!!$ ! Investing 1gC in the canopy enables the plant to assimilate more carbon
1082	!!$ ! The gain (G) can be approximated by using the 'radiation use efficiency' as
1083	!!$ ! follows: RUE * one_year ( 1. - exp (-0.5 * LAI ))
1084	!!$ ! Where, 0.5 is the extinction factor that accounts for the fact the lower parts
1085	!!$ ! of the canopy receive less light. Note that RUE has a peculiar definition and is
1086	!!$ ! calculated as the ratio of GPP over the fraction of radiation absorbed by the canopy.
1087	!!$ ! Hence the unit of RUE is gC.m^{-2}.day^{-1}. The marginal gain of one unit of LAI is dG/dLAI:
1088	!!$ ! 0.5 * one_year * RUE * exp (-0.5 * LAI).
1089	!!$ ! Subsequently, the optimal LAI is approximated by
1090	!!$ ! LAI_opt = -2. * log(2(dC/dt)/(RUEone_year))
1091	!!$ ! Added the qm_height requirement since for a grass, it had no biomass
1092	!!$ ! but it did have individuals. This caused qm_height to be zero and a crash
1093	!!$ ! in the calculation of lai_target.
1094	!!$ IF ( (rue_longterm(ipts,j) .GT. min_stomate) .AND. (ind(ipts,j) .NE. zero &
1095	!!$ .AND. qm_height(ipts,j) .NE. 0) ) THEN
1096	!!$
1097	!!$ ! Scheme in line with the documentation
1098	!!$ lai_target(ipts,j) = -deux* log( (deux * (one_year/tau_leaf(j))/sla(j) + &
1099	!!$ ((one_year/tau_root(j))/LF(ipts,j))/sla(j) + &
1100	!!$ ((one_year/tau_sap(j))*qm_height(ipts,j)/KF(ipts,j))/sla(j)) / &
1101	!!$ (rue_longterm(ipts,j)*one_year))
1102	!!$ lai_target(ipts,j) = MAX(MIN(lai_target(ipts,j),12.),.5)
1103	!!$
1104	!!$ ELSE
1105	!!$
1106	!!$ lai_target(ipts,j) = 0.5
1107	!!$
1108	!!$ ENDIF
1109	!++++++++++
1110
1111	!! 3.6 Calculate mean leaf age
1112	leaf_meanage = zero
1113	DO m = 1,nleafages
1114
1115	leaf_meanage = leaf_meanage + leaf_age(ipts,j,m) * leaf_frac(ipts,j,m)
1116
1117	ENDDO
1118
1119
1120	!! 3.7 Calculate labile fraction
1121	! Use constant labile fraction to initiate on-set of leaves in spring
1122	IF ( (biomass(ipts,j,ileaf,icarbon) .LE. min_stomate) .AND. &
1123	(use_reserve(ipts,j) .GT. min_stomate) ) THEN
1124
1125	lab_fac(ipts,j) = 0.7
1126
1127	! Calculate labile fraction when a canopy is present but its lai is below ::lai_target
1128	! the labile fraction is a function of ::leaf_meanage, the current lai calculated as
1129	! ::biomass(ipts,j,ileaf,icarbon)*sla(j), the ::lai_target and ::ecureuil. This functions
1130	! scales lab_fac to a value between 0.1 and 0.7. Its scientific basis remains unclear.
1131	ELSEIF ( (biomass(ipts,j,ileaf,icarbon) .GT. min_stomate) .AND. &
1132	(lai_target(ipts,j) .GT. min_stomate) .AND. (.NOT. senescence(ipts,j)) ) THEN
1133
1134	lab_fac(ipts,j) = 0.1 + 0.6 * MAX(0.0,1.-MAX(ecureuil(j)*leaf_meanage/45., &
1135	biomass(ipts,j,ileaf,icarbon)*sla(j)/lai_target(ipts,j)))
1136
1137	! If the canopy has reached lai_target or is senescent lab_fac = 0.1
1138	ELSE
1139
1140	lab_fac(ipts,j) = 0.1
1141
1142	ENDIF
1143
1144
1145	!! 3.8 Calculate allocatable carbon
1146	! Total allocatable biomass during this time step determined from GPP.
1147	! GPP was calculated as CO2 assimilation in enerbil.f90
1148	! Under some exceptional conditions :gpp could be negative when
1149	! the dark respiration exceeds the photosynthesis. When this happens
1150	! the dark respiration is paid for by the labile and carbres pools
1151	IF ( (biomass(ipts,j,ilabile,icarbon) + gpp_daily(ipts,j) * dt) .LT. zero ) THEN
1152
1153	deficit = (biomass(ipts,j,ilabile,icarbon) + gpp_daily(ipts,j) * dt)
1154
1155	! The deficit is less than the carbon reserve
1156	IF (-deficit .LE. biomass(ipts,j,icarbres,icarbon)) THEN
1157
1158	! Pay the deficit from the reserve pool
1159	biomass(ipts,j,icarbres,icarbon) = &
1160	biomass(ipts,j,icarbres,icarbon) + deficit
1161	biomass(ipts,j,ilabile,icarbon) = &
1162	biomass(ipts,j,ilabile,icarbon) - deficit
1163
1164	ELSE
1165
1166	! Not enough carbon to pay the deficit, the individual
1167	! is going to die at the end of this day
1168	biomass(ipts,j,ilabile,icarbon) = &
1169	biomass(ipts,j,ilabile,icarbon) + biomass(ipts,j,icarbres,icarbon)
1170	biomass(ipts,j,icarbres,icarbon) = zero
1171
1172	! Truncate the dark respiration to the available carbon. Now we
1173	! should use up all the reserves. If the plant has no leaves, it
1174	! will die quickly after this.
1175	gpp_daily(ipts,j) = - biomass(ipts,j,ilabile,icarbon)/dt
1176
1177	ENDIF
1178
1179	ENDIF
1180
1181	! Labile carbon pool after possible correction for dark respiration
1182	biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) + &
1183	gpp_daily(ipts,j) * dt
1184
1185	IF(ld_alloc .AND. ipts == test_grid .AND. j == test_pft)THEN
1186	WRITE(numout,*) 'Adding gpp to labile pool'
1187	WRITE(numout,*) 'biomass(ipts,j,ilabile,icarbon)',biomass(ipts,j,ilabile,icarbon)
1188	WRITE(numout,*) 'gpp_daily(ipts,j)',gpp_daily(ipts,j)
1189	ENDIF
1190
1191	!! 3.9 Calculate activity of labile carbon pool
1192	! Similar realtionship as that used for the temperature response of
1193	! maintenance respiration. The parameters in the equation were calibrated
1194	! to give a fraction of 0.1 of GPP at reference temperature tl (i.e. 10Â°C)
1195	! Note that the temperature response has a lower slope than for respiration
1196	! to avoid too large turnover rates at high temperature.
1197	IF (tl(ipts) .GT. -2.) THEN
1198
1199	gtemp = EXP(308.56/4.*(1.0/56.02-1.0/(tl(ipts)+46.02)))
1200
1201	ELSE
1202
1203	gtemp = zero
1204
1205	ENDIF
1206
1207	! If there is a plant, and we are either at the very start or in the growing season
1208	! not during senescences, calculate labile pool use for growth
1209	IF (ind(ipts,j) .GT. min_stomate .AND. &
1210	!!$ when_growthinit(ipts,j) .LT. (large_value - un) .AND. &
1211	.NOT.senescence(ipts,j)) THEN
1212
1213	! The labile pool is filled. Re-calculate turnover of the labile pool.
1214	! Only if the labile pool is very small turnover will exceed 0.75
1215	! and the pool will thus be almost entirely emptied
1216	IF (biomass(ipts,j,ilabile,icarbon) .GT. min_stomate) THEN
1217
1218	gtemp = MAX(MIN( gtemp * lab_fac(ipts,j), 0.75 ), zero)
1219
1220	! The labile pool is empty but the carbohydrate pool is filled. Move carbohydrates to the labile
1221	! pool and recalculate the turnover of the labile pool.
1222	ELSEIF (biomass(ipts,j,icarbres,icarbon) .GT. min_stomate) THEN
1223
1224	biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) + 0.05 * &
1225	biomass(ipts,j,icarbres,icarbon)
1226	biomass(ipts,j,icarbres,icarbon) = biomass(ipts,j,icarbres,icarbon) * 0.95
1227	gtemp = MAX(MIN(gtemp*lab_fac(ipts,j), 0.75), zero)
1228
1229	IF(ld_alloc .AND. ipts == test_grid .AND. j == test_pft)THEN
1230	WRITE(numout,*) 'Moving some carbon from carbres to labile pool 1'
1231	WRITE(numout,*) 'biomass(ipts,j,ilabile,icarbon)',biomass(ipts,j,ilabile,icarbon)
1232	WRITE(numout,*) 'biomass(ipts,j,icarbres,icarbon)',biomass(ipts,j,icarbres,icarbon)
1233	ENDIF
1234
1235	! There is no labile or carbohydrate pool to use carbon from. Labile pool is not used
1236	ELSE
1237
1238	gtemp = zero
1239
1240	ENDIF
1241
1242	ENDIF
1243
1244
1245	!! 3.10 Calculate allocatable part of the labile pool
1246	! If there is a plant, and we are
1247	! either at the very start or in the growing season not during
1248	! senescences and after senescence only if use_reserve > 0., calculate
1249	! labile pool use for growth.
1250	IF (ind(ipts,j) .GT. min_stomate .AND. &
1251	!!$ when_growthinit(ipts,j) .LT. (large_value - un) .AND. &
1252	.NOT.senescence(ipts,j)) THEN
1253
1254	! Use carbon from the labile pool to allocate. The allometric (or
1255	! functional) allocation scheme transfers gpp to the labile pool
1256	! (see above) and then uses the labile pool (gpp + labile(t-1)) to sustain
1257	! growth. The fraction of the labile pool that can be used is a
1258	! function of the temperature and phenology. bm_alloc_tot in
1259	! gC m-2 dt-1
1260	bm_alloc_tot(ipts,j) = gtemp * biomass(ipts,j,ilabile,icarbon)
1261
1262	! The conditions do not support growth
1263	ELSE
1264
1265	bm_alloc_tot(ipts,j) = zero
1266
1267	ENDIF
1268
1269	! Update the labile carbon pool
1270	biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) - &
1271	bm_alloc_tot(ipts,j)
1272
1273	IF(ld_alloc .AND. ipts == test_grid .AND. j == test_pft)THEN
1274	WRITE(numout,*) "First bm_alloc_tot ", bm_alloc_tot(ipts,j)
1275	WRITE(numout,*) "senescence(ipts,j) ", senescence(ipts,j)
1276	WRITE(numout,*) "gtemp ", gtemp
1277	WRITE(numout,*) "biomass(ipts,j,ilabile,icarbon) ", biomass(ipts,j,ilabile,icarbon)
1278	WRITE(numout,*) "biomass(ipts,j,icarbres,icarbon) ", biomass(ipts,j,icarbres,icarbon)
1279	WRITE(numout,*) "lab_fac(ipts,j) ", lab_fac(ipts,j)
1280	WRITE(numout,*) "tl(ipts) ", tl(ipts)
1281	ENDIF
1282
1283
1284	!! 3.11 Maintenance respiration
1285	! First, total maintenance respiration for the whole plant is calculated by
1286	! summing maintenance respiration of the different plant compartments.
1287	! This simply recalculates the maintenance respiration from stomate_resp.f90
1288	! Maintenance respiration of the different plant parts is calculated in
1289	! stomate_resp.f90 as a function of the plant's temperature, the long term
1290	! temperature and plant coefficients:
1291	! The unit of ::resp_maint is gC m-2 dt-1
1292	resp_maint(ipts,j) = resp_maint(ipts,j) + SUM(resp_maint_part(ipts,j,:))
1293
1294	! Following the calculation of hourly maintenance respiration, verify that
1295	! the PFT has not been killed after calcul of resp_maint_part in stomate.
1296	! Can this generaly calculated ::resp_maint be use under the given
1297	! conditions? Surpress the respiration for deciduous
1298	! PFTs as long as they haven't carried leaves at least once. When
1299	! starting from scratch there is no budburst in the first year because
1300	! the longterm phenological parameters are not initialized yet. If
1301	! not surpressed respiration consumes all the reserves before the PFT
1302	! can start growing. The code would establish a new PFT but it was
1303	! decided to surpress this respiration because it has no physiological
1304	! bases.
1305	IF (ind(ipts,j) .GT. min_stomate .AND. &
1306	rue_longterm(ipts,j) .NE. un) THEN
1307
1308	!+++CHECK+++
1309	! Can the calculated maintenance respiration be used ? Or
1310	! does it has to be adjusted for special cases. Maintenance
1311	! respiration should be positive. In case it is very low, use 20%
1312	! (::maint_from_labile) of the active labile carbon pool (gC m-2 dt-1)
1313	! resp_maint(ipts,j) = MAX(zero, MAX(maint_from_labile * gtemp *
1314	! biomass(ipts,j,ilabile,icarbon), resp_maint(ipts,j)))
1315
1316	! Calculate resp_maint for the labile pool as well, no need to have the
1317	! above threshold. Make sure resp_maint is not zero
1318	resp_maint(ipts,j) = MAX(zero, resp_maint(ipts,j))
1319	!+++++++++++
1320
1321	! Phenological growth makes use of the reserves. Some carbon needs to remain
1322	! to support the growth, hence, respiration will be limited. In this case
1323	! resp_maint ((gC m-2 dt-1) should not be more than 80% (::maint_from_gpp)
1324	! of the GPP (gC m-2 s-1)
1325	IF (lab_fac(ipts,j) .GT. 0.3) THEN
1326
1327	resp_maint(ipts,j) = MIN( MAX(zero, maint_from_gpp * gpp_daily(ipts,j) * dt), &
1328	resp_maint(ipts,j))
1329
1330	ENDIF
1331
1332	ELSE
1333
1334	! No plants, no respiration
1335	resp_maint(ipts,j) = zero
1336
1337	ENDIF
1338
1339	! The calculation of ::resp_maint is solely based on the demand i.e.
1340	! given the biomass and the condition of the plant, how much should be
1341	! respired. It is not sure that this demand can be satisfied i.e. the
1342	! calculated maintenance respiration may exceed the available carbon
1343	IF ( bm_alloc_tot(ipts,j) - resp_maint(ipts,j) .LT. zero ) THEN
1344
1345	deficit = bm_alloc_tot(ipts,j) - resp_maint(ipts,j)
1346
1347	! The deficit is less than the carbon reserve
1348	IF (-deficit .LE. biomass(ipts,j,icarbres,icarbon)) THEN
1349
1350	! Pay the deficit from the reserve pool
1351	biomass(ipts,j,icarbres,icarbon) = &
1352	biomass(ipts,j,icarbres,icarbon) + deficit
1353	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - deficit
1354
1355	ELSE
1356
1357	! Not enough carbon to pay the deficit, the individual
1358	! is going to die at the end of this day
1359	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) + &
1360	biomass(ipts,j,icarbres,icarbon)
1361	biomass(ipts,j,icarbres,icarbon) = zero
1362
1363	! Truncate the maintenance respiration to the available carbon
1364	resp_maint(ipts,j) = bm_alloc_tot(ipts,j)
1365
1366	ENDIF
1367
1368	ENDIF
1369
1370	! Final ::resp_maint is known
1371	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - resp_maint(ipts,j)
1372	IF(ld_alloc .AND. ipts == test_grid .AND. j == test_pft)THEN
1373	WRITE(numout,*) "resp_maint ", resp_maint(ipts,j)
1374	ENDIF
1375
1376	!! 3.12 Growth respiration
1377	! Calculate total growth respiration and update allocatable carbon
1378	! Growth respiration is a tax on productivity, not actual allocation
1379	! Total growth respiration has be calculated before the allocation
1380	! takes place because the allocation itself is not linear. After
1381	! the allocation has been calculated, growth respiration can be
1382	! calculated for each biomass component separatly. The unit of
1383	! resp_growth is gC m-2 dt-1. Surpress the respiration for deciduous
1384	! PFTs as long as they haven't carried leaves at least once. When
1385	! starting from scratch there is no budburst in the first year because
1386	! the longterm phenological parameters are not initialized yet. If
1387	! not surpressed respiration consumes all the reserves before the PFT
1388	! can start growing. The code would establish a new PFT but it was
1389	! decided to surpress this respiration because it has no physiological
1390	! bases.
1391	IF (ind(ipts,j) .GT. min_stomate .AND. &
1392	rue_longterm(ipts,j) .NE. un) THEN
1393
1394	resp_growth(ipts,j) = frac_growthresp(j) * MAX(zero, bm_alloc_tot(ipts,j))
1395	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - resp_growth(ipts,j)
1396
1397	ENDIF
1398
1399	IF(ld_alloc .AND. j == test_pft .AND. ipts == test_grid)THEN
1400	WRITE(numout,*) 'initial bm_alloc_tot, ', bm_alloc_tot(ipts,j) + resp_growth(ipts,j)
1401	WRITE(numout,*) 'growth_resp, ', resp_growth(ipts,j)
1402	WRITE(numout,*) 'bm_alloc_tot after growth resp ',bm_alloc_tot(ipts,j)
1403	WRITE(numout,*) 'gpp_daily: ',gpp_daily(ipts,j)
1404	ENDIF
1405
1406	! Occasionally, there is a very special situation which arises, where
1407	! bm_alloc_tot is greater than min_stomate before accounting for growth respiration,
1408	! but not afterwards. This causes a mass balance error because growth respiration is
1409	! non-zero but bm_alloc_tot is too small to trigger loops below, so nothing is
1410	! done with that carbon. In this situation, the amout of carbon to allocate
1411	! is so low that nothing really changes. We set the growth respiration
1412	! to zero in this special case to avoid mass imbalance, even though this
1413	! will not effect the trajectory of the plant. It seems to happen on
1414	! the same day as leaves start growing, before any GPP is calculated.
1415	IF(((bm_alloc_tot(ipts,j) + resp_growth(ipts,j)) .GT. min_stomate) .AND. &
1416	(bm_alloc_tot(ipts,j) .LT. min_stomate))THEN
1417
1418	bm_alloc_tot(ipts,j)=bm_alloc_tot(ipts,j) + resp_growth(ipts,j)
1419	resp_growth(ipts,j)=zero
1420
1421	ENDIF
1422
1423	!! 3.12 Distribute stand level ilabile and icarbres at the tree level
1424	! The labile and carbres pools are calculated at the stand level but
1425	! are then redistributed at the tree level. This has the advantage
1426	! that biomass and circ_class_biomass have the same dimensions for
1427	! nparts which comes in handy when phenology and mortality are
1428	! calculated.
1429	IF ( is_tree(j) ) THEN
1430
1431	! Reset to zero to enable a loop over nparts
1432	circ_class_biomass(ipts,j,:,ilabile,:) = zero
1433	circ_class_biomass(ipts,j,:,icarbres,:) = zero
1434
1435	! Distribute labile and reserve pools over the circumference classes
1436	DO m = 1,nelements
1437
1438	! Total biomass across parts and circumference classes
1439	temp_total_biomass = zero
1440
1441	DO l = 1,ncirc
1442
1443	DO k = 1,nparts
1444
1445	temp_total_biomass = temp_total_biomass + &
1446	circ_class_biomass(ipts,j,l,k,m) * circ_class_n(ipts,j,l)
1447
1448	ENDDO
1449
1450	ENDDO
1451
1452	! Total biomass across parts but for a specific circumference class
1453	DO l = 1,ncirc
1454
1455	temp_class_biomass = zero
1456
1457	DO k = 1,nparts
1458
1459	temp_class_biomass = temp_class_biomass + &
1460	circ_class_biomass(ipts,j,l,k,m) * circ_class_n(ipts,j,l)
1461
1462	ENDDO
1463
1464	IF (temp_total_biomass .NE. zero) THEN
1465
1466	! Share of this circumference class to the total biomass
1467	temp_share = temp_class_biomass / temp_total_biomass
1468
1469	! Allocation of ilabile at the tree level (gC tree-1)
1470	circ_class_biomass(ipts,j,l,ilabile,m) = temp_share * &
1471	biomass(ipts,j,ilabile,m) / circ_class_n(ipts,j,l)
1472
1473	! Allocation of icarbres at the tree level (gC tree-1)
1474	circ_class_biomass(ipts,j,l,icarbres,m) = temp_share * &
1475	biomass(ipts,j,icarbres,m) / circ_class_n(ipts,j,l)
1476
1477	ELSE
1478
1479	circ_class_biomass(ipts,j,l,ilabile,m) = zero
1480	circ_class_biomass(ipts,j,l,icarbres,m) = zero
1481
1482	ENDIF
1483
1484	ENDDO ! ncirc
1485
1486	ENDDO ! nelements
1487
1488	! Grasses and crops
1489	ELSE
1490
1491	DO m = 1,nelements
1492
1493	! synchronize biomass and circ_class_biomass
1494	IF (ind(ipts,j) .GT. zero) THEN
1495
1496	circ_class_biomass(ipts,j,1,:,m) = biomass(ipts,j,:,m) / ind(ipts,j)
1497
1498	ELSE
1499
1500	circ_class_biomass(ipts,j,1,:,m) = zero
1501
1502	ENDIF
1503
1504	ENDDO
1505
1506	ENDIF ! is_tree
1507
1508	ENDDO ! pnts
1509
1510
1511	!! 5. Allometric allocation
1512
1513	DO ipts = 1, npts
1514
1515	!! 5.1 Initialize allocated biomass pools
1516	f_alloc(ipts,j,:) = zero
1517	Cl_inc(:) = zero
1518	Cs_inc(:) = zero
1519	Cr_inc(:) = zero
1520	Cf_inc(:) = zero
1521	Cl_incp(:) = zero
1522	Cs_incp(:) = zero
1523	Cr_incp(:) = zero
1524	Cs_inc_est(:) = zero
1525	Cl_target(:) = zero
1526	Cr_target(:) = zero
1527	Cs_target(:) = zero
1528
1529	!! 5.2 Calculate allocated biomass pools for trees
1530
1531	!! 5.2.1 Stand to tree allocation rule of Deleuze & Dhote
1532	IF ( is_tree(j) .AND. bm_alloc_tot(ipts,j) .GT. min_stomate ) THEN
1533
1534	! Basal area at the tree level (m2 tree-1)
1535	circ_class_ba_eff(:) = wood_to_ba_eff(circ_class_biomass(ipts,j,:,:,icarbon),j)
1536	circ_class_circ_eff(:) = 2 * pi * SQRT(circ_class_ba_eff(:)/pi)
1537
1538	! According to equation (-) in Bellasen et al 2010.
1539	! ln(sigmas) = a_sig * ln(circ_med) + b_sig
1540	! sigmas = exp(a_sig*log(median(circ_med))+b_sig);
1541	! However, in the code (sapiens_forestry.f90) a different expression was used
1542	! sigmas = 0.023+0.58*prctile(circ_med,0.05);
1543	! Any of these implementations could work but seem to be more suited for
1544	! continues or nearly continuous diameter distributions, say n_circ > 10
1545	! For a small number of diameter classes sigma depends on a prescribed
1546	! circumference percentile.
1547	IF (ncirc .GE. 6) THEN
1548
1549	! Calculate the median circumference
1550	DO l = 1,ncirc
1551
1552	IF (SUM(circ_class_n(ipts,j,1:l)) .GE. 0.5 * ind(ipts,j)) THEN
1553
1554	median_circ = circ_class_circ_eff(l) - 5 * min_stomate
1555
1556	EXIT
1557
1558	ENDIF
1559
1560	ENDDO
1561
1562	sigma(ipts,j) = deleuze_a(j) + deleuze_b(j) * median_circ
1563
1564	ELSE
1565
1566	! The X percentile of the trees that will receive the photosynthates
1567	! depends on the FM type. In a coppice stand there is a lot of
1568	! competition between the shoots and only the top half of the shoots
1569	! will receive GPP, the other half receives only little GPP. This was
1570	! implemnted to get a reasonable diameter growth of coppice stands.
1571	! If deleuze_p is independent from FM, FM strategies with high densities
1572	! have very slow diameter growth because the GPP has to be distributed
1573	! over a large number of individuals.
1574	IF (forest_managed(ipts,j) == 3) THEN
1575
1576	deleuze_p(j) = deleuze_p_coppice(j)
1577
1578	ELSEIF (forest_managed(ipts,j) == 1 .OR. &
1579	forest_managed(ipts,j) == 2 .OR. forest_managed(ipts,j) == 4) THEN
1580
1581	deleuze_p(j) = deleuze_p_all(j)
1582
1583	ELSE
1584
1585	WRITE(numout, *) 'forest management, ', forest_managed(ipts,j)
1586	CALL ipslerr_p (3,'growth_fun_all', &
1587	'Forest management strategy does not exist','','')
1588
1589	ENDIF
1590	! Search for the X percentile, where X is given by ::deleuze_p
1591	! Substract a very small number (5*min_stomate) just to be sure that
1592	! the circ_class will be corectly accounted for in GE or LE statements
1593	DO l = 1,ncirc
1594
1595	IF (SUM(circ_class_n(ipts,j,1:l)) .GE. deleuze_p(j) * ind(ipts,j)) THEN
1596
1597	sigma(ipts,j) = circ_class_circ_eff(l) - 5 * min_stomate
1598
1599	EXIT
1600
1601	ENDIF
1602
1603	ENDDO
1604
1605	ENDIF
1606
1607
1608	!! 5.2 Calculate allocated biomass pools for trees
1609	! Only possible if there is biomass to allocate
1610	! Use sigma and m_dv to calculate a single coefficient that can be
1611	! used in the subsequent allocation scheme.
1612	circ_class_dba(:) = (circ_class_circ_eff(:) - m_dv(j)*sigma(ipts,j) + &
1613	SQRT((m_dv(j)sigma(ipts,j) + circ_class_circ_eff(:))*2 - &
1614	(4sigma(ipts,j)circ_class_circ_eff(:)))) / 2
1615
1616	!! 5.2.2 Scaling factor to convert variables to the individual plant
1617	! Allocation is on an individual basis. Stand-level variables need to convert to a
1618	! single individual. Different approach between the DGVM and statitic approach
1619	IF (control%ok_dgvm) THEN
1620
1621	! The DGVM does currently NOT work with the new allocation, consider this as
1622	! placeholder. The original code had two different transformations to
1623	! calculate the scalars. Both could be used but the units will differ.
1624	! When fixing the DGVM check which quantities need to be multiplied by scal
1625	! scal = ind(ipts,j) * cn_ind(ipts,j) / veget_max(ipts,j)
1626	scal = veget_max(ipts,j) / ind(ipts,j)
1627
1628	ELSE
1629
1630	! circ_class_biomass contain the data at the tree level
1631	! no conversion required
1632	scal = 1.
1633
1634	ENDIF
1635
1636
1637	!! 5.2.3 Current biomass pools per tree (gC tree^-1)
1638	! We will have different trees so this has to be calculated from the
1639	! diameter relationships
1640	Cs(:) = ( circ_class_biomass(ipts,j,:,isapabove,icarbon) + &
1641	circ_class_biomass(ipts,j,:,isapbelow,icarbon) ) * scal
1642	Cr(:) = circ_class_biomass(ipts,j,:,iroot,icarbon) * scal
1643	Cl(:) = circ_class_biomass(ipts,j,:,ileaf,icarbon) * scal
1644	Ch(:) = ( circ_class_biomass(ipts,j,:,iheartabove,icarbon) + &
1645	circ_class_biomass(ipts,j,:,iheartbelow,icarbon) ) * scal
1646
1647	! Total amount of carbon that needs to ba allocated (::bm_alloc_tot).
1648	! bm_alloc_tot is in gC m-2 day-1. At 1 m2 there are ::ind number of
1649	! trees. We calculate the allocation for ::ncirc trees. Hence b_inc_tot
1650	! needs to be scaled in the allocation routines. For all cases were
1651	! allocation takes place for a single circumference class, scaling
1652	! could be done before the allocation. In the ordinary allocation
1653	! allocation takes place to all circumference classes at the same time.
1654	! Hence scaling takes place in that step for consistency we scale during
1655	! allocation. Note that b_inc (the carbon allocated to an individual
1656	! circumference class cannot be estimates at this point.
1657	b_inc_tot = bm_alloc_tot(ipts,j)
1658
1659
1660	!! 5.2.4 C-allocation for trees
1661	! The mass conservation equations are detailed in the header of this subroutine.
1662	! The scheme assumes a functional relationships between leaves, sapwood and
1663	! roots. When carbon is added to the leaf biomass pool, an increase in the root
1664	! biomass is to be expected to sustain water transport from the roots to the
1665	! leaves. Also sapwood is needed to sustain this water transport and to support
1666	! the leaves.
1667	DO l = 1,ncirc
1668
1669	!! 5.2.4.1 Calculate tree height
1670	circ_class_height_eff(l) = pipe_tune2(j)* &
1671	(4/picirc_class_ba_eff(l))*(pipe_tune3(j)/2)
1672
1673
1674	!! 5.2.4.2 Do the biomass pools respect the pipe model?
1675	! Do the current leaf, sapwood and root components respect the allometric
1676	! constraints? Due to plant phenology it is possible that we have too much
1677	! sapwood compared to the leaf and root mass (i.e. in early spring).
1678	! Calculate the optimal root and leaf mass, given the current wood mass
1679	! by using the basic allometric relationships. Calculate the optimal sapwood
1680	! mass as a function of the current leaf and root mass.
1681	Cl_target(l) = MAX( KF(ipts,j) * Cs(l) / circ_class_height_eff(l), &
1682	Cr(l) * LF(ipts,j) , Cl(l))
1683	Cr_target(l) = MAX( Cl_target(l) / LF(ipts,j), &
1684	Cs(l) * KF(ipts,j) / LF(ipts,j) / circ_class_height_eff(l) , Cr(l))
1685	Cs_target(l) = MAX( Cl(l) / KF(ipts,j) * circ_class_height_eff(l), &
1686	Cr(l) * LF(ipts,j) / KF(ipts,j) * circ_class_height_eff(l) , Cs(l))
1687
1688	!---TEMP---
1689	IF (j.EQ.test_pft .AND. ld_alloc) THEN
1690	WRITE(numout,*) 'bm_alloc_tot, ', bm_alloc_tot(ipts,j)
1691	WRITE(numout,*) 'Does the tree needs reshaping? Class: ',l
1692	WRITE(numout,*) 'circ_class_height_eff, ', circ_class_height_eff(l)
1693	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
1694	WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(l)-Cl(l), Cl_target(l), Cl(l)
1695	WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(l)-Cs(l), Cs_target(l), Cs(l)
1696	WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(l)-Cr(l), Cr_target(l), Cr(l)
1697	ENDIF
1698	!----------
1699
1700	!! 5.2.4.2 Check dimensions of the trees
1701	! If Cs = Cs_target then ba and height are correct, else calculate
1702	! the correct dimensions
1703	IF ( Cs_target(l) - Cs(l) .GT. min_stomate ) THEN
1704
1705	! If Cs = Cs_target then dia and height are correct. However,
1706	! if Cl = Cl_target or Cr = Cr_target then dia and height need
1707	! to be re-estimated. Cs_target should satify the relationship
1708	! Cl/Cs = KF/height where height is a function of Cs_target
1709	! <=> (KFCs_target)/(pipe_tune2(Cs_target+Ch)/pi/4)**&
1710	! (pipe_tune3/(2+pipe_tune3)) = Cl_target. Search Cs needed to
1711	! sustain the max of Cl or Cr. Search max of Cl and Cr first
1712	Cl_target(l) = MAX(Cl(l), Cr(l)*LF(ipts,j))
1713	Cs_target(l) = newX(KF(ipts,j), Ch(l), pipe_tune2(j), &
1714	pipe_tune3(j), Cl_target(l), &
1715	tree_ff(j)pipe_density(j)pi/4*pipe_tune2(j), &
1716	Cs(l), 2*Cs(l), 2, j, ipts)
1717
1718	! Recalculate height and ba from the correct Cs_target
1719	circ_class_height_eff(l) = Cs_target(l)*KF(ipts,j)/Cl_target(l)
1720	circ_class_ba_eff(l) = pi/4*(circ_class_height_eff(l)/ &
1721	pipe_tune2(j))**(2/pipe_tune3(j))
1722	Cl_target(l) = KF(ipts,j) * Cs_target(l) / circ_class_height_eff(l)
1723	Cr_target(l) = Cl_target(l) / LF(ipts,j)
1724
1725	ENDIF
1726
1727	!---TEMP---
1728	IF (j.EQ.test_pft .AND. ld_alloc) THEN
1729	WRITE(numout,*) 'height_fin, ba_fin, ', circ_class_height_eff(:), &
1730	circ_class_ba_eff(:)
1731	WRITE(numout,*) 'Cl_target, Cs_target, Cr_target, ', Cl_target(:), &
1732	Cs_target(:), Cr_target(:)
1733	WRITE(numout,*) 'New target values'
1734	WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(l)-Cl(l), Cl_target(l), Cl(l)
1735	WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(l)-Cs(l), Cs_target(l), Cs(l)
1736	WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(l)-Cr(l), Cr_target(l), Cr(l)
1737	ENDIF
1738	!-----------
1739
1740	ENDDO
1741
1742	! The step estimate is used to linearalize the diameter vs height relationship.
1743	! Use a prior to distribute b_inc_tot over the individual trees. The share of
1744	! the total sapwood mass is used as a prior. Subsequently, estimate the change in
1745	! diameter by assuming all the available C for allocation will be used in Cs.
1746	! Hence, this represents the maximum possible diameter increase. It was not tested
1747	! whether this is the best prior but it seems to work OK although it often results
1748	! in very small (1e-8) negative values, with even more rare 1e-6 negative values.
1749	! A C-balance closure check could reveal
1750	! whether this is a real issue and requires to change the prior or not.
1751	! Calculate the linear slope (::s) of the relationship between ba and h as
1752	! (1) s = (ba2-ba)/(height2-height).
1753	! The goal is to approximate the ba2 that
1754	! is predicted through the non-linear ordinary allocation approach, as this will
1755	! keep the trees in allometric balance. In the next time step, allometric
1756	! balance is recalculated and can be corrected through the so-called phenological
1757	! growth; hence, small deviations resulting from the linearization will not
1758	! accumulate with time.
1759	! Note that ba2 = ba + delta_ba and that height and ba are related as
1760	! (2) height = k2(4ba/pi)**(k3/2)
1761	! At this stage the only information we have is that there is b_inc_tot (gC m-2)
1762	! available for allocation. There are two obvious approximations both making use
1763	! of the same assumption, i.e. that for the initial estimate of delta_ba height is
1764	! constant. The first approximation is crude and assumes that all the available C
1765	! is used in Cs_inc (thus Cs_inc = b_inc_tot / ind ). The second approximation,
1766	! implemented here, makes use of the allometric rules and thus accounts for the
1767	! knowledge that allocating one unit the sapwood comes with a cost in leaves and
1768	! roots thus:
1769	! b_inc_temp = Cs_inc+Cl_inc+Cr_inc
1770	! (3) <=> b_inc_temp ~= (Cs_inc_est+Cs) + KF*(Cs_inc_est+Cs)/H + ...
1771	! KF/LF*(Cs_inc_est+Cs)/H - Cs - Cl - Cr
1772	! b_inc_temp is the amount of carbon that can be allocated to each diameter class.
1773	! However, only the total amount i.e. b_inc_tot is known. Total allocatable carbon
1774	! is distributed over the different diameter classes proportional to their share
1775	! of the total wood biomass. Divide by circ_class_n to get the correct units
1776	! (gC tree-1)
1777	! (4) b_inc_temp ~= b_inc_tot / circ_class_n * (circ_class_n * ba**(1+k3)) / ...
1778	! sum(circ_class_n * ba**(1+k3))
1779	! By substituting (4) in (3) an expression is obtained to approximate the carbon
1780	! that will be allocated to sapwood growth per diameter class ::Cs_inc_est. This
1781	! estimate is then used to calculate delta_ba (called ::step) as
1782	! step = (Cs+Ch+Cs_inc_set)/(tree_ffpipe_densityheight) - ba where height is
1783	! calculated from (2) after replacing ba by ba+delta_ba
1784
1785	!+++CHECK+++
1786	!Alternative decribed in the documentation - most complete
1787	Cs_inc_est(:) = ( b_inc_tot / circ_class_n(ipts,j,:) * &
1788	(circ_class_n(ipts,j,:) * circ_class_ba_eff(:)**(un+pipe_tune3(j))) / &
1789	(SUM(circ_class_n(ipts,j,:) * circ_class_ba_eff(:)**(un+pipe_tune3(j)))) + &
1790	Cs(:) + Cl(:) + Cr(:)) * circ_class_height_eff(:) / &
1791	(circ_class_height_eff(:) + KF(ipts,j) + KF(ipts,j)/LF(ipts,j)) - Cs(:)
1792	!Keep it simple
1793	!Cs_inc_est(:) = ( b_inc_tot / circ_class_n(ipts,j,:) * &
1794	! (circ_class_n(ipts,j,:) * circ_class_ba_eff(:)**(un+pipe_tune3(j))) / &
1795	! (SUM(circ_class_n(ipts,j,:) * circ_class_ba_eff(:)**(un+pipe_tune3(j)))))
1796	!+++++++++++
1797
1798	step(:) = ((Ch(:)+Cs(:)+Cs_inc_est(:)) / (tree_ff(j)pipe_density(j) &
1799	circ_class_height_eff(:))) - circ_class_ba_eff(:)
1800
1801	!++++ CHECK ++++++
1802	! It can happen that step is equal to zero sometimes. I'm not sure why, but
1803	! there was a case where it was nonzero for circ classes 1 and 3, and zero
1804	! for 2. This causes s to be zero and provokes a divide by zero error later
1805	! on. What if we make it not zero? This might cause a small mass balance
1806	! error for this timestep, but I would rather have that than getting an
1807	! infinite biomass, which is what happened in the other case. These limits
1808	! are arbitrary and adjusted by hand. If the output file doesn't show this
1809	! warning very often, I think we're okay, since the amount of carbon is really
1810	! small.
1811	DO l=1,ncirc
1812	IF(step(l) .LT. min_stomate*0.01 .AND. step(l) .GT. zero)THEN
1813	step(l)=min_stomate*0.02
1814	IF (ld_alloc) THEN
1815	WRITE(numout,*) 'WARNING: Might cause mass balance problems in fun_all, position 1'
1816	WRITE(numout,*) 'WARNING: ips,j ',ipts,j
1817	END IF
1818	ELSEIF(step(l) .GT. -min_stomate*0.01 .AND. step(l) .LT. zero)THEN
1819	step(l)=-min_stomate*0.02
1820	IF (ld_alloc) THEN
1821	WRITE(numout,*) 'WARNING: Might cause mass balance problems in fun_all, position 2'
1822	WRITE(numout,*) 'WARNING: ips,j ',ipts,j
1823	END IF
1824	ENDIF
1825	ENDDO
1826	!+++++++++++++++++
1827	s(:) = step(:)/(pipe_tune2(j)(4.0_r_std/pi(circ_class_ba_eff(:)+step(:)))**&
1828	(pipe_tune3(j)/deux) - &
1829	pipe_tune2(j)(4.0_r_std/picirc_class_ba_eff(:))**(pipe_tune3(j)/deux))
1830
1831	!! 5.2.4.3 Phenological growth
1832	! Phenological growth and reshaping of the tree in line with the pipe model.
1833	! Turnover removes C from the different plant components but at a
1834	! component-specific rate, as such the allometric constraints are distorted
1835	! at every time step and should be restored before ordinary growth can
1836	! take place
1837	l = ncirc
1838	DO WHILE ( (l .GT. zero) .AND. (b_inc_tot .GT. min_stomate) )
1839
1840	!! 5.2.4.3.1 The available wood can sustain the available leaves and roots
1841	! Calculate whether the wood is in allometric balance. The target values
1842	! should always be larger than the current pools so the use of ABS is
1843	! redundant but was used to be on the safe side (here and in the rest
1844	! of the module) as it could help to find logical flaws.
1845	IF ( ABS(Cs_target(l) - Cs(l)) .LT. min_stomate ) THEN
1846
1847	! Use the difference between the target and the actual to
1848	! ensure mass balance closure because l times a values
1849	! smaller than min_stomate can still add up to a value
1850	! exceeding min_stomate.
1851	Cs_incp(l) = MAX(zero, Cs_target(l) - Cs(l))
1852
1853	! Enough leaves and wood, only grow roots
1854	IF ( ABS(Cl_target(l) - Cl(l)) .LT. min_stomate ) THEN
1855
1856	! Allocate at the tree level to restore allometric balance
1857	! Some carbon may have been used for Cs_incp and Cl_incp
1858	! adjust the total allocatable carbon
1859	Cl_incp(l) = MAX(zero, Cl_target(l) - Cl(l))
1860	Cr_incp(l) = MAX( MIN(b_inc_tot / circ_class_n(ipts,j,l) - &
1861	Cs_incp(l) - Cl_incp(l), Cr_target(l) - Cr(l)), zero )
1862
1863	! Write debug comments to output file
1864	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
1865	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
1866	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
1867	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
1868	circ_class_n, ind, 1)
1869	ENDIF
1870
1871	! Sufficient wood and roots, allocate C to leaves
1872	ELSEIF ( ABS(Cr_target(l) - Cr(l)) .LT. min_stomate ) THEN
1873
1874	! Allocate at the tree level to restore allometric balance
1875	! Some carbon may have been used for Cs_incp and Cr_incp
1876	! adjust the total allocatable carbon
1877	Cr_incp(l) = MAX(zero, Cr_target(l) - Cr(l))
1878	Cl_incp(l) = MAX( MIN(b_inc_tot / circ_class_n(ipts,j,l) - &
1879	Cs_incp(l) - Cr_incp(l), Cl_target(l) - Cl(l)), zero )
1880
1881	! Write debug comments to output file
1882	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
1883	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
1884	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
1885	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
1886	grow_wood, circ_class_n, ind, 2)
1887	ENDIF
1888
1889	! Both leaves and roots are needed to restore the allometric relationships
1890	ELSEIF ( ABS(Cl_target(l) - Cl(l)) .GT. min_stomate .AND. &
1891	ABS(Cr_target(l) - Cr(l)) .GT. min_stomate ) THEN
1892
1893	! Allocate at the tree level to restore allometric balance
1894	! The equations can be rearanged and written as
1895	! (i) b_inc = Cl_inc + Cr_inc
1896	! (ii) Cr_inc = (Cl_inc+Cl)/LF - Cr
1897	! Substitue (ii) in (i) and solve for Cl_inc
1898	! <=> Cl_inc = (LF*(b_inc+Cr)-Cl)/(1+LF)
1899	Cl_incp(l) = MIN( ((LF(ipts,j) * ((b_inc_tot/circ_class_n(ipts,j,l) - &
1900	Cs_incp(l)) + Cr(l))) - Cl(l)) / &
1901	(1 + LF(ipts,j)), Cl_target(l) - Cl(l) )
1902	Cr_incp(l) = MIN ( ((Cl_incp(l) + Cl(l)) / LF(ipts,j)) - Cr(l), &
1903	Cr_target(l) - Cr(l))
1904
1905	! The imbalance between Cr and Cl can be so big that (Cl+Cl_inc)/LF
1906	! is still less then the available root carbon (observed!). This would
1907	! result in a negative Cr_incp
1908	IF ( Cr_incp(l) .LT. zero ) THEN
1909
1910	Cl_incp(l) = MIN( b_inc_tot/circ_class_n(ipts,j,l) - Cs_incp(l), &
1911	Cl_target(l) - Cl(l) )
1912	Cr_incp(l) = (b_inc_tot/circ_class_n(ipts,j,l)) - Cs_incp(l) - &
1913	Cl_incp(l)
1914
1915	ELSEIF (Cl_incp(l) .LT. zero) THEN
1916
1917	Cr_incp(l) = MIN( b_inc_tot/circ_class_n(ipts,j,l) - Cs_incp(l), &
1918	Cr_target(l) - Cr(l) )
1919	Cl_incp(l) = (b_inc_tot/circ_class_n(ipts,j,l)) - &
1920	Cs_incp(l) - Cr_incp(l)
1921
1922	ENDIF
1923
1924	! Write debug comments to output file
1925	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
1926	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
1927	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
1928	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
1929	grow_wood, circ_class_n, ind, 3)
1930	ENDIF
1931
1932	ELSE
1933
1934	WRITE(numout,*) 'Exc 1-3: unexpected exception'
1935	IF(ld_stop)THEN
1936	CALL ipslerr_p (3,'growth_fun_all',&
1937	'Exc 1-3: unexpected exception','','')
1938	ENDIF
1939
1940	ENDIF
1941
1942	!! 5.2.4.3.2 Enough leaves to sustain the wood and roots
1943	ELSEIF ( ABS(Cl_target(l) - Cl(l)) .LT. min_stomate ) THEN
1944
1945	! Use the difference between the target and the actual to
1946	! ensure mass balance closure because l times a values
1947	! smaller than min_stomate can still add up to a value
1948	! exceeding min_stomate.
1949	Cl_incp(l) = MAX(zero, Cl_target(l) - Cl(l))
1950
1951	! Enough leaves and wood, only grow roots
1952	! This duplicates Exc 1 and these lines should never be called
1953	IF ( ABS(Cs_target(l) - Cs(l)) .LT. min_stomate ) THEN
1954
1955	! Allocate at the tree level to restore allometric balance
1956	! Some carbon may have been used for Cs_incp and Cl_incp
1957	! adjust the total allocatable carbon
1958	Cs_incp(l) = MAX(zero, ABS(Cs_target(l) - Cs(l)))
1959	Cr_incp(l) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,l) - &
1960	Cl_incp(l) - Cs_incp(l), Cr_target(l) - Cr(l)), zero )
1961
1962	! Write debug comments to output file
1963	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
1964	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
1965	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
1966	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
1967	circ_class_n, ind, 4)
1968	ENDIF
1969
1970	! Enough leaves and roots. Need to grow sapwood to support the available
1971	! canopy and roots
1972	ELSEIF ( ABS(Cr_target(l) - Cr(l)) .LT. min_stomate ) THEN
1973
1974	! In truth, there might be a little root carbon to allocate here,
1975	! since min_stomate is not equal to zero. If there is
1976	! enough of this small carbon in every circ class, and there
1977	! are enough circ classes, ordinary allocation will be skipped
1978	! below and we might try to force allocation, which is silly
1979	! if the different in the root masses is around 1e-8. This
1980	! means we will allocate a tiny amount to the roots to make
1981	! sure they are exactly in balance.
1982	Cr_incp(l) = MAX(zero, ABS(Cr_target(l) - Cr(l)))
1983	Cs_incp(l) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,l) - &
1984	Cl_incp(l) - Cr_incp(l), Cs_target(l) - Cs(l)), zero )
1985
1986	! Write debug comments to output file
1987	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
1988	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
1989	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
1990	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
1991	grow_wood, circ_class_n, ind, 5)
1992	ENDIF
1993
1994	! Need both wood and roots to restore the allometric relationships
1995	ELSEIF ( ABS(Cs_target(l) - Cs(l) ) .GT. min_stomate .AND. &
1996	ABS(Cr_target(l) - Cr(l)) .GT. min_stomate ) THEN
1997
1998	! circ_class_ba_eff and circ_class_height_eff are already calculated
1999	! for a tree in balance. It would be rather complicated to follow
2000	! the allometric rules for wood allocation (implying changes in height
2001	! and basal area) because the tree is not in balance yet. First try
2002	! if we can simply satisfy the allocation needs
2003	IF (Cs_target(l) - Cs(l) + Cr_target(l) - Cr(l) .LE. &
2004	b_inc_tot/circ_class_n(ipts,j,l) - Cl_incp(l)) THEN
2005
2006	Cr_incp(l) = Cr_target(l) - Cr(l)
2007	Cs_incp(l) = Cs_target(l) - Cs(l)
2008
2009	! Try to satisfy the need for roots
2010	ELSEIF (Cr_target(l) - Cr(l) .LE. b_inc_tot/circ_class_n(ipts,j,l) - &
2011	Cl_incp(l)) THEN
2012
2013	Cr_incp(l) = Cr_target(l) - Cr(l)
2014	Cs_incp(l) = b_inc_tot/circ_class_n(ipts,j,l) - &
2015	Cl_incp(l) - Cr_incp(l)
2016
2017	! There is not enough use whatever is available
2018	ELSE
2019
2020	Cr_incp(l) = b_inc_tot/circ_class_n(ipts,j,l) - Cl_incp(l)
2021	Cs_incp(l) = zero
2022
2023	ENDIF
2024
2025	! Write debug comments to output file
2026	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
2027	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2028	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2029	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
2030	circ_class_n, ind, 6)
2031	ENDIF
2032
2033	ELSE
2034
2035	WRITE(numout,*) 'Exc 4-6: unexpected exception'
2036	IF(ld_stop)THEN
2037	CALL ipslerr_p (3,'growth_fun_all',&
2038	'Exc 4-6: unexpected exception','','')
2039	ENDIF
2040
2041	ENDIF
2042
2043
2044	!! 5.2.4.3.3 Enough roots to sustain the wood and leaves
2045	ELSEIF ( ABS(Cr_target(l) - Cr(l)) .LT. min_stomate ) THEN
2046
2047	! Use the difference between the target and the actual to
2048	! ensure mass balance closure because l times a values
2049	! smaller than min_stomate can still add up to a value
2050	! exceeding min_stomate.
2051	Cr_incp(l) = MAX(zero, Cr_target(l) - Cr(l))
2052
2053	! Enough roots and wood, only grow leaves
2054	! This duplicates Exc 2 and these lines should thus never be called
2055	IF ( ABS(Cs_target(l) - Cs(l)) .LT. min_stomate ) THEN
2056
2057	! Allocate at the tree level to restore allometric balance
2058	Cs_incp(l) = MAX(zero, Cs_target(l) - Cs(l))
2059	Cl_incp(l) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,l) - &
2060	Cs_incp(l) - Cr_incp(l), &
2061	Cl_target(l) - Cl(l)), zero )
2062
2063	! Write debug comments to output file
2064	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
2065	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2066	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2067	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
2068	circ_class_n, ind, 7)
2069	ENDIF
2070
2071	! Enough leaves and roots. Need to grow sapwood to support the
2072	! available canopy and roots. Duplicates Exc. 4 and these lines
2073	! should thus never be called
2074	ELSEIF ( ABS(Cl_target(l) - Cl(l)) .LT. min_stomate ) THEN
2075
2076	! Allocate at the tree level to restore allometric balance
2077	Cl_incp(l) = MAX(zero, Cl_target(l) - Cl(l))
2078	Cs_incp(l) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,l) - &
2079	Cr_incp(l) - Cl_incp(l), Cs_target(l) - Cs(l) ), zero )
2080
2081	! Write debug comments to output file
2082	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
2083	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2084	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2085	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
2086	circ_class_n, ind, 8)
2087	ENDIF
2088
2089	! Need both wood and leaves to restore the allometric relationships
2090	ELSEIF ( ABS(Cs_target(l) - Cs(l)) .GT. min_stomate .AND. &
2091	ABS(Cl_target(l) - Cl(l)) .GT. min_stomate ) THEN
2092
2093	! circ_class_ba_eff and circ_class_height_eff are already calculated
2094	! for a tree in balance. It would be rather complicated to follow
2095	! the allometric rules for wood allocation (implying changes in height
2096	! and basal area) because the tree is not in balance.First try if we
2097	! can simply satisfy the allocation needs
2098	IF (Cs_target(l) - Cs(l) + Cl_target(l) - Cl(l) .LE. &
2099	b_inc_tot/circ_class_n(ipts,j,l) - Cr_incp(l)) THEN
2100
2101	Cl_incp(l) = Cl_target(l) - Cl(l)
2102	Cs_incp(l) = Cs_target(l) - Cs(l)
2103
2104	! Try to satisfy the need for leaves
2105	ELSEIF (Cl_target(l) - Cl(l) .LE. b_inc_tot/circ_class_n(ipts,j,l) - &
2106	Cr_incp(l)) THEN
2107
2108	Cl_incp(l) = Cl_target(l) - Cl(l)
2109	Cs_incp(l) = b_inc_tot/circ_class_n(ipts,j,l) - &
2110	Cr_incp(l) - Cl_incp(l)
2111
2112	! There is not enough use whatever is available
2113	ELSE
2114
2115	Cl_incp(l) = b_inc_tot/circ_class_n(ipts,j,l) - Cr_incp(l)
2116	Cs_incp(l) = zero
2117
2118	ENDIF
2119
2120	! Write debug comments to output file
2121	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
2122	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2123	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2124	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
2125	circ_class_n, ind, 9)
2126	ENDIF
2127
2128	ELSE
2129
2130	WRITE(numout,*) 'Exc 7-9: unexpected exception'
2131	IF(ld_stop)THEN
2132	CALL ipslerr_p (3,'growth_fun_all',&
2133	'Exc 7-9: unexpected exception','','')
2134	ENDIF
2135
2136	ENDIF
2137
2138	! Either Cl_target, Cs_target or Cr_target should be zero
2139	ELSE
2140
2141	! Something possibly important was overlooked
2142	WRITE(numout,*) 'WARNING 4: logical flaw in the phenological allocation, PFT, class: ', j, l
2143	WRITE(numout,*) 'WARNING 4: PFT, ipts: ',j,ipts
2144	WRITE(numout,*) 'Cs - Cs_target', Cs(l), Cs_target(l)
2145	WRITE(numout,*) 'Cl - Cl_target', Cl(l), Cl_target(l)
2146	WRITE(numout,*) 'Cr - Cr_target', Cr(l), Cr_target(l)
2147	IF(ld_stop)THEN
2148	CALL ipslerr_p (3,'growth_fun_all',&
2149	'WARNING 4: logical flaw in the phenological allocation','','')
2150	ENDIF
2151
2152	ENDIF
2153
2154	!! 5.2.4.4 Wrap-up phenological allocation
2155	IF ( Cl_incp(l) .GE. zero .OR. Cr_incp(l) .GE. zero .OR. &
2156	Cs_incp(l) .GE. zero) THEN
2157
2158	! Fake allocation for less messy equations in next case,
2159	! incp needs to be added to inc at the end
2160	Cl(l) = Cl(l) + Cl_incp(l)
2161	Cr(l) = Cr(l) + Cr_incp(l)
2162	Cs(l) = Cs(l) + Cs_incp(l)
2163	b_inc_tot = b_inc_tot - (circ_class_n(ipts,j,l) * &
2164	(Cl_incp(l) + Cr_incp(l) + Cs_incp(l)))
2165
2166	! Something is wrong with the calculations
2167	IF (b_inc_tot .LT. -min_stomate) THEN
2168
2169	WRITE(numout,*) 'WARNING 5: numerical problem, overspending in phenological allocation'
2170	WRITE(numout,*) 'WARNING 5: PFT, ipts: ',j,ipts
2171	CALL ipslerr_p (3,'growth_fun_all',&
2172	'WARNING 5: numerical problem, overspending in phenological allocation','','')
2173	ENDIF
2174
2175	ELSE
2176
2177	! The code was written such that the increment pools should be
2178	! greater than or equal to zero. If this is not the case, something
2179	! fundamental is wrong with the if-then constructs under Â§5.2.4.3
2180	WRITE(numout,*) 'WARNING 6: PFT, ipts: ',j,ipts
2181	CALL ipslerr_p (3,'growth_fun_all',&
2182	'WARNING 6: numerical problem, one of the increment pools is less than zero','','')
2183	ENDIF
2184
2185	! Set counter for next circumference class
2186	l = l-1
2187
2188	ENDDO ! DO WHILE l.GE.1 .AND. b_inc_tot .GT. min_stomate
2189
2190
2191	!! 5.2.5 Calculate the expected size of the reserve pool
2192	! use the minimum of either (1) 2% of the total sapwood biomass or
2193	! (2) the amount of carbon needed to develop the optimal LAI and the roots
2194	! This reserve pool estimate is only used to decide whether wood should be
2195	! grown or not. When really dealing with the reserves the reserve pool is
2196	! recalculated. See further below Â§7.1.
2197	reserve_pool = MIN( 0.02 * ( biomass(ipts,j,isapabove,icarbon) + &
2198	biomass(ipts,j,isapbelow,icarbon)), &
2199	lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j)))
2200	grow_wood = .TRUE.
2201
2202	! If the carbohydrate pool is too small, don't grow wood
2203	IF ( (pheno_type(j) .NE. 1) .AND. &
2204	(biomass(ipts,j,icarbres,icarbon) .LE. reserve_pool) ) THEN
2205
2206	grow_wood = .FALSE.
2207
2208	ENDIF
2209
2210	! Write debug comments to output file
2211	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
2212	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2213	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2214	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
2215	circ_class_n, ind, 10)
2216	ENDIF
2217
2218
2219	!! 5.2.6 Ordinary growth
2220	! Allometric relationship between components is respected, sustain
2221	! ordinary growth and allocate
2222	! biomass to leaves, wood, roots and fruits.
2223	IF ( (SUM( ABS(Cl_target(:) - Cl(:)) ) .LE. min_stomate) .AND. &
2224	(SUM( ABS(Cs_target(:) - Cs(:)) ) .LE. min_stomate) .AND. &
2225	(SUM( ABS(Cr_target(:) - Cr(:)) ) .LE. min_stomate) .AND. &
2226	(grow_wood) .AND. (b_inc_tot .GT. min_stomate) ) THEN
2227
2228	! Allocate fraction of carbon to fruit production (at the tree level)
2229	Cf_inc(:) = b_inc_tot / SUM(circ_class_n(ipts,j,:)) * fruit_alloc(j)
2230
2231	! Residual carbon is allocated to the other components (b_inc_tot is
2232	! at the stand level)
2233	b_inc_tot = b_inc_tot * (un-fruit_alloc(j))
2234
2235	! Substitute (7), (8) and (9) in (1)
2236	! b_inc = tree_ffpipe_density(ba+circ_class_dbagammas)...
2237	! (height+(circ_class_dba/s*gammas)) - Cs - Ch + ...
2238	! KFtree_ffpipe_density(ba+circ_class_dbagammas) - ...
2239	! (KFCh)/(height+(circ_class_dba/sgammas)) - Cl + ...
2240	! KF/LFtree_ffpipe_density(ba+circ_class_dbagammas) - ...
2241	! (KFCh/LF)/(height+(circ_class_dba/sgammas)) - Cr
2242	!
2243	! b_inc+Cs+Ch+Cl+Cr = tree_ffpipe_density(ba+circ_class_dbagammas)...
2244	! (height+(circ_class_dba/s*gammas)) + ...
2245	! KFtree_ffpipe_density(ba+circ_class_dbagammas) - ...
2246	! (KFCh)/(height+(circ_class_dba/sgammas)) + ...
2247	! KF/LFtree_ffpipe_density(ba+circ_class_dbagammas) - ...
2248	! (KFCh/LF)/(height+(circ_class_dba/sgammas))
2249	! <=> b_inc+Cs+Ch+Cl+Cr = circ_class_dba^2/stree_ff...
2250	! pipe_densitygammas^2 + circ_class_dba/sbatree_ff...
2251	! pipe_density*gammas + ...
2252	! circ_class_dbaheighttree_ffpipe_densitygammas + ...
2253	! bcirc_class_dbaheighttree_ff*pipe_density - ...
2254	! (ChKFs)/(circ_class_dbagammas+heights) + ...
2255	! circ_class_dbaKFtree_ffpipe_densitygammas + ...
2256	! baKFtree_ff*pipe_density - ...
2257	! (ChKFs)/(LF(circ_class_dbagammas+height*s)) + ...
2258	! circ_class_dbaKF/LFtree_ffpipe_densitygammas + ...
2259	! baKF/LFtree_ff*pipe_density
2260	! (10) b_inc+Cs+Ch+Cl+Cr = (circ_class_dba^2/stree_ff...
2261	! pipe_density)*gammas^2 + ...
2262	! (circ_class_dba/sbatree_ff*pipe_density + ...
2263	! circ_class_dbaheighttree_ff*pipe_density + ...
2264	! circ_class_dbaKFtree_ff*pipe_density + ...
2265	! circ_class_dbaKF/LFtree_ffpipe_density)gammas - ...
2266	! (ChKFs)(1+1/LF)/(circ_class_dbagammas+heights) + ...
2267	! bcirc_class_dbaheighttree_ff*pipe_density + ...
2268	! baKFtree_ffpipe_density + baKF/LFtree_ffpipe_density
2269	!
2270	! Note that b_inc is not known, only b_inc_tot (= sum(b_inc) is known.
2271	! The above equations are for individual trees, at the stand level we
2272	! have to take the sum over the individuals which is
2273	! equivalant to substituting (10) in (2)
2274	! (11) sum(b_inc) + sum(Cs+Ch+Cl+Cr) = ...
2275	! sum(circ_class_dba^2/stree_ffpipe_density) * gammas^2 + ...
2276	! sum(circ_class_dba/sbatree_ff*pipe_density + ...
2277	! circ_class_dbaheighttree_ff*pipe_density + ...
2278	! circ_class_dbaKFtree_ff*pipe_density + ...
2279	! circ_class_dbaKF/LFtree_ffpipe_density) gammas - ...
2280	! sum[(ChKFs)(1+1/LF)/(circ_class_dbagammas+heights)] + ...
2281	! sum(bcirc_class_dbaheighttree_ff*pipe_density + ...
2282	! baKFtree_ffpipe_density + baKF/LFtree_ffpipe_density)
2283	!
2284	! The term sum[(ChKFs)(1+1/LF)/(circ_class_dbagammas+heights)]
2285	! can be approximated by a series expansion
2286	! (12) sum((ChKFs)(1+1/LF)/(height*s) + ...
2287	! sum((ChKFs)(1+1/LF)circ_class_dba/(heights)^2)*gammas + ...
2288	! sum((ChKFs)(1+1/LF)circ_class_dba^2/(heights)^3)*gammas^2
2289	!
2290	! Substitute (12) in (11)
2291	! sum(b_inc) + sum(Cs+Ch+Cl+Cr) = ...
2292	! sum(circ_class_dba^2/stree_ffpipe_density - ...
2293	! (ChKFs)(1+1/LF)circ_class_dba^2/(heights)^3) gammas^2 + ...
2294	! sum(circ_class_dba/sbatree_ff*pipe_density + ...
2295	! circ_class_dbaheighttree_ff*pipe_density + ...
2296	! circ_class_dbaKFtree_ff*pipe_density + ...
2297	! circ_class_dbaKF/LFtree_ff*pipe_density + ...
2298	! (ChKFs)(1+1/LF)circ_class_dba/(heights)^2) gammas + ...
2299	! sum(bcirc_class_dbaheighttree_ff*pipe_density + ...
2300	! baKFtree_ffpipe_density + baKF/LFtree_ffpipe_density - ...
2301	! (ChKFs)(1+1/LF)/(heights))
2302	!
2303	! Solve this quadratic equation for gammas.
2304	a = SUM( circ_class_n(ipts,j,:) * &
2305	(circ_class_dba(:)*2/s(:)tree_ff(j)*pipe_density(j) - &
2306	(Ch(:)KF(ipts,j)s(:))(1+1/LF(ipts,j))&
2307	(circ_class_dba(:)*2/(circ_class_height_eff(:)s(:))**3)) )
2308	b = SUM( circ_class_n(ipts,j,:) * &
2309	(circ_class_dba(:)/s(:)circ_class_ba_eff(:)tree_ff(j)*pipe_density(j) + &
2310	circ_class_dba(:)circ_class_height_eff(:)tree_ff(j)*pipe_density(j) + &
2311	circ_class_dba(:)KF(ipts,j)tree_ff(j)*pipe_density(j) + &
2312	circ_class_dba(:)KF(ipts,j)/LF(ipts,j)tree_ff(j)*pipe_density(j) + &
2313	(Ch(:)KF(ipts,j)s(:))(1+1/LF(ipts,j))circ_class_dba(:)/&
2314	(circ_class_height_eff(:)s(:))*2) )
2315	c = SUM( circ_class_n(ipts,j,:) * &
2316	(circ_class_ba_eff(:)circ_class_height_eff(:)&
2317	tree_ff(j)*pipe_density(j) + &
2318	circ_class_ba_eff(:)KF(ipts,j)tree_ff(j)*pipe_density(j) + &
2319	circ_class_ba_eff(:)KF(ipts,j)/LF(ipts,j)tree_ff(j)*pipe_density(j) - &
2320	(Ch(:)KF(ipts,j)s(:))*(1+1/LF(ipts,j))/&
2321	(circ_class_height_eff(:)*s(:)) - &
2322	(Cs(:) + Ch(:) + Cl(:) + Cr(:))) ) - b_inc_tot
2323
2324	! Solve the quadratic equation agammas2 + bgammas + c = 0, for gammas.
2325	gammas(ipts,j) = (-b + sqrt(b*2-4ac)) / (2a)
2326
2327	!++++++ TEMP ++++++
2328	!!$ IF(test_pft == j .AND. test_grid ==ipts)THEN
2329	!!$ WRITE(numout,*) 'Testing for the slope'
2330	!!$ DO i=1,100
2331	!!$ tempi=1
2332	!!$ delta_ba(tempi) = circ_class_dba(tempi) * gammas * REAL(i)/50.0
2333	!!$ delta_height(tempi) = delta_ba(tempi)/s(tempi)
2334	!!$ Cs_inc(tempi) = tree_ff(j)pipe_density(j)(circ_class_ba_eff(tempi) + delta_ba(tempi))*(circ_class_height_eff(tempi) + &
2335	!!$ delta_height(tempi)) - Cs(tempi) - Ch(tempi)
2336	!!$ Cl_inc(tempi) = KF(ipts,j)tree_ff(j)pipe_density(j)*(circ_class_ba_eff(tempi)+delta_ba(tempi)) - &
2337	!!$ (KF(ipts,j)*Ch(tempi))/(circ_class_height_eff(tempi)+delta_height(tempi)) - Cl(tempi)
2338	!!$ Cr_inc(tempi) = KF(ipts,j)/LF(ipts,j)tree_ff(j)pipe_density(j)*(circ_class_ba_eff(tempi)+delta_ba(tempi)) - &
2339	!!$ (KF(ipts,j)*Ch(tempi)/LF(ipts,j))/(circ_class_height_eff(tempi)+delta_height(tempi)) - Cr(tempi)
2340	!!$ WRITE(numout,'(10F20.10)') delta_height(tempi),delta_ba(tempi),Cs_inc(tempi),Cl_inc(tempi),Cr_inc(tempi)
2341	!!$ ENDDO
2342	!!$ WRITE(numout,*) 'End testing for the slope'
2343	!!$ END IF
2344	!+++++++++++++++++
2345
2346	! The solution for gammas is then used to calculate delta_ba (eq. 3),
2347	! delta_height (eq. 6), Cs_inc (eq. 7), Cl_inc (eq. 8) and Cr_inc (eq. 9).
2348	! See comment on the calculation of delta_height and its implications on
2349	! numerical consistency at the similar statement in Â§5.2.4.3.1
2350	delta_ba(:) = circ_class_dba(:) * gammas(ipts,j)
2351	store_delta_ba(ipts,j,:) = delta_ba(:)
2352	delta_height(:) = delta_ba(:)/s(:)
2353	Cs_inc(:) = tree_ff(j)pipe_density(j)(circ_class_ba_eff(:) + &
2354	delta_ba(:))*(circ_class_height_eff(:) + &
2355	delta_height(:)) - Cs(:) - Ch(:)
2356	Cl_inc(:) = KF(ipts,j)tree_ff(j)pipe_density(j)*&
2357	(circ_class_ba_eff(:)+delta_ba(:)) - &
2358	(KF(ipts,j)*Ch(:))/(circ_class_height_eff(:)+delta_height(:)) - Cl(:)
2359	Cr_inc = KF(ipts,j)/LF(ipts,j)tree_ff(j)pipe_density(j)*&
2360	(circ_class_ba_eff(:)+delta_ba(:)) - &
2361	(KF(ipts,j)*Ch(:)/LF(ipts,j))/(circ_class_height_eff(:)+&
2362	delta_height(:)) - Cr(:)
2363
2364	! After thousands of simulation years we had a single pixel where
2365	! one of the three circ_class got a negative growth. The cause is not
2366	! is not entirely clear but could be related to the fact that KF
2367	! changes from one day to another in combination with a low b_inc.
2368	! If this happens, we don't allocate and simply leave the carbon
2369	! in the labile pool. We will try again with more carbon the next day.
2370	! This case is dealt with later in the code - see warning 10
2371
2372
2373	! Write debug comments to output file
2374	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
2375	WRITE(numout,*) 'a, b, c, gammas, ', a, b, c, gammas(ipts,j)
2376	WRITE(numout,*) 'delta_height, ', delta_height(:)
2377	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
2378	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
2379	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
2380	circ_class_n, ind, 11)
2381	ENDIF
2382
2383	! Wrap-up ordinary growth
2384	! Calculate C that was not allocated, note that Cf_inc was already substracted
2385	b_inc_tot = b_inc_tot - &
2386	SUM(circ_class_n(ipts,j,:)*(Cl_inc(:) + Cr_inc(:) + Cs_inc(:)))
2387
2388	!---TEMP---
2389	IF (j.EQ.test_pft .AND. ld_alloc) THEN
2390	WRITE(numout,*) 'wrap-up ordinary allocation, left b_in_tot, ', b_inc_tot
2391	ENDIF
2392	!----------
2393
2394
2395	!! 5.2.7 Don't grow wood, use C to fill labile pool
2396	ELSEIF ( (.NOT. grow_wood) .AND. (b_inc_tot .GT. min_stomate) ) THEN
2397
2398	! Calculate the C that needs to be distributed to the
2399	! labile pool. The fraction is proportional to the ratio
2400	! between the total allocatable biomass and the unallocated
2401	! biomass per tree (b_inc now contains the unallocated
2402	! biomass). At the end of the allocation scheme bm_alloc_tot
2403	! is substracted from the labile biomass pool to update the
2404	! biomass pool (biomass(:,:,ilabile) = biomass(:,:,ilabile) -
2405	! bm_alloc_tot(:,:)). At that point, the scheme puts the
2406	! unallocated b_inc into the labile pool. What we
2407	! want is that the unallocated fraction is removed from
2408	! ::bm_alloc_tot such that only the allocated C is removed
2409	! from the labile pool. b_inc_tot will be moved back into
2410	! the labile pool in 5.2.11
2411	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - b_inc_tot
2412	biomass(ipts,j,ilabile,icarbon) = &
2413	biomass(ipts,j,ilabile,icarbon) + b_inc_tot
2414
2415	! Wrap-up ordinary growth
2416	! Calculate C that was not allocated (b_inc_tot), the
2417	! equation should read b_inc_tot = b_inc_tot - b_inc_tot
2418	! note that Cf_inc was already substracted
2419	b_inc_tot = zero
2420
2421	!---TEMP---
2422	IF (j.EQ.test_pft .AND. ld_alloc) THEN
2423	WRITE(numout,*) 'No wood growth, move remaining C to labile pool'
2424	WRITE(numout,*) 'bm_alloc_tot_new, ',bm_alloc_tot(ipts,j)
2425	WRITE(numout,*) 'wrap-up ordinary allocation, left b_inc_tot, ', b_inc_tot
2426	ENDIF
2427	!----------
2428
2429
2430	!! 5.2.8 Error - the allocation scheme is overspending
2431	ELSEIF (b_inc_tot .LT. min_stomate) THEN
2432
2433	IF (b_inc_tot .LT. -min_stomate) THEN
2434
2435	! Something is wrong with the calculations
2436	WRITE(numout,*) 'WARNING 7: numerical problem overspending in ordinary allocation'
2437	WRITE(numout,*) 'WARNING 7: PFT, ipts: ',j,ipts
2438	WRITE(numout,*) 'WARNING 7: b_inc_tot', b_inc_tot
2439	IF(ld_stop)THEN
2440	CALL ipslerr_p (3,'growth_fun_all',&
2441	'WARNING 7: numerical problem overspending in ordinary allocation','','')
2442	ENDIF
2443
2444	ELSE
2445
2446	IF (j.EQ.test_pft .AND. ld_alloc) THEN
2447
2448	! Succesful allocation
2449	WRITE(numout,*) 'Successful allocation'
2450
2451	ENDIF
2452
2453	ENDIF
2454
2455	! Althought the biomass components respect the allometric relationships, there
2456	! is no carbon left to allocate
2457	b_inc_tot = zero
2458	Cl_inc(:) = zero
2459	Cs_inc(:) = zero
2460	Cr_inc(:) = zero
2461	Cf_inc(:) = zero
2462
2463	ENDIF ! Ordinary allocation
2464
2465	!! 5.2.9 Forced allocation
2466	! Although this should not happen, in case the functional allocation did not
2467	! consume all the allocatable carbon, the remaining C is left for the next day,
2468	! and some of the biomass is used to produce fruits (tuned). The numerical
2469	! precision of the allocation scheme (i.e. the linearisation) is similar to
2470	! min_stomate (i.e. 10-8) resulting in 'false' warnings. In the latter case
2471	! forced allocation is applied but only for very small amounts of carbon
2472	! i.e. between 10-5 and 10-8.
2473	IF ( b_inc_tot .GT. min_stomate) THEN
2474
2475	WRITE(numout,*) 'WARNING 8: b_inc_tot greater than min_stomate force allocation'
2476	WRITE(numout,*) 'WARNING 8: PFT, ipts: ',j,ipts
2477	WRITE(numout,*) 'WARNING 8: b_inc_tot, ', b_inc_tot
2478	IF(ld_stop)THEN
2479	CALL ipslerr_p (3,'growth_fun_all',&
2480	'WARNING 8: b_inc_tot greater than min_stomate force allocation','','')
2481	ENDIF
2482
2483	!+++CHECK+++
2484	! We should not end-up here. We need some code to break the conditions
2485	! that made us end-up here. The current code will do this job.
2486	!!$ ! Calculate fraction that will be allocated to fruit. The fraction is proportional to the
2487	!!$ ! ratio between the total allocatable biomass and the unallocated biomass per tree
2488	!!$ frac = fruit_alloc(j) * MIN(1., bm_alloc_tot(ipts,j) / b_inc_tot)
2489	!!$ Cf_inc(:) = Cf_inc(:) + b_inc_tot * frac
2490	!!$ b_inc_tot = b_inc_tot * (1 - frac)
2491	!!$
2492	!!$ ! Calculate the C that needs to be distributed to the labile pool. The fraction is proportional
2493	!!$ ! to the ratio between the total allocatable biomass and the unallocated biomass per tree (b_inc
2494	!!$ ! now contains the unallocated biomass). At the end of the allocation scheme bm_alloc_tot is
2495	!!$ ! substracted from the labile biomass pool to update the biomass pool (biomass(:,:,ilabile) =
2496	!!$ ! biomass(:,:,ilabile,icarbon) - bm_alloc_tot(:,:)). At that point, the scheme puts the
2497	!!$ ! unallocated b_inc into the labile pool.
2498	!!$ bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) * &
2499	!!$ ( 1. - (1.-frac) * b_inc_tot / bm_alloc_tot(ipts,j) )
2500	!+++++++++++
2501
2502	ELSEIF ( (b_inc_tot .LT. min_stomate) .AND. (b_inc_tot .GE. -min_stomate) ) THEN
2503
2504	! Successful allocation
2505	IF (j.EQ.test_pft .AND. ld_alloc) THEN
2506	WRITE(numout,*) 'Successful allocation'
2507	ENDIF
2508
2509	ELSE
2510
2511	! Something possibly important was overlooked
2512	IF ( (b_inc_tot .LT. 100min_stomate) .AND. (b_inc_tot .GE. -100min_stomate) ) THEN
2513	IF (j.EQ.test_pft .AND. ld_alloc) THEN
2514	WRITE(numout,*) 'Marginally successful allocation - precision better than 10-6'
2515	WRITE(numout,*) 'PFT, b_inc_tot', j, b_inc_tot
2516	ENDIF
2517	ELSE
2518	WRITE(numout,*) 'WARNING 9: Logical flaw unexpected result in the ordinary allocation'
2519	WRITE(numout,*) 'WARNING 9: b_inc_tot, ',b_inc_tot
2520	WRITE(numout,*) 'WARNING 9: PFT, ipts: ',j,ipts
2521	IF(ld_stop)THEN
2522	CALL ipslerr_p (3,'growth_fun_all',&
2523	'WARNING 9: Logical flaw unexpected result in the ordinary allocation','','')
2524	ENDIF
2525	ENDIF
2526
2527	ENDIF
2528
2529	! The second problem we need to catch is when one of the increment pools is
2530	! negative. This is an undesired outcome (see comment where ::KF_old is
2531	! calculated in this routine. In that case we write a warning, set all increment
2532	! pools to zero and try it again at the next time step. A likely cause of this
2533	! problem is a too large change in KF from one time step to another. Try decreasing
2534	! the acceptable value for an absolute increase in KF.
2535	IF (MINVAL(Cs_inc(:)) .LT. zero .OR. MINVAL(Cr_inc(:)) .LT. zero .OR. &
2536	MINVAL(Cs_inc(:)) .LT. zero) THEN
2537
2538	! Do not allocate - save the carbon for the next time step
2539	WRITE(numout,*) 'WARNING 10: numerical problem, one of the increment pools is less than zero'
2540	WRITE(numout,*) 'WARNING 10: PFT, ipts: ',j,ipts
2541	WRITE(numout,*) 'WARNING 10: Cl_inc(:): ',Cl_inc(:)
2542	WRITE(numout,*) 'WARNING 10: Cr_inc(:): ',Cr_inc(:)
2543	WRITE(numout,*) 'WARNING 10: Cs_inc(:): ',Cs_inc(:)
2544	WRITE(numout,*) 'WARNING 10: PFT, ipts: ',j,ipts
2545	WRITE(numout,*) 'WARNING 10: We will undo the allocation'
2546	WRITE(numout,*) ' and save the carbon for the next day'
2547
2548	! Reverse the allocation
2549
2550	b_inc_tot = b_inc_tot + &
2551	SUM(circ_class_n(ipts,j,:)*(Cl_inc(:) + Cr_inc(:) + Cs_inc(:)))
2552	Cl_inc(:) = zero
2553	Cr_inc(:) = zero
2554	Cs_inc(:) = zero
2555
2556	ENDIF
2557
2558	!! 5.2.10 Wrap-up phenological and ordinary allocation
2559	Cl_inc(:) = Cl_inc(:) + Cl_incp(:)
2560	Cr_inc(:) = Cr_inc(:) + Cr_incp(:)
2561	Cs_inc(:) = Cs_inc(:) + Cs_incp(:)
2562	residual(ipts,j) = b_inc_tot
2563
2564	!---TEST---
2565	IF (j.EQ.test_pft .AND. ld_alloc) THEN
2566	WRITE(numout,*) 'Final allocation', ipts, j
2567	WRITE(numout,*) 'Cl, Cs, Cr', Cl(:), Cs(:), Cr(:)
2568	WRITE(numout,*) 'Cl_incp, Cs_incp, Cr_incp, ', Cl_incp(:), Cs_incp(:), Cr_incp(:)
2569	WRITE(numout,*) 'Cl_inc, Cs_ins, Cr_inc, Cf_inc, ', Cl_inc(:), Cs_inc(:), Cr_inc(:), Cf_inc(:)
2570	WRITE(numout,*) 'unallocated/residual, ', b_inc_tot
2571	WRITE(numout,*) 'Old ba, delta_ba, new ba, ', circ_class_ba_eff(:), delta_ba(:), circ_class_ba_eff(:)+delta_ba(:)
2572	DO l=1,ncirc
2573	WRITE(numout,*) 'Circ_class_biomass, ',circ_class_biomass(ipts,j,l,:,icarbon)
2574	ENDDO
2575	ENDIF
2576	!----------
2577
2578
2579	!! 5.2.11 Account for the residual
2580	! The residual is usually around ::min_stomate but we deal
2581	! with it anyway to make sure the mass balance is closed
2582	! and as a way to detect errors. Move the unallocated carbon
2583	! back into the labile pool
2584	IF (biomass(ipts,j,ilabile,icarbon) + residual(ipts,j) .LE. min_stomate) THEN
2585
2586	deficit = biomass(ipts,j,ilabile,icarbon) + residual(ipts,j)
2587
2588	! The deficit is less than the carbon reserve
2589	IF (-deficit .LE. biomass(ipts,j,icarbres,icarbon)) THEN
2590
2591	! Pay the deficit from the reserve pool
2592	biomass(ipts,j,icarbres,icarbon) = &
2593	biomass(ipts,j,icarbres,icarbon) + deficit
2594	biomass(ipts,j,ilabile,icarbon) = &
2595	biomass(ipts,j,ilabile,icarbon) - deficit
2596
2597	ELSE
2598
2599	! Not enough carbon to pay the deficit
2600	! There is likely a bigger problem somewhere in
2601	! this routine
2602	WRITE(numout,*) 'WARNING 11: PFT, ipts: ',j,ipts
2603	CALL ipslerr_p (3,'growth_fun_all',&
2604	'WARNING 11: numerical problem overspending ',&
2605	'when trying to account for unallocatable C ','')
2606
2607	ENDIF
2608
2609	ELSE
2610
2611	! Move the unallocated carbon back into the labile pool
2612	biomass(ipts,j,ilabile,icarbon) = &
2613	biomass(ipts,j,ilabile,icarbon) + residual(ipts,j)
2614
2615	ENDIF
2616
2617	!! 5.2.12 Standardise allocation factors
2618	! Strictly speaking the allocation factors do not need to be
2619	! calculated because the functional allocation scheme allocates
2620	! absolute amounts of carbon. Hence, Cl_inc could simply be
2621	! added to biomass(:,:,ileaf,icarbon), Cr_inc to
2622	! biomass(:,:,iroot,icarbon), etc. However, using allocation
2623	! factors bears some elegance in respect to distributing the
2624	! growth respiration if this would be required. Further it
2625	! facilitates comparison to the resource limited allocation
2626	! scheme (stomate_growth_res_lim.f90) and it comes in handy
2627	! for model-data comparison. This allocation takes place at
2628	! the tree level - note that ::biomass is the only prognostic
2629	! variable from the tree-based allocation
2630
2631	! Allocation
2632	Cl_inc(:) = MAX(zero, circ_class_n(ipts,j,:) * Cl_inc(:))
2633	Cr_inc(:) = MAX(zero, circ_class_n(ipts,j,:) * Cr_inc(:))
2634	Cs_inc(:) = MAX(zero, circ_class_n(ipts,j,:) * Cs_inc(:))
2635	Cf_inc(:) = MAX(zero, circ_class_n(ipts,j,:) * Cf_inc(:))
2636
2637	! Total_inc is based on the updated Cl_inc, Cr_inc, Cs_inc and Cf_inc. Therefore, do not multiply
2638	! circ_class_n(ipts,j,:) again
2639	total_inc = SUM(Cf_inc(:) + Cl_inc(:) + Cs_inc(:) + Cr_inc(:))
2640
2641	! Relative allocation
2642	IF ( total_inc .GT. min_stomate ) THEN
2643
2644	Cl_inc(:) = Cl_inc(:) / total_inc
2645	Cs_inc(:) = Cs_inc(:) / total_inc
2646	Cr_inc(:) = Cr_inc(:) / total_inc
2647	Cf_inc(:) = Cf_inc(:) / total_inc
2648
2649	ELSE
2650
2651	bm_alloc_tot(ipts,j) = zero
2652	Cl_inc(:) = zero
2653	Cs_inc(:) = zero
2654	Cr_inc(:) = zero
2655	Cf_inc(:) = zero
2656
2657	ENDIF
2658
2659
2660	!! 5.2.13 Convert allocation to allocation facors
2661	! Convert allocation of individuals to ORCHIDEE's allocation
2662	! factors - see comment for 5.2.5. Aboveground sapwood
2663	! allocation is age dependent in trees. ::alloc_min and
2664	! ::alloc_max must range between 0 and 1.
2665	alloc_sap_above = alloc_min(j) + ( alloc_max(j) - alloc_min(j) ) * &
2666	( 1. - EXP( -age(ipts,j) / demi_alloc(j) ) )
2667
2668	! Leaf, wood, root and fruit allocation
2669	f_alloc(ipts,j,ileaf) = SUM(Cl_inc(:))
2670	f_alloc(ipts,j,isapabove) = SUM(Cs_inc(:)*alloc_sap_above)
2671	f_alloc(ipts,j,isapbelow) = SUM(Cs_inc(:)*(1.-alloc_sap_above))
2672	f_alloc(ipts,j,iroot) = SUM(Cr_inc(:))
2673	f_alloc(ipts,j,ifruit) = SUM(Cf_inc(:))
2674
2675	! Absolute allocation at the tree level and for an individual tree (gC tree-1)
2676	! The labile and reserve pools are not allocated at the tree level. However,
2677	! stand level ilabile and icarbres biomass will be redistributed at the tree
2678	! level later in this subroutine. This is done after the relative allocation
2679	! beacuse now ::alloc_sap_above is known
2680	circ_class_biomass(ipts,j,:,ileaf,icarbon) = &
2681	circ_class_biomass(ipts,j,:,ileaf,icarbon) + &
2682	( Cl_inc(:) * total_inc / circ_class_n(ipts,j,:) )
2683	circ_class_biomass(ipts,j,:,isapabove,icarbon) = &
2684	circ_class_biomass(ipts,j,:,isapabove,icarbon) + &
2685	( Cs_inc(:) * alloc_sap_above * total_inc / &
2686	circ_class_n(ipts,j,:) )
2687	circ_class_biomass(ipts,j,:,isapbelow,icarbon) = &
2688	circ_class_biomass(ipts,j,:,isapbelow,icarbon) + &
2689	( Cs_inc(:) * (un - alloc_sap_above) * &
2690	total_inc / circ_class_n(ipts,j,:) )
2691	circ_class_biomass(ipts,j,:,iroot,icarbon) = &
2692	circ_class_biomass(ipts,j,:,iroot,icarbon) + &
2693	( Cr_inc(:) * total_inc / circ_class_n(ipts,j,:) )
2694	circ_class_biomass(ipts,j,:,ifruit,icarbon) = &
2695	circ_class_biomass(ipts,j,:,ifruit,icarbon) + &
2696	( Cf_inc(:) * total_inc / circ_class_n(ipts,j,:) )
2697
2698	!+++TEMP+++
2699	IF (ld_alloc) THEN
2700	tempi = zero
2701	DO icirc = 1,ncirc
2702	IF ( Cl_inc(icirc) .LT. zero) THEN
2703	WRITE(numout,*) 'Cl_inc, ', j, Cl_inc(icirc)
2704	tempi = un
2705	ENDIF
2706	IF ( Cs_inc(icirc) * alloc_sap_above .LT. zero) THEN
2707	WRITE(numout,*) 'Cs_inc aboveground, ', j, &
2708	Cs_inc(icirc) * alloc_sap_above
2709	tempi = un
2710	ENDIF
2711	IF ( Cs_inc(icirc) * (un - alloc_sap_above) .LT. zero) THEN
2712	WRITE(numout,*) 'Cs_inc aboveground, ', j, &
2713	Cs_inc(icirc) * (un-alloc_sap_above)
2714	tempi = un
2715	ENDIF
2716	IF ( Cr_inc(icirc) .LT. zero) THEN
2717	WRITE(numout,*) 'Cr_inc, ', j, Cr_inc(icirc)
2718	tempi = un
2719	ENDIF
2720	IF ( Cf_inc(icirc) .LT. zero) THEN
2721	WRITE(numout,*) 'Cf_inc, ', j, Cf_inc(icirc)
2722	tempi = un
2723	ENDIF
2724	IF ( total_inc .LT. zero) THEN
2725	WRITE(numout,*) 'total_inc, ', j, total_inc
2726	tempi = un
2727	ENDIF
2728	IF ( circ_class_n(ipts,j,icirc) .LT. zero) THEN
2729	WRITE(numout,*) 'circ_class_n, ', j, circ_class_n(ipts,j,icirc)
2730	tempi = un
2731	ENDIF
2732	ENDDO
2733	IF (tempi == un) CALL ipslerr_p (3,'growth_fun_all',&
2734	'WARNING 11bis: the solution has negative values',&
2735	'None of these variables should be negative','')
2736	ENDIF
2737	!++++++++++
2738
2739	ELSEIF (is_tree(j)) THEN
2740
2741	IF(ld_alloc) WRITE(numout,*) 'there is no tree biomass to allocate, PFT, ', j
2742
2743	ENDIF ! Is there biomass to allocate (Â§5.2 - far far up)
2744
2745
2746	!! 5.3 Calculate allocated biomass pools for grasses and crops
2747	! Only possible if there is biomass to allocate
2748	IF ( .NOT. is_tree(j) .AND. bm_alloc_tot(ipts,j) .GT. min_stomate ) THEN
2749
2750	!! 5.3.1 Scaling factor to convert variables to the individual plant
2751	! Allocation is on an individual basis (gC ind-1). Stand-level variables
2752	! need to convert to a single individual. The absence of sapwood makes
2753	! this irrelevant because the allocation reduces to a linear function
2754	! (contrary to the non-linearity of tree allocation). For the
2755	! beauty of consistency, the transformations will be implemented.
2756	! Different approach between the DGVM and statitic approach
2757	IF (control%ok_dgvm) THEN
2758
2759	! The DGVM does NOT work with the functional allocation. Consider
2760	! this code as a placeholder. The original code had two different
2761	! transformations to calculate the scalars. Both could be used but
2762	! the units will differ. For consistency only one was retained
2763	! scal = ind(ipts,j) * cn_ind(ipts,j) / veget_max(ipts,j)
2764	scal = veget_max(ipts,j) / ind(ipts,j)
2765
2766	ELSE
2767
2768	! By dividing the actual biomass by the number of individuals
2769	! the biomass of an individual is obtained. Note that a grass/crop
2770	! individual was defined as 1m-2 of vegetation
2771	scal = 1./ ind(ipts,j)
2772
2773	ENDIF
2774
2775
2776	!! 5.3.2 Current biomass pools per grass/crop (gC ind^-1)
2777	! Cs has too many dimensions for grass/crops. To have a consistent notation the same variables
2778	! are used as for trees but the dimension of Cs, Cl and Cr i.e. ::ncirc should be ignored
2779	Cs(:) = biomass(ipts,j,isapabove,icarbon) * scal
2780	Cr(:) = biomass(ipts,j,iroot,icarbon) * scal
2781	Cl(:) = biomass(ipts,j,ileaf,icarbon) * scal
2782	Ch(:) = zero
2783
2784	! Total amount of carbon that needs to be allocated (::bm_alloc_tot). bm_alloc_tot is
2785	! in gC m-2 day-1. At 1 m2 there are ::ind number of grasses.
2786	b_inc_tot = bm_alloc_tot(ipts,j)
2787
2788	!! 5.3.3 C-allocation for crops and grasses
2789	! The mass conservation equations are detailed in the header of this subroutine.
2790	! The scheme assumes a functional relationships between leaves and roots for grasses and crops.
2791	! When carbon is added to the leaf biomass pool, an increase in the root biomass is to be
2792	! expected to sustain water transport from the roots to the leaves.
2793
2794	!! 5.3.3.1 Do the biomass pools respect the pipe model?
2795	! Do the current leaf, sapwood and root components respect the allometric
2796	! constraints? Calculate the optimal root and leaf mass, given the current wood mass
2797	! by using the basic allometric relationships. Calculate the optimal sapwood
2798	! mass as a function of the current leaf and root mass.
2799	Cl_target(1) = MAX( Cs(1) * KF(ipts,j) , Cr(1) * LF(ipts,j), Cl(1) )
2800	Cs_target(1) = MAX( Cl_target(1) / KF(ipts,j), Cr(1) * LF(ipts,j) / KF(ipts,j), Cs(1) )
2801	Cr_target(1) = MAX( Cl_target(1) / LF(ipts,j), Cs_target(1) * KF(ipts,j) / LF(ipts,j), Cr(1) )
2802
2803	! Write debug comments to output file
2804	IF (j .EQ. test_pft .AND. ld_alloc) THEN
2805	WRITE(numout,*) 'bm_alloc_tot, ',bm_alloc_tot(ipts,j)
2806	WRITE(numout,*) 'Does the grass/crop needs reshaping?'
2807	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
2808	WRITE(numout,) 'qm_height, ', (Cl_target(1) sla(j) * lai_to_height(j))
2809	WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(1)-Cl(1), Cl_target(1), Cl(1)
2810	WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(1)-Cs(1), Cs_target(1), Cs(1)
2811	WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(1)-Cr(1), Cr_target(1), Cr(1)
2812	ENDIF
2813
2814
2815	!! 5.3.3.2 Phenological growth
2816	! Phenological growth and reshaping of the grass/crop in line with the pipe model. Turnover removes
2817	! C from the different plant components but at a component-specific rate, as such the allometric
2818	! constraints are distorted at every time step and should be restored before ordinary growth can
2819	! take place
2820
2821	!! 5.3.3.2.1 The available structural C can sustain the available leaves and roots
2822	! Calculate whether the structural c is in allometric balance. The target values should
2823	! always be larger than the current pools so the use of ABS is redundant but was used to
2824	! be on the safe side (here and in the rest of the module) as it could help to find
2825	! logical flaws.
2826	IF ( ABS(Cs_target(1) - Cs(1)) .LT. min_stomate ) THEN
2827
2828	Cs_incp(1) = MAX(zero, Cs_target(1) - Cs(1))
2829
2830	! Enough leaves and structural biomass, only grow roots
2831	IF ( ABS(Cl_target(1) - Cl(1)) .LT. min_stomate ) THEN
2832
2833	! Allocate at the tree level to restore allometric balance
2834	Cl_incp(1) = MAX(zero, Cl_target(1) - Cl(1))
2835	Cr_incp(1) = MAX( MIN(b_inc_tot / ind(ipts,j) - Cs_incp(1) - Cl_incp(1), &
2836	Cr_target(1) - Cr(1)), zero )
2837
2838	! Write debug comments to output file
2839	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
2840	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
2841	b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
2842	grow_wood, circ_class_n, ind, 12)
2843	ENDIF
2844
2845	! Sufficient structural C and roots, allocate C to leaves
2846	ELSEIF ( ABS(Cr_target(1) - Cr(1)) .LT. min_stomate ) THEN
2847
2848	! Allocate at the tree level to restore allometric balance
2849	Cr_incp(1) = MAX(zero, Cr_target(1) - Cr(1))
2850	Cl_incp(1) = MAX( MIN(b_inc_tot / ind(ipts,j) - Cs_incp(1) - Cr_incp(1), &
2851	Cl_target(1) - Cl(1)), zero )
2852
2853	! Update vegetation height
2854	qm_height = (Cl(1) + Cl_incp(1)) * sla(j) * lai_to_height(j)
2855
2856	! Write debug comments to output file
2857	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
2858	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
2859	b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
2860	grow_wood, circ_class_n, ind, 13)
2861	ENDIF
2862
2863	! Both leaves and roots are needed to restore the allometric relationships
2864	ELSEIF ( ABS(Cl_target(1) - Cl(1)) .GT. min_stomate .AND. &
2865	ABS(Cr_target(1) - Cr(1)) .GT. min_stomate ) THEN
2866
2867	! Allocate at the tree level to restore allometric balance
2868	! The equations can be rearanged and written as
2869	! (i) b_inc = Cl_inc + Cr_inc
2870	! (ii) Cr_inc = (Cl_inc+Cl)/LF - Cr
2871	! Substitue (ii) in (i) and solve for Cl_inc
2872	! <=> Cl_inc = (LF*(b_inc+Cr)-Cl)/(1+LF)
2873	Cl_incp(1) = MIN( ((LF(ipts,j) * ((b_inc_tot/ind(ipts,j)) - Cs_incp(1) + Cr(1))) - Cl(1)) / &
2874	(1 + LF(ipts,j)), Cl_target(1) - Cl(1) )
2875	Cr_incp(1) = MIN ( ((Cl_incp(1) + Cl(1)) / LF(ipts,j)) - Cr(1), &
2876	Cr_target(1) - Cr(1))
2877
2878	! The imbalance between Cr and Cl can be so big that (Cl+Cl_inc)/LF is still less
2879	! then the available root carbon (observed!). This would result in a negative Cr_incp
2880	IF ( Cr_incp(1) .LT. zero ) THEN
2881
2882	Cl_incp(1) = MIN( b_inc_tot/ind(ipts,j) - Cs_incp(1), Cl_target(1) - Cl(1) )
2883	Cr_incp(1) = b_inc_tot/ind(ipts,j) - Cs_incp(1) - Cl_incp(1)
2884
2885	ELSEIF (Cl_incp(1) .LT. zero) THEN
2886
2887	Cr_incp(1) = MIN( b_inc_tot/ind(ipts,j) - Cs_incp(1), Cr_target(1) - Cr(1) )
2888	Cl_incp(1) = (b_inc_tot/ind(ipts,j)) - Cs_incp(1) - Cr_incp(1)
2889
2890	ENDIF
2891
2892	! Update vegetation height
2893	qm_height = (Cl(1) + Cl_incp(1)) * sla(j) * lai_to_height(j)
2894
2895	! Write debug comments to output file
2896	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
2897	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
2898	b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
2899	grow_wood, circ_class_n, ind, 14)
2900	ENDIF
2901
2902	ELSE
2903
2904	WRITE(numout,*) 'WARNING 12: Exc 1-3 unexpected exception'
2905	WRITE(numout,*) 'WARNING 12: PFT, ipts: ',j,ipts
2906	IF(ld_stop)THEN
2907	CALL ipslerr_p (3,'growth_fun_all',&
2908	'WARNING 12: Exc 1-3 unexpected exception','','')
2909	ENDIF
2910
2911	ENDIF
2912
2913
2914	!! 5.3.3.3.2 Enough leaves to sustain the structural C and roots
2915	ELSEIF ( ABS(Cl_target(1) - Cl(1)) .LT. min_stomate ) THEN
2916
2917	Cl_incp(1) = MAX(zero, Cl_target(1) - Cl(1))
2918
2919	! Enough leaves and structural C, only grow roots
2920	! This duplicates Exc 1 and these lines should never be called
2921	IF ( ABS(Cs_target(1) - Cs(1)) .LT. min_stomate ) THEN
2922
2923	! Allocate at the tree level to restore allometric balance
2924	Cs_incp(1) = MAX(zero, Cs_target(1) - Cs(1))
2925	Cr_incp(1) = MAX( MIN(b_inc_tot/ind(ipts,j) - Cl_incp(1) - Cs_incp(1), &
2926	Cr_target(1) - Cr(1)), zero )
2927
2928	! Write debug comments to output file
2929	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
2930	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
2931	b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
2932	grow_wood, circ_class_n, ind, 15)
2933	ENDIF
2934
2935	! Enough leaves and roots. Need to grow structural C to support the available canopy and roots
2936	ELSEIF ( ABS(Cr_target(1) - Cr(1)) .LT. min_stomate ) THEN
2937
2938	Cr_incp(1) = MAX(zero, Cr_target(1) - Cr(1))
2939	Cs_incp(1) = MAX( MIN(b_inc_tot/ind(ipts,j) - Cr_incp(1) - Cl_incp(1), &
2940	Cs_target(1) - Cs(1)), zero )
2941
2942	! Write debug comments to output file
2943	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
2944	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
2945	b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
2946	grow_wood, circ_class_n, ind, 16)
2947	ENDIF
2948
2949	! Need both structural C and roots to restore the allometric relationships
2950	ELSEIF ( ABS(Cs_target(1) - Cs(1) ) .GT. min_stomate .AND. &
2951	ABS(Cr_target(1) - Cr(1)) .GT. min_stomate ) THEN
2952
2953	! First try if we can simply satisfy the allocation needs
2954	IF (Cs_target(1) - Cs(1) + Cr_target(1) - Cr(1) .LE. &
2955	b_inc_tot/ind(ipts,j) - Cl_incp(1)) THEN
2956
2957	Cr_incp(1) = Cr_target(1) - Cr(1)
2958	Cs_incp(1) = Cs_target(1) - Cs(1)
2959
2960	! Try to satisfy the need for the roots
2961	ELSEIF (Cr_target(1) - Cr(1) .LE. b_inc_tot/ind(ipts,j) - Cl_incp(1)) THEN
2962
2963	Cr_incp(1) = Cr_target(1) - Cr(1)
2964	Cs_incp(1) = b_inc_tot/ind(ipts,j) - Cl_incp(1) - Cr_incp(1)
2965
2966
2967	! There is not enough use whatever is available
2968	ELSE
2969
2970	Cr_incp(1) = b_inc_tot/ind(ipts,j) - Cl_incp(1)
2971	Cs_incp(1) = zero
2972
2973	ENDIF
2974
2975	! Write debug comments to output file
2976	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
2977	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
2978	b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
2979	grow_wood, circ_class_n, ind, 17)
2980	ENDIF
2981
2982	ELSE
2983
2984	WRITE(numout,*) 'WARNING 13: Exc 4-6 unexpected exception'
2985	WRITE(numout,*) 'WARNING 13: PFT, ipts: ',j,ipts
2986	IF(ld_stop)THEN
2987	CALL ipslerr_p (3,'growth_fun_all',&
2988	'WARNING 13: Exc 4-6 unexpected exception','','')
2989	ENDIF
2990
2991	ENDIF
2992
2993
2994	!! 5.3.3.3.3 Enough roots to sustain the wood and leaves
2995	ELSEIF ( ABS(Cr_target(1) - Cr(1)) .LT. min_stomate ) THEN
2996
2997	Cr_incp(1) = MAX(zero, Cr_target(1) - Cr(1))
2998
2999	! Enough roots and wood, only grow leaves
3000	! This duplicates Exc 2 and these lines should thus never be called
3001	IF ( ABS(Cs_target(1) - Cs(1)) .LT. min_stomate ) THEN
3002
3003	! Allocate at the tree level to restore allometric balance
3004	Cs_incp(1) = MAX(zero, Cs_target(1) - Cs(1))
3005	Cl_incp(1) = MAX( MIN(b_inc_tot/ind(ipts,j) - Cr_incp(1) - Cs_incp(1), &
3006	Cl_target(1) - Cl(1)), zero )
3007
3008	! Update vegetation height
3009	qm_height = (Cl(1) + Cl_incp(1)) * sla(j) * lai_to_height(j)
3010
3011	! Write debug comments to output file
3012	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
3013	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
3014	b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
3015	grow_wood, circ_class_n, ind, 18)
3016	ENDIF
3017
3018	! Enough leaves and roots. Need to grow sapwood to support the available canopy and roots
3019	! Duplicates Exc. 4 and these lines should thus never be called
3020	ELSEIF ( ABS(Cl_target(1) - Cl(1)) .LT. min_stomate ) THEN
3021
3022	! Allocate at the tree level to restore allometric balance
3023	Cl_incp(1) = MAX(zero, Cl_target(1) - Cl(1))
3024	Cs_incp(1) = MAX( MIN(b_inc_tot/ind(ipts,j) - Cr_incp(1) - Cl_incp(1), &
3025	Cs_target(1) - Cs(1) ), zero )
3026
3027	! Write debug comments to output file
3028	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
3029	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
3030	b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
3031	grow_wood, circ_class_n, ind, 19)
3032	ENDIF
3033
3034	! Need both wood and leaves to restore the allometric relationships
3035	ELSEIF ( ABS(Cs_target(1) - Cs(1)) .GT. min_stomate .AND. &
3036	ABS(Cl_target(1) - Cl(1)) .GT. min_stomate ) THEN
3037
3038	! circ_class_ba_eff and circ_class_height_eff are already calculated
3039	! for a tree in balance. It would be rather complicated to follow
3040	! the allometric rules for wood allocation (implying changes in height
3041	! and basal area) because the tree is not in balance.First try if we
3042	! can simply satisfy the allocation needs
3043	IF (Cs_target(1) - Cs(1) + Cl_target(1) - Cl(1) .LE. &
3044	b_inc_tot/ind(ipts,j) - Cr_incp(1)) THEN
3045
3046	Cl_incp(1) = Cl_target(1) - Cl(1)
3047	Cs_incp(1) = Cs_target(1) - Cs(1)
3048
3049	! Try to satisfy the need for leaves
3050	ELSEIF (Cl_target(1) - Cl(1) .LE. b_inc_tot/ind(ipts,j) - Cr_incp(1)) THEN
3051
3052	Cl_incp(1) = Cl_target(1) - Cl(1)
3053	Cs_incp(1) = b_inc_tot/ind(ipts,j) - Cr_incp(1) - Cl_incp(1)
3054
3055	! There is not enough use whatever is available
3056	ELSE
3057
3058	Cl_incp(1) = b_inc_tot/ind(ipts,j) - Cr_incp(1)
3059	Cs_incp(1) = zero
3060
3061	ENDIF
3062
3063	! Calculate the height of the expanded canopy
3064	qm_height(ipts,j) = (Cl(1) + Cl_inc(1)) * sla(j) * lai_to_height(j)
3065
3066	! Write debug comments to output file
3067	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
3068	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
3069	b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
3070	grow_wood, circ_class_n, ind, 20)
3071	ENDIF
3072
3073	ELSE
3074
3075	WRITE(numout,*) 'WARNING 14: Exc 7-9 unexpected exception'
3076	WRITE(numout,*) 'WARNING 14: PFT, ipts: ',j, ipts
3077	IF(ld_stop)THEN
3078	CALL ipslerr_p (3,'growth_fun_all',&
3079	'WARNING 14: Exc 7-9 unexpected exception','','')
3080	ENDIF
3081
3082	ENDIF
3083
3084	! Either Cl_target, Cs_target or Cr_target should be zero
3085	ELSE
3086
3087	! Something possibly important was overlooked
3088	WRITE(numout,*) 'WARNING 15: Logical flaw in phenological allocation '
3089	WRITE(numout,*) 'WARNING 15: PFT, ipts: ',j, ipts
3090	WRITE(numout,*) 'Cs - Cs_target', Cs(1), Cs_target(1)
3091	WRITE(numout,*) 'Cl - Cl_target', Cl(1), Cl_target(1)
3092	WRITE(numout,*) 'Cr - Cr_target', Cr(1), Cr_target(1)
3093	IF(ld_stop)THEN
3094	CALL ipslerr_p (3,'growth_fun_all',&
3095	'WARNING 15: Logical flaw in phenological allocation','','')
3096	ENDIF
3097
3098	ENDIF
3099
3100
3101	!! 5.3.4 Wrap-up phenological allocation
3102	IF ( Cl_incp(1) .GE. zero .OR. Cr_incp(1) .GE. zero .OR. Cs_incp(1) .GE. zero) THEN
3103
3104	! Fake allocation for less messy equations in next
3105	! case, incp needs to be added to inc at the end
3106	Cl(1) = Cl(1) + Cl_incp(1)
3107	Cr(1) = Cr(1) + Cr_incp(1)
3108	Cs(1) = Cs(1) + Cs_incp(1)
3109	b_inc_tot = b_inc_tot - (ind(ipts,j) * (Cl_incp(1) + Cr_incp(1) + Cs_incp(1)))
3110
3111	ELSE
3112
3113	! The code was written such that the increment pools should be greater than or equal
3114	! to zero. If this is not the case, something fundamental is wrong with the if-then
3115	! constructs under Â§5.3.3.2
3116	WRITE(numout,*) 'WARNING 16: numerical problem, one of the increment pools is less than zero'
3117	WRITE(numout,*) 'WARNING 16: Cl_incp(1), Cr_incp(1), Cs_incp(1), j, ipts',&
3118	Cl_incp(1), Cr_incp(1), Cs_incp(1), j, ipts
3119	IF(ld_stop)THEN
3120	CALL ipslerr_p (3,'growth_fun_all',&
3121	'WARNING 16: numerical problem, one of the increment pools is less than zero','','')
3122	ENDIF
3123
3124	ENDIF
3125
3126	! Height depends on Cl, so update height when Cl gets updated
3127	qm_height(ipts,j) = Cl(1) * sla(j) * lai_to_height(j)
3128
3129	! Something is wrong with the calculations
3130	IF (b_inc_tot .LT. -min_stomate) THEN
3131
3132	WRITE(numout,*) 'WARNING 17: numerical problem overspending in the phenological allocation'
3133	WRITE(numout,*) 'WARNING 17: b_inc_tot, j, ipts',b_inc_tot, j, ipts
3134	WRITE(numout,*) 'WARNING 17: Cl_incp, Cr_incp, Cs_incp, ', Cl_incp(1), Cr_incp(1), Cs_incp(1)
3135	IF(ld_stop)THEN
3136	CALL ipslerr_p (3,'growth_fun_all',&
3137	'WARNING 17: numerical problem overspending in the phenological allocation','','')
3138	ENDIF
3139
3140	ENDIF
3141
3142
3143	!! 5.3.5 Calculate the expected size of the reserve pool
3144	! use the minimum of either (1) 20% of the total sapwood biomass or
3145	! (2) the amount of carbon needed to develop the optimal LAI and the roots
3146	! This reserve pool estimate is only used to decide whether wood should be
3147	! grown or not. When really dealing with the reserves the reserve pool is
3148	! recalculated. See further below Â§7.1.
3149
3150	!+++CHECK+++
3151	! Sapwood has no meaning for grasses and crops - reserves should sustain the canopy
3152	! For trees 2% was used, given the much lower sapwood pool for grasses and crops we
3153	! set it arbitrairly to 10%
3154	reserve_pool = MIN( 0.10 * ( biomass(ipts,j,isapabove,icarbon) + &
3155	biomass(ipts,j,isapbelow,icarbon)), lai_target(ipts,j)/sla(j)*&
3156	(1.+0.3/ltor(ipts,j)) )
3157	!+++++++++++
3158	grow_wood = .TRUE.
3159
3160	! If the carbohydrate pool is too small, don't grow structural C and
3161	! thus skip ordinary allocation
3162	IF ( (pheno_type(j) .NE. 1) .AND. &
3163	(biomass(ipts,j,icarbres,icarbon) .LE. reserve_pool) ) THEN
3164
3165	grow_wood = .FALSE.
3166
3167	ENDIF
3168
3169	! Write debug comments to output file
3170	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
3171	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
3172	delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
3173	KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
3174	circ_class_n, ind, 21)
3175	ENDIF
3176
3177
3178	!! 5.3.6 Ordinary growth
3179	! Allometric relationship between components is respected, sustain
3180	! ordinary growth and allocate biomass to leaves, wood, roots and fruits.
3181	IF ( (ABS(Cl_target(1) - Cl(1) ) .LE. min_stomate) .AND. &
3182	(ABS(Cs_target(1) - Cs(1) ) .LE. min_stomate) .AND. &
3183	(ABS(Cr_target(1) - Cr(1) ) .LE. min_stomate) .AND. &
3184	(grow_wood) .AND. (b_inc_tot/ind(ipts,j) .GT. min_stomate) ) THEN
3185
3186	! Allocate fraction of carbon to fruit production (at the tree level)
3187	Cf_inc(:) = b_inc_tot * fruit_alloc(j)
3188
3189	! Residual carbon is allocated to the other components (b_inc_tot is
3190	! at the stand level)
3191	b_inc_tot = b_inc_tot * (1-fruit_alloc(j))
3192
3193	! Following allometric allocation
3194	! (i) b_inc = Cl_inc + Cr_inc + Cs_inc
3195	! (ii) Cr_inc = (Cl + Cl_inc)/LF - Cr
3196	! (iii) Cs_inc = (Cl + Cl_inc) / KF - Cs
3197	! Substitue (ii) and (iii) in (i) and solve for Cl_inc
3198	! <=> b_inc = Cl_inc + ( Cl_inc + Cl ) / KF - Cs + ( Cl_inc + Cl ) / LF - Cr
3199	! <=> b_inc = Cl_inc * ( 1.+ 1/KF + 1./LF ) + Cl/LF - Cs - Cr
3200	! <=> Cl_inc = ( b_inc - Cl/LF + Cs + Cr ) / ( 1.+ 1/KF + 1./LF )
3201	Cl_inc(1) = MAX( (b_inc_tot/ind(ipts,j) - Cl(1)/LF(ipts,j) - &
3202	Cl(1)/KF(ipts,j) + Cs(1) + Cr(1)) / &
3203	(1. + 1./KF(ipts,j) + 1./LF(ipts,j)), zero)
3204
3205	IF (Cl_inc(1) .LE. zero) THEN
3206
3207	Cr_inc(:) = zero
3208	Cs_inc(:) = zero
3209
3210	ELSE
3211
3212	! Calculate the height of the expanded canopy
3213	qm_height(ipts,j) = (Cl(1) + Cl_inc(1)) * sla(j) * lai_to_height(j)
3214
3215	! Use the solution for Cl_inc to calculate Cr_inc and Cs_inc according to (ii) and (iii)
3216	Cr_inc(1) = (Cl(1) + Cl_inc(1)) / LF(ipts,j) - Cr(1)
3217	Cs_inc(1) = (Cl(1)+Cl_inc(1)) / KF(ipts,j) - Cs(1)
3218
3219	ENDIF
3220
3221	! Write debug comments to output file
3222	IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
3223	CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
3224	b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
3225	grow_wood, circ_class_n, ind, 22)
3226	ENDIF
3227
3228	! Wrap-up ordinary growth
3229	! Calculate C that was not allocated, note that Cf_inc was already substracted
3230	b_inc_tot = b_inc_tot - (ind(ipts,j) * (Cl_inc(1) + Cr_inc(1) + Cs_inc(1)))
3231
3232	!---TEMP---
3233	IF (j.EQ.test_pft .AND. ld_alloc) THEN
3234	WRITE(numout,*) 'wrap-up ordinary allocation, left b_in_tot, ', b_inc_tot
3235	ENDIF
3236	!----------
3237
3238
3239	!! 5.3.7 Don't grow wood, use C to fill labile pool
3240	ELSEIF ( (.NOT. grow_wood) .AND. (b_inc_tot .GT. min_stomate) ) THEN
3241
3242	! Calculate the C that needs to be distributed to the
3243	! labile pool. The fraction is proportional to the ratio
3244	! between the total allocatable biomass and the unallocated
3245	! biomass per tree (b_inc now contains the unallocated
3246	! biomass). At the end of the allocation scheme bm_alloc_tot
3247	! is substracted from the labile biomass pool to update the
3248	! biomass pool (biomass(:,:,ilabile) = biomass(:,:,ilabile) -
3249	! bm_alloc_tot(:,:)). At that point, the scheme puts the
3250	! unallocated b_inc into the labile pool. What we
3251	! want is that the unallocated fraction is removed from
3252	! ::bm_alloc_tot such that only the allocated C is removed
3253	! from the labile pool. b_inc_tot will be moved back into
3254	! the labile pool in 5.2.11
3255	bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - b_inc_tot
3256	biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) + &
3257	b_inc_tot
3258
3259	! Wrap-up ordinary growth
3260	! Calculate C that was not allocated (b_inc_tot), the
3261	! equation should read b_inc_tot = b_inc_tot - b_inc_tot
3262	! note that Cf_inc was already substracted
3263	b_inc_tot = zero
3264
3265	!---TEMP---
3266	IF (j.EQ.test_pft .AND. ld_alloc) THEN
3267	WRITE(numout,*) 'No wood growth, move remaining C to labile pool'
3268	WRITE(numout,*) 'bm_alloc_tot_new, ',bm_alloc_tot(ipts,j)
3269	WRITE(numout,*) 'wrap-up ordinary allocation, left b_inc_tot, ', b_inc_tot
3270	ENDIF
3271	!----------
3272
3273	!! 5.3.8 Error - the allocation scheme is overspending
3274	ELSEIF (b_inc_tot .LE. min_stomate) THEN
3275
3276	IF (b_inc_tot .LT. -min_stomate) THEN
3277
3278	! Something is wrong with the calculations
3279	WRITE(numout,*) 'WARNING 18: numerical problem overspending in ordinary allocation'
3280	WRITE(numout,*) 'WARNING 18: PFT, ipts, b_inc_tot: ', j, ipts,b_inc_tot
3281	IF(ld_stop)THEN
3282	CALL ipslerr_p (3,'growth_fun_all',&
3283	'WARNING 18: numerical problem overspending in ordinary allocation','','')
3284	ENDIF
3285
3286	ELSE
3287
3288	IF (j .EQ. test_pft .AND. ld_alloc) THEN
3289
3290	! Succesful allocation
3291	WRITE(numout,*) 'Successful allocation'
3292
3293	ENDIF
3294
3295	ENDIF
3296
3297	! Althought the biomass components respect the allometric relationships, there
3298	! is no carbon left to allocate
3299	b_inc_tot = zero
3300	Cl_inc(1) = zero
3301	Cs_inc(1) = zero
3302	Cr_inc(1) = zero
3303	Cf_inc(1) = zero
3304
3305	ELSE
3306
3307	WRITE(numout,*) 'WARNING 19: Logical flaw unexpected result in ordinary allocation'
3308	WRITE(numout,*) 'WARNING 19: PFT, ipts: ', j, ipts
3309	WRITE(numout,*) 'WARNING 19: ',ABS(Cl_target(1) - Cl(1) ) , Cl(1)
3310	WRITE(numout,*) 'WARNING 19: ',ABS(Cs_target(1) - Cs(1) ) , Cs(1)
3311	WRITE(numout,*) 'WARNING 19: ',ABS(Cr_target(1) - Cr(1) ) , Cr(1)
3312	WRITE(numout,*) 'WARNING 19: ',grow_wood
3313	WRITE(numout,*) 'WARNING 19: ',b_inc_tot,ind(ipts,j),b_inc_tot/ind(ipts,j)
3314	IF(ld_stop)THEN
3315	CALL ipslerr_p (3,'growth_fun_all',&
3316	'WARNING 19: Logical flaw unexpected result in ordinary allocation','','')
3317	ENDIF
3318
3319	ENDIF ! Ordinary allocation
3320
3321
3322	!! 5.3.9 Forced allocation
3323	! Although this should not happen, in case the functional allocation did not consume
3324	! all the allocatable carbon, the remaining C is left for the next day, and some of
3325	! the biomass is used to produce fruits (tuned)
3326	IF ( b_inc_tot .GT. min_stomate ) THEN
3327
3328	WRITE(numout,*) 'WARNING 20: unexpected outcome force allocation'
3329	WRITE(numout,*) 'WARNING 20: grow_wood, b_inc_tot: ', grow_wood, b_inc_tot
3330	WRITE(numout,*) 'WARNING 20: PFT, ipts: ',j,ipts
3331	IF(ld_stop)THEN
3332	CALL ipslerr_p (3,'growth_fun_all',&
3333	'WARNING 20: unexpected outcome force allocation','','')
3334	ENDIF
3335
3336	!+++CHECK+++
3337	!!$ ! Calculate fraction that will be allocated to fruit. The fraction is proportional to the
3338	!!$ ! ratio between the total allocatable biomass and the unallocated biomass per tree
3339	!!$ frac = 0.1 * MIN(1., bm_alloc_tot(ipts,j) / b_inc_tot)
3340	!!$ Cf_inc(:) = Cf_inc(:) + b_inc_tot * frac
3341	!!$ b_inc_tot = b_inc_tot * (1 - frac)
3342	!!$
3343	!!$ ! Calculate the C that needs to be distributed to the labile pool. The fraction is proportional
3344	!!$ ! to the ratio between the total allocatable biomass and the unallocated biomass per tree (b_inc
3345	!!$ ! now contains the unallocated biomass). At the end of the allocation scheme bm_alloc_tot is
3346	!!$ ! substracted from the labile biomass pool to update the biomass pool (biomass(:,:,ilabile) =
3347	!!$ ! biomass(:,:,ilabile,icarbon) - bm_alloc_tot(:,:)). At that point, the scheme puts the
3348	!!$ ! unallocated b_inc into the labile pool.
3349	!!$ bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) * ( 1. - (1.-frac) * b_inc_tot / bm_alloc_tot(ipts,j) )
3350	!++++++++++
3351
3352	ELSEIF ( (b_inc_tot .LT. min_stomate) .AND. (b_inc_tot .GE. -min_stomate) ) THEN
3353
3354	! Successful allocation
3355	!---TEMP---
3356	IF (j.EQ.test_pft .AND. ld_alloc) THEN
3357	WRITE(numout,*) 'Successful allocation'
3358	ENDIF
3359	!----------
3360
3361	ELSE
3362
3363	! Something possibly important was overlooked
3364	IF ( (b_inc_tot .LT. 100min_stomate) .AND. (b_inc_tot .GE. -100min_stomate) ) THEN
3365	IF (j.EQ.test_pft .AND. ld_alloc) THEN
3366	WRITE(numout,*) 'Marginally successful allocation - precision is better than 10-6', j
3367	ENDIF
3368	ELSE
3369	WRITE(numout,*) 'WARNING 21: Logical flaw unexpected result in ordinary allocation'
3370	WRITE(numout,*) 'WARNING 21: b_inc_tot', b_inc_tot
3371	WRITE(numout,*) 'WARNING 21: PFT, ipts: ',j,ipts
3372	CALL ipslerr_p (3,'growth_fun_all',&
3373	'WARNING 21: Logical flaw unexpected result in ordinary allocation','','')
3374	ENDIF
3375
3376	ENDIF
3377
3378	! The second problem we need to catch is when one of the increment pools is
3379	! negative. This is an undesired outcome (see comment where ::KF_old is
3380	! calculated in this routine. In that case we write a warning, set all increment
3381	! pools to zero and try it again at the next time step. A likely cause of this
3382	! problem is a too large change in KF from one time step to another. Try decreasing
3383	! the acceptable value for an absolute increase in KF.
3384	IF (Cs_inc(1) .LT. zero .OR. Cr_inc(1) .LT. zero .OR. Cs_inc(1) .LT. zero) THEN
3385
3386	! Do not allocate - save the carbon for the next time step
3387	Cl_inc(1) = zero
3388	Cr_inc(1) = zero
3389	Cs_inc(1) = zero
3390	WRITE(numout,*) 'WARNING 22: numerical problem, one of the increment pools is less than zero'
3391	WRITE(numout,*) 'WARNING 22: PFT, ipts: ',j,ipts
3392
3393	ENDIF
3394
3395
3396	!! 5.3.10 Wrap-up phenological and ordinary allocation
3397	Cl_inc(1) = Cl_inc(1) + Cl_incp(1)
3398	Cr_inc(1) = Cr_inc(1) + Cr_incp(1)
3399	Cs_inc(1) = Cs_inc(1) + Cs_incp(1)
3400	residual(ipts,j) = b_inc_tot
3401
3402	!---TEMP---
3403	IF (j.EQ.test_pft .AND. ld_alloc) THEN
3404	WRITE(numout,*) 'Final allocation', j
3405	WRITE(numout,*) 'Cl, Cs, Cr', Cl(1), Cs(1), Cr(1)
3406	WRITE(numout,*) 'Cl_incp, Cs_incp, Cr_incp, ', Cl_incp(1), Cs_incp(1), Cr_incp(1)
3407	WRITE(numout,*) 'Cl_inc, Cs_ins, Cr_inc, Cf_inc, ', Cl_inc(1), Cs_inc(1), Cr_inc(1), Cf_inc(1)
3408	WRITE(numout,*) 'unallocated/residual, ', b_inc_tot
3409	ENDIF
3410	!----------
3411
3412
3413	!! 5.3.11 Account for the residual
3414	! The residual is usually around ::min_stomate but we deal
3415	! with it anyway to make sure the mass balance is closed
3416	! and as a way to detect errors. Move the unallocated carbon
3417	! back into the labile pool
3418	IF (biomass(ipts,j,ilabile,icarbon) + residual(ipts,j) .LE. min_stomate) THEN
3419
3420	deficit = biomass(ipts,j,ilabile,icarbon) + residual(ipts,j)
3421
3422	! The deficit is less than the carbon reserve
3423	IF (-deficit .LE. biomass(ipts,j,icarbres,icarbon)) THEN
3424
3425	! Pay the deficit from the reserve pool
3426	biomass(ipts,j,icarbres,icarbon) = &
3427	biomass(ipts,j,icarbres,icarbon) + deficit
3428	biomass(ipts,j,ilabile,icarbon) = &
3429	biomass(ipts,j,ilabile,icarbon) - deficit
3430
3431	ELSE
3432
3433	! Not enough carbon to pay the deficit
3434	! There is likely a bigger problem somewhere in
3435	! this routine
3436	WRITE(numout,*) 'WARNING 23: PFT, ipts: ',j,ipts
3437	CALL ipslerr_p (3,'growth_fun_all',&
3438	'WARNING 23: numerical problem overspending ',&
3439	'when trying to account for unallocatable C ','')
3440
3441	ENDIF
3442
3443	ELSE
3444
3445	! Move the unallocated carbon back into the labile pool
3446	biomass(ipts,j,ilabile,icarbon) = &
3447	biomass(ipts,j,ilabile,icarbon) + residual(ipts,j)
3448
3449	ENDIF
3450
3451	!! 5.3.12 Standardise allocation factors
3452	! Strictly speaking the allocation factors do not need to be calculated because the functional
3453	! allocation scheme allocates absolute amounts of carbon. Hence, Cl_inc could simply be added to
3454	! biomass(:,:,ileaf,icarbon), Cr_inc to biomass(:,:,iroot,icarbon), etc. However, using allocation
3455	! factors bears some elegance in respect to distributing the growth respiration if this would be
3456	! required. Further it facilitates comparison to the resource limited allocation scheme
3457	! (stomate_growth_res_lim.f90) and it comes in handy for model-data comparison. This allocation
3458	! takes place at the tree level - note that ::biomass is the only prognostic variable from the tree-based
3459	! allocation
3460
3461	! Allocation
3462	Cl_inc(1) = MAX(zero, ind(ipts,j) * Cl_inc(1))
3463	Cr_inc(1) = MAX(zero, ind(ipts,j) * Cr_inc(1))
3464	Cs_inc(1) = MAX(zero, ind(ipts,j) * Cs_inc(1))
3465	Cf_inc(1) = MAX(zero, ind(ipts,j) * Cf_inc(1))
3466
3467	! Total_inc is based on the updated Cl_inc, Cr_inc, Cs_inc and Cf_inc. Therefore, do not multiply
3468	! ind(ipts,j) again
3469	total_inc = (Cf_inc(1) + Cl_inc(1) + Cs_inc(1) + Cr_inc(1))
3470
3471	! Relative allocation
3472	IF ( total_inc .GT. min_stomate ) THEN
3473
3474	Cl_inc(1) = Cl_inc(1) / total_inc
3475	Cs_inc(1) = Cs_inc(1) / total_inc
3476	Cr_inc(1) = Cr_inc(1) / total_inc
3477	Cf_inc(1) = Cf_inc(1) / total_inc
3478
3479	ELSE
3480
3481	bm_alloc_tot(ipts,j) = zero
3482	Cl_inc(1) = zero
3483	Cs_inc(1) = zero
3484	Cr_inc(1) = zero
3485	Cf_inc(1) = zero
3486
3487	ENDIF
3488
3489
3490	!! 5.3.13 Convert allocation to allocation facors
3491	! Convert allocation of individuals to ORCHIDEE's allocation factors - see comment for 5.2.5
3492	! Aboveground sapwood allocation is age dependent in trees, but there is only aboveground
3493	! allocation in grasses
3494	alloc_sap_above = un
3495
3496	! Leaf, wood, root and fruit allocation
3497	f_alloc(ipts,j,ileaf) = Cl_inc(1)
3498	f_alloc(ipts,j,isapabove) = Cs_inc(1)*alloc_sap_above
3499	f_alloc(ipts,j,isapbelow) = Cs_inc(1)*(1.-alloc_sap_above)
3500	f_alloc(ipts,j,iroot) = Cr_inc(1)
3501	f_alloc(ipts,j,ifruit) = Cf_inc(1)
3502
3503	ELSEIF (.NOT. is_tree(j)) THEN
3504
3505	IF(ld_alloc) WRITE(numout,*) 'there is no non-tree biomass to allocate, PFT, ', j
3506	f_alloc(ipts,j,ileaf) = zero
3507	f_alloc(ipts,j,isapabove) = zero
3508	f_alloc(ipts,j,isapbelow) = zero
3509	f_alloc(ipts,j,iroot) = zero
3510	f_alloc(ipts,j,ifruit) = zero
3511
3512	ENDIF ! .NOT. is_tree(j) and there is biomass to allocate (Â§5.3 - far far up)
3513
3514	ENDDO ! npts
3515
3516	!! 5.4 Allocate allocatable biomass to different plant compartments
3517	! The amount of allocatable biomass to each compartment is a fraction ::f_alloc of the total
3518	! allocatable biomass - see comment for 5.2.6
3519	DO k = 1, nparts
3520
3521	bm_alloc(:,j,k,icarbon) = f_alloc(:,j,k) * (bm_alloc_tot(:,j) - residual(:,j))
3522
3523	ENDDO
3524
3525	!---TEMP---
3526	IF (j .EQ. test_pft .AND. ld_alloc) THEN
3527	DO ipts=1,npts
3528	IF(test_grid == ipts)THEN
3529	WRITE(numout,*) 'bm_alloc_tot(ipts,j), ', j, bm_alloc_tot(ipts,j)
3530	WRITE(numout,*) 'f_alloc(ipts,j,:), ', f_alloc(ipts,j,:)
3531	WRITE(numout,*) 'residual(ipts,j), ', residual(ipts,j)
3532	ENDIF
3533	END DO
3534	ENDIF
3535	!----------
3536
3537	ENDDO ! # End Loop over # of PFTs
3538
3539	! we need to zero the array for PFT 1, since it has not been calculated but it
3540	! is used in implict loops below
3541	bm_alloc_tot(:,1) = zero
3542	bm_alloc(:,1,:,icarbon) = zero
3543
3544
3545	!! 6. Update the biomass with newly allocated biomass after respiration
3546
3547	! Update the biomass pools
3548	!---TEMP---
3549	IF (ld_alloc) THEN
3550	DO ipts=1,npts
3551	DO j=1,nvm
3552	IF(ipts == test_grid .AND. j == test_pft)THEN
3553	WRITE(numout,*) 'biomass, ', biomass(test_grid,test_pft,:,icarbon)
3554	WRITE(numout,*) 'bm_alloc, ', bm_alloc(test_grid,test_pft,:,icarbon)
3555	ENDIF
3556	ENDDO
3557	ENDDO
3558	ENDIF
3559	!----------
3560	! I'm putting in a test here to see if we try to allocate
3561	! a negative amount of biomass. That's a bad thing if we do.
3562	DO ipts=1,npts
3563	DO j=1,nvm
3564	DO ipar=1,nparts
3565	IF(j == test_pft .AND. ipts == test_grid)THEN
3566	IF(bm_alloc(test_grid,test_pft,ipar,icarbon) .LT. zero)THEN
3567	WRITE(numout,*) 'Trying to allocate negative biomass!'
3568	WRITE(numout,*) 'ipts,j,ipar: ',ipts,j,ipar
3569	WRITE(numout,*) 'bm_alloc(test_grid,test_pft,ipar,icarbon): ',&
3570	bm_alloc(test_grid,test_pft,ipar,icarbon)
3571	IF(ld_stop)THEN
3572	CALL ipslerr_p (3,'growth_fun_all',&
3573	'Trying to allocate negative biomass!','','')
3574	ENDIF
3575	ENDIF
3576	END IF
3577	ENDDO
3578	ENDDO
3579	ENDDO
3580
3581	biomass(:,:,:,icarbon) = biomass(:,:,:,icarbon) + bm_alloc(:,:,:,icarbon)
3582
3583
3584	!! 7. Use or fill reserve pools depending on relative size of the labile and reserve C pool
3585
3586	! +++ CHECK +++
3587	! Externalize all the hard coded values i.e. 0.3
3588
3589	! Calculate the labile pool for all plants and also the reserve pool for trees
3590	DO j = 2,nvm
3591
3592	DO ipts = 1,npts
3593
3594
3595	IF (veget_max(ipts,j) .LE. min_stomate) THEN
3596
3597	! this vegetation type is not present, so no reason to do the
3598	! calculation. CYCLE will take us out of the innermost DO loop
3599	CYCLE
3600
3601	ENDIF
3602
3603	! There is vegetation present and has started growing. The second and third condition
3604	! required to make the PFT survive the first year during which the long term climate
3605	! variables are initialized for the phenology. If these conditions are not added, the
3606	! reserves are respired well before growth ever starts
3607	IF ( veget_max(ipts,j) .GT. min_stomate .AND. &
3608	rue_longterm(ipts,j) .GE. zero .AND. &
3609	rue_longterm(ipts,j) .NE. un) THEN
3610
3611	!! 7.1 Calculate the optimal size of the pools
3612	! The size of the labile pool is proportional to the assumed activity of living tissues
3613	! and its relative nitrogen content). The numerical value of ::lab_fac is already a
3614	! tuning variable, the division by 10 (default for ::labile_reserve) stresses the importance
3615	! of this variable to scale other processes.
3616	!+++CHECK+++
3617	! There is an inconsistency in the calculation - most pools are in gN but leaves is in gC
3618	! The correction is proposed, that implies that the parameter labile_reserve will need to
3619	! be tuned
3620	!!$ VERSION WITH CONSISTENT UNITS
3621	!!$ labile_pool = lab_fac(ipts,j)/labile_reserve * &
3622	!!$ ( biomass(ipts,j,ileaf,icarbon) / cn_leaf_prescribed(j) + &
3623	!!$ fcn_root(j) * ( biomass(ipts,j,iroot,icarbon) + biomass(ipts,j,ifruit,icarbon) ) + &
3624	!!$ fcn_wood(j) * ( biomass(ipts,j,isapabove,icarbon) + biomass(ipts,j,isapbelow,icarbon) + &
3625	!!$ biomass(ipts,j,icarbres,icarbon) ) )
3626	!!$ ORIGINAL VERSION WITH INCONSISTENT UNITS
3627	!!$ labile_pool = lab_fac(ipts,j)/labile_reserve * ( biomass(ipts,j,ileaf,icarbon) + &
3628	!!$ fcn_root(j) * ( biomass(ipts,j,iroot,icarbon) + biomass(ipts,j,ifruit,icarbon) ) + &
3629	!!$ fcn_wood(j) * ( biomass(ipts,j,isapabove,icarbon) + biomass(ipts,j,isapbelow,icarbon) + &
3630	!!$ biomass(ipts,j,icarbres,icarbon) ) )
3631	!!$ labile_pool = MAX ( labile_pool, gpp_to_labile(j) * gpp_week(ipts,j) )
3632
3633	! We had an endless series of problems which were often difficult to
3634	! understand but which always seemed to be related to a sudden drop
3635	! in biomass(ilabile). This drop was often the result of a sudden
3636	! change in labile_pool. Given that there is not much science behind
3637	! this approach it seems a good idea to remove this max statement to
3638	! avoid sudden changes. Rather than using the actual biomass we propose
3639	! to use the target biomass. This assumes that the tree would like to
3640	! fill its labile pool to be optimal when it would be in allometric
3641	! balance.
3642	IF (is_tree(j)) THEN
3643
3644	! We will make use of the REAL sapwood, heartwood and effective height
3645	! and then calculate the target leaves and roots. This approach gives
3646	! us a target for a labile_pool of a tree in allometric balance.
3647	! Basal area at the tree level (m2 tree-1)
3648	circ_class_ba_eff(:) = wood_to_ba_eff(circ_class_biomass(ipts,j,:,:,icarbon),j)
3649
3650	! Current biomass pools per tree (gC tree^-1)
3651	! We will have different trees so this has to be calculated from the
3652	! diameter relationships
3653	Cs(:) = ( circ_class_biomass(ipts,j,:,isapabove,icarbon) + &
3654	circ_class_biomass(ipts,j,:,isapbelow,icarbon) ) * scal
3655
3656	DO l = 1,ncirc
3657
3658	! Calculate tree height
3659	circ_class_height_eff(l) = pipe_tune2(j)(4/picirc_class_ba_eff(l))**(pipe_tune3(j)/2)
3660
3661	! Use the pipe model to calculate the target leaf and root
3662	! biomasses
3663	Cl_target(l) = KF(ipts,j) * Cs(l) / circ_class_height_eff(l)
3664	Cr_target(l) = Cl_target(l) / LF(ipts,j)
3665
3666	ENDDO
3667
3668	! grasses and crops
3669	ELSEIF ( .NOT. is_tree(j)) THEN
3670
3671	Cs(:) = zero
3672	Cl_target(:) = zero
3673	Cr_target(:) = zero
3674	! Current biomass pools per grass/crop (gC ind^-1)
3675	! Cs has too many dimensions for grass/crops. To have a consistent notation the same variables
3676	! are used as for trees but the dimension of Cs, Cl and Cr i.e. ::ncirc should be ignored
3677	Cs(1) = biomass(ipts,j,isapabove,icarbon) * scal
3678
3679	! Use the pipe model to calculate the target leaf and root
3680	! biomasses
3681	Cl_target(1) = Cs(1) * KF(ipts,j)
3682	Cr_target(1) = Cl_target(1) / LF(ipts,j)
3683
3684	ENDIF !is_tree
3685
3686	! Accounting for the N-concentration of the tissue as a proxy
3687	! of tissue activity
3688	labile_pool = lab_fac(ipts,j)/labile_reserve(j) * &
3689	( SUM(Cl_target(:)) / cn_leaf_prescribed(j) + &
3690	SUM(Cr_target(:)) * fcn_root(j) + &
3691	SUM(Cs(:)) * fcn_wood(j) )
3692	!+++++++++++
3693
3694	!+++TEMP+++
3695	IF (j .EQ. test_pft .AND. ld_alloc) THEN
3696	WRITE(numout,*) 'lab_fac, labile pool, ', lab_fac(ipts,j), labile_pool
3697	ENDIF
3698	!++++++++++
3699
3700	! The max size of reserve pool is proportional to the size of the storage organ (the sapwood)
3701	! and a the leaf functional trait of the PFT (::phene_type_tab). The reserve pool is
3702	! constrained by the mass needed to replace foliage and roots. This constraint prevents the
3703	! scheme from putting too much reserves in big trees (which have a lot of sapwood compared to
3704	! small trees). Exessive storage would hamper tree growth and would make mortality less likely.
3705	IF(is_tree(j)) THEN
3706
3707	IF (pheno_type(j).EQ.1) THEN
3708
3709	! Evergreen trees are not very conservative with respect to C-storage. Therefore, only 5%
3710	! of their sapwood mass is stored in their reserve pool.
3711	reserve_pool = MIN(evergreen_reserve(j) * ( biomass(ipts,j,isapabove,icarbon) + &
3712	biomass(ipts,j,isapbelow,icarbon)), lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j)))
3713
3714	IF (j .EQ. test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
3715	WRITE(numout,*) 'What happens to the reserve and labile pools? Evergreen'
3716	WRITE(numout,*) 'carbres, reserve_pool: ',&
3717	biomass(ipts,j,icarbres,icarbon),reserve_pool
3718	WRITE(numout,*) 'ilabile, labile_pool: ',&
3719	biomass(ipts,j,ilabile,icarbon),labile_pool
3720	WRITE(numout,*) 'evergreen_reserve(j): ',&
3721	evergreen_reserve(j)
3722	WRITE(numout,*) 'isapabove,isapbelow: ',&
3723	biomass(ipts,j,isapabove,icarbon), biomass(ipts,j,isapbelow,icarbon)
3724	WRITE(numout,*) 'lai_target,sla,ltor: ',&
3725	lai_target(ipts,j),sla(j),ltor(ipts,j)
3726	WRITE(numout,*) 'term1, term2: ',&
3727	evergreen_reserve(j) * ( biomass(ipts,j,isapabove,icarbon) + &
3728	biomass(ipts,j,isapbelow,icarbon)),&
3729	lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j))
3730	ENDIF
3731
3732
3733	ELSE
3734
3735	! Deciduous trees are more conservative and 12% of their sapwood mass is stored in the
3736	! reserve pool. The scheme avoids that during the growing season too much reserve are
3737	! accumulated (which would hamper growth), therefore, the reduced rate of 12% is used
3738	! until scenecence.
3739	IF (bm_alloc_tot(ipts,j) .GT. min_stomate) THEN
3740
3741	reserve_pool = MIN(deciduous_reserve(j) * ( biomass(ipts,j,isapabove,icarbon) + &
3742	biomass(ipts,j,isapbelow,icarbon)), lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j)))
3743
3744	IF (j .EQ. test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
3745	WRITE(numout,*) 'What happens to the reserve and labile pools? Deciduous'
3746	WRITE(numout,*) 'carbres, reserve_pool: ',&
3747	biomass(ipts,j,icarbres,icarbon),reserve_pool
3748	WRITE(numout,*) 'deciduous_reserve: ',&
3749	deciduous_reserve(j)
3750	WRITE(numout,*) 'isapabove,isapbelow: ',&
3751	biomass(ipts,j,isapabove,icarbon), biomass(ipts,j,isapbelow,icarbon)
3752	WRITE(numout,*) 'lai_target,sla,ltor: ',&
3753	lai_target(ipts,j),sla(j),ltor(ipts,j)
3754	WRITE(numout,*) 'term1, term2: ',&
3755	deciduous_reserve(j) * ( biomass(ipts,j,isapabove,icarbon) + &
3756	biomass(ipts,j,isapbelow,icarbon)),&
3757	lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j))
3758	ENDIF
3759
3760	ELSE
3761
3762	! If the plant is scenecent, allow for a higher reserve mass. Plants can then use the
3763	! excess labile C, that is no longer used for growth and would be respired otherwise,
3764	! to regrow leaves after the dormant period.
3765	reserve_pool = MIN(senescense_reserve(j) * ( biomass(ipts,j,isapabove,icarbon) + &
3766	biomass(ipts,j,isapbelow,icarbon)), lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j)))
3767
3768	IF (j .EQ. test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
3769	WRITE(numout,*) 'What happens to the reserve and labile pools? Senescent'
3770	WRITE(numout,*) 'carbres, reserve_pool: ',&
3771	biomass(ipts,j,icarbres,icarbon),reserve_pool
3772	WRITE(numout,*) 'senescense_reserve(j): ',&
3773	senescense_reserve(j)
3774	WRITE(numout,*) 'isapabove,isapbelow: ',&
3775	biomass(ipts,j,isapabove,icarbon), biomass(ipts,j,isapbelow,icarbon)
3776	WRITE(numout,*) 'lai_target,sla,ltor: ',&
3777	lai_target(ipts,j),sla(j),ltor(ipts,j)
3778	WRITE(numout,*) 'term1, term2: ',&
3779	senescense_reserve(j) * ( biomass(ipts,j,isapabove,icarbon) + &
3780	biomass(ipts,j,isapbelow,icarbon)),&
3781	lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j))
3782	ENDIF
3783
3784	ENDIF ! Scenecent
3785
3786	ENDIF ! Phenology type
3787
3788	! Grasses
3789	ELSE
3790
3791	!+++CHECK+++
3792	! The min criterion results in the reserves being zero because isapabove goes to zero
3793	! when the reserves are most needed
3794	reserve_pool = MIN(0.3 * ( biomass(ipts,j,iroot,icarbon) + biomass(ipts,j,isapabove,icarbon) + &
3795	biomass(ipts,j,isapbelow,icarbon)), lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j)))
3796	!!$ reserve_pool = lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j))
3797	!+++++++++++
3798
3799	!+++TEMP+++
3800	IF (j .EQ. test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
3801	WRITE(numout,*) 'reserve pool, 30%', reserve_pool
3802	ENDIF
3803	!++++++++++
3804
3805	ENDIF
3806
3807	!! 7.2 Move carbon between the reserve pools
3808	! Fill the reserve pools up to their optimal level or until the min/max limits are reached
3809	! The original approcah in OCN resulted in instabilities and sometimes oscilations. For
3810	! this reason a more simple and straightforward transfer between the pools has been
3811	! implemented.
3812
3813	!! 7.2.1 Burn excess reserves
3814	! The actual reserve and/or labile pool exceed the required pools (as calculated in 7.1)
3815	! The excessive reserve pools respires C which needs to be accounted for in the
3816	! growth respiration. Because of this line of code, npp cannot be calculated at the
3817	! start of the of this subroutine (i.e. between section 4 and 5). Last, correct the
3818	! labile and reserve pool for this respiration flux. Note that instead of respiring
3819	! this carbon it could be used for leaching, feeding mycorrhizae, producing DOCs,
3820	! producing VOCs or any other component of NPP that does not end up in the biomass.
3821	IF ( (biomass(ipts,j,icarbres,icarbon) .GE. reserve_pool) .AND. &
3822	(biomass(ipts,j,ilabile,icarbon) .GE. labile_pool) ) THEN
3823
3824	! reserves are full
3825	IF ( biomass(ipts,j,icarbres,icarbon) .GT. reserve_pool ) THEN
3826
3827	excess = biomass(ipts,j,icarbres,icarbon) - reserve_pool
3828
3829	!---TEMP---
3830	IF (j.EQ.test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
3831	WRITE(numout,*) 'excess reserve, ', &
3832	excess, biomass(ipts,j,icarbres,icarbon), &
3833	reserve_pool
3834	ENDIF
3835	!----------
3836
3837	resp_growth(ipts,j) = resp_growth(ipts,j) + 0.1 * excess
3838	biomass(ipts,j,icarbres,icarbon) = biomass(ipts,j,icarbres,icarbon) - &
3839	0.1 * excess
3840
3841	ENDIF
3842
3843	! labile is full
3844	! Try not buring the labile pool. I am commenting out this part because
3845	! this can prevent trees from growing after coppicing. It is unclear
3846	! exactly what the point of it is, too. In another loop, if the
3847	! labile pool is overful but the carbres pool is just below the limit,
3848	! the code is supposed to move labile carbon to the reserve pool. It does
3849	! it so slowly, though, that it might as well not be doing it at all. Here
3850	! we burn off the reserves while leaving the labile pool, since the labile
3851	! pool is used for allocation. This implicitly supposes that some of the
3852	! carbon burned off from the reserve pool turns into labile carbon, enough
3853	! to counter whatever is burned off from the labile pool.
3854	!!$ IF ( biomass(ipts,j,ilabile,icarbon) .GT. labile_pool ) THEN
3855	!!$
3856	!!$ excess = biomass(ipts,j,ilabile,icarbon) - labile_pool
3857	!!$
3858	!!$ !---TEMP---
3859	!!$ IF (j.EQ.test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
3860	!!$ WRITE(numout,*) 'excess labile, ', &
3861	!!$ excess, biomass(ipts,j,ilabile,icarbon), &
3862	!!$ labile_pool
3863	!!$ ENDIF
3864	!!$ !----------
3865	!!$
3866	!!$ resp_growth(ipts,j) = resp_growth(ipts,j) + 0.1 * excess
3867	!!$ biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) - &
3868	!!$ 0.1 * excess
3869	!!$
3870	!!$ ENDIF
3871
3872	!---TEMP---
3873	IF (j.EQ.test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
3874	WRITE(numout,*) 'reserve pools are considered too full'
3875	WRITE(numout,*) 'excess, ', excess
3876	WRITE(numout,*) 'resp_growth, ', resp_growth(ipts,j)
3877	WRITE(numout,*) 'biomass(ilabile) really final, ', biomass(ipts,j,ilabile,icarbon)
3878	WRITE(numout,*) 'biomass(icarbres) really final, ', biomass(ipts,j,icarbres,icarbon)
3879	WRITE(numout,*) 'when_growthinit, ', when_growthinit(ipts,j) , j
3880	WRITE(numout,*) 'senescence, ',senescence(ipts,j), j
3881	ENDIF
3882	!----------
3883
3884	!! 7.2.2 Enough reserves, not enough labile
3885	ELSEIF ( (biomass(ipts,j,icarbres,icarbon) .GE. reserve_pool) .AND. &
3886	(biomass(ipts,j,ilabile,icarbon) .LT. labile_pool) ) THEN
3887
3888	! We need to move carbon from the reserve pool to the labile pool. We will move
3889	! this gradually. Calculate the maximum flow of the carbon reserve pool to labile
3890	IF (is_tree(j)) THEN
3891
3892	! During the dormant season for evergreens or the growing season for both functional leaf
3893	! traits.
3894	IF ( (biomass(ipts,j,ileaf,icarbon) .GT. min_stomate .AND. &
3895	f_alloc(ipts,j,isapabove) .LE. min_stomate) .OR. &
3896	(lab_fac(ipts,j) .GT. 0.1) ) THEN
3897
3898	! Don't move more than an arbitrary 5% from the carbohydrate reserve pool
3899	!!$ use_max = biomass(ipts,j,icarbres,icarbon) * MIN(0.05,reserve_scal)
3900	use_max = biomass(ipts,j,icarbres,icarbon) * 0.05
3901
3902	! Dormant season
3903	ELSE
3904
3905	! Don't move any carbon between the reserve and the labile pool
3906	use_max = zero
3907
3908	ENDIF ! Growing or dormant season
3909
3910	! Grasses
3911	ELSE
3912
3913	! During the growing season
3914	IF (biomass(ipts,j,ileaf,icarbon).GT.min_stomate) THEN
3915
3916	! Don't move more than an arbitrary 5% from the carbohydrate reserve pool
3917	!!$ use_max = biomass(ipts,j,icarbres,icarbon) * MIN(0.05,reserve_scal)
3918	use_max = biomass(ipts,j,icarbres,icarbon) * 0.05
3919
3920	! Dormant season
3921	ELSE
3922
3923	! Don't move any carbon between the reserve and the labile pool
3924	use_max = zero
3925
3926	ENDIF ! Growing or dormant season
3927
3928	ENDIF ! Trees or grasses
3929
3930	! Calculate the required flow of the carbon reserve pool to labile
3931	! Propose to use what can be moved from the reserve pool (::use_max) or
3932	! the amount required to fill the pool.
3933	use_res = MAX(zero, MIN(use_max, labile_pool-biomass(ipts,j,ilabile,icarbon)))
3934
3935	! Update labile pool and reserve
3936	bm_alloc(ipts,j,icarbres,icarbon) = use_res
3937	biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) + &
3938	bm_alloc(ipts,j,icarbres,icarbon)
3939	biomass(ipts,j,icarbres,icarbon) = biomass(ipts,j,icarbres,icarbon) - &
3940	bm_alloc(ipts,j,icarbres,icarbon)
3941
3942	!+++TEMP+++
3943	IF (j .EQ. test_pft .AND. ld_alloc) THEN
3944	WRITE(numout,*) 'move carbon from reserve to labile'
3945	WRITE(numout,*) 'use_res, ', use_res
3946	WRITE(numout,*) 'required: reserve and labile pool, ',reserve_pool, labile_pool
3947	WRITE(numout,*) 'available: reserve and labile, ', biomass(ipts,j,icarbres,icarbon), &
3948	biomass(ipts,j,ilabile,icarbon)
3949	ENDIF
3950	!++++++++++
3951
3952	! 7.2.3 Enough labile, not enough reserves
3953	ELSEIF ( (biomass(ipts,j,icarbres,icarbon) .LT. reserve_pool) .AND. &
3954	(biomass(ipts,j,ilabile,icarbon) .GE. labile_pool) ) THEN
3955
3956	! The labile carbon is more mobile than the reserve pool but
3957	! it is also more important in the allocation scheme because
3958	! it generates growth respiration and it is used to calculate
3959	! bm_alloc. Therefore, the mobility of the labile pool was
3960	! restricted to an arbitrary 15%
3961	use_max = biomass(ipts,j,ilabile,icarbon) * 0.15
3962
3963	! Propose to use what can be moved from the reserve labile pool(::use_max) or
3964	! the amount required to fill the pool.
3965	use_lab = MAX(zero, MIN(use_max, reserve_pool-biomass(ipts,j,icarbres,icarbon)))
3966
3967	! Update labile pool and reserve
3968	bm_alloc(ipts,j,icarbres,icarbon) = use_lab
3969	biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) - &
3970	bm_alloc(ipts,j,icarbres,icarbon)
3971	biomass(ipts,j,icarbres,icarbon) = biomass(ipts,j,icarbres,icarbon) + &
3972	bm_alloc(ipts,j,icarbres,icarbon)
3973
3974	!+++TEMP+++
3975	IF (j .EQ. test_pft .AND. ld_alloc) THEN
3976	WRITE(numout,*) 'move carbon from labile to reserve'
3977	WRITE(numout,*) 'use_lab, ', use_lab
3978	WRITE(numout,*) 'required: reserve and labile pool, ',reserve_pool, labile_pool
3979	WRITE(numout,*) 'available: reserve and labile, ', biomass(ipts,j,icarbres,icarbon), &
3980	biomass(ipts,j,ilabile,icarbon)
3981	ENDIF
3982	!++++++++++
3983
3984
3985	!! 7.2.3 We don't have enough carbon in both reserve pools. We will
3986	! redistribute what we have to minimise the tension between available and
3987	! required
3988	ELSEIF ( (biomass(ipts,j,icarbres,icarbon) .LT. reserve_pool) .AND. &
3989	(biomass(ipts,j,ilabile,icarbon) .LT. labile_pool) ) THEN
3990
3991	!+++CHECK+++
3992	! not really clear what the advantage is of doing this. Best case it avoids
3993	! that one of the pools gets depleted. Worst case it takes a lot of C (relatively)
3994	! speaking from the labile pool (which is much smaller than the reserve pool).
3995	! The carbon that is lacking to satisfy the needs of the reserve pools
3996	!!$ shortage = (reserve_pool + labile_pool) - &
3997	!!$ (biomass(ipts,j,icarbres,icarbon) + biomass(ipts,j,ilabile,icarbon))
3998	!!$
3999	!!$ ! Share of the reserve pool in the total requirement
4000	!!$ reserve_scal = reserve_pool/(reserve_pool+labile_pool)
4001	!!$
4002	!!$ ! The shortage that should occur in the reserve pool
4003	!!$ ! under the assumption that the optimal shortage is
4004	!!$ ! proportional to the required reserve and labil pool
4005	!!$ use_res = shortage * reserve_scal
4006	!!$
4007	!!$ ! Update labile pool and reserve
4008	!!$ bm_alloc(ipts,j,icarbres,icarbon) = zero
4009	!!$ biomass(ipts,j,ilabile,icarbon) = labile_pool - (shortage - use_res)
4010	!!$ biomass(ipts,j,icarbres,icarbon) = reserve_pool - use_res
4011	!+++++++++++
4012
4013	!++++++++++++++++
4014	! Try moving carbon from reserves to labile, just because labile seems
4015	! to be essential for growing leaves. If we don't have enough, the
4016	! trees stop growing but don't die.
4017	!shortage = labile_pool - biomass(ipts,j,ilabile,icarbon)
4018	!IF(shortage .GT. biomass(ipts,j,icarbres,icarbon))THEN
4019	! biomass(ipts,j,ilabile,icarbon)=biomass(ipts,j,ilabile,icarbon)+0.9*shortage
4020	! biomass(ipts,j,icarbres,icarbon)=biomass(ipts,j,icarbres,icarbon)-0.9*shortage
4021	!ENDIF
4022	!++++++++++++++++++++++++++
4023
4024	!+++Temp+++
4025	IF (j .EQ. test_pft .AND. ld_alloc) THEN
4026	WRITE(numout,*) 'not enough carbon to satify the total requirement of labile and reserve'
4027	!WRITE(numout,*) 'use_res,shortage,reserve_scale: ', use_res,shortage,reserve_scal
4028	WRITE(numout,*) 'bm_alloc: ',bm_alloc(ipts,j,icarbres,icarbon)
4029	WRITE(numout,*) 'bm_alloc_tot: ',bm_alloc_tot(ipts,j)
4030	WRITE(numout,'(A,2ES20.10)') 'required: reserve and labile pool, ',&
4031	reserve_pool, labile_pool
4032	WRITE(numout,'(A,2ES20.10)') 'available: reserve and labile, ', &
4033	biomass(ipts,j,icarbres,icarbon), &
4034	biomass(ipts,j,ilabile,icarbon)
4035	ENDIF
4036	!++++++++++
4037
4038	!! 7.4 Unexpected condition
4039	ELSE
4040
4041	IF(ld_warn .OR. ld_alloc) THEN
4042	WRITE(numout,*) 'An unexpected condition occured for the reserve pools'
4043	WRITE(numout,*) 'required: reserve and labile pool, ',reserve_pool, labile_pool
4044	WRITE(numout,*) 'available: reserve and labile, ', biomass(ipts,j,icarbres,icarbon), &
4045	biomass(ipts,j,ilabile,icarbon)
4046	CALL ipslerr_p (3,'growth_fun_all',&
4047	'An unexpected condition occured for the reserve pools','','')
4048	ENDIF
4049
4050	ENDIF
4051
4052
4053	!!$ !! 7.2 Calculate the C that could move from the reserve pool to the labile pool
4054	!!$ ! Fill the reserve pools up to their optimal level or until the min/max limits are reached
4055	!!$
4056	!!$ !+++CHECK++++
4057	!!$ ! SL does not understand the benefit of this implementation
4058	!!$ ! Should equally well work without it
4059	!!$ ! Calcualte the tension between the required and demanded reserve pool
4060	!!$ IF (reserve_pool .GT. min_stomate) THEN
4061	!!$
4062	!!$ reserve_scal = MAX( MIN(biomass(ipts,j,icarbres,icarbon)/reserve_pool,un), zero)
4063	!!$
4064	!!$ ELSE
4065	!!$
4066	!!$ reserve_scal = zero
4067	!!$
4068	!!$ ENDIF
4069	!!$ !+++++++++++++
4070	!!$
4071	!!$
4072	!!$ !! 7.3 Calculate the C that is required to fill the labile pool
4073	!!$ ! Propose to use what can be moved from the reserve pool (::use_max) or the amount required
4074	!!$ ! to fill the pool.
4075	!!$ use_res = MAX(zero, MIN(use_max, labile_pool-biomass(ipts,j,ilabile,icarbon)))
4076	!!$
4077	!!$ !+++TEMP+++
4078	!!$ IF (j .EQ. test_pft .AND. ld_alloc) THEN
4079	!!$ WRITE(numout,*) 'use_res, ', use_res
4080	!!$ ENDIF
4081	!!$ !++++++++++
4082	!!$
4083	!!$ ! Check wether there is excessive carbon in the reserve pool
4084	!!$ IF ( (biomass(ipts,j,icarbres,icarbon).GT.reserve_pool) .AND. (reserve_pool .GT. min_stomate) ) THEN
4085	!!$
4086	!!$ ! Calculate the amount of carbon that will be moved from the reserve pool to the labile pool
4087	!!$ use_res = MIN(0.25 * biomass(ipts,j,icarbres,icarbon), &
4088	!!$ MAX( biomass(ipts,j,icarbres,icarbon)-reserve_pool, use_res ))
4089	!!$
4090	!!$ ENDIF
4091	!!$
4092	!!$ !! 7.4 Avoid overflow of the reserve pool
4093	!!$ use_max = labile_pool
4094	!!$ use_lab = MAX(zero, biomass(ipts,j,ilabile,icarbon)-use_max) * (un - reserve_scal)
4095	!!$
4096	!!$
4097	!!$ !! 7.5 Calculate flow between the pools
4098	!!$ ! Net carbon flow between reserve and labile pool adjust the reserve compartment in bm_alloc
4099	!!$ bm_alloc(ipts,j,icarbres,icarbon) = MAX( MIN(use_lab-use_res, biomass(ipts,j,ilabile,icarbon)), &
4100	!!$ -biomass(ipts,j,icarbres,icarbon) )
4101	!!$
4102	!!$ !+++TEMP+++
4103	!!$ IF (j .EQ. test_pft .AND. ld_alloc) THEN
4104	!!$ WRITE(numout,*) 'bm_alloc(icarbes), ', bm_alloc(ipts,j,icarbres,icarbon)
4105	!!$ WRITE(numout,*) 'use_lab, ', use_lab
4106	!!$ WRITE(numout,*) 'use_res, ', use_res
4107	!!$ WRITE(numout,*) 'biomass(ilabile), ', biomass(ipts,j,ilabile,icarbon)
4108	!!$ WRITE(numout,*) 'biomass(icarbres), ', biomass(ipts,j,icarbres,icarbon)
4109	!!$ WRITE(numout,*) 'biomass(ilabile) final, ', biomass(ipts,j,ilabile,icarbon) - &
4110	!!$ bm_alloc(ipts,j,icarbres,icarbon)
4111	!!$ WRITE(numout,*) 'biomass(icarbres) final, ', biomass(ipts,j,icarbres,icarbon) + &
4112	!!$ bm_alloc(ipts,j,icarbres,icarbon)
4113	!!$ ENDIF
4114	!!$ !++++++++++
4115	!!$
4116	!!$ ! Update labile pool and reserve
4117	!!$ biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) - bm_alloc(ipts,j,icarbres,icarbon)
4118	!!$ biomass(ipts,j,icarbres,icarbon) = biomass(ipts,j,icarbres,icarbon) + bm_alloc(ipts,j,icarbres,icarbon)
4119
4120	ELSEIF ( veget_max(ipts,j) .GT. min_stomate .AND. &
4121	rue_longterm(ipts,j) .EQ. un) THEN
4122
4123	! There hasn't been any photosynthesis yet. This happens when a new vegetation
4124	! is prescribed and the longterm phenology variables are not initialized yet.
4125	! These conditions happen when the model is started from scratch (no restart files).
4126	! Because the plants are very small, they contain little reserves. We increased the
4127	! amount of reserves by a factor ::tune_r_in_sapling where r stands for reserves.
4128	! However, this amount gets simply respired before it is needed because the
4129	! reserve_pool is calculated as a function of the sapwood biomass which is very
4130	! low because the plants are really small. Here we skip recalculating the
4131	! reserve_pool until the day we start using it.
4132
4133	ELSE
4134
4135	! No reason to be here
4136	WRITE(numout,*) 'Error: unexpected condition for the reserve pools, pft, ',j
4137	WRITE(numout,*) 'veget_max, rue_longterm, ', veget_max(ipts,j), rue_longterm(ipts,j)
4138
4139	ENDIF ! rue_longterm
4140
4141
4142	!! 7.8 Calculate NPP
4143	! Calculate the NPP @tex $(gC.m^{-2}dt^{-1})$ @endtex as the difference between GPP and the two
4144	! components of autotrophic respiration (maintenance and growth respiration). GPP, R_maint and R_growth
4145	! are prognostic variables, NPP is calculated as the residuals and is thus a diagnostic variable.
4146	! Note that NPP is not used in the allocation scheme, instead bm_alloc_tot is allocated. The
4147	! physiological difference between both is that bm_alloc_tot does no longer contain the reserves and
4148	! labile pools and is only the carbon that needs to go into the biomass pools. NPP contains the reserves
4149	! and labile carbon. Note that GPP is in gC m-2 s-1 whereas the respiration terms were calculated in
4150	! gC m-2 dt-1
4151	npp(ipts,j) = gpp_daily(ipts,j) - resp_growth(ipts,j)/dt - resp_maint(ipts,j)/dt
4152
4153	!---TEMP---
4154	IF (j.EQ.test_pft .AND. ld_alloc) THEN
4155	WRITE(numout,'(A,20F20.10)') 'GPP_DAILY, NPP, Rag, Ra, ', gpp_daily(ipts,j), npp(ipts,j), &
4156	resp_growth(ipts,j)/dt, resp_maint(ipts,j)/dt
4157	WRITE(numout,*) 'PFT, bm_alloc_tot, ', bm_alloc_tot(ipts,j)
4158	WRITE(numout,*) 'PFT, sum of bm_alloc components, ', SUM(bm_alloc(ipts,j,:,icarbon))
4159	ENDIF
4160	!----------
4161
4162
4163	!! 7.9 Distribute stand level ilabile and icarbres at the tree level
4164	! The labile and carbres pools are calculated at the stand level but are then redistributed at the
4165	! tree level. This has the advantage that biomass and circ_class_biomass have the same dimensions
4166	! for nparts which comes in handy when phenology and mortality are calculated.
4167
4168	IF (is_tree(j)) THEN
4169
4170	! Initialize to enable a loop over nparts
4171	circ_class_biomass(ipts,j,:,ilabile,:) = zero
4172	circ_class_biomass(ipts,j,:,icarbres,:) = zero
4173
4174	! Distribute labile and reserve pools over the circumference classes
4175	DO m = 1,nelements
4176
4177	! Total biomass across parts and circumference classes
4178	temp_total_biomass = zero
4179
4180	DO l = 1,ncirc
4181
4182	DO k = 1,nparts
4183
4184	temp_total_biomass = temp_total_biomass + circ_class_biomass(ipts,j,l,k,m) * circ_class_n(ipts,j,l)
4185
4186	ENDDO
4187
4188	ENDDO
4189
4190	! Total biomass across parts but for a specific circumference class
4191	DO l = 1,ncirc
4192
4193	temp_class_biomass = zero
4194
4195	DO k = 1,nparts
4196
4197	temp_class_biomass = temp_class_biomass + circ_class_biomass(ipts,j,l,k,m) * circ_class_n(ipts,j,l)
4198
4199	ENDDO
4200
4201	IF( temp_total_biomass .NE. zero) THEN
4202
4203	! Share of this circumference class to the total biomass
4204	temp_share = temp_class_biomass / temp_total_biomass
4205
4206	! Allocation of ilabile at the tree level (gC tree-1)
4207	circ_class_biomass(ipts,j,l,ilabile,m) = temp_share * &
4208	biomass(ipts,j,ilabile,m) / circ_class_n(ipts,j,l)
4209
4210	! Allocation of icarbres at the tree level (gC tree-1)
4211	circ_class_biomass(ipts,j,l,icarbres,m) = temp_share * &
4212	biomass(ipts,j,icarbres,m) / circ_class_n(ipts,j,l)
4213	ELSE
4214
4215	circ_class_biomass(ipts,j,l,ilabile,m) = zero
4216	circ_class_biomass(ipts,j,l,icarbres,m) = zero
4217
4218	ENDIF
4219
4220	ENDDO ! ncirc
4221
4222	ENDDO ! nelements
4223
4224	! Grasses and crops
4225	ELSE
4226
4227	DO m = 1,nelements
4228
4229	! synchronize biomass and circ_class_biomass
4230	IF (ind(ipts,j) .GT. zero) THEN
4231
4232	circ_class_biomass(ipts,j,1,:,m) = biomass(ipts,j,:,m) / ind(ipts,j)
4233
4234	ELSE
4235
4236	circ_class_biomass(ipts,j,1,:,m) = zero
4237
4238	ENDIF
4239
4240	ENDDO
4241
4242	ENDIF ! is_tree
4243
4244	ENDDO ! pnts
4245
4246	ENDDO ! PFTs
4247
4248
4249	!! 8. Check mass balance closure
4250
4251	! Calculate pools at the end of the routine
4252	pool_end = zero
4253	DO ipar = 1,nparts
4254	DO iele = 1,nelements
4255	pool_end(:,:,iele) = pool_end(:,:,iele) + &
4256	(biomass(:,:,ipar,iele) * veget_max(:,:))
4257	ENDDO
4258	ENDDO
4259
4260	! Calculate components of the mass balance
4261	check_intern(:,:,iatm2land,icarbon) = gpp_daily(:,:) * dt * veget_max(:,:)
4262	check_intern(:,:,iland2atm,icarbon) = -un * (resp_maint(:,:) + resp_growth(:,:)) * &
4263	veget_max(:,:)
4264	check_intern(:,:,ilat2out,icarbon) = -un * zero
4265	check_intern(:,:,ilat2in,icarbon) = un * zero
4266	check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - &
4267	pool_start(:,:,icarbon))
4268	closure_intern = zero
4269	DO imbc = 1,nmbcomp
4270	closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + &
4271	check_intern(:,:,imbc,icarbon)
4272	ENDDO
4273
4274	! Write conclusion
4275	DO ipts=1,npts
4276	DO j=1,nvm
4277	IF(ABS(closure_intern(ipts,j,icarbon)) .LE. min_stomate)THEN
4278	IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in stomate_growth_fun_all.f90'
4279	ELSE
4280	WRITE(numout,*) 'Error: mass balance is not closed in stomate_growth_fun_all.f90'
4281	WRITE(numout,*) ' ipts,j; ', ipts,j
4282	WRITE(numout,*) ' Difference is, ', closure_intern(ipts,j,icarbon)
4283	WRITE(numout,*) ' pool_end,pool_start: ', pool_end(ipts,j,icarbon), pool_start(ipts,j,icarbon)
4284	WRITE(numout,*) ' gpp_daily, veget_max: ', gpp_daily(ipts,j),veget_max(ipts,j)
4285	WRITE(numout,*) ' resp_maint,resp_growth: ', resp_maint(ipts,j),resp_growth(ipts,j)
4286	IF(ld_stop)THEN
4287	CALL ipslerr_p (3,'growth_fun_all', 'Mass balance error.','','')
4288	ENDIF
4289	ENDIF
4290	ENDDO
4291	ENDDO
4292
4293	!+++HACK++++
4294	! JR 080315 temporary hardwire for testing PFTs 4
4295	! comment out this sections for tree growth profiles
4296	IF (ld_fake_height) THEN
4297	!Do nothing
4298	ELSE
4299	!Go to James' Hardwire
4300	IF (control%ok_new_enerbil_nextstep ) THEN
4301	! this was a simple means to hardwire a canopy profile without having to use a spin-up file
4302	! for testing. It is now commented out to avoid compilation errors for the INPUT variables
4303	! ind and circ_class_n
4304
4305	! ind(1,4) = 0.6d0
4306	! biomass(1,4,1,1) = 10919.1492214105
4307	! biomass(1,4,2,1) = 119092.584535974
4308	! biomass(1,4,3,1) = 119092.584535974
4309	! biomass(1,4,4,1) = 23818.5169071949
4310	! biomass(1,4,5,1) = 23818.5169071949
4311	! biomass(1,4,6,1) = 3717.22198731141
4312	! biomass(1,4,7,1) = 0.000000000000000E+000
4313	! biomass(1,4,8,1) = 0.000000000000000E+000
4314	! biomass(1,4,9,1) = 348.380698397579
4315	! circ_class_n(1,4,1) = 0.570200000000000
4316	! circ_class_n(1,4,2) = 2.840000000000000E-002
4317	! circ_class_n(1,4,3) = 1.400000000000000E-003
4318
4319	! circ_class_biomass(1,4,1,1,1) = 18198.5820356842
4320	! circ_class_biomass(1,4,1,2,1) = 198487.640893291
4321	! circ_class_biomass(1,4,1,3,1) = 198487.640893291
4322	! circ_class_biomass(1,4,1,4,1) = 39697.5281786581
4323	! circ_class_biomass(1,4,1,5,1) = 39697.5281786581
4324	! circ_class_biomass(1,4,1,6,1) = 6195.36997885235
4325	! circ_class_biomass(1,4,1,7,1) = 0.000000000000000E+000
4326	! circ_class_biomass(1,4,1,8,1) = 0.000000000000000E+000
4327	! circ_class_biomass(1,4,1,9,1) = 580.634497329298
4328	! circ_class_biomass(1,4,2,1,1) = 18198.5820356842
4329	! circ_class_biomass(1,4,2,2,1) = 198487.640893291
4330	! circ_class_biomass(1,4,2,3,1) = 198487.640893291
4331	! circ_class_biomass(1,4,2,4,1) = 39697.5281786581
4332	! circ_class_biomass(1,4,2,5,1) = 39697.5281786581
4333	! circ_class_biomass(1,4,2,6,1) = 6195.36997885235
4334	! circ_class_biomass(1,4,2,7,1) = 0.000000000000000E+000
4335	! circ_class_biomass(1,4,2,8,1) = 0.000000000000000E+000
4336	! circ_class_biomass(1,4,2,9,1) = 580.634497329298
4337	! circ_class_biomass(1,4,3,1,1) = 18198.5820356842
4338	! circ_class_biomass(1,4,3,2,1) = 198487.640893291
4339	! circ_class_biomass(1,4,3,3,1) = 198487.640893291
4340	! circ_class_biomass(1,4,3,4,1) = 39697.5281786581
4341	! circ_class_biomass(1,4,3,5,1) = 39697.5281786581
4342	! circ_class_biomass(1,4,3,6,1) = 6195.36997885235
4343	! circ_class_biomass(1,4,3,7,1) = 0.000000000000000E+000
4344	! circ_class_biomass(1,4,3,8,1) = 0.000000000000000E+000
4345	! circ_class_biomass(1,4,3,9,1) = 580.634497329298
4346	END IF ! (control%ok_new_enerbil_nextstep ) THEN
4347	END IF !(ld_fake_height)
4348	!----------
4349
4350
4351	!! 9. Update leaf age
4352
4353	! Leaf age is needed to calculate the turnover and vmax in the stomate_turnover.f90 and stomate_vmax.f90 routines.
4354	! Leaf biomass is distributed according to its age into several "age classes" with age class=1 representing the
4355	! youngest class, and consisting of the most newly allocated leaf biomass.
4356
4357	!! 9.1 Update quantity and age of the leaf biomass in the youngest class
4358	! The new amount of leaf biomass in the youngest age class (leaf_mass_young) is the sum of :
4359	! - the leaf biomass that was already in the youngest age class (leaf_frac(:,j,1) * lm_old(:,j)) with the
4360	! leaf age given in leaf_age(:,j,1)
4361	! - and the new biomass allocated to leaves (bm_alloc(:,j,ileaf,icarbon)) with a leaf age of zero.
4362	leaf_mass_young(:,:) = leaf_frac(:,:,1) * lm_old(:,:) + bm_alloc(:,:,ileaf,icarbon)
4363
4364	! The age of the updated youngest age class is the average of the ages of its 2 components: bm_alloc(leaf) of age
4365	! '0', and leaf_frac*lm_old(=leaf_mass_young-bm_alloc) of age 'leaf_age(:,:,1)'
4366	DO ipts=1,npts
4367
4368	DO j=1,nvm
4369
4370	! IF(veget_max(ipts,j) == zero)THEN
4371	! ! this vegetation type is not present, so no reason to do the
4372	! ! calculation
4373	! CYCLE
4374	! ENDIF
4375
4376	IF( (bm_alloc(ipts,j,ileaf,icarbon) .GT. min_stomate ) .AND. &
4377	( leaf_mass_young(ipts,j) .GT. min_stomate ) )THEN
4378
4379
4380	leaf_age(ipts,j,1) = MAX ( zero, leaf_age(ipts,j,1) * &
4381	( leaf_mass_young(ipts,j) - bm_alloc(ipts,j,ileaf,icarbon) ) / &
4382	& leaf_mass_young(ipts,j) )
4383
4384	ENDIF
4385
4386	!+++TEMP+++
4387	!!$ IF(j == test_pft .AND. ipts == test_grid)THEN
4388	!!$ WRITE(numout,*) 'VCMAX: leaf_age growth: ',leaf_age(ipts,j,1),&
4389	!!$ bm_alloc(ipts,j,ileaf,icarbon),leaf_mass_young(ipts,j),&
4390	!!$ biomass(ipts,j,ileaf,icarbon)
4391	!!$ ENDIF
4392	!++++++++++
4393
4394	ENDDO
4395
4396	ENDDO
4397
4398	!! 8.2 Decrease reduction of photosynthesis
4399	! Decrease reduction of photosynthesis from new (undamaged) foliage
4400	!!$ WHERE(biomass(:,:,ileaf,icarbon).GT.min_stomate)
4401	!!$
4402	!!$ t_photo_stress(:,:) = (t_photo_stress(:,:) * lm_old(:,:) + &
4403	!!$ bm_alloc(:,:,ileaf,icarbon))/biomass(:,:,ileaf,icarbon)
4404	!!$
4405	!!$ ENDWHERE
4406
4407
4408	!! 9.3 Update leaf age
4409	! Update fractions of leaf biomass in each age class (fraction in youngest class increases)
4410
4411	!! 9.3.1 Update age of youngest leaves
4412	! For age class 1 (youngest class), because we have added biomass to the youngest class, we need to update
4413	! the fraction of total leaf biomass that belongs to the youngest age class : updated mass in class divided
4414	! by new total leaf mass
4415	WHERE ( biomass(:,:,ileaf,icarbon) .GT. min_stomate )
4416
4417	leaf_frac(:,:,1) = leaf_mass_young(:,:) / biomass(:,:,ileaf,icarbon)
4418
4419	ENDWHERE
4420
4421
4422	!! 9.3.2 Update age of other age classes
4423	! Because the total leaf biomass has changed, we need to update the fraction of leaves in each age class:
4424	! mass in leaf age class (from previous fraction of leaves in this class and previous total leaf biomass)
4425	! divided by new total mass
4426	DO m = 2, nleafages ! Loop over # leaf age classes
4427
4428	WHERE ( biomass(:,:,ileaf,icarbon) .GT. min_stomate )
4429
4430	leaf_frac(:,:,m) = leaf_frac(:,:,m) * lm_old(:,:) / biomass(:,:,ileaf,icarbon)
4431
4432	ENDWHERE
4433
4434	ENDDO ! Loop over # leaf age classes
4435
4436
4437	!! 10. Update whole-plant age
4438
4439	!! 10.1 PFT age
4440	! At every time step, increase age of the biomass that was already present at previous time step.
4441	! Age is expressed in years, and the time step 'dt' in days so age increase is: dt divided by number
4442	! of days in a year.
4443	WHERE ( PFTpresent(:,:) )
4444
4445	age(:,:) = age(:,:) + dt/one_year
4446
4447	ELSEWHERE
4448
4449	age(:,:) = zero
4450
4451	ENDWHERE
4452
4453
4454	!! 10.2 Age of grasses and crops
4455	! For grasses and crops, biomass with age 0 has been added to the whole plant with age 'age'. New biomass is the sum of
4456	! the current total biomass in all plant parts (bm_new), bm_new(:) = SUM( biomass(:,j,:), DIM=2 ). The biomass that has
4457	! just been added is the sum of the allocatable biomass of all plant parts (bm_add), its age is zero. bm_add(:) =
4458	! SUM( bm_alloc(:,j,:,icarbon), DIM=2 ). Before allocation, the plant biomass is bm_new-bm_add, its age is "age(:,j)".
4459	! The age of the new biomass is the average of the ages of previous and added biomass.
4460	! For trees, age is treated in "establish" if vegetation is dynamic, and in turnover routines if it is static (in this
4461	! case, only the age of the heartwood is accounted for).
4462	DO j = 2,nvm
4463
4464	IF ( .NOT. is_tree(j) ) THEN
4465
4466	bm_new(:) = biomass(:,j,ileaf,icarbon) + biomass(:,j,isapabove,icarbon) + &
4467	biomass(:,j,iroot,icarbon) + biomass(:,j,ifruit,icarbon)
4468	bm_add(:) = bm_alloc(:,j,ileaf,icarbon) + bm_alloc(:,j,isapabove,icarbon) + &
4469	bm_alloc(:,j,iroot,icarbon) + bm_alloc(:,j,ifruit,icarbon)
4470
4471	WHERE ( ( bm_new(:) .GT. min_stomate ) .AND. ( bm_add(:) .GT. min_stomate ) )
4472
4473	age(:,j) = age(:,j) * ( bm_new(:) - bm_add(:) ) / bm_new(:)
4474
4475	ENDWHERE
4476
4477	ENDIF ! is .NOT. tree
4478
4479	ENDDO ! Loop over #PFTs
4480
4481	!!$ ! +++HACK+++
4482	!!$ ! 10.3 This is only for the model validation
4483	!!$ ! LAI is imposed with "IMPOSE_LAI" (the maximun value within a year)
4484	!!$ !
4485	!!$ ! Reset the Biomass in leaf, labile and carbonate pools
4486	!!$ ! In order to impose the LAI value & profile we need to recalculate the biomass
4487	!!$ ! based on impose lai and default SLA(specific of leaf area index)
4488	!!$ ! A monthy LAI scaling factor LAI_SCALE was also introduced for descrption the dynamic of LAI
4489	!!$ ! >>> This will arise a mass balance issue in stomate_lpj routine
4490	!!$ ! >>> Make sure you change the ERROR level of "check_biomass_sync" in funtion_library
4491	!!$ ! >>> to "2" to avoid model stop
4492	!!$ ! So, the model is suggested not to run over than one year when the flage turned on.
4493	istep=istep+1
4494	IF (ld_fake_height) THEN
4495	WRITE(numout,'(A,I6,I6)') '!=== CALL FUNTIONAL ALLOCATION STEP & RESET BIOMASS ====',test_pft, istep
4496
4497
4498	!GET impose LAI & LAI_SCALE
4499	CALL getin_p('IMPOSE_LAI',impose_lai)
4500	lai_fac = 1.0
4501	CALL getin_p('LAI_FAC',lai_fac)
4502	impose_lai = impose_lai*lai_fac
4503	DO j=1, 13
4504	WRITE(temp_text,'(A11,I5.5)') 'LAI_SCALE__',j
4505	CALL getin_p(trim(temp_text),lai_scale(j))
4506	WRITE(numout,*) trim(temp_text), lai_scale(j)
4507	ENDDO
4508
4509	!START a simple linear interpolation based on impose lai and lai scale
4510	!Here, we use a simple 30 days for cycling of one month
4511	month_id = INT(istep/30.) + 1
4512	IF (month_id .GT. 12) THEN
4513	! only for final 5 days set to a constant as impose_lai*lai_scale(13)
4514	daily_lai = (impose_lai)*lai_scale(month_id)
4515	ELSE
4516	daily_lai = ( (impose_lai)*lai_scale(month_id) + &
4517	((lai_scale(month_id+1)-lai_scale(month_id))impose_lai/30) (MOD(istep,30)+1) )
4518	ENDIF
4519	IF (daily_lai .LT. 0.) daily_lai=0.
4520	WRITE(numout,*) 'MONTH_ID:',month_id ,'MONTH_DAY:', (MOD(istep,30)+1)
4521	WRITE(numout,*) '!=== Daily LAI ====:', daily_lai
4522	WRITE(numout,*) 'BIOMASS_IN_LEAF:', daily_lai/sla(test_pft)
4523	!Covert the daily lai to biomass in leaf, labile ans carbres pools
4524	biomass(test_grid,test_pft,ileaf,icarbon)= daily_lai/sla(test_pft)
4525	!For these two carbon pools we can simply set them as a coinstant value
4526	!labile and carbre pools are for sustaining the photothesis during bad weather conditions.
4527	biomass(test_grid,test_pft,ilabile,icarbon)= 500.
4528	biomass(test_grid,test_pft,icarbres,icarbon)= 500.
4529	!Calculate the biomass in each circ_class again.
4530	DO icirc=1,ncirc
4531	circ_class_biomass(test_grid,test_pft,icirc,:,icarbon)= &
4532	(biomass(test_grid,test_pft,:,icarbon)/float(ncirc))/circ_class_n(test_grid,test_pft,icirc)
4533	WRITE(numout,*) 'circ_class_n:',circ_class_n(test_grid,test_pft,icirc)
4534	WRITE(numout,*) 'leaf_biomass:',biomass(test_grid,test_pft,ileaf,icarbon)
4535	WRITE(numout,*) 'circ_biomass:',circ_class_biomass(test_grid,test_pft,icirc,ileaf,icarbon)
4536	ENDDO
4537	ENDIF !ld_fake_height
4538	!!$ !++++++++
4539
4540
4541
4542	!! 11. Write history files
4543
4544	!---TEMP---
4545	!!$ DO ipts = 1, npts
4546	!!$ height_out(ipts,1) = zero
4547	!!$ DO j = 2, nvm
4548	!!$ height_out(ipts,j) = SUM(circ_class_height_eff(:))/ncirc
4549	!!$ ENDDO
4550	!!$ ENDDO
4551	!---------
4552
4553	!!$ !+++++++++ TEMP ++++++++++
4554	!!$ ! Just for testing. Set the labile and reserve pools to zero to see if it dies.
4555	!!$ istep=istep+1
4556	!!$ IF(istep == 600)THEN
4557	!!$ WRITE(numout,'(A,I6,I6)') '!********** KILLING PFT ',test_pft,istep
4558	!!$ biomass(test_grid,test_pft,ileaf,icarbon)=zero
4559	!!$ biomass(test_grid,test_pft,ilabile,icarbon)=zero
4560	!!$ biomass(test_grid,test_pft,icarbres,icarbon)=zero
4561	!!$ circ_class_biomass(test_grid,test_pft,:,ileaf,icarbon)=zero
4562	!!$ circ_class_biomass(test_grid,test_pft,:,ilabile,icarbon)=zero
4563	!!$ circ_class_biomass(test_grid,test_pft,:,icarbres,icarbon)=zero
4564	!!$ ENDIF
4565	!!$ !+++++++++++++++++++++++++
4566
4567	! Save in history file the variables describing the biomass allocated to the plant parts
4568	CALL histwrite (hist_id_stomate, 'BM_ALLOC_LEAF', itime, &
4569	bm_alloc(:,:,ileaf,icarbon), npts*nvm, horipft_index)
4570	CALL histwrite (hist_id_stomate, 'BM_ALLOC_SAP_AB', itime, &
4571	bm_alloc(:,:,isapabove,icarbon), npts*nvm, horipft_index)
4572	CALL histwrite (hist_id_stomate, 'BM_ALLOC_SAP_BE', itime, &
4573	bm_alloc(:,:,isapbelow,icarbon), npts*nvm, horipft_index)
4574	CALL histwrite (hist_id_stomate, 'BM_ALLOC_ROOT', itime, &
4575	bm_alloc(:,:,iroot,icarbon), npts*nvm, horipft_index)
4576	CALL histwrite (hist_id_stomate, 'BM_ALLOC_FRUIT', itime, &
4577	bm_alloc(:,:,ifruit,icarbon), npts*nvm, horipft_index)
4578	CALL histwrite (hist_id_stomate, 'BM_ALLOC_RES', itime, &
4579	bm_alloc(:,:,icarbres,icarbon), npts*nvm, horipft_index)
4580	CALL histwrite (hist_id_stomate, 'RUE_LONGTERM', itime, &
4581	rue_longterm(:,:), npts*nvm, horipft_index)
4582	CALL histwrite (hist_id_stomate, 'KF', itime, &
4583	k_latosa(:,:), npts*nvm, horipft_index)
4584
4585	DO ipts = 1,npts
4586	DO j = 1,nvm
4587	IF(is_tree(j))THEN
4588	! Calculate the forestry basal area (thus NOT the effective ba)
4589	circ_class_ba(:) = wood_to_ba(circ_class_biomass(ipts,j,:,:,icarbon),j)
4590	ba(ipts,j) = SUM(circ_class_ba(:)circ_class_n(ipts,j,:)) m2_to_ha
4591	wood_volume(ipts,j) = wood_to_volume(biomass(ipts,j,:,icarbon),j,&
4592	branch_ratio(j),0)
4593	store_circ_class_ba(ipts,j,:) = circ_class_ba(:)
4594	ELSE
4595	ba(ipts,j) = val_exp
4596	wood_volume(ipts,j) = val_exp
4597	store_circ_class_ba(ipts,j,:) = val_exp
4598	ENDIF
4599	ENDDO
4600	ENDDO
4601
4602	CALL histwrite (hist_id_stomate, 'BA', itime, &
4603	ba(:,:), npts*nvm, horipft_index)
4604	CALL histwrite (hist_id_stomate, 'WOOD_VOL', itime, &
4605	wood_volume(:,:), npts*nvm, horipft_index)
4606
4607	DO icirc = 1,ncirc
4608	WRITE(var_name,'(A,I3.3)') 'CCBA_',icirc
4609	CALL histwrite (hist_id_stomate, var_name, itime, &
4610	store_circ_class_ba(:,:,icirc), npts*nvm, horipft_index)
4611	WRITE(var_name,'(A,I3.3)') 'CCDELTABA_',icirc
4612	CALL histwrite (hist_id_stomate, VAR_NAME, itime, &
4613	store_delta_ba(:,:,icirc), npts*nvm, horipft_index)
4614	ENDDO
4615
4616	IF (bavard.GE.4) WRITE(numout,*) 'Leaving functional growth'
4617
4618
4619	END SUBROUTINE growth_fun_all
4620
4621
4622
4623	!! ================================================================================================================================
4624	!! FUNCTION : func_derfunc
4625	!!
4626	!>\BRIEF Calculate value for a function and its derivative
4627	!!
4628	!!
4629	!! DESCRIPTION : the routine describes the function and its derivative. Both function and derivative are used
4630	!! by the optimisation scheme. Hence, this function is part of the optimisation scheme and is only
4631	!! called by the optimisation
4632	!!
4633	!! RECENT CHANGE(S):
4634	!!
4635	!! MAIN OUTPUT VARIABLE(S): f, df
4636	!!
4637	!! REFERENCE(S) : Numerical recipies in Fortran 77
4638	!!
4639	!! FLOWCHART :
4640	!! \n
4641	!_ ================================================================================================================================
4642
4643	SUBROUTINE func_derfunc(x, n, o, p, q, r, t, eq_num, f, df)
4644
4645	!! 0. Variable and parameter declaration
4646
4647	!! 0.1 Input variables
4648	REAL(r_std), INTENT(in) :: x !! x value for which the function f(x) will be evaluated
4649	REAL(r_std), INTENT(in) :: n,o,p,q,r,t !! Coefficients of the equation. Not all equations use all coefficients
4650	INTEGER(i_std), INTENT(in) :: eq_num !! Function i.e. f(x), g(x), ...
4651
4652	!! 0.2 Output variables
4653	REAL(r_std), INTENT(out) :: f !! Value y for f(x)
4654	REAL(r_std), INTENT(out) :: df !! Value y for derivative[f(x)]
4655
4656	!! 0.3 Modified variables
4657
4658	!! 0.4 Local variables
4659	!_ ================================================================================================================================
4660
4661	!! 1. Calculate f(x) and df(x)
4662
4663	IF (eq_num .EQ. 1) THEN
4664
4665	!f = nx4 + ox*3 + px*2 + qx + r
4666	!df = 4nx*3 + 3ox2 + 2p*x + q
4667
4668	ELSEIF (eq_num .EQ. 2) THEN
4669
4670	f = ( (nx)/(p((x+o)/t)**(q/(2+q))) ) - r
4671	df = ( n(o(q+2)+2x)((o+x)/t)*(-q/(q+2)) ) / ( p(q+2)*(o+x) )
4672
4673	ENDIF
4674
4675	END SUBROUTINE func_derfunc
4676
4677
4678	!! ================================================================================================================================
4679	!! FUNCTION : iterative_solver
4680	!!
4681	!>\BRIEF find best fitting x for f(x)
4682	!!
4683	!!
4684	!! DESCRIPTION : The function makes use of an iterative approach to optimise the value for X. The solver
4685	!! splits the search region in two but there is an additional check to ensure that bounds are not
4686	!! exceeded.
4687	!!
4688	!! RECENT CHANGE(S):
4689	!!
4690	!! MAIN OUTPUT VARIABLE(S): x
4691	!!
4692	!! REFERENCE(S) : Numerical recipies in Fortran 77
4693	!!
4694	!! FLOWCHART :
4695	!! \n
4696	!_ ================================================================================================================================
4697
4698	FUNCTION newX(n, o, p, q, r, t, x1, x2, eq_num, j, ipts)
4699
4700	!! 0. Variable and parameter declaration
4701
4702	!! 0.1 Input variables
4703	REAL(r_std), INTENT(in) :: n,o,p,q,r,t !! Coefficients of the equation. Not all
4704	!! equations use all coefficients
4705	REAL(r_std), INTENT(in) :: x1 !! Lower boundary off search range
4706	REAL(r_std), INTENT(in) :: x2 !! Upper boundary off search range
4707	INTEGER(i_std), INTENT(in) :: eq_num !! Function for which an iterative solution is
4708	!! searched
4709	INTEGER(i_std), INTENT(in) :: j !! Number of PFT
4710	INTEGER(i_std), INTENT(in) :: ipts !! Number of grdi square...for debugging
4711
4712	!! 0.2 Output variables
4713
4714	!! 0.3 Modified variables
4715
4716	!! 0.4 Local variables
4717	INTEGER(i_std), PARAMETER :: maxit = 20 !! Maximum number of iterations
4718	INTEGER(i_std), PARAMETER :: max_attempt = 5 !! Maximum number of iterations
4719	INTEGER(i_std) :: i, attempt !! Index
4720	REAL(r_std) :: newX !! New estimate for X
4721	REAL(r_std) :: fl, fh, f !! Value of the function for the lower bound (x1),
4722	!! upper bound (x2) and the new value (newX)
4723	REAL(r_std) :: xh, xl !! Checked lower and upper bounds
4724	REAL(r_std) :: df !! Value of the derivative of the function for newX
4725	REAL(r_std) :: dx, dxold !! Slope of improvement
4726	REAL(r_std) :: temp !! Dummy variable for value swaps
4727	REAL(r_std) :: low, high !! temporary variables for x1 and x2 to avoid
4728	!! intent in/out conflicts with Cs
4729	LOGICAL :: found_range !! Flag indicating whether the range in which
4730	!! a solution exists was identified.
4731
4732
4733	!_ ================================================================================================================================
4734
4735	!! 1. Find solution for X
4736
4737	! Not sure whether our initial range is large enough. We will
4738	! start with a narrow range so we are more likely to fine the
4739	! solution witin ::maxit iterations. If there is no solution
4740	! in the initial range we will expande the range and try again
4741
4742	! Initilaze flags and counters
4743	attempt = 2
4744	found_range = .FALSE.
4745	low = x1
4746	high = x2
4747
4748
4749	! Calculate y for the upper and lower bound
4750	DO WHILE (.NOT. found_range .AND. attempt .LT. max_attempt)
4751
4752	CALL func_derfunc(low, n, o, p, q, r, t, eq_num, fl, df)
4753	CALL func_derfunc(high, n, o, p, q, r, t, eq_num, fh, df)
4754
4755	IF ((fl .GT. 0.0 .AND. fh .GT. 0.0) .OR. &
4756	(fl .LT. 0.0 .AND. fh .LT. 0.0)) THEN
4757
4758	IF (attempt .GT. max_attempt) THEN
4759
4760	! If the sign of y does not changes between the upper
4761	! and lower bound there no solution with the specified range
4762	WRITE(numout,*) 'Iterative procedure - tried really hard but'
4763	WRITE(numout,*) 'no solution exists within the specified range'
4764	WRITE(numout,*) 'PFT, grid square: ',j,ipts
4765	CALL ipslerr_p (3,'growth_fun_all','newX',&
4766	'Iterative procedure - tried really hard but failed','')
4767
4768	ELSE
4769
4770	! Update counter
4771	attempt = attempt + 1
4772
4773	! Use previous upper boundary as the lower
4774	! boundary for the next range search. Increase
4775	! the upper boundary
4776	temp = high
4777	high = x1 * attempt
4778	low = temp
4779
4780	! Enlarge the search range
4781	!!$ WRITE(numout,*) 'Iterative procedure - enlarge the search range'
4782	!!$ WRITE(numout,*) 'New range: ', x1, x2
4783	!!$ WRITE(numout,*) 'PFT, grid square, range: ',j,ipts,attempt
4784
4785	ENDIF
4786
4787	ELSE
4788
4789	found_range = .TRUE.
4790
4791	ENDIF
4792
4793	ENDDO
4794
4795	! Only when we found a range we will search for the solution
4796	IF (found_range) THEN
4797
4798	! If the sign of y changes between the upper and lower bound there is a solution
4799	IF ( ABS(fl) .LT. min_stomate ) THEN
4800
4801	! The lower bound is the solution - most likely the lower bound is too high
4802	newX = x1
4803	RETURN
4804
4805	ELSEIF ( ABS(fh) .LT. min_stomate ) THEN
4806
4807	! The upper bound is the solution - most likely the upper bound is too low
4808	newX = x2
4809	RETURN
4810
4811	ELSEIF (fl .LT. 0.0) THEN
4812
4813	! Accept the lower and upper bounds as specified
4814	xl = x1
4815	xh = x2
4816	ELSE
4817
4818	! Lower and upper bounds were swapped, correct their ranking
4819	xh = x1
4820	xl = x2
4821	ENDIF
4822
4823	! Estimate the initial newX value
4824	newX = 0.5 * (x1+x2)
4825	dxold = ABS(x2-x1)
4826	dx = dxold
4827
4828	ENDIF
4829
4830	! Calculate y=f(x) and df(x) for initial guess of newX
4831	CALL func_derfunc(newX, n, o, p, q, r, t, eq_num, f, df)
4832
4833	! Evaluate for the maximum number of iterations
4834	DO i = 1,maxit
4835
4836	IF ( ((newX-xh)df-f)((newX-xl)df-f) .GT. 0.0 .OR. ABS(deuxf) > ABS(dxold*df) ) THEN
4837
4838	! Bisection
4839	dxold = dx
4840	dx = 0.5 * (xh-xl)
4841	newX = xl+dx
4842	IF (xl .EQ. newX) RETURN
4843
4844	ELSE
4845
4846	! Newton
4847	dxold = dx
4848	dx = f/df
4849	temp = newX
4850	newX = newX-dx
4851	IF (temp .EQ. newX) RETURN
4852
4853	ENDIF
4854
4855	! Precision reached
4856	IF ( ABS(dx) .LT. min_stomate) RETURN
4857
4858	! Precision was not reached calculate f(x) and df(x) for newX
4859	CALL func_derfunc(newX, n, o, p, q, r, t, eq_num, f, df)
4860
4861	! Narrow down the range
4862	IF (f .LT. 0.0) then
4863	xl = newX
4864	ELSE
4865	xh = newX
4866	ENDIF
4867
4868	ENDDO ! maximum number of iterations
4869
4870	!---TEMP---
4871	IF (j.EQ. test_pft) THEN
4872	WRITE(numout,*) 'Iterative procedure: exceeded maximum iterations'
4873	ENDIF
4874	!----------
4875
4876	END FUNCTION newX
4877
4878
4879	!! ================================================================================================================================
4880	!! SUBROUTINE : comments
4881	!!
4882	!>\BRIEF Contains all comments to check the code
4883	!!
4884	!!
4885	!! DESCRIPTION : contains all comments to check the code. By setting pft_test to 0, this routine is not called
4886	!!
4887	!! RECENT CHANGE(S):
4888	!!
4889	!! MAIN OUTPUT VARIABLE(S): none
4890	!!
4891	!! REFERENCE(S) : none
4892	!!
4893	!! FLOWCHART :
4894	!! \n
4895	!_ ================================================================================================================================
4896
4897	SUBROUTINE comment(npts, Cl_target, Cl, Cs_target, &
4898	Cs, Cr_target, Cr, delta_ba, &
4899	ipts, j, l, b_inc_tot, &
4900	Cl_incp, Cs_incp, Cr_incp, KF, LF, &
4901	Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
4902	grow_wood, circ_class_n, ind, n_comment)
4903
4904	!! 0. Variable and parameter declaration
4905
4906	!! 0.1 Input variables
4907	INTEGER(i_std), INTENT(in) :: npts !! Defined in stomate_growth_fun_all
4908	REAL(r_std), DIMENSION(:), INTENT(in) :: Cl_target, Cs_target, Cr_target !! Defined in stomate_growth_fun_all
4909	REAL(r_std), DIMENSION(:), INTENT(in) :: Cl_incp, Cs_incp, Cr_incp !! Defined in stomate_growth_fun_all
4910	REAL(r_std), DIMENSION(:), INTENT(in) :: Cl_inc, Cs_inc, Cr_inc, Cf_inc !! Defined in stomate_growth_fun_all
4911	REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: circ_class_n !! Defined in stomate_growth_fun_all
4912	REAL(r_std), DIMENSION(:), INTENT(in) :: Cl, Cs, Cr !! Defined in stomate_growth_fun_all
4913	REAL(r_std), DIMENSION(:), INTENT(in) :: delta_ba !! Defined in stomate_growth_fun_all
4914	REAL(r_std), DIMENSION(:,:), INTENT(in) :: KF, LF, ind !! Defined in stomate_growth_fun_all
4915	REAL(r_std), INTENT(in) :: b_inc_tot !! Defined in stomate_growth_fun_all
4916	INTEGER(i_std), INTENT(in) :: ipts, j, l !! Defined in stomate_growth_fun_all
4917	LOGICAL, INTENT(in) :: grow_wood !! Defined in stomate_growth_fun_all
4918
4919	!! 0.2 Output variables
4920
4921	!! 0.3 Modified variables
4922
4923	!! 0.4 Local variables
4924	INTEGER(i_std) :: n_comment !! Comment number
4925	!_ ================================================================================================================================
4926
4927	SELECT CASE (n_comment)
4928	CASE (1)
4929	! Enough leaves and wood, grow roots
4930	WRITE(numout,*) 'Exc 1: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, class, '
4931	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
4932	b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
4933	IF (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -min_stomate) THEN
4934	WRITE(numout,*) 'Exc 1.1: unallocated less then 0: overspending, ', b_inc_tot - &
4935	(circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
4936	ELSE
4937	IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. zero) .AND. &
4938	((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .LE. min_stomate) ) THEN
4939	WRITE(numout,*) 'Exc 1.2: unallocated <>= 0 but tree is in good shape: successful allocation'
4940	ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
4941	.LE. min_stomate) .AND. &
4942	(circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l)) .GT. min_stomate) ) THEN
4943	WRITE(numout,*) 'Exc 1.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
4944	ELSE
4945	WRITE(numout,*) 'WARNING 24: Exc 1.4 unexpected result'
4946	WRITE(numout,*) 'WARNING 24: PFT, ipts: ',j,ipts
4947	ENDIF
4948	ENDIF
4949
4950	CASE (2)
4951	! Enough wood and roots, grow leaves
4952	WRITE(numout,*) 'Exc 2: Cl_incp(<>0), Cs_incp (=0), Cr_incp (=0), unallocated, class, '
4953	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
4954	b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
4955	IF (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -min_stomate) THEN
4956	WRITE(numout,*) 'Exc 2.1: unallocated less then 0: overspending, ', b_inc_tot - &
4957	(circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
4958	ELSE
4959	IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. zero) .AND. &
4960	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .LE. min_stomate) ) THEN
4961	WRITE(numout,*) 'Exc 2.2: unallocated <>= 0 but tree is in good shape: successful allocation'
4962	ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
4963	.LE. min_stomate) .AND. &
4964	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .GT. min_stomate) ) THEN
4965	WRITE(numout,*) 'Exc 2.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
4966	ELSE
4967	WRITE(numout,*) 'WARNING 25: Exc 2.4 unexpected result'
4968	WRITE(numout,*) 'WARNING 25: PFT, ipts: ',j,ipts
4969	ENDIF
4970	ENDIF
4971
4972
4973	CASE (3)
4974
4975	! Enough wood, grow leaves and roots
4976	WRITE(numout,*) 'Exc 3: Cl_incp(<>0), Cs_incp(=0), Cr_incp(<>0), unallocated, class, '
4977	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), b_inc_tot - &
4978	(circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))), l
4979	IF (b_inc_tot - circ_class_n(ipts,j,l) * (Cl_incp(l) + Cs_incp(l) + Cr_incp(l)) &
4980	.LT. -min_stomate) THEN
4981	WRITE(numout,*) 'Exc 3.1: unallocated less then 0: overspending, ', b_inc_tot - &
4982	(circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) )
4983	ELSE
4984	IF ( (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) &
4985	.GE. min_stomate) .AND. &
4986	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l)) ) .LE. min_stomate) .AND. &
4987	((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l)) ) .LE. min_stomate) ) THEN
4988	WRITE(numout,*) 'Exc 3.2: unallocated <>= 0 but tree is in good shape: successful allocation'
4989	ELSEIF ( (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
4990	.LE. min_stomate) .AND. &
4991	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l)) ) .GT. min_stomate) .AND. &
4992	((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l)) ) .GT. min_stomate) ) THEN
4993	WRITE(numout,*) 'Exc 3.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
4994	ELSE
4995	WRITE(numout,*) 'WARNING 26: Exc 3.4 unexpected result'
4996	WRITE(numout,*) 'WARNING 26: PFT, ipts: ',j,ipts
4997	ENDIF
4998	ENDIF
4999
5000	CASE(4)
5001	! Enough leaves and wood, grow roots
5002	WRITE(numout,*) 'Exc 4: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, class, '
5003	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
5004	b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
5005	IF (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -min_stomate) THEN
5006	WRITE(numout,*) 'Exc 4.1: unallocated less then 0: overspending, ', b_inc_tot - &
5007	(circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
5008	ELSE
5009	IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. zero) .AND. &
5010	((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .LE. min_stomate) ) THEN
5011	WRITE(numout,*) 'Exc 4.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5012	ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
5013	.LE. min_stomate) .AND. &
5014	((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .GT. min_stomate) ) THEN
5015	WRITE(numout,*) 'Exc 4.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5016	ELSE
5017	WRITE(numout,*) 'WARNING 27: Exc 4.4 unexpected result'
5018	WRITE(numout,*) 'WARNING 27: PFT, ipts: ',j,ipts
5019	ENDIF
5020	ENDIF
5021
5022	CASE(5)
5023	! Enough leaves and roots, grow wood
5024	WRITE(numout,*) 'Exc 5: Cl_incp(=0), Cs_incp (<>0), Cr_incp (=0), unallocated, class, '
5025	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
5026	b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
5027	IF (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -min_stomate) THEN
5028	WRITE(numout,*) 'Exc 5.1: unallocated less then 0: overspending, ', b_inc_tot - &
5029	(circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
5030	ELSE
5031	IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. zero) .AND. &
5032	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .LE. min_stomate) ) THEN
5033	WRITE(numout,*) 'Exc 5.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5034	ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
5035	.LE. min_stomate) .AND. &
5036	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .GT. min_stomate) ) THEN
5037	WRITE(numout,*) 'Exc 5.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5038	ELSE
5039	WRITE(numout,*) 'WARNING 28: Exc 5.4 unexpected result'
5040	WRITE(numout,*) 'WARNING 28: PFT, ipts: ',j,ipts
5041	ENDIF
5042	ENDIF
5043
5044	CASE(6)
5045	! Enough leaves, grow wood and roots
5046	WRITE(numout,*) 'Exc 6: Cl_incp(=0), Cs_incp(<>0), Cr_incp(<>0), unallocated'
5047	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
5048	b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
5049	IF (b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .LT. -min_stomate) THEN
5050	WRITE(numout,*) 'Exc 6.1: unallocated less then 0: overspending, ', &
5051	b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
5052	ELSE
5053	IF ( (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .GE. zero) .AND. &
5054	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .LE. min_stomate) .AND. &
5055	((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .LE. min_stomate) ) THEN
5056	WRITE(numout,*) 'Exc 6.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5057	ELSEIF ( (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .LE. min_stomate) .AND. &
5058	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .GT. min_stomate) .OR. &
5059	((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .GT. min_stomate) ) THEN
5060	WRITE(numout,*) &
5061	'Exc 6.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5062	ELSE
5063	WRITE(numout,*) 'WARNING 29: Exc 6.4 unexpected result'
5064	WRITE(numout,*) 'WARNING 29: PFT, ipts: ',j,ipts
5065	ENDIF
5066	ENDIF
5067
5068	CASE(7)
5069	! Enough leaves and wood, grow roots
5070	WRITE(numout,*) 'Exc 7: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, class, '
5071	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
5072	b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
5073	IF (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -min_stomate) THEN
5074	WRITE(numout,*) 'Exc 7.1: unallocated less then 0: overspending, ', b_inc_tot - &
5075	(circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
5076	ELSE
5077	IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. zero) .AND. &
5078	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .LE. min_stomate) ) THEN
5079	WRITE(numout,*) 'Exc 7.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5080	ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
5081	.LE. min_stomate) .AND. &
5082	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .GT. min_stomate) ) THEN
5083	WRITE(numout,*) 'Exc 7.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5084	ELSE
5085	WRITE(numout,*) 'WARNING 30: Exc 7.4 unexpected result'
5086	WRITE(numout,*) 'WARNING 30: PFT, ipts: ',j,ipts
5087	ENDIF
5088	ENDIF
5089
5090	CASE(8)
5091	! Enough leaves and roots, grow wood
5092	WRITE(numout,*) 'Exc 8: Cl_incp(=0), Cs_incp (<>0), Cr_incp (=0), unallocated, class, '
5093	WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
5094	b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
5095	IF (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -min_stomate) THEN
5096	WRITE(numout,*) 'Exc 8.1: unallocated less then 0: overspending, ', b_inc_tot - &
5097	(circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
5098	ELSE
5099	IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. zero) .AND. &
5100	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .LE. min_stomate) ) THEN
5101	WRITE(numout,*) 'Exc 8.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5102	ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
5103	.LE. min_stomate) .AND. &
5104	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .GT. min_stomate) ) THEN
5105	WRITE(numout,*) 'Exc 8.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5106	ELSE
5107	WRITE(numout,*) 'WARNING 31: Exc 8.4 unexpected result'
5108	WRITE(numout,*) 'WARNING 31: PFT, ipts: ',j,ipts
5109	ENDIF
5110	ENDIF
5111
5112	CASE(9)
5113	! Enough roots, grow leaves and wood
5114	WRITE(numout,*) 'Exc 9: delta_ba, Cl_incp(<>0), Cs_incp(<>0), Cr_incp(=0), unallocated, class, '
5115	WRITE(numout,*) delta_ba(:), Cl_incp(l), Cs_incp(l), Cr_incp(l), &
5116	b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))), l
5117	IF (b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .LT. -min_stomate) THEN
5118	WRITE(numout,*) 'Exc 9.1: unallocated less then 0: overspending, ', &
5119	b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
5120	ELSE
5121	IF ( (b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .GE. zero) .AND. &
5122	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .LE. min_stomate) .AND. &
5123	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .LE. min_stomate) ) THEN
5124	WRITE(numout,*) 'Exc 9.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5125	ELSEIF ( (b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) &
5126	.LE. min_stomate) .AND. &
5127	((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .GT. min_stomate) .OR. &
5128	((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .GT. min_stomate) ) THEN
5129	WRITE(numout,*) 'Exc 9.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5130	ELSE
5131	WRITE(numout,*) 'WARNING 32: Exc 9.4 unexpected result'
5132	WRITE(numout,*) 'WARNING 32: PFT, ipts: ',j,ipts
5133	ENDIF
5134	ENDIF
5135
5136	CASE(10)
5137	! Ready for ordinary allocation
5138	WRITE(numout,*) 'Ready for ordinary allocation?'
5139	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
5140	WRITE(numout,*) 'b_inc_tot, ', b_inc_tot
5141	WRITE(numout,*) 'Cl, Cs, Cr', Cl(:), Cs(:), Cr(:)
5142	WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(:)-Cl(:)
5143	WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(:)-Cs(:)
5144	WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(:)-Cr(:)
5145	IF (b_inc_tot .GT. min_stomate) THEN
5146	IF (SUM(ABS(Cl_target(:)-Cl(:))) .LE. min_stomate) THEN
5147	IF (SUM(ABS(Cs_target(:)-Cs(:))) .LE. min_stomate) THEN
5148	IF (SUM(ABS(Cr_target(:)-Cr(:))) .LE. min_stomate) THEN
5149	IF (grow_wood) THEN
5150	WRITE(numout,*) 'should result in exc 10.1 or 10.2'
5151	ELSE
5152	WRITE(numout,*) 'No wood growth. Not a problem! Just an observation.'
5153	ENDIF
5154	ELSE
5155	WRITE(numout,*) 'WARNING 34: problem with Cr_target'
5156	WRITE(numout,*) 'WARNING 34: PFT, ipts: ',j,ipts
5157	ENDIF
5158	ELSE
5159	WRITE(numout,*) 'WARNING 35: problem with Cs_target'
5160	WRITE(numout,*) 'WARNING 35: PFT, ipts: ',j,ipts
5161	ENDIF
5162	ELSE
5163	WRITE(numout,*) 'WARNING 36: problem with Cl_target'
5164	WRITE(numout,*) 'WARNING 36: PFT, ipts: ',j,ipts
5165	ENDIF
5166	ELSEIF(b_inc_tot .LT. -min_stomate) THEN
5167	WRITE(numout,*) 'WARNING 37: problem with b_inc_tot'
5168	WRITE(numout,*) 'WARNING 37: PFT, ipts: ',j,ipts
5169	ELSE
5170	WRITE(numout,*) 'no unallocated fraction'
5171	ENDIF
5172
5173	CASE(11)
5174	! Ordinary allocation
5175	WRITE(numout,*) 'delta_ba, ', delta_ba
5176	IF ( (SUM(Cl_inc(:)) .GE. zero) .AND. (SUM(Cs_inc(:)) .GE. zero) .AND. &
5177	(SUM(Cr_inc(:)) .GE. zero) .AND. &
5178	( b_inc_tot - SUM(circ_class_n(ipts,j,:) * (Cl_inc(:)+Cs_inc(:)+Cr_inc(:))) .GT. -1*min_stomate) .AND. &
5179	( b_inc_tot - SUM(circ_class_n(ipts,j,:) * (Cl_inc(:)+Cs_inc(:)+Cr_inc(:))) .LT. min_stomate ) ) THEN
5180	WRITE(numout,*) 'Exc 10.1: Ordinary allocation was succesful'
5181	WRITE(numout,*) 'Cl_inc, Cs_inc, Cr_inc, unallocated', Cl_inc(:), Cs_inc(:), Cr_inc(:), &
5182	b_inc_tot - SUM(circ_class_n(ipts,j,:) * (Cl_inc(:)+Cs_inc(:)+Cr_inc(:)))
5183	ELSE
5184	WRITE(numout,*) 'WARNING 38: Exc 10.2 problem with ordinary allocation'
5185	WRITE(numout,*) 'WARNING 38: PFT, ipts: ',j,ipts
5186	WRITE(numout,*) 'Cl_inc, Cs_inc, Cr_inc, unallocated', Cl_inc(:), Cs_inc(:), Cr_inc(:), &
5187	b_inc_tot - SUM(circ_class_n(ipts,j,:) * (Cl_inc(:)+Cs_inc(:)+Cr_inc(:)))
5188	ENDIF
5189
5190	CASE(12)
5191	! Enough leaves and structure, grow roots
5192	WRITE(numout,*) 'Exc 1: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, '
5193	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
5194	b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
5195	IF (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -min_stomate) THEN
5196	WRITE(numout,*) 'Exc 1.1: unallocated less then 0: overspending, ', b_inc_tot - &
5197	(ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
5198	ELSE
5199	IF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. zero) .AND. &
5200	((ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .LE. min_stomate) ) THEN
5201	WRITE(numout,*) 'Exc 1.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5202	ELSEIF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
5203	.LE. min_stomate) .AND. &
5204	(ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1)) .GT. min_stomate) ) THEN
5205	WRITE(numout,*) 'Exc 1.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5206	ELSE
5207	WRITE(numout,*) 'WARNING 39: Exc 1.4 unexpected result'
5208	WRITE(numout,*) 'WARNING 39: PFT, ipts: ',j,ipts
5209	ENDIF
5210	ENDIF
5211
5212	CASE(13)
5213	! Enough structural C and roots, grow leaves
5214	WRITE(numout,*) 'Exc 2: Cl_incp(<>0), Cs_incp (=0), Cr_incp (=0), unallocated, '
5215	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
5216	b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
5217	IF (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -min_stomate) THEN
5218	WRITE(numout,*) 'Exc 2.1: unallocated less then 0: overspending, ', b_inc_tot - &
5219	(ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
5220	ELSE
5221	IF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. zero) .AND. &
5222	((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .LE. min_stomate) ) THEN
5223	WRITE(numout,*) 'Exc 2.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5224	ELSEIF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
5225	.LE. min_stomate) .AND. &
5226	((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .GT. min_stomate) ) THEN
5227	WRITE(numout,*) 'Exc 2.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5228	ELSE
5229	WRITE(numout,*) 'WARNING 40: Exc l.4 unexpected result'
5230	WRITE(numout,*) 'WARNING 40: PFT, ipts: ',j,ipts
5231	ENDIF
5232	ENDIF
5233
5234	CASE(14)
5235	! Enough structural C and root, grow leaves
5236	WRITE(numout,*) 'Exc 3: Cl_incp(<>0), Cs_incp(=0), Cr_incp(<>0), unallocated, '
5237	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), b_inc_tot - &
5238	(ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
5239	IF (b_inc_tot - ind(ipts,j) * (Cl_incp(1) + Cs_incp(1) + Cr_incp(1)) &
5240	.LT. -min_stomate) THEN
5241	WRITE(numout,*) 'Exc 3.1: unallocated less then 0: overspending, ', b_inc_tot - &
5242	(ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
5243	ELSE
5244	IF ( (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) &
5245	.GE. min_stomate) .AND. &
5246	((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1)) ) .LE. min_stomate) .AND. &
5247	((ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1)) ) .LE. min_stomate) ) THEN
5248	WRITE(numout,*) 'Exc 3.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5249	ELSEIF ( (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
5250	.LE. min_stomate) .AND. &
5251	((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1)) ) .GT. min_stomate) .AND. &
5252	((ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1)) ) .GT. min_stomate) ) THEN
5253	WRITE(numout,*) 'Exc 3.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5254	ELSE
5255	WRITE(numout,*) 'WARNING 41: Exc 3.4 unexpected result'
5256	WRITE(numout,*) 'WARNING 41: PFT, ipts: ',j,ipts
5257	ENDIF
5258	ENDIF
5259
5260	CASE(15)
5261	! Enough leaves and structural C, grow roots
5262	WRITE(numout,*) 'Exc 4: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, '
5263	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
5264	b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
5265	IF (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -min_stomate) THEN
5266	WRITE(numout,*) 'Exc 4.1: unallocated less then 0: overspending, ', b_inc_tot - &
5267	(ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
5268	ELSE
5269	IF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. zero) .AND. &
5270	((ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .LE. min_stomate) ) THEN
5271	WRITE(numout,*) 'Exc 4.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5272	ELSEIF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
5273	.LE. min_stomate) .AND. &
5274	((ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .GT. min_stomate) ) THEN
5275	WRITE(numout,*) 'Exc 4.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5276	ELSE
5277	WRITE(numout,*) 'WARNING 42: Exc 4.4 unexpected result'
5278	WRITE(numout,*) 'WARNING 42: PFT, ipts: ',j,ipts
5279	ENDIF
5280	ENDIF
5281
5282	CASE(16)
5283	! Enough leaves and roots, grow structural C
5284	WRITE(numout,*) 'Exc 5: Cl_incp(=0), Cs_incp (<>0), Cr_incp (=0), unallocated, '
5285	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
5286	b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
5287	IF (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -min_stomate) THEN
5288	WRITE(numout,*) 'Exc 5.1: unallocated less then 0: overspending, ', b_inc_tot - &
5289	(ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
5290	ELSE
5291	IF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. zero) .AND. &
5292	((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .LE. min_stomate) ) THEN
5293	WRITE(numout,*) 'Exc 5.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5294	ELSEIF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
5295	.LE. min_stomate) .AND. &
5296	((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .GT. min_stomate) ) THEN
5297	WRITE(numout,*) 'Exc 5.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5298	ELSE
5299	WRITE(numout,*) 'WARNING 43: Exc 5.4 unexpected result'
5300	WRITE(numout,*) 'WARNING 43: PFT, ipts: ',j,ipts
5301	ENDIF
5302	ENDIF
5303
5304	CASE(17)
5305	! Enough leaves, grow structural C and roots
5306	WRITE(numout,*) 'Exc 6: Cl_incp(=0), Cs_incp(<>0), Cr_incp(<>0), unallocated'
5307	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
5308	b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
5309	IF (b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) .LT. -min_stomate) THEN
5310	WRITE(numout,*) 'Exc 6.1: unallocated less then 0: overspending, ', &
5311	b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
5312	ELSE
5313	IF ( (b_inc_tot - ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) .GE. zero) .AND. &
5314	((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .LE. min_stomate) .AND. &
5315	((ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .LE. min_stomate) ) THEN
5316	WRITE(numout,*) 'Exc 6.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5317	ELSEIF ( (b_inc_tot - ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) .LE. min_stomate) .AND. &
5318	((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .GT. min_stomate) .AND. &
5319	((ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .GT. min_stomate) ) THEN
5320	WRITE(numout,*) &
5321	'Exc 6.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5322	ELSE
5323	WRITE(numout,*) 'WARNING 44: Exc 6.4 unexpected result'
5324	WRITE(numout,*) 'WARNING 44: PFT, ipts: ',j,ipts
5325	ENDIF
5326	ENDIF
5327
5328	CASE(18)
5329	! Enough leaves and structural C, grow roots
5330	WRITE(numout,*) 'Exc 7: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, '
5331	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
5332	b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
5333	IF (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -min_stomate) THEN
5334	WRITE(numout,*) 'Exc 7.1: unallocated less then 0: overspending, ', b_inc_tot - &
5335	(ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
5336	ELSE
5337	IF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. zero) .AND. &
5338	((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .LE. min_stomate) ) THEN
5339	WRITE(numout,*) 'Exc 7.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5340	ELSEIF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
5341	.LE. min_stomate) .AND. &
5342	((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .GT. min_stomate) ) THEN
5343	WRITE(numout,*) 'Exc 7.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5344	ELSE
5345	WRITE(numout,*) 'WARNING 45: Exc 7.4 unexpected result'
5346	WRITE(numout,*) 'WARNING 45: PFT, ipts: ',j,ipts
5347	ENDIF
5348	ENDIF
5349
5350	CASE(19)
5351	! Enough leaves and roots, grow structural C
5352	WRITE(numout,*) 'Exc 8: Cl_incp(=0), Cs_incp (<>0), Cr_incp (=0), unallocated, '
5353	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
5354	b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
5355	IF (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -min_stomate) THEN
5356	WRITE(numout,*) 'Exc 8.1: unallocated less then 0: overspending, ', b_inc_tot - &
5357	(ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
5358	ELSE
5359	IF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. zero) .AND. &
5360	((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .LE. min_stomate) ) THEN
5361	WRITE(numout,*) 'Exc 8.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5362	ELSEIF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
5363	.LE. min_stomate) .AND. &
5364	((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .GT. min_stomate) ) THEN
5365	WRITE(numout,*) 'Exc 8.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5366	ELSE
5367	WRITE(numout,*) 'WARNING 46: Exc 8.4 unexpected result'
5368	WRITE(numout,*) 'WARNING 46: PFT, ipts: ',j,ipts
5369	ENDIF
5370	ENDIF
5371
5372	CASE(20)
5373	! Enough roots, grow structural C and leaves
5374	WRITE(numout,*) 'Exc 9: Cl_incp(<>0), Cs_incp(<>0), Cr_incp(=0), unallocated, '
5375	WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
5376	b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
5377	WRITE(numout,) 'term 1', b_inc_tot - (ind(ipts,j) (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
5378	WRITE(numout,) 'term 2', (ind(ipts,j) ABS(Cl_target(1)-Cl(1)-Cl_incp(1)))
5379	WRITE(numout,) 'term 3', (ind(ipts,j) ABS(Cs_target(1)-Cs(1)-Cs_incp(1)))
5380	IF (b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) .LT. -min_stomate) THEN
5381	WRITE(numout,*) 'Exc 9.1: unallocated less then 0: overspending, ', &
5382	b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
5383	ELSE
5384	IF ( (b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) .GE. zero) .AND. &
5385	((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .LE. min_stomate) .AND. &
5386	((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .LE. min_stomate) ) THEN
5387	WRITE(numout,*) 'Exc 9.2: unallocated <>= 0 but tree is in good shape: successful allocation'
5388	ELSEIF ( (b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) .LE. min_stomate) .AND. &
5389	(((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .GT. min_stomate) .OR. &
5390	((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .GT. min_stomate) ) ) THEN
5391	WRITE(numout,*) 'Exc 9.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
5392	ELSE
5393	WRITE(numout,*) 'WARNING 47: Exc 9.4 unexpected result'
5394	WRITE(numout,*) 'WARNING 47: PFT, ipts: ',j,ipts
5395	ENDIF
5396	ENDIF
5397
5398	CASE(21)
5399	! Ready for ordinary allocation
5400	WRITE(numout,*) 'Ready for ordinary allocation?'
5401	WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
5402	WRITE(numout,*) 'b_inc_tot, ', b_inc_tot
5403	WRITE(numout,*) 'Cl, Cs, Cr', Cl(1), Cs(1), Cr(1)
5404	WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(1)-Cl(1)
5405	WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(1)-Cs(1)
5406	WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(1)-Cr(1)
5407	IF (b_inc_tot .GT. min_stomate) THEN
5408	IF (ABS(Cl_target(1)-Cl(1)) .LE. min_stomate) THEN
5409	IF (ABS(Cs_target(1)-Cs(1)) .LE. min_stomate) THEN
5410	IF (ABS(Cr_target(1)-Cr(1)) .LE. min_stomate) THEN
5411	IF (b_inc_tot .GT. min_stomate) THEN
5412	IF (grow_wood) THEN
5413	WRITE(numout,*) 'should result in exc 10.1 or 10.2'
5414	ELSE
5415	WRITE(numout,*) 'WARNING 48: no wood growth'
5416	WRITE(numout,*) 'WARNING 48: PFT, ipts: ',j,ipts
5417	ENDIF
5418	ENDIF
5419	ELSE
5420	WRITE(numout,*) 'WARNING 49: problem with Cr_target'
5421	WRITE(numout,*) 'WARNING 49: PFT, ipts: ',j,ipts
5422	ENDIF
5423	ELSE
5424	WRITE(numout,*) 'WARNING 50: problem with Cs_target'
5425	WRITE(numout,*) 'WARNING 50: PFT, ipts: ',j,ipts
5426	ENDIF
5427	ELSE
5428	WRITE(numout,*) 'WARNING 51: problem with Cl_target'
5429	WRITE(numout,*) 'WARNING 51: PFT, ipts: ',j,ipts
5430	ENDIF
5431	ELSEIF(b_inc_tot .LT. -min_stomate) THEN
5432	WRITE(numout,*) 'WARNING 52: problem with b_inc_tot'
5433	WRITE(numout,*) 'WARNING 52: PFT, ipts: ',j,ipts
5434	ELSE
5435	WRITE(numout,*) 'no unallocated fraction'
5436	ENDIF
5437
5438	CASE(22)
5439	! Ordinary allocation
5440	IF ( ((Cl_inc(1)) .GE. zero) .AND. ((Cs_inc(1)) .GE. zero) .AND. &
5441	((Cr_inc(1)) .GE. zero) .AND. &
5442	( b_inc_tot - (ind(ipts,j) * (Cl_inc(1)+Cs_inc(1)+Cr_inc(1))) .GT. -1*min_stomate) .AND. &
5443	( b_inc_tot - (ind(ipts,j) * (Cl_inc(1)+Cs_inc(1)+Cr_inc(1))) .LT. min_stomate ) ) THEN
5444	WRITE(numout,*) 'Exc 10.1: Ordinary allocation was succesful'
5445	WRITE(numout,*) 'Cl_inc, Cs_inc, Cr_inc, unallocated', Cl_inc(1), Cs_inc(1), Cr_inc(1), &
5446	b_inc_tot - (ind(ipts,j) * (Cl_inc(1)+Cs_inc(1)+Cr_inc(1)))
5447	ELSE
5448	WRITE(numout,*) 'WARNING 53: Exc 10.2 problem with ordinary allocation'
5449	WRITE(numout,*) 'WARNING 53: PFT, ipts: ',j,ipts
5450	WRITE(numout,*) 'Cl_inc, Cs_inc, Cr_inc, unallocated', Cl_inc(1), Cs_inc(1), Cr_inc(1), &
5451	b_inc_tot - (ind(ipts,j) * (Cl_inc(1)+Cs_inc(1)+Cr_inc(1)))
5452	ENDIF
5453
5454	END SELECT
5455
5456	END SUBROUTINE comment
5457
5458	END MODULE stomate_growth_fun_all

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

Download in other formats: