source: tags/ORCHIDEE/src_stomate/stomate_phenology.f90 @ 6

Last change on this file since 6 was 6, checked in by orchidee, 14 years ago

import first tag equivalent to CVS orchidee_1_9_5 + OOL_1_9_5
File size: 36.5 KB
Line 
1! Phenology
2!
3! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_phenology.f90,v 1.11 2010/04/06 16:06:34 ssipsl Exp $
4! IPSL (2006)
5!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
6!
7MODULE stomate_phenology
8
9  ! modules used:
10
11  USE ioipsl
12  USE stomate_constants
13  USE constantes_veg
14
15  IMPLICIT NONE
16
17  ! private & public routines
18
19  PRIVATE
20  PUBLIC phenology,phenology_clear
21
22  ! first call
23  LOGICAL, SAVE                                              :: firstcall = .TRUE.
24  LOGICAL, SAVE                                              :: firstcall_hum = .TRUE.
25  LOGICAL, SAVE                                              :: firstcall_moi = .TRUE.
26  LOGICAL, SAVE                                              :: firstcall_humgdd = .TRUE.
27  LOGICAL, SAVE                                              :: firstcall_moigdd = .TRUE.
28
29CONTAINS
30
31  SUBROUTINE phenology_clear
32    firstcall=.TRUE.
33    firstcall_hum=.TRUE.
34    firstcall_moi = .TRUE.
35    firstcall_humgdd = .TRUE.
36    firstcall_moigdd = .TRUE.
37  END SUBROUTINE phenology_clear
38
39  SUBROUTINE phenology (npts, dt, PFTpresent, &
40       veget_max, &
41       tlong_ref, t2m_month, t2m_week, gpp, &
42       maxmoiavail_lastyear, minmoiavail_lastyear, &
43       moiavail_month, moiavail_week, &
44       gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
45       senescence, time_lowgpp, time_hum_min, &
46       biomass, leaf_frac, leaf_age, &
47       when_growthinit, co2_to_bm, lai)
48
49    !
50    ! 0 declarations
51    !
52
53    ! 0.1 input
54
55    ! Domain size
56    INTEGER(i_std), INTENT(in)                                        :: npts
57    ! time step in days
58    REAL(r_std), INTENT(in)                                     :: dt
59    ! PFT exists
60    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                  :: PFTpresent
61    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
62    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: veget_max
63    ! "long term" 2 meter reference temperatures (K)
64    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: tlong_ref
65    ! "monthly" 2-meter temperatures (K)
66    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: t2m_month
67    ! "weekly" 2-meter temperatures (K)
68    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: t2m_week
69    ! daily gross primary productivity (gC/(m**2 of ground)/day)
70    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: gpp
71    ! last year's maximum moisture availability
72    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: maxmoiavail_lastyear
73    ! last year's minimum moisture availability
74    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: minmoiavail_lastyear
75    ! "monthly" moisture availability
76    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: moiavail_month
77    ! "weekly" moisture availability
78    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: moiavail_week
79    ! growing degree days, threshold -5 deg C
80    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: gdd_m5_dormance
81    ! growing degree days, since midwinter
82    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: gdd_midwinter
83    ! number of chilling days since leaves were lost
84    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: ncd_dormance
85    ! number of growing days, threshold -5 deg C
86    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: ngd_minus5
87    ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
88    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                  :: senescence
89    ! duration of dormance (d)
90    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: time_lowgpp
91    ! time elapsed since strongest moisture availability (d)
92    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: time_hum_min
93
94    ! 0.2 modified fields
95
96    ! biomass (gC/(m**2 of ground))
97    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)     :: biomass
98    ! fraction of leaves in leaf age class
99    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_frac
100    ! leaf age (days)
101    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_age
102    ! how many days ago was the beginning of the growing season
103    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: when_growthinit
104    ! co2 taken up (gC/(m**2 of total ground)/day)
105    !NV passge 2D
106    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                 :: co2_to_bm
107
108    ! 0.3 output
109
110    ! leaf area index
111    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: lai
112
113    ! 0.4 local
114
115    ! take carbon from atmosphere if carbohydrate reserve too small?
116    LOGICAL, PARAMETER                                         :: always_init = .FALSE.
117    ! minimum time (d) since last beginning of a growing season
118    REAL(r_std), PARAMETER                                      :: min_growthinit_time = 300.
119    ! are we allowed to decalre the beginning of the growing season?
120    LOGICAL, DIMENSION(npts,nvm)                              :: allow_initpheno
121    ! biomass we would like to have
122    REAL(r_std), DIMENSION(npts)                                :: bm_wanted
123    ! biomass we use (from carbohydrate reserve or from atmosphere)
124    REAL(r_std), DIMENSION(npts)                                :: bm_use
125    ! minimum leaf mass (gC/(m**2 of ground))
126    REAL(r_std), DIMENSION(npts)                                :: lm_min
127    ! does the leaf age distribution have to be reset?
128    LOGICAL(r_std), DIMENSION(npts)                             :: age_reset
129    ! indices
130    INTEGER(i_std)                                              :: i,j,m
131    ! signal to start putting leaves on
132    LOGICAL, DIMENSION(npts,nvm)                              :: begin_leaves
133
134    REAL(r_std), DIMENSION(npts,nvm)                          :: histvar
135
136    ! =========================================================================
137
138    IF (bavard.GE.3) WRITE(numout,*) 'Entering phenology'
139
140    !
141    ! 1 first call
142    !
143
144    IF ( firstcall ) THEN
145
146       WRITE(numout,*) 'phenology:'
147
148       WRITE(numout,*) '   > take carbon from atmosphere if carbohydrate' // &
149            ' reserve too small: ', always_init
150
151       WRITE(numout,*) '   > minimum time since last beginning of a growing' // &
152            ' season (d): ', min_growthinit_time
153
154       firstcall = .FALSE.
155
156    ENDIF
157
158    !
159    ! 2 various things
160    !
161
162    !
163    ! 2.1 allow detection of the beginning of the growing season if dormance was
164    !     long enough and last beginning of growing season was a sufficiently
165    !     long time ago
166    !
167
168    DO j = 2,nvm
169
170       WHERE ( ( time_lowgpp(:,j) .GE. pheno_crit%lowgpp_time(j) ) .AND. &
171            ( when_growthinit(:,j) .GT. min_growthinit_time )          )
172          allow_initpheno(:,j) = .TRUE.
173       ELSEWHERE
174          allow_initpheno(:,j) = .FALSE.
175       ENDWHERE
176
177    ENDDO
178
179    WHERE(allow_initpheno)
180       histvar=un
181    ELSEWHERE
182       histvar=zero
183    ENDWHERE
184    CALL histwrite (hist_id_stomate, 'ALLOW_INITPHENO', itime, histvar, npts*nvm, horipft_index)
185
186    !
187    ! 2.2 increase counter: how many days ago was the beginning of the growing season
188    !     Needed for allocation
189    !
190
191    when_growthinit(:,:) = when_growthinit(:,:) + dt
192
193    !
194    ! 3 Check biometeorological conditions
195    !
196
197    ! default: phenology does not start
198    begin_leaves(:,:) = .FALSE.
199
200    ! different kinds of phenology
201
202    DO j = 2,nvm
203
204       SELECT CASE ( pheno_crit%pheno_model(j) )
205
206       CASE ( 'hum' )
207
208          CALL pheno_hum (npts, j, PFTpresent, allow_initpheno, &
209               moiavail_month, moiavail_week, &
210               maxmoiavail_lastyear, minmoiavail_lastyear, &
211               begin_leaves)
212
213       CASE ( 'moi' )
214
215          CALL pheno_moi (npts, j, PFTpresent, allow_initpheno, &
216               time_hum_min, &
217               moiavail_month, moiavail_week, &
218               begin_leaves)
219
220
221       CASE ( 'ncdgdd' )
222
223          CALL pheno_ncdgdd (npts, j, PFTpresent, allow_initpheno, &
224               ncd_dormance, gdd_midwinter, &
225               t2m_month, t2m_week, begin_leaves)
226
227       CASE ( 'ngd' )
228
229          CALL pheno_ngd (npts, j, PFTpresent, allow_initpheno, ngd_minus5, &
230               t2m_month, t2m_week, begin_leaves)
231
232       CASE ( 'humgdd' )
233
234          CALL pheno_humgdd (npts, j, PFTpresent, allow_initpheno, gdd_m5_dormance, &
235               maxmoiavail_lastyear, minmoiavail_lastyear, &
236               tlong_ref, t2m_month, t2m_week, &
237               moiavail_week, moiavail_month, &
238               begin_leaves)
239
240       CASE ( 'moigdd' )
241
242          CALL pheno_moigdd (npts, j, PFTpresent, allow_initpheno, gdd_m5_dormance, &
243               time_hum_min, &
244               tlong_ref, t2m_month, t2m_week, &
245               moiavail_week, moiavail_month, &
246               begin_leaves)
247
248       CASE ( 'none' )
249
250          ! no action
251
252       CASE default
253
254          WRITE(numout,*) 'phenology: don''t know how to treat this PFT.'
255          WRITE(numout,*) '  number:',j
256          WRITE(numout,*) '  phenology model: ',pheno_crit%pheno_model(j)
257          STOP
258
259       END SELECT
260
261    ENDDO
262
263    WHERE(begin_leaves)
264       histvar=un
265    ELSEWHERE
266       histvar=zero
267    ENDWHERE
268    CALL histwrite (hist_id_stomate, 'BEGIN_LEAVES', itime, histvar, npts*nvm, horipft_index)
269
270    !
271    ! 4 leaves start to grow if meteorological conditions are favourable and if
272    !   leaf regrowth is allowed (cf also turnover)
273    !
274
275    DO j = 2,nvm
276
277       age_reset(:) = .FALSE.
278
279       DO i = 1, npts
280
281          IF ( begin_leaves(i,j) ) THEN
282
283             lm_min(i) = pheno_crit%lai_initmin(j) / sla(j)
284
285             ! do we have to put a minimum biomass into the leaves?
286
287             IF ( biomass(i,j,ileaf) .LT. lm_min(i) ) THEN
288
289                !
290                ! 4.1 determine how much biomass we can use
291                !
292
293                bm_wanted(i) = 2. * lm_min(i)
294
295                ! eventually take the missing carbon from the atmosphere and
296                ! put it into carbohydrate reserve
297
298                IF ( always_init .AND. ( biomass(i,j,icarbres) .LT. bm_wanted(i) ) ) THEN
299                   !NV passage 2D
300                   co2_to_bm(i,j) = co2_to_bm(i,j) + ( bm_wanted(i) - biomass(i,j,icarbres) ) / dt
301
302                   biomass(i,j,icarbres) = bm_wanted(i)
303
304                ENDIF
305
306                bm_use(i) = MIN( biomass(i,j,icarbres), bm_wanted(i) )
307
308                !
309                ! 4.2 dispatch that biomass on leaves and roots
310                !
311
312                biomass(i,j,ileaf) = biomass(i,j,ileaf) + bm_use(i) / 2.
313
314                biomass(i,j,iroot) = biomass(i,j,iroot) + bm_use(i) / 2.
315
316                !
317                ! 4.3 decrease reservoir biomass
318                !
319
320                biomass(i,j,icarbres) = biomass(i,j,icarbres) - bm_use(i)
321
322                !
323                ! 4.4 decide whether we have to reset then leaf age distribution
324                !     (done later for better vectorization)
325                !
326
327                age_reset(i) = .TRUE.
328
329             ENDIF  ! leaf mass is very low
330
331             !
332             ! 4.5 reset counter: start of the growing season
333             !
334
335             when_growthinit(i,j) = 0.0
336
337          ENDIF    ! start of the growing season
338
339       ENDDO      ! loop over grid points
340
341       !
342       ! 4.6 reset leaf age distribution where necessary
343       !     simply say that everything is in the youngest age class
344       !
345
346       ! 4.6.1 fractions
347
348       WHERE ( age_reset(:) )
349          leaf_frac(:,j,1) = 1.0
350       ENDWHERE
351       DO m = 2, nleafages
352          WHERE ( age_reset(:) )
353             leaf_frac(:,j,m) = 0.0
354          ENDWHERE
355       ENDDO
356
357       ! 4.6.2 ages
358
359       DO m = 1, nleafages
360          WHERE ( age_reset(:) )
361             leaf_age(:,j,m) = 0.0
362          ENDWHERE
363       ENDDO
364
365    ENDDO        ! loop over PFTs
366
367
368    IF (bavard.GE.4) WRITE(numout,*) 'Leaving phenology'
369
370  END SUBROUTINE phenology
371
372  !
373  ! ==============================================================================
374  ! Phenology: begins if "weekly" soil humidity starts to exceed a certain threshold
375  !            value. This value depends on last year's max and min humidity ...
376  !            Always initiate growing season if soil moisture exceeds a certain threshold.
377  !
378
379  SUBROUTINE pheno_hum (npts, j, PFTpresent, allow_initpheno, &
380       moiavail_month, moiavail_week, &
381       maxmoiavail_lastyear, minmoiavail_lastyear, &
382       begin_leaves)
383
384    !
385    ! 0 declarations
386    !
387
388    ! 0.1 input
389
390    ! Domain size
391    INTEGER(i_std), INTENT(in)                                     :: npts
392    ! PFT index
393    INTEGER(i_std), INTENT(in)                               :: j
394    ! PFT exists
395    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
396    ! are we allowed to decalre the beginning of the growing season?
397    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
398    ! "monthly" moisture availability
399    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_month
400    ! "weekly" moisture availability
401    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_week
402    ! last year's maximum moisture availability
403    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: maxmoiavail_lastyear
404    ! last year's minimum moisture availability
405    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: minmoiavail_lastyear
406
407    ! 0.2 output
408
409    ! signal to start putting leaves on
410    LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves
411
412    ! 0.3 local
413
414    ! moisture availability above which moisture tendency doesn't matter
415    REAL(r_std), PARAMETER                                   :: moiavail_always_tree = 1.0
416    REAL(r_std), PARAMETER                                   :: moiavail_always_grass = 0.6
417    REAL(r_std)                                              :: moiavail_always
418    ! first call
419    REAL(r_std), DIMENSION(npts)                             :: availability_crit
420    ! index
421    INTEGER(i_std)                                           :: i
422
423    ! =========================================================================
424
425    IF (bavard.GE.3) WRITE(numout,*) 'Entering hum'
426
427    !
428    ! Initializations
429    !
430
431    !
432    ! 1.1 messages
433    !
434
435    IF ( firstcall_hum ) THEN
436
437       WRITE(numout,*) 'pheno_hum:'
438       WRITE(numout,*) '   > moisture availability above which moisture tendency doesn''t matter: '
439       WRITE(numout,*) '         trees:', moiavail_always_tree
440       WRITE(numout,*) '         grasses:', moiavail_always_grass
441
442       firstcall_hum = .FALSE.
443
444    ENDIF
445
446    !
447    ! 1.2 initialize output
448    !
449
450    begin_leaves(:,j) = .FALSE.
451
452    !
453    ! 1.3 check the prescribed critical value
454    !
455
456    IF ( pheno_crit%hum_frac(j) .EQ. undef ) THEN
457
458       WRITE(numout,*) 'hum: pheno_crit%hum_frac is undefined for PFT',j
459       WRITE(numout,*) 'We stop.'
460       STOP
461
462    ENDIF
463
464    !
465    ! 1.4 critical moisture availability above which we always detect the beginning of the
466    !     growing season.
467    !
468
469    IF ( tree(j) ) THEN
470       moiavail_always = moiavail_always_tree
471    ELSE
472       moiavail_always = moiavail_always_grass
473    ENDIF
474
475    !
476    ! 2 PFT has to be there and start of growing season must be allowed
477    !
478
479    DO i = 1, npts
480
481       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
482
483          ! critical availability: depends on last year's max and min.
484
485          availability_crit(i) = minmoiavail_lastyear(i,j) + pheno_crit%hum_frac(j) * &
486               ( maxmoiavail_lastyear(i,j) - minmoiavail_lastyear(i,j) )
487
488          ! the favorable season starts if the "monthly" moisture availability is still quite
489          ! low, but the "weekly" availability is already higher (as it reacts faster).
490          ! If monthly moisture availability is high enough, also initiate growing season if
491          ! this has not happened yet.
492
493          IF ( ( ( moiavail_week(i,j)  .GE. availability_crit(i) ) .AND. &
494               ( moiavail_month(i,j) .LT. moiavail_week(i,j) )   ) .OR. &
495               ( moiavail_month(i,j) .GE. moiavail_always )                ) THEN
496             begin_leaves(i,j) = .TRUE.
497          ENDIF
498
499       ENDIF        ! PFT there and start of growing season allowed
500
501    ENDDO
502
503    IF (bavard.GE.4) WRITE(numout,*) 'Leaving hum'
504
505  END SUBROUTINE pheno_hum
506
507  !
508  ! ==============================================================================
509  ! Phenology: begins if moisture minium was a sufficiently long time ago.
510  !            Additionally, "weekly" soil humidity must be higher that "monthly" soil
511  !            humidity.
512  !
513
514  SUBROUTINE pheno_moi (npts, j, PFTpresent, allow_initpheno, &
515       time_hum_min, &
516       moiavail_month, moiavail_week, &
517       begin_leaves)
518
519    !
520    ! 0 declarations
521    !
522
523    ! 0.1 input
524
525    ! Domain size
526    INTEGER(i_std), INTENT(in)                                     :: npts
527    ! PFT index
528    INTEGER(i_std), INTENT(in)                               :: j
529    ! PFT exists
530    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
531    ! are we allowed to decalre the beginning of the growing season?
532    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
533    ! time elapsed since strongest moisture availability (d)
534    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: time_hum_min
535    ! "monthly" moisture availability
536    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_month
537    ! "weekly" moisture availability
538    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_week
539
540    ! 0.2 output
541
542    ! signal to start putting leaves on
543    LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves
544
545    ! 0.3 local
546
547    ! moisture availability above which moisture tendency doesn't matter
548    ! moisture availability above which moisture tendency doesn't matter
549    REAL(r_std), PARAMETER                                   :: moiavail_always_tree = 1.0
550    REAL(r_std), PARAMETER                                   :: moiavail_always_grass = 0.6
551    REAL(r_std)                                              :: moiavail_always
552    ! index
553    INTEGER(i_std)                                           :: i
554
555    ! =========================================================================
556
557    IF (bavard.GE.3) WRITE(numout,*) 'Entering moi'
558
559    !
560    ! Initializations
561    !
562
563    !
564    ! 1.1 messages
565    !
566
567    IF ( firstcall_moi ) THEN
568
569       WRITE(numout,*) 'pheno_moi:'
570       WRITE(numout,*) '   > moisture availability above which moisture tendency doesn''t matter: '
571       WRITE(numout,*) '         trees:', moiavail_always_tree
572       WRITE(numout,*) '         grasses:', moiavail_always_grass
573
574       firstcall_moi = .FALSE.
575
576    ENDIF
577
578    !
579    ! 1.2 initialize output
580    !
581
582    begin_leaves(:,j) = .FALSE.
583
584    !
585    ! 1.3 check the prescribed critical value
586    !
587
588    IF ( pheno_crit%hum_min_time(j) .EQ. undef ) THEN
589
590       WRITE(numout,*) 'moi: pheno_crit%hum_min_time is undefined for PFT',j
591       WRITE(numout,*) 'We stop.'
592       STOP
593
594    ENDIF
595
596    !
597    ! 1.4 critical moisture availability above which we always detect the beginning of the
598    !     growing season.
599    !
600
601    IF ( tree(j) ) THEN
602       moiavail_always = moiavail_always_tree
603    ELSE
604       moiavail_always = moiavail_always_grass
605    ENDIF
606
607    !
608    ! 2 PFT has to be there and start of growing season must be allowed
609    !
610
611    DO i = 1, npts
612
613       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
614
615          ! the favorable season starts if the moisture minimum was a sufficiently long
616          ! time ago and if the "monthly" moisture availability is lower than the "weekly"
617          ! availability (this means that soil moisture is increasing).
618          ! If monthly moisture availability is high enough, also initiate growing season if
619          ! this has not happened yet.
620
621          IF  ( ( ( moiavail_week(i,j) .GT. moiavail_month(i,j) ) .AND. &
622               ( time_hum_min(i,j) .GT. pheno_crit%hum_min_time(j) )    ) .OR. &
623               ( moiavail_month(i,j) .GE. moiavail_always )                     ) THEN
624             begin_leaves(i,j) = .TRUE.
625          ENDIF
626
627       ENDIF        ! PFT there and start of growing season allowed
628
629    ENDDO
630
631    IF (bavard.GE.4) WRITE(numout,*) 'Leaving moi'
632
633  END SUBROUTINE pheno_moi
634
635  !
636  ! ==============================================================================
637  ! Phenology: leaves are put on if gdd exceeds a critical value.
638  !            Additionally, there has to be at least some moisture.
639  !            Set gdd to undef if beginning of the growing season detected.
640  !
641
642  SUBROUTINE pheno_humgdd (npts, j, PFTpresent, allow_initpheno, gdd, &
643       maxmoiavail_lastyear, minmoiavail_lastyear, &
644       tlong_ref, t2m_month, t2m_week, &
645       moiavail_week, moiavail_month, &
646       begin_leaves)
647
648    !
649    ! 0 declarations
650    !
651
652    ! 0.1 input
653
654    ! Domain size
655    INTEGER(i_std), INTENT(in)                                     :: npts
656    ! PFT index
657    INTEGER(i_std), INTENT(in)                               :: j
658    ! PFT exists
659    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
660    ! are we allowed to decalre the beginning of the growing season?
661    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
662    ! growing degree days, calculated since leaves have fallen
663    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: gdd
664    ! last year's maximum moisture availability
665    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: maxmoiavail_lastyear
666    ! last year's minimum moisture availability
667    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: minmoiavail_lastyear
668    ! "long term" 2 meter temperatures (K)
669    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: tlong_ref
670    ! "monthly" 2-meter temperatures (K)
671    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month
672    ! "weekly" 2-meter temperatures (K)
673    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week
674    ! "weekly" moisture availability
675    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_week
676    ! "monthly" moisture availability
677    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_month
678
679    ! 0.2 output
680
681    ! signal to start putting leaves on
682    LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves
683
684    ! 0.3 local
685
686    ! moisture availability above which moisture tendency doesn't matter
687    ! moisture availability above which moisture tendency doesn't matter
688    REAL(r_std), PARAMETER                                   :: moiavail_always_tree = 1.0
689    REAL(r_std), PARAMETER                                   :: moiavail_always_grass = 0.6
690    REAL(r_std)                                              :: moiavail_always
691    ! monthly temp. above which temp. tendency doesn't matter
692    REAL(r_std), PARAMETER                                   :: t_always = ZeroCelsius + 10.
693    ! critical moisture availability
694    REAL(r_std), DIMENSION(npts)                             :: moiavail_crit
695    ! long term temperature, C
696    REAL(r_std), DIMENSION(npts)                             :: tl
697    ! critical GDD
698    REAL(r_std), DIMENSION(npts)                             :: gdd_crit
699    ! index
700    INTEGER(i_std)                                           :: i
701
702    ! =========================================================================
703
704    IF (bavard.GE.3) WRITE(numout,*) 'Entering humgdd'
705
706    !
707    ! 1 Initializations
708    !
709
710    !
711    ! 1.1 messages
712    !
713
714    IF ( firstcall_humgdd ) THEN
715
716       WRITE(numout,*) 'pheno_humgdd:'
717       WRITE(numout,*) '   > moisture availability above which moisture tendency doesn''t matter: '
718       WRITE(numout,*) '         trees:', moiavail_always_tree
719       WRITE(numout,*) '         grasses:', moiavail_always_grass
720       WRITE(numout,*) '   > monthly temp. above which temp. tendency doesn''t matter: ', &
721            t_always
722
723       firstcall_humgdd = .FALSE.
724
725    ENDIF
726
727    !
728    ! 1.2 initialize output
729    !
730
731    begin_leaves(:,j) = .FALSE.
732
733    !
734    ! 1.3 check the prescribed critical values
735    !
736
737    IF ( ANY(pheno_crit%gdd(j,:) .EQ. undef) ) THEN
738
739       WRITE(numout,*) 'humgdd: pheno_crit%gdd is undefined for PFT',j
740       WRITE(numout,*) 'We stop.'
741       STOP
742
743    ENDIF
744
745    IF ( pheno_crit%hum_frac(j) .EQ. undef ) THEN
746
747       WRITE(numout,*) 'humgdd: pheno_crit%hum_frac is undefined for PFT',j
748       WRITE(numout,*) 'We stop.'
749       STOP
750
751    ENDIF
752
753    !
754    ! 1.4 critical moisture availability above which we always detect the beginning of the
755    !     growing season.
756    !
757
758    IF ( tree(j) ) THEN
759       moiavail_always = moiavail_always_tree
760    ELSE
761       moiavail_always = moiavail_always_grass
762    ENDIF
763
764    !
765    ! 2 PFT has to be there, start of growing season must be allowed,
766    !   and gdd has to be defined
767    !
768
769    DO i = 1, npts
770
771       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
772            ( gdd(i,j) .NE. undef )                           ) THEN
773
774          ! is critical gdd reached and is temperature increasing?
775          ! be sure that at least some humidity
776
777          moiavail_crit(i) = minmoiavail_lastyear(i,j) + pheno_crit%hum_frac(j) * &
778               ( maxmoiavail_lastyear(i,j) - minmoiavail_lastyear(i,j) )
779
780          tl(i) = tlong_ref(i) - ZeroCelsius
781          gdd_crit(i) = pheno_crit%gdd(j,1) + tl(i)*pheno_crit%gdd(j,2) + &
782               tl(i)*tl(i)*pheno_crit%gdd(j,3)
783
784          IF ( ( gdd(i,j) .GE. gdd_crit(i) ) .AND. &
785               ( ( t2m_week(i) .GT. t2m_month(i) ) .OR. &
786               ( t2m_month(i) .GT. t_always )          ) .AND. &
787               ( ( ( moiavail_week(i,j)  .GE. moiavail_crit(i) ) .AND. &
788               ( moiavail_month(i,j) .LT. moiavail_crit(i) )        ) .OR. &
789               ( moiavail_month(i,j) .GE. moiavail_always )                   ) )  THEN
790             begin_leaves(i,j) = .TRUE.
791          ENDIF
792
793       ENDIF        ! PFT there and start of growing season allowed
794
795    ENDDO
796
797    IF (bavard.GE.4) WRITE(numout,*) 'Leaving humgdd'
798
799  END SUBROUTINE pheno_humgdd
800
801  !
802  ! ==============================================================================
803  ! Phenology: leaves are put on if gdd exceeds a critical value.
804  !            Additionally, a certain time must have elapsed since the moisture minimum.
805  !            Set gdd to undef if beginning of the growing season detected.
806  !
807
808  SUBROUTINE pheno_moigdd (npts, j, PFTpresent, allow_initpheno, gdd, &
809       time_hum_min, &
810       tlong_ref, t2m_month, t2m_week, &
811       moiavail_week, moiavail_month, &
812       begin_leaves)
813
814    !
815    ! 0 declarations
816    !
817
818    ! 0.1 input
819
820    ! Domain size
821    INTEGER(i_std), INTENT(in)                                     :: npts
822    ! PFT index
823    INTEGER(i_std), INTENT(in)                               :: j
824    ! PFT exists
825    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
826    ! are we allowed to decalre the beginning of the growing season?
827    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
828    ! growing degree days, calculated since leaves have fallen
829    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: gdd
830    ! time elapsed since strongest moisture availability (d)
831    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: time_hum_min
832    ! "long term" 2 meter temperatures (K)
833    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: tlong_ref
834    ! "monthly" 2-meter temperatures (K)
835    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month
836    ! "weekly" 2-meter temperatures (K)
837    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week
838    ! "weekly" moisture availability
839    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_week
840    ! "monthly" moisture availability
841    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_month
842
843    ! 0.2 output
844
845    ! signal to start putting leaves on
846    LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves
847
848    ! 0.3 local
849
850    ! moisture availability above which moisture tendency doesn't matter
851    ! moisture availability above which moisture tendency doesn't matter
852    REAL(r_std), PARAMETER                                   :: moiavail_always_tree = 1.0
853    REAL(r_std), PARAMETER                                   :: moiavail_always_grass = 0.6
854    REAL(r_std)                                              :: moiavail_always
855    ! monthly temp. above which temp. tendency doesn't matter
856    REAL(r_std), PARAMETER                                   :: t_always = ZeroCelsius + 10.
857    ! long term temperature, C
858    REAL(r_std), DIMENSION(npts)                             :: tl
859    ! critical GDD
860    REAL(r_std), DIMENSION(npts)                             :: gdd_crit
861    ! index
862    INTEGER(i_std)                                           :: i
863
864    ! =========================================================================
865
866    IF (bavard.GE.3) WRITE(numout,*) 'Entering moigdd'
867
868    !
869    ! 1 Initializations
870    !
871
872    !
873    ! 1.1 messages
874    !
875
876    IF ( firstcall_moigdd ) THEN
877
878       WRITE(numout,*) 'pheno_moigdd:'
879       WRITE(numout,*) '   > moisture availability above which moisture tendency doesn''t matter: '
880       WRITE(numout,*) '         trees:', moiavail_always_tree
881       WRITE(numout,*) '         grasses:', moiavail_always_grass
882       WRITE(numout,*) '   > monthly temp. above which temp. tendency doesn''t matter: ', &
883            t_always
884
885       firstcall_moigdd = .FALSE.
886
887    ENDIF
888
889    !
890    ! 1.2 initialize output
891    !
892
893    begin_leaves(:,j) = .FALSE.
894
895    !
896    ! 1.3 check the prescribed critical values
897    !
898
899    IF ( ANY(pheno_crit%gdd(j,:) .EQ. undef) ) THEN
900
901       WRITE(numout,*) 'moigdd: pheno_crit%gdd is undefined for PFT',j
902       WRITE(numout,*) 'We stop.'
903       STOP
904
905    ENDIF
906
907    IF ( pheno_crit%hum_min_time(j) .EQ. undef ) THEN
908
909       WRITE(numout,*) 'moigdd: pheno_crit%hum_min_time is undefined for PFT',j
910       WRITE(numout,*) 'We stop.'
911       STOP
912
913    ENDIF
914
915    !
916    ! 1.4 critical moisture availability above which we always detect the beginning of the
917    !     growing season.
918    !
919
920    IF ( tree(j) ) THEN
921       moiavail_always = moiavail_always_tree
922    ELSE
923       moiavail_always = moiavail_always_grass
924    ENDIF
925
926    !
927    ! 2 PFT has to be there, start of growing season must be allowed,
928    !   and gdd has to be defined
929    !
930
931    DO i = 1, npts
932
933       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
934            ( gdd(i,j) .NE. undef )                           ) THEN
935
936          ! is critical gdd reached and is temperature increasing?
937          ! has enough time gone by since moisture minimum and is moisture increasing?
938
939          tl(i) = tlong_ref(i) - ZeroCelsius
940          gdd_crit(i) = pheno_crit%gdd(j,1) + tl(i)*pheno_crit%gdd(j,2) + &
941               tl(i)*tl(i)*pheno_crit%gdd(j,3)
942
943          IF ( ( gdd(i,j) .GE. gdd_crit(i) ) .AND. &
944               ( ( t2m_week(i) .GT. t2m_month(i) ) .OR. &
945               ( t2m_month(i) .GT. t_always )          ) .AND. &
946               ( ( ( time_hum_min(i,j) .GT. pheno_crit%hum_min_time(j) ) .AND. &
947               ( moiavail_week(i,j) .GT. moiavail_month(i,j) )            ) .OR. &
948               ( moiavail_month(i,j) .GE. moiavail_always )                         ) )  THEN
949             begin_leaves(i,j) = .TRUE.
950          ENDIF
951
952       ENDIF        ! PFT there and start of growing season allowed
953
954    ENDDO
955
956    IF (bavard.GE.4) WRITE(numout,*) 'Leaving moigdd'
957
958  END SUBROUTINE pheno_moigdd
959
960
961  !
962  ! ==============================================================================
963  ! Phenology: leaves are put on if a certain relationship between ncd since leaves were
964  !            lost (number of chilling days) and gdd since midwinter (growing degree
965  !            days) is fulfilled
966  !
967
968  SUBROUTINE pheno_ncdgdd (npts, j, PFTpresent, allow_initpheno, &
969       ncd_dormance, gdd_midwinter, &
970       t2m_month, t2m_week, begin_leaves)
971
972    !
973    ! 0 declarations
974    !
975
976    ! 0.1 input
977
978    ! Domain size
979    INTEGER(i_std), INTENT(in)                                     :: npts
980    ! PFT index
981    INTEGER(i_std), INTENT(in)                               :: j
982    ! PFT exists
983    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
984    ! are we allowed to declare the beginning of the growing season?
985    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
986    ! number of chilling days since leaves were lost
987    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: ncd_dormance
988    ! growing degree days since midwinter
989    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: gdd_midwinter
990    ! "monthly" 2-meter temperatures (K)
991    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month
992    ! "weekly" 2-meter temperatures (K)
993    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week
994
995    ! 0.2 output
996
997    ! signal to start putting leaves on
998    LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves
999
1000    ! 0.3 local
1001
1002    ! index
1003    INTEGER(i_std)                                           :: i
1004    ! critical gdd
1005    REAL(r_std)                                              :: gdd_min
1006
1007    ! =========================================================================
1008
1009    IF (bavard.GE.3) WRITE(numout,*) 'Entering ncdgdd'
1010
1011    !
1012    ! 1 Initializations
1013    !
1014
1015    !
1016    ! 1.1 initialize output
1017    !
1018
1019    begin_leaves(:,j) = .FALSE.
1020
1021    !
1022    ! 1.2 check the prescribed critical values
1023    !
1024
1025    IF ( pheno_crit%ncdgdd_temp(j) .EQ. undef ) THEN
1026
1027       WRITE(numout,*) 'ncdgdd: pheno_crit%ncdgdd_temp is undefined for PFT',j
1028       WRITE(numout,*) 'We stop.'
1029       STOP
1030
1031    ENDIF
1032
1033    !
1034    ! 2 PFT has to be there and start of growing season must be allowed
1035    !
1036
1037    DO i = 1, npts
1038
1039       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
1040            ( gdd_midwinter(i,j) .NE. undef ) .AND. &
1041            ( ncd_dormance(i,j) .NE. undef )                  ) THEN
1042
1043          ! critical gdd
1044
1045          gdd_min = ( 603. / exp(0.0091*ncd_dormance(i,j)) - 64. )
1046
1047          ! has the critical gdd been reached and are temperatures increasing?
1048
1049          IF ( ( gdd_midwinter(i,j) .GE. gdd_min ) .AND. &
1050               ( t2m_week(i) .GT. t2m_month(i) ) ) THEN
1051             begin_leaves(i,j) = .TRUE.
1052             gdd_midwinter(i,j)=undef
1053          ENDIF
1054
1055       ENDIF        ! PFT there and start of growing season allowed
1056
1057    ENDDO
1058
1059    IF (bavard.GE.4) WRITE(numout,*) 'Leaving ncdgdd'
1060
1061  END SUBROUTINE pheno_ncdgdd
1062
1063  !
1064  ! ==============================================================================
1065  ! Phenology: leaves are put on if ngd (number of growing days, defined as
1066  !            days with t>-5 deg C) exceeds a critical value.
1067  !
1068
1069  SUBROUTINE pheno_ngd (npts, j, PFTpresent, allow_initpheno, ngd, &
1070       t2m_month, t2m_week, begin_leaves)
1071
1072    !
1073    ! 0 declarations
1074    !
1075
1076    ! 0.1 input
1077
1078    ! Domain size
1079    INTEGER(i_std), INTENT(in)                                     :: npts
1080    ! PFT index
1081    INTEGER(i_std), INTENT(in)                               :: j
1082    ! PFT exists
1083    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
1084    ! are we allowed to declare the beginning of the growing season?
1085    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
1086    ! growing degree days
1087    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: ngd
1088    ! "monthly" 2-meter temperatures (K)
1089    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month
1090    ! "weekly" 2-meter temperatures (K)
1091    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week
1092
1093    ! 0.2 output
1094
1095    ! signal to start putting leaves on
1096    LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves
1097
1098    ! 0.3 local
1099
1100    ! index
1101    INTEGER(i_std)                                           :: i
1102
1103    ! =========================================================================
1104
1105    IF (bavard.GE.3) WRITE(numout,*) 'Entering ngd'
1106
1107    !
1108    ! Initializations
1109    !
1110
1111    !
1112    ! 1.1 initialize output
1113    !
1114
1115    begin_leaves(:,j) = .FALSE.
1116
1117    !
1118    ! 1.2 check the prescribed critical value
1119    !
1120
1121    IF ( pheno_crit%ngd(j) .EQ. undef ) THEN
1122
1123       WRITE(numout,*) 'ngd: pheno_crit%ngd is undefined for PFT',j
1124       WRITE(numout,*) 'We stop.'
1125       STOP
1126
1127    ENDIF
1128
1129    !
1130    ! 2 PFT has to be there and start of growing season must be allowed
1131    !
1132
1133    DO i = 1, npts
1134
1135       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
1136
1137          ! is critical ngd reached and are temperatures increasing?
1138
1139          IF ( ( ngd(i,j) .GE. pheno_crit%ngd(j) ) .AND. &
1140               ( t2m_week(i) .GT. t2m_month(i) )        ) THEN
1141             begin_leaves(i,j) = .TRUE.
1142          ENDIF
1143
1144       ENDIF        ! PFT there and start of growing season allowed
1145
1146    ENDDO
1147
1148    IF (bavard.GE.4) WRITE(numout,*) 'Leaving ngd'
1149
1150  END SUBROUTINE pheno_ngd
1151
1152END MODULE stomate_phenology
Note: See TracBrowser for help on using the repository browser.