source: branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate_phenology.f90 @ 109

Last change on this file since 109 was 109, checked in by didier.solyga, 13 years ago

Add initialisation for allow_initpheno (copy from the trunk version)
File size: 35.2 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_data
13  USE constantes
14  USE pft_parameters
15
16  IMPLICIT NONE
17
18  ! private & public routines
19
20  PRIVATE
21  PUBLIC phenology,phenology_clear
22
23  ! first call
24  LOGICAL, SAVE                                              :: firstcall = .TRUE.
25  LOGICAL, SAVE                                              :: firstcall_hum = .TRUE.
26  LOGICAL, SAVE                                              :: firstcall_moi = .TRUE.
27  LOGICAL, SAVE                                              :: firstcall_humgdd = .TRUE.
28  LOGICAL, SAVE                                              :: firstcall_moigdd = .TRUE.
29
30CONTAINS
31
32  SUBROUTINE phenology_clear
33    firstcall=.TRUE.
34    firstcall_hum=.TRUE.
35    firstcall_moi = .TRUE.
36    firstcall_humgdd = .TRUE.
37    firstcall_moigdd = .TRUE.
38  END SUBROUTINE phenology_clear
39
40  SUBROUTINE phenology (npts, dt, PFTpresent, &
41       veget_max, &
42       tlong_ref, t2m_month, t2m_week, gpp, &
43       maxmoiavail_lastyear, minmoiavail_lastyear, &
44       moiavail_month, moiavail_week, &
45       gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
46       senescence, time_lowgpp, time_hum_min, &
47       biomass, leaf_frac, leaf_age, &
48       when_growthinit, co2_to_bm, lai)
49
50    !
51    ! 0 declarations
52    !
53
54    ! 0.1 input
55
56    ! Domain size
57    INTEGER(i_std), INTENT(in)                                        :: npts
58    ! time step in days
59    REAL(r_std), INTENT(in)                                     :: dt
60    ! PFT exists
61    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                  :: PFTpresent
62    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
63    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: veget_max
64    ! "long term" 2 meter reference temperatures (K)
65    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: tlong_ref
66    ! "monthly" 2-meter temperatures (K)
67    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: t2m_month
68    ! "weekly" 2-meter temperatures (K)
69    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: t2m_week
70    ! daily gross primary productivity (gC/(m**2 of ground)/day)
71    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: gpp
72    ! last year's maximum moisture availability
73    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: maxmoiavail_lastyear
74    ! last year's minimum moisture availability
75    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: minmoiavail_lastyear
76    ! "monthly" moisture availability
77    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: moiavail_month
78    ! "weekly" moisture availability
79    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: moiavail_week
80    ! growing degree days, threshold -5 deg C
81    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: gdd_m5_dormance
82    ! growing degree days, since midwinter
83    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: gdd_midwinter
84    ! number of chilling days since leaves were lost
85    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: ncd_dormance
86    ! number of growing days, threshold -5 deg C
87    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: ngd_minus5
88    ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
89    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                  :: senescence
90    ! duration of dormance (d)
91    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: time_lowgpp
92    ! time elapsed since strongest moisture availability (d)
93    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: time_hum_min
94
95    ! 0.2 modified fields
96
97    ! biomass (gC/(m**2 of ground))
98    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)     :: biomass
99    ! fraction of leaves in leaf age class
100    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_frac
101    ! leaf age (days)
102    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_age
103    ! how many days ago was the beginning of the growing season
104    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: when_growthinit
105    ! co2 taken up (gC/(m**2 of total ground)/day)
106    !NV passge 2D
107    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                 :: co2_to_bm
108
109    ! 0.3 output
110
111    ! leaf area index
112    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: lai
113
114    ! 0.4 local
115
116    ! are we allowed to decalre the beginning of the growing season?
117    LOGICAL, DIMENSION(npts,nvm)                              :: allow_initpheno
118    ! biomass we would like to have
119    REAL(r_std), DIMENSION(npts)                                :: bm_wanted
120    ! biomass we use (from carbohydrate reserve or from atmosphere)
121    REAL(r_std), DIMENSION(npts)                                :: bm_use
122    ! minimum leaf mass (gC/(m**2 of ground))
123    REAL(r_std), DIMENSION(npts)                                :: lm_min
124    ! does the leaf age distribution have to be reset?
125    LOGICAL(r_std), DIMENSION(npts)                             :: age_reset
126    ! indices
127    INTEGER(i_std)                                              :: i,j,m
128    ! signal to start putting leaves on
129    LOGICAL, DIMENSION(npts,nvm)                              :: begin_leaves
130
131    REAL(r_std), DIMENSION(npts,nvm)                          :: histvar
132
133    ! =========================================================================
134
135    IF (bavard.GE.3) WRITE(numout,*) 'Entering phenology'
136
137    !
138    ! 1 first call
139    !
140
141    IF ( firstcall ) THEN
142
143       WRITE(numout,*) 'phenology:'
144
145       WRITE(numout,*) '   > take carbon from atmosphere if carbohydrate' // &
146            ' reserve too small: ', always_init
147
148       WRITE(numout,*) '   > minimum time since last beginning of a growing' // &
149            ' season (d): ', min_growthinit_time
150
151       firstcall = .FALSE.
152
153    ENDIF
154
155    !
156    ! 2 various things
157    !
158
159    !
160    ! 2.1 allow detection of the beginning of the growing season if dormance was
161    !     long enough and last beginning of growing season was a sufficiently
162    !     long time ago
163    !
164
165    allow_initpheno(:,1) = .FALSE. ! Add 02/02/2011 correctio of MM for the 1.9.5-1 version
166    DO j = 2,nvm
167
168       WHERE ( ( time_lowgpp(:,j) .GE. lowgpp_time(j) ) .AND. &
169            ( when_growthinit(:,j) .GT. min_growthinit_time )          )
170          allow_initpheno(:,j) = .TRUE.
171       ELSEWHERE
172          allow_initpheno(:,j) = .FALSE.
173       ENDWHERE
174
175    ENDDO
176
177    WHERE(allow_initpheno)
178       histvar=un
179    ELSEWHERE
180       histvar=zero
181    ENDWHERE
182    CALL histwrite (hist_id_stomate, 'ALLOW_INITPHENO', itime, histvar, npts*nvm, horipft_index)
183
184    !
185    ! 2.2 increase counter: how many days ago was the beginning of the growing season
186    !     Needed for allocation
187    !
188
189    when_growthinit(:,:) = when_growthinit(:,:) + dt
190
191    !
192    ! 3 Check biometeorological conditions
193    !
194
195    ! default: phenology does not start
196    begin_leaves(:,:) = .FALSE.
197
198    ! different kinds of phenology
199   
200    ! used in all the differents models of phenology DS 17112010
201    t_always = ZeroCelsius + t_always_add
202
203    DO j = 2,nvm
204
205       SELECT CASE ( 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_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) = 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) = 1.0
351       ENDWHERE
352       DO m = 2, nleafages
353          WHERE ( age_reset(:) )
354             leaf_frac(:,j,m) = 0.0
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) = 0.0
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(out)              :: 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 = 1.0
417!    REAL(r_std), PARAMETER                                   :: moiavail_always_grass = 0.6
418
419    REAL(r_std)                                              :: moiavail_always
420    ! first call
421    REAL(r_std), DIMENSION(npts)                             :: availability_crit
422    ! index
423    INTEGER(i_std)                                           :: i
424
425    ! =========================================================================
426
427    IF (bavard.GE.3) WRITE(numout,*) 'Entering hum'
428
429    !
430    ! Initializations
431    !
432
433    !
434    ! 1.1 messages
435    !
436
437    IF ( firstcall_hum ) THEN
438
439       WRITE(numout,*) 'pheno_hum:'
440       WRITE(numout,*) '   > moisture availability above which moisture tendency doesn''t matter: '
441       WRITE(numout,*) '         trees:', moiavail_always_tree
442       WRITE(numout,*) '         grasses:', moiavail_always_grass
443
444       firstcall_hum = .FALSE.
445
446    ENDIF
447
448    !
449    ! 1.2 initialize output
450    !
451
452    begin_leaves(:,j) = .FALSE.
453
454    !
455    ! 1.3 check the prescribed critical value
456    !
457
458    IF ( hum_frac(j) .EQ. undef ) THEN
459
460       WRITE(numout,*) 'hum: hum_frac is undefined for PFT',j
461       WRITE(numout,*) 'We stop.'
462       STOP
463
464    ENDIF
465
466    !
467    ! 1.4 critical moisture availability above which we always detect the beginning of the
468    !     growing season.
469    !
470
471    IF ( tree(j) ) THEN
472       moiavail_always = moiavail_always_tree
473    ELSE
474       moiavail_always = moiavail_always_grass
475    ENDIF
476
477    !
478    ! 2 PFT has to be there and start of growing season must be allowed
479    !
480
481    DO i = 1, npts
482
483       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
484
485          ! critical availability: depends on last year's max and min.
486
487          availability_crit(i) = minmoiavail_lastyear(i,j) + hum_frac(j) * &
488               ( maxmoiavail_lastyear(i,j) - minmoiavail_lastyear(i,j) )
489
490          ! the favorable season starts if the "monthly" moisture availability is still quite
491          ! low, but the "weekly" availability is already higher (as it reacts faster).
492          ! If monthly moisture availability is high enough, also initiate growing season if
493          ! this has not happened yet.
494
495          IF ( ( ( moiavail_week(i,j)  .GE. availability_crit(i) ) .AND. &
496               ( moiavail_month(i,j) .LT. moiavail_week(i,j) )   ) .OR. &
497               ( moiavail_month(i,j) .GE. moiavail_always )                ) THEN
498             begin_leaves(i,j) = .TRUE.
499          ENDIF
500
501       ENDIF        ! PFT there and start of growing season allowed
502
503    ENDDO
504
505    IF (bavard.GE.4) WRITE(numout,*) 'Leaving hum'
506
507  END SUBROUTINE pheno_hum
508
509  !
510  ! ==============================================================================
511  ! Phenology: begins if moisture minium was a sufficiently long time ago.
512  !            Additionally, "weekly" soil humidity must be higher that "monthly" soil
513  !            humidity.
514  !
515
516  SUBROUTINE pheno_moi (npts, j, PFTpresent, allow_initpheno, &
517       time_hum_min, &
518       moiavail_month, moiavail_week, &
519       begin_leaves)
520
521    !
522    ! 0 declarations
523    !
524
525    ! 0.1 input
526
527    ! Domain size
528    INTEGER(i_std), INTENT(in)                                     :: npts
529    ! PFT index
530    INTEGER(i_std), INTENT(in)                               :: j
531    ! PFT exists
532    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
533    ! are we allowed to decalre the beginning of the growing season?
534    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
535    ! time elapsed since strongest moisture availability (d)
536    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: time_hum_min
537    ! "monthly" moisture availability
538    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_month
539    ! "weekly" moisture availability
540    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_week
541
542    ! 0.2 output
543
544    ! signal to start putting leaves on
545    LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves
546
547    ! 0.3 local
548
549    ! moisture availability above which moisture tendency doesn't matter
550    REAL(r_std)                                              :: moiavail_always
551    ! index
552    INTEGER(i_std)                                           :: i
553
554    ! =========================================================================
555
556    IF (bavard.GE.3) WRITE(numout,*) 'Entering moi'
557
558    !
559    ! Initializations
560    !
561
562    !
563    ! 1.1 messages
564    !
565
566    IF ( firstcall_moi ) THEN
567
568       WRITE(numout,*) 'pheno_moi:'
569       WRITE(numout,*) '   > moisture availability above which moisture tendency doesn''t matter: '
570       WRITE(numout,*) '         trees:', moiavail_always_tree
571       WRITE(numout,*) '         grasses:', moiavail_always_grass
572
573       firstcall_moi = .FALSE.
574
575    ENDIF
576
577    !
578    ! 1.2 initialize output
579    !
580
581    begin_leaves(:,j) = .FALSE.
582
583    !
584    ! 1.3 check the prescribed critical value
585    !
586
587    IF ( hum_min_time(j) .EQ. undef ) THEN
588
589       WRITE(numout,*) 'moi: hum_min_time is undefined for PFT',j
590       WRITE(numout,*) 'We stop.'
591       STOP
592
593    ENDIF
594
595    !
596    ! 1.4 critical moisture availability above which we always detect the beginning of the
597    !     growing season.
598    !
599
600    IF ( tree(j) ) THEN
601       moiavail_always = moiavail_always_tree
602    ELSE
603       moiavail_always = moiavail_always_grass
604    ENDIF
605
606    !
607    ! 2 PFT has to be there and start of growing season must be allowed
608    !
609
610    DO i = 1, npts
611
612       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
613
614          ! the favorable season starts if the moisture minimum was a sufficiently long
615          ! time ago and if the "monthly" moisture availability is lower than the "weekly"
616          ! availability (this means that soil moisture is increasing).
617          ! If monthly moisture availability is high enough, also initiate growing season if
618          ! this has not happened yet.
619
620          IF  ( ( ( moiavail_week(i,j) .GT. moiavail_month(i,j) ) .AND. &
621               ( time_hum_min(i,j) .GT. hum_min_time(j) )    ) .OR. &
622               ( moiavail_month(i,j) .GE. moiavail_always )                     ) THEN
623             begin_leaves(i,j) = .TRUE.
624          ENDIF
625
626       ENDIF        ! PFT there and start of growing season allowed
627
628    ENDDO
629
630    IF (bavard.GE.4) WRITE(numout,*) 'Leaving moi'
631
632  END SUBROUTINE pheno_moi
633
634  !
635  ! ==============================================================================
636  ! Phenology: leaves are put on if gdd exceeds a critical value.
637  !            Additionally, there has to be at least some moisture.
638  !            Set gdd to undef if beginning of the growing season detected.
639  !
640
641  SUBROUTINE pheno_humgdd (npts, j, PFTpresent, allow_initpheno, gdd, &
642       maxmoiavail_lastyear, minmoiavail_lastyear, &
643       tlong_ref, t2m_month, t2m_week, &
644       moiavail_week, moiavail_month, &
645       begin_leaves)
646
647    !
648    ! 0 declarations
649    !
650
651    ! 0.1 input
652
653    ! Domain size
654    INTEGER(i_std), INTENT(in)                                     :: npts
655    ! PFT index
656    INTEGER(i_std), INTENT(in)                               :: j
657    ! PFT exists
658    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
659    ! are we allowed to decalre the beginning of the growing season?
660    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
661    ! growing degree days, calculated since leaves have fallen
662    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: gdd
663    ! last year's maximum moisture availability
664    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: maxmoiavail_lastyear
665    ! last year's minimum moisture availability
666    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: minmoiavail_lastyear
667    ! "long term" 2 meter temperatures (K)
668    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: tlong_ref
669    ! "monthly" 2-meter temperatures (K)
670    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month
671    ! "weekly" 2-meter temperatures (K)
672    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week
673    ! "weekly" moisture availability
674    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_week
675    ! "monthly" moisture availability
676    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_month
677
678    ! 0.2 output
679
680    ! signal to start putting leaves on
681    LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves
682
683    ! 0.3 local
684
685    ! moisture availability above which moisture tendency doesn't matter
686    REAL(r_std)                                              :: moiavail_always
687    ! critical moisture availability
688    REAL(r_std), DIMENSION(npts)                             :: moiavail_crit
689    ! long term temperature, C
690    REAL(r_std), DIMENSION(npts)                             :: tl
691    ! critical GDD
692    REAL(r_std), DIMENSION(npts)                             :: gdd_crit
693    ! index
694    INTEGER(i_std)                                           :: i
695
696    ! =========================================================================
697
698    IF (bavard.GE.3) WRITE(numout,*) 'Entering humgdd'
699
700    !
701    ! 1 Initializations
702    !
703
704    !
705    ! 1.1 messages
706    !
707
708    IF ( firstcall_humgdd ) THEN
709
710       WRITE(numout,*) 'pheno_humgdd:'
711       WRITE(numout,*) '   > moisture availability above which moisture tendency doesn''t matter: '
712       WRITE(numout,*) '         trees:', moiavail_always_tree
713       WRITE(numout,*) '         grasses:', moiavail_always_grass
714       WRITE(numout,*) '   > monthly temp. above which temp. tendency doesn''t matter: ', &
715            t_always
716
717       firstcall_humgdd = .FALSE.
718
719    ENDIF
720
721    !
722    ! 1.2 initialize output
723    !
724
725    begin_leaves(:,j) = .FALSE.
726
727    !
728    ! 1.3 check the prescribed critical values
729    !
730
731    IF ( ANY(pheno_gdd_crit(j,:) .EQ. undef) ) THEN
732
733       WRITE(numout,*) 'humgdd:pheno_gdd_crit is undefined for PFT',j
734       WRITE(numout,*) 'We stop.'
735       STOP
736
737    ENDIF
738
739    IF ( hum_frac(j) .EQ. undef ) THEN
740
741       WRITE(numout,*) 'humgdd: hum_frac is undefined for PFT',j
742       WRITE(numout,*) 'We stop.'
743       STOP
744
745    ENDIF
746
747    !
748    ! 1.4 critical moisture availability above which we always detect the beginning of the
749    !     growing season.
750    !
751
752    IF ( tree(j) ) THEN
753       moiavail_always = moiavail_always_tree
754    ELSE
755       moiavail_always = moiavail_always_grass
756    ENDIF
757
758    !
759    ! 2 PFT has to be there, start of growing season must be allowed,
760    !   and gdd has to be defined
761    !
762
763    DO i = 1, npts
764
765       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
766            ( gdd(i,j) .NE. undef )                           ) THEN
767
768          ! is critical gdd reached and is temperature increasing?
769          ! be sure that at least some humidity
770
771          moiavail_crit(i) = minmoiavail_lastyear(i,j) + hum_frac(j) * &
772               ( maxmoiavail_lastyear(i,j) - minmoiavail_lastyear(i,j) )
773
774          tl(i) = tlong_ref(i) - ZeroCelsius
775          gdd_crit(i) = pheno_gdd_crit(j,1) + tl(i)*pheno_gdd_crit(j,2) + &
776               tl(i)*tl(i)*pheno_gdd_crit(j,3)
777
778
779          IF ( ( gdd(i,j) .GE. gdd_crit(i) ) .AND. &
780               ( ( t2m_week(i) .GT. t2m_month(i) ) .OR. &
781               ( t2m_month(i) .GT. t_always )          ) .AND. &
782               ( ( ( moiavail_week(i,j)  .GE. moiavail_crit(i) ) .AND. &
783               ( moiavail_month(i,j) .LT. moiavail_crit(i) )        ) .OR. &
784               ( moiavail_month(i,j) .GE. moiavail_always )                   ) )  THEN
785             begin_leaves(i,j) = .TRUE.
786          ENDIF
787
788       ENDIF        ! PFT there and start of growing season allowed
789
790    ENDDO
791
792    IF (bavard.GE.4) WRITE(numout,*) 'Leaving humgdd'
793
794  END SUBROUTINE pheno_humgdd
795
796  !
797  ! ==============================================================================
798  ! Phenology: leaves are put on if gdd exceeds a critical value.
799  !            Additionally, a certain time must have elapsed since the moisture minimum.
800  !            Set gdd to undef if beginning of the growing season detected.
801  !
802
803  SUBROUTINE pheno_moigdd (npts, j, PFTpresent, allow_initpheno, gdd, &
804       time_hum_min, &
805       tlong_ref, t2m_month, t2m_week, &
806       moiavail_week, moiavail_month, &
807       begin_leaves)
808
809    !
810    ! 0 declarations
811    !
812
813    ! 0.1 input
814
815    ! Domain size
816    INTEGER(i_std), INTENT(in)                                     :: npts
817    ! PFT index
818    INTEGER(i_std), INTENT(in)                               :: j
819    ! PFT exists
820    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
821    ! are we allowed to decalre the beginning of the growing season?
822    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
823    ! growing degree days, calculated since leaves have fallen
824    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: gdd
825    ! time elapsed since strongest moisture availability (d)
826    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: time_hum_min
827    ! "long term" 2 meter temperatures (K)
828    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: tlong_ref
829    ! "monthly" 2-meter temperatures (K)
830    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month
831    ! "weekly" 2-meter temperatures (K)
832    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week
833    ! "weekly" moisture availability
834    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_week
835    ! "monthly" moisture availability
836    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_month
837
838    ! 0.2 output
839
840    ! signal to start putting leaves on
841    LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves
842
843    ! 0.3 local
844
845    ! moisture availability above which moisture tendency doesn't matter
846    REAL(r_std)                                              :: moiavail_always
847    ! long term temperature, C
848    REAL(r_std), DIMENSION(npts)                             :: tl
849    ! critical GDD
850    REAL(r_std), DIMENSION(npts)                             :: gdd_crit
851    ! index
852    INTEGER(i_std)                                           :: i
853
854    ! =========================================================================
855
856    IF (bavard.GE.3) WRITE(numout,*) 'Entering moigdd'
857
858    !
859    ! 1 Initializations
860    !
861
862    !
863    ! 1.1 messages
864    !
865
866    IF ( firstcall_moigdd ) THEN
867
868       WRITE(numout,*) 'pheno_moigdd:'
869       WRITE(numout,*) '   > moisture availability above which moisture tendency doesn''t matter: '
870       WRITE(numout,*) '         trees:', moiavail_always_tree
871       WRITE(numout,*) '         grasses:', moiavail_always_grass
872       WRITE(numout,*) '   > monthly temp. above which temp. tendency doesn''t matter: ', &
873            t_always
874
875       firstcall_moigdd = .FALSE.
876
877    ENDIF
878
879    !
880    ! 1.2 initialize output
881    !
882
883    begin_leaves(:,j) = .FALSE.
884
885    !
886    ! 1.3 check the prescribed critical values
887    !
888
889    IF ( ANY(pheno_gdd_crit(j,:) .EQ. undef) ) THEN
890
891       WRITE(numout,*) 'moigdd: pheno_gdd_crit is undefined for PFT',j
892       WRITE(numout,*) 'We stop.'
893       STOP
894
895    ENDIF
896
897    IF ( hum_min_time(j) .EQ. undef ) THEN
898
899       WRITE(numout,*) 'moigdd: hum_min_time is undefined for PFT',j
900       WRITE(numout,*) 'We stop.'
901       STOP
902
903    ENDIF
904
905    !
906    ! 1.4 critical moisture availability above which we always detect the beginning of the
907    !     growing season.
908    !
909
910    IF ( tree(j) ) THEN
911       moiavail_always = moiavail_always_tree
912    ELSE
913       moiavail_always = moiavail_always_grass
914    ENDIF
915
916    !
917    ! 2 PFT has to be there, start of growing season must be allowed,
918    !   and gdd has to be defined
919    !
920
921    DO i = 1, npts
922
923       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
924            ( gdd(i,j) .NE. undef )                           ) THEN
925
926          ! is critical gdd reached and is temperature increasing?
927          ! has enough time gone by since moisture minimum and is moisture increasing?
928
929          tl(i) = tlong_ref(i) - ZeroCelsius
930          gdd_crit(i) = pheno_gdd_crit(j,1) + tl(i)*pheno_gdd_crit(j,2) + &
931               tl(i)*tl(i)*pheno_gdd_crit(j,3)
932
933          IF ( ( gdd(i,j) .GE. gdd_crit(i) ) .AND. &
934               ( ( t2m_week(i) .GT. t2m_month(i) ) .OR. &
935               ( t2m_month(i) .GT. t_always )          ) .AND. &
936               ( ( ( time_hum_min(i,j) .GT. hum_min_time(j) ) .AND. &
937               ( moiavail_week(i,j) .GT. moiavail_month(i,j) )            ) .OR. &
938               ( moiavail_month(i,j) .GE. moiavail_always )                         ) )  THEN
939             begin_leaves(i,j) = .TRUE.
940          ENDIF
941
942       ENDIF        ! PFT there and start of growing season allowed
943
944    ENDDO
945
946    IF (bavard.GE.4) WRITE(numout,*) 'Leaving moigdd'
947
948  END SUBROUTINE pheno_moigdd
949
950
951  !
952  ! ==============================================================================
953  ! Phenology: leaves are put on if a certain relationship between ncd since leaves were
954  !            lost (number of chilling days) and gdd since midwinter (growing degree
955  !            days) is fulfilled
956  !
957
958  SUBROUTINE pheno_ncdgdd (npts, j, PFTpresent, allow_initpheno, &
959       ncd_dormance, gdd_midwinter, &
960       t2m_month, t2m_week, begin_leaves)
961
962    !
963    ! 0 declarations
964    !
965
966    ! 0.1 input
967
968    ! Domain size
969    INTEGER(i_std), INTENT(in)                                     :: npts
970    ! PFT index
971    INTEGER(i_std), INTENT(in)                               :: j
972    ! PFT exists
973    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
974    ! are we allowed to declare the beginning of the growing season?
975    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
976    ! number of chilling days since leaves were lost
977    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: ncd_dormance
978    ! growing degree days since midwinter
979    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: gdd_midwinter
980    ! "monthly" 2-meter temperatures (K)
981    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month
982    ! "weekly" 2-meter temperatures (K)
983    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week
984
985    ! 0.2 output
986
987    ! signal to start putting leaves on
988    LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves
989
990    ! 0.3 local
991
992    ! index
993    INTEGER(i_std)                                           :: i
994    ! critical gdd
995    REAL(r_std)                                              :: gdd_min
996
997    ! =========================================================================
998
999    IF (bavard.GE.3) WRITE(numout,*) 'Entering ncdgdd'
1000
1001    !
1002    ! 1 Initializations
1003    !
1004
1005    !
1006    ! 1.1 initialize output
1007    !
1008
1009    begin_leaves(:,j) = .FALSE.
1010
1011    !
1012    ! 1.2 check the prescribed critical values
1013    !
1014
1015    IF ( ncdgdd_temp(j) .EQ. undef ) THEN
1016
1017       WRITE(numout,*) 'ncdgdd: ncdgdd_temp is undefined for PFT',j
1018       WRITE(numout,*) 'We stop.'
1019       STOP
1020
1021    ENDIF
1022
1023    !
1024    ! 2 PFT has to be there and start of growing season must be allowed
1025    !
1026
1027    DO i = 1, npts
1028
1029       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
1030            ( gdd_midwinter(i,j) .NE. undef ) .AND. &
1031            ( ncd_dormance(i,j) .NE. undef )                  ) THEN
1032
1033          ! critical gdd
1034
1035          gdd_min = ( gddncd_ref / exp(gddncd_curve*ncd_dormance(i,j)) - gddncd_offset )
1036
1037          ! has the critical gdd been reached and are temperatures increasing?
1038
1039          IF ( ( gdd_midwinter(i,j) .GE. gdd_min ) .AND. &
1040               ( t2m_week(i) .GT. t2m_month(i) ) ) THEN
1041             begin_leaves(i,j) = .TRUE.
1042             gdd_midwinter(i,j)=undef
1043          ENDIF
1044
1045       ENDIF        ! PFT there and start of growing season allowed
1046
1047    ENDDO
1048
1049    IF (bavard.GE.4) WRITE(numout,*) 'Leaving ncdgdd'
1050
1051  END SUBROUTINE pheno_ncdgdd
1052
1053  !
1054  ! ==============================================================================
1055  ! Phenology: leaves are put on if ngd (number of growing days, defined as
1056  !            days with t>-5 deg C) exceeds a critical value.
1057  !
1058
1059  SUBROUTINE pheno_ngd (npts, j, PFTpresent, allow_initpheno, ngd, &
1060       t2m_month, t2m_week, begin_leaves)
1061
1062    !
1063    ! 0 declarations
1064    !
1065
1066    ! 0.1 input
1067
1068    ! Domain size
1069    INTEGER(i_std), INTENT(in)                                     :: npts
1070    ! PFT index
1071    INTEGER(i_std), INTENT(in)                               :: j
1072    ! PFT exists
1073    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
1074    ! are we allowed to declare the beginning of the growing season?
1075    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
1076    ! growing degree days
1077    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: ngd
1078    ! "monthly" 2-meter temperatures (K)
1079    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month
1080    ! "weekly" 2-meter temperatures (K)
1081    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week
1082
1083    ! 0.2 output
1084
1085    ! signal to start putting leaves on
1086    LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves
1087
1088    ! 0.3 local
1089
1090    ! index
1091    INTEGER(i_std)                                           :: i
1092
1093    ! =========================================================================
1094
1095    IF (bavard.GE.3) WRITE(numout,*) 'Entering ngd'
1096
1097    !
1098    ! Initializations
1099    !
1100
1101    !
1102    ! 1.1 initialize output
1103    !
1104
1105    begin_leaves(:,j) = .FALSE.
1106
1107    !
1108    ! 1.2 check the prescribed critical value
1109    !
1110
1111    IF ( ngd_crit(j) .EQ. undef ) THEN
1112
1113       WRITE(numout,*) 'ngd: ngd_crit is undefined for PFT',j
1114       WRITE(numout,*) 'We stop.'
1115       STOP
1116
1117    ENDIF
1118
1119    !
1120    ! 2 PFT has to be there and start of growing season must be allowed
1121    !
1122
1123    DO i = 1, npts
1124
1125       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
1126
1127          ! is critical ngd reached and are temperatures increasing?
1128
1129          IF ( ( ngd(i,j) .GE. ngd_crit(j) ) .AND. &
1130               ( t2m_week(i) .GT. t2m_month(i) )        ) THEN
1131             begin_leaves(i,j) = .TRUE.
1132          ENDIF
1133
1134       ENDIF        ! PFT there and start of growing season allowed
1135
1136    ENDDO
1137
1138    IF (bavard.GE.4) WRITE(numout,*) 'Leaving ngd'
1139
1140  END SUBROUTINE pheno_ngd
1141
1142END MODULE stomate_phenology
Note: See TracBrowser for help on using the repository browser.