source: tags/ORCHIDEE_1_9_5_2/ORCHIDEE/src_stomate/stomate_phenology.f90 @ 2061

Last change on this file since 2061 was 45, checked in by mmaipsl, 14 years ago

MM: Tests with lf95 compiler : correct f95 strict norm problems.

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