SURFEX  V8_0
Surfex V8_0 release
 All Classes Files Functions Variables
av_pgd.F90
Go to the documentation of this file.
1 !SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
2 !SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
3 !SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
4 !SFX_LIC for details. version 1.
5 ! ##################
6  MODULE modi_av_pgd
7 ! ##################
8 INTERFACE av_pgd
9 !
10  SUBROUTINE av_pgd_2d (DTCO, &
11  pfield,pcover,pdata,hsftype,hatype,ocover,pdz,kdecade)
12 
13 !
14 USE modd_data_cover_n, ONLY : data_cover_t
15 TYPE(data_cover_t), INTENT(INOUT) :: dtco
16 !
17 REAL, DIMENSION(:,:), INTENT(OUT) :: pfield ! secondary field to construct
18 REAL, DIMENSION(:,:,:), INTENT(IN) :: pcover ! fraction of each cover class
19 REAL, DIMENSION(:), INTENT(IN) :: pdata ! secondary field value for each class
20  CHARACTER(LEN=3), INTENT(IN) :: hsftype ! Type of surface where the field
21  ! is defined
22  CHARACTER(LEN=3), INTENT(IN) :: hatype ! Type of averaging
23 LOGICAL, DIMENSION(:), INTENT(IN) :: ocover
24 REAL, DIMENSION(:,:), INTENT(IN), OPTIONAL :: pdz ! first model half level
25 INTEGER, INTENT(IN), OPTIONAL :: kdecade ! current month
26 !
27 END SUBROUTINE av_pgd_2d
28 !
29  SUBROUTINE av_patch_pgd (DTCO, &
30  pfield,pcover,pdata,hsftype,hatype,ocover,pdz,kdecade)
31 
32 !
33 USE modd_data_cover_n, ONLY : data_cover_t
34 TYPE(data_cover_t), INTENT(INOUT) :: dtco
35 !
36 REAL, DIMENSION(:,:,:), INTENT(OUT) :: pfield ! secondary field to construct for each patch
37 REAL, DIMENSION(:,:,:), INTENT(IN) :: pcover ! fraction of each cover class
38 REAL, DIMENSION(:,:), INTENT(IN) :: pdata ! secondary field value for each class in each vegtype
39  CHARACTER(LEN=3), INTENT(IN) :: hsftype ! Type of surface where the field
40  ! is defined
41  CHARACTER(LEN=3), INTENT(IN) :: hatype ! Type of averaging
42 LOGICAL, DIMENSION(:), INTENT(IN) :: ocover
43 REAL, DIMENSION(:,:), INTENT(IN), OPTIONAL :: pdz ! first model half level
44 INTEGER, INTENT(IN), OPTIONAL :: kdecade ! current month
45 !
46 END SUBROUTINE av_patch_pgd
47 !
48  SUBROUTINE av_pgd_1d (DTCO, &
49  pfield,pcover,pdata,hsftype,hatype,ocover,pdz,kdecade)
50 
51 !
52 USE modd_data_cover_n, ONLY : data_cover_t
53 TYPE(data_cover_t), INTENT(INOUT) :: dtco
54 !
55 REAL, DIMENSION(:), INTENT(OUT) :: pfield ! secondary field to construct
56 REAL, DIMENSION(:,:), INTENT(IN) :: pcover ! fraction of each cover class
57 REAL, DIMENSION(:), INTENT(IN) :: pdata ! secondary field value for each class
58  CHARACTER(LEN=3), INTENT(IN) :: hsftype ! Type of surface where the field
59  ! is defined
60  CHARACTER(LEN=3), INTENT(IN) :: hatype ! Type of averaging
61  LOGICAL, DIMENSION(:), INTENT(IN) :: ocover
62 REAL, DIMENSION(:), INTENT(IN), OPTIONAL :: pdz ! first model half level
63 INTEGER, INTENT(IN), OPTIONAL :: kdecade ! current month
64 !
65 END SUBROUTINE av_pgd_1d
66 !
67  SUBROUTINE av_patch_pgd_1d (DTCO, &
68  pfield,pcover,pdata,hsftype,hatype,ocover,pdz,kdecade)
69 
70 !
71 USE modd_data_cover_n, ONLY : data_cover_t
72 TYPE(data_cover_t), INTENT(INOUT) :: dtco
73 !
74 REAL, DIMENSION(:,:), INTENT(OUT) :: pfield ! secondary field to construct for each patch
75 REAL, DIMENSION(:,:), INTENT(IN) :: pcover ! fraction of each cover class
76 REAL, DIMENSION(:,:), INTENT(IN) :: pdata ! secondary field value for each class in each vegtype
77  CHARACTER(LEN=3), INTENT(IN) :: hsftype ! Type of surface where the field
78  ! is defined
79  CHARACTER(LEN=3), INTENT(IN) :: hatype ! Type of averaging
80 LOGICAL, DIMENSION(:), INTENT(IN) :: ocover
81 REAL, DIMENSION(:), INTENT(IN), OPTIONAL :: pdz ! first model half level
82 INTEGER, INTENT(IN), OPTIONAL :: kdecade ! current month
83 !
84 END SUBROUTINE av_patch_pgd_1d
85 !
86  SUBROUTINE major_patch_pgd_1d(TFIELD,PCOVER,TDATA,HSFTYPE,HATYPE,OCOVER,KDECADE)
87 
88 !
89 USE modd_type_date_surf
90 TYPE (date_time), DIMENSION(:,:), INTENT(OUT) :: tfield ! secondary field to construct for each patch
91 REAL, DIMENSION(:,:), INTENT(IN) :: pcover ! fraction of each cover class
92 TYPE (date_time), DIMENSION(:,:), INTENT(IN) :: tdata ! secondary field to construct for each patch
93  CHARACTER(LEN=3), INTENT(IN) :: hsftype ! Type of surface where the field
94  ! is defined
95  CHARACTER(LEN=3), INTENT(IN) :: hatype ! Type of averaging
96 LOGICAL, DIMENSION(:), INTENT(IN) :: ocover
97 INTEGER, INTENT(IN), OPTIONAL :: kdecade ! current month
98 !
99 END SUBROUTINE major_patch_pgd_1d
100 !
101 
102 !
103 END INTERFACE
104 END MODULE modi_av_pgd
105 !
106 !
107 ! ################################################################
108  SUBROUTINE av_pgd_1d (DTCO, &
109  pfield,pcover,pdata,hsftype,hatype,ocover,pdz,kdecade)
110 ! ################################################################
111 !
112 !!**** *AV_PGD* average a secondary physiographic variable from the
113 !! fractions of coverage class.
114 !!
115 !! PURPOSE
116 !! -------
117 !!
118 !! METHOD
119 !! ------
120 !!
121 !! The averaging is performed with one way into three:
122 !!
123 !! - arithmetic averaging (HATYPE='ARI')
124 !!
125 !! - inverse averaging (HATYPE='INV')
126 !!
127 !! - inverse of square logarithm averaging (HATYPE='CDN') :
128 !!
129 !! 1 / ( ln (dz/data) )**2
130 !!
131 !! This latest uses (if available) the height of the first model mass
132 !! level. In the other case, 20m is chosen. It works for roughness lengths.
133 !!
134 !! EXTERNAL
135 !! --------
136 !!
137 !! IMPLICIT ARGUMENTS
138 !! ------------------
139 !!
140 !! REFERENCE
141 !! ---------
142 !!
143 !! AUTHOR
144 !! ------
145 !!
146 !! V. Masson Meteo-France
147 !!
148 !! MODIFICATION
149 !! ------------
150 !
151 ! F.Solmon patch modif: remove the case 'veg' as veg is defined for patches
152 !
153 !! Original 15/12/97
154 !! V. Masson 01/2004 Externalization
155 !! R. Alkama 05/2012 Add 6 tree vegtypes (9 rather than 3)
156 !!
157 !----------------------------------------------------------------------------
158 !
159 !* 0. DECLARATION
160 ! -----------
161 !
162 !
163 USE modd_data_cover_n, ONLY : data_cover_t
164 !
165 USE modd_surf_par, ONLY : xundef
166 USE modd_data_cover, ONLY : xdata_bld_height
167 USE modd_data_cover_par, ONLY : nvt_tebd, nvt_bone, nvt_trbe, xcdref, nvt_trbd, &
168  nvt_tebe, nvt_tene, nvt_bobd, nvt_bond, nvt_shrb
169 !
170 !
171 USE yomhook ,ONLY : lhook, dr_hook
172 USE parkind1 ,ONLY : jprb
173 !
174 USE modi_abor1_sfx
175 !
176 IMPLICIT NONE
177 !
178 !* 0.1 Declaration of arguments
179 ! ------------------------
180 !
181 !
182 TYPE(data_cover_t), INTENT(INOUT) :: dtco
183 !
184 REAL, DIMENSION(:), INTENT(OUT) :: pfield ! secondary field to construct
185 REAL, DIMENSION(:,:), INTENT(IN) :: pcover ! fraction of each cover class
186 REAL, DIMENSION(:), INTENT(IN) :: pdata ! secondary field value for each class
187  CHARACTER(LEN=3), INTENT(IN) :: hsftype ! Type of surface where the field
188  ! is defined
189  CHARACTER(LEN=3), INTENT(IN) :: hatype ! Type of averaging
190 LOGICAL, DIMENSION(:), INTENT(IN) :: ocover
191 REAL, DIMENSION(:), INTENT(IN), OPTIONAL :: pdz ! first model half level
192 INTEGER, INTENT(IN), OPTIONAL :: kdecade ! current month
193 !
194 !* 0.2 Declaration of local variables
195 ! ------------------------------
196 !
197 INTEGER :: jj
198 INTEGER :: icover ! number of cover classes
199 INTEGER :: jcover ! loop on cover classes
200 !
201 REAL, DIMENSION(SIZE(PCOVER,1)) :: zwork, zdz
202 REAL :: zweight
203 REAL, DIMENSION(SIZE(PCOVER,1)) :: zcover_weight
204 REAL :: zdata
205 REAL, DIMENSION(SIZE(PCOVER,1)) :: zsum_cover_weight
206 REAL, DIMENSION(SIZE(PCOVER,1)) :: zweight_max
207 REAL(KIND=JPRB) :: zhook_handle
208 !-------------------------------------------------------------------------------
209 !
210 !* 1.1 field does not exist
211 ! --------------------
212 !
213 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_1D',0,zhook_handle)
214 IF (SIZE(pfield)==0 .AND. lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_1D',1,zhook_handle)
215 IF (SIZE(pfield)==0) RETURN
216 !
217 !-------------------------------------------------------------------------------
218 !
219 !* 1.2 Initializations
220 ! ---------------
221 !
222 icover=SIZE(ocover)
223 !
224 IF (present(pdz)) THEN
225  zdz(:)=pdz(:)
226 ELSE
227  zdz(:)=xcdref
228 END IF
229 !
230 pfield(:)=xundef
231 !
232 zwork(:)=0.
233 zweight_max(:)=0.
234 zsum_cover_weight(:)=0.
235 !-------------------------------------------------------------------------------
236 jcover = 0
237 DO jj=1,icover
238  !
239  IF (.NOT.ocover(jj)) cycle
240  !
241  jcover = jcover + 1
242  !
243 !-------------------------------------------------------------------------------
244 !
245 !* 2. Selection of the weighting function
246 ! -----------------------------------
247 !
248  SELECT CASE (hsftype)
249  CASE('ALL')
250  zweight=1.
251 
252  CASE('NAT')
253  zweight=dtco%XDATA_NATURE(jj)
254 
255  CASE('GRD')
256  zweight=dtco%XDATA_TOWN (jj) * dtco%XDATA_GARDEN(jj)
257 
258  CASE('TWN')
259  zweight=dtco%XDATA_TOWN (jj)
260 
261  CASE('WAT')
262  zweight=dtco%XDATA_WATER (jj)
263 
264  CASE('SEA')
265  zweight=dtco%XDATA_SEA (jj)
266 
267  CASE('BLD')
268  zweight=dtco%XDATA_TOWN (jj) * dtco%XDATA_BLD(jj)
269 
270  CASE('BLV') !* building Volume
271  zweight=dtco%XDATA_TOWN (jj) * dtco%XDATA_BLD(jj) &
272  * xdata_bld_height(jj)
273 
274  CASE('STR')
275  zweight=dtco%XDATA_TOWN (jj) * ( 1. - dtco%XDATA_BLD(jj) )
276 
277  CASE('TRE')
278  pfield(:)=0.
279  zweight=dtco%XDATA_NATURE(jj) * ( dtco%XDATA_VEGTYPE(jj,nvt_tebd) &
280  + dtco%XDATA_VEGTYPE(jj,nvt_trbe) &
281  + dtco%XDATA_VEGTYPE(jj,nvt_trbd) &
282  + dtco%XDATA_VEGTYPE(jj,nvt_tebe) &
283  + dtco%XDATA_VEGTYPE(jj,nvt_tene) &
284  + dtco%XDATA_VEGTYPE(jj,nvt_bobd) &
285  + dtco%XDATA_VEGTYPE(jj,nvt_bond) &
286  + dtco%XDATA_VEGTYPE(jj,nvt_shrb) &
287  + dtco%XDATA_VEGTYPE(jj,nvt_bone) )
288 
289  CASE('GRT')
290  pfield(:)=0.
291  zweight=dtco%XDATA_TOWN(jj) * dtco%XDATA_GARDEN(jj) &
292  * ( dtco%XDATA_VEGTYPE(jj,nvt_tebd) &
293  + dtco%XDATA_VEGTYPE(jj,nvt_trbe) &
294  + dtco%XDATA_VEGTYPE(jj,nvt_trbd) &
295  + dtco%XDATA_VEGTYPE(jj,nvt_tebe) &
296  + dtco%XDATA_VEGTYPE(jj,nvt_tene) &
297  + dtco%XDATA_VEGTYPE(jj,nvt_bobd) &
298  + dtco%XDATA_VEGTYPE(jj,nvt_bond) &
299  + dtco%XDATA_VEGTYPE(jj,nvt_shrb) &
300  + dtco%XDATA_VEGTYPE(jj,nvt_bone) )
301 
302  CASE default
303  CALL abor1_sfx('AV_PGD_1D: WEIGHTING FUNCTION NOT ALLOWED '//hsftype)
304  END SELECT
305 !
306 !-------------------------------------------------------------------------------
307 !
308 !* 3. Averaging
309 ! ---------
310 !
311 !* 3.1 Work arrays
312 ! -----------
313 !
314  zcover_weight(:) = pcover(:,jcover) * zweight
315 !
316  zsum_cover_weight(:) = zsum_cover_weight(:) + zcover_weight(:)
317 !
318  zdata = pdata(jj)
319 !
320 !* 3.2 Selection of averaging type
321 ! ---------------------------
322 !
323  SELECT CASE (hatype)
324 !
325 !-------------------------------------------------------------------------------
326 !
327 !* 3.4 Arithmetic averaging
328 ! --------------------
329 !
330  CASE ('ARI')
331 !
332  zwork(:) = zwork(:) + zdata * zcover_weight(:)
333 !
334 !-------------------------------------------------------------------------------
335 !
336 !* 3.5 Inverse averaging
337 ! -----------------
338 !
339  CASE('INV' )
340 !
341  zwork(:)= zwork(:) + 1./zdata * zcover_weight(:)
342 !
343 !-------------------------------------------------------------------------------!
344 !
345 !* 3.6 Roughness length averaging
346 ! --------------------------
347 
348 !
349  CASE('CDN')
350 !
351  zwork(:)= zwork(:) + 1./(log(zdz(:)/zdata))**2 * zcover_weight(:)
352 !
353 !-------------------------------------------------------------------------------
354 !
355 !* 3.7 Majoritary averaging
356 ! --------------------
357 !
358  CASE('MAJ' )
359 !
360  WHERE(zcover_weight(:)>zweight_max(:))
361  zweight_max(:) = zcover_weight(:)
362  zwork(:) = zdata
363  END WHERE
364 !
365 !-------------------------------------------------------------------------------
366 !
367  CASE default
368  CALL abor1_sfx('AV_PGD_1D: (1) AVERAGING TYPE NOT ALLOWED : "'//hatype//'"')
369 !
370  END SELECT
371 !
372 END DO
373 !
374 !-------------------------------------------------------------------------------
375 !
376 !* 4. End of Averaging
377 ! ----------------
378 !
379 !* 4.1 Selection of averaging type
380 ! ---------------------------
381 !
382  SELECT CASE (hatype)
383 !
384 !-------------------------------------------------------------------------------
385 !
386 !* 4.2 Arithmetic averaging
387 ! --------------------
388 !
389  CASE ('ARI')
390 !
391  WHERE ( zsum_cover_weight(:) >0. )
392  pfield(:) = zwork(:) / zsum_cover_weight(:)
393  END WHERE
394 !
395 !-------------------------------------------------------------------------------
396 !
397 !* 4.3 Inverse averaging
398 ! -----------------
399 !
400  CASE('INV' )
401 !
402  WHERE ( zsum_cover_weight(:) >0. )
403  pfield(:) = zsum_cover_weight(:) / zwork(:)
404  END WHERE
405 !
406 !-------------------------------------------------------------------------------!
407 !
408 !* 4.4 Roughness length averaging
409 ! --------------------------
410 
411 !
412  CASE('CDN')
413 !
414  WHERE ( zsum_cover_weight(:) >0. )
415  pfield(:) = zdz(:) * exp( - sqrt(zsum_cover_weight(:)/zwork(:)) )
416  END WHERE
417 !
418 !-------------------------------------------------------------------------------
419 !
420 !* 4.4 Majoritary averaging
421 ! --------------------
422 !
423  CASE('MAJ' )
424 !
425  WHERE ( zsum_cover_weight(:) >0. )
426  pfield(:) = zwork(:)
427  END WHERE
428 !
429 !-------------------------------------------------------------------------------
430 !
431  CASE default
432  CALL abor1_sfx('AV_PGD_1D: (2) AVERAGING TYPE NOT ALLOWED')
433 !
434 END SELECT
435 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_1D',1,zhook_handle)
436 !
437 !
438 !-------------------------------------------------------------------------------
439 !
440 END SUBROUTINE av_pgd_1d
441 !
442 !
443 !
444 ! ################################################################
445  SUBROUTINE av_patch_pgd_1d (DTCO, &
446  pfield,pcover,pdata,hsftype,hatype,ocover,pdz,kdecade)
447 ! ################################################################
448 !
449 !!**** *AV_PATCH_PGD* average for each surface patch a secondary physiographic
450 !! variable from the
451 !! fractions of coverage class.
452 !!
453 !! PURPOSE
454 !! -------
455 !!
456 !! METHOD
457 !! ------
458 !!
459 !! The averaging is performed with one way into three:
460 !!
461 !! - arithmetic averaging (HATYPE='ARI')
462 !!
463 !! - inverse averaging (HATYPE='INV')
464 !!
465 !! - inverse of square logarithm averaging (HATYPE='CDN') :
466 !!
467 !! 1 / ( ln (dz/data) )**2
468 !!
469 !! This latest uses (if available) the height of the first model mass
470 !! level. In the other case, 20m is chosen. It works for roughness lengths.
471 !!
472 !! EXTERNAL
473 !! --------
474 !!
475 !! IMPLICIT ARGUMENTS
476 !! ------------------
477 !!
478 !! REFERENCE
479 !! ---------
480 !!
481 !! AUTHOR
482 !! ------
483 !!
484 !! F.Solmon /V. Masson
485 !!
486 !! MODIFICATION
487 !! ------------
488 
489 !!
490 !! Original 15/12/97
491 !! V. Masson 01/2004 Externalization
492 !! R. Alkama 05/2012 Add 6 tree vegtypes (9 rather than 3)
493 !!
494 !----------------------------------------------------------------------------
495 !
496 !* 0. DECLARATION
497 ! -----------
498 !
499 !
500 USE modd_data_cover_n, ONLY : data_cover_t
501 !
502 USE modd_surf_par, ONLY : xundef
503 USE modd_data_cover, ONLY : xdata_veg, xdata_lai
504 USE modd_data_cover_par, ONLY : nvt_tebd, nvt_bone, nvt_trbe, nvegtype, xcdref, nvt_trbd, &
505  nvt_tebe, nvt_tene, nvt_bobd, nvt_bond, nvt_shrb
506 !
507 USE modi_vegtype_to_patch
508 !
509 !
510 !
511 USE yomhook ,ONLY : lhook, dr_hook
512 USE parkind1 ,ONLY : jprb
513 !
514 USE modi_abor1_sfx
515 !
516 IMPLICIT NONE
517 !
518 !* 0.1 Declaration of arguments
519 ! ------------------------
520 !
521 !
522 TYPE(data_cover_t), INTENT(INOUT) :: dtco
523 !
524 REAL, DIMENSION(:,:), INTENT(OUT) :: pfield ! secondary field to construct
525 REAL, DIMENSION(:,:), INTENT(IN) :: pcover ! fraction of each cover class
526 REAL, DIMENSION(:,:), INTENT(IN) :: pdata ! secondary field value for each class
527  CHARACTER(LEN=3), INTENT(IN) :: hsftype ! Type of surface where the field
528  ! is defined
529  CHARACTER(LEN=3), INTENT(IN) :: hatype ! Type of averaging
530 LOGICAL, DIMENSION(:), INTENT(IN) :: ocover
531 REAL, DIMENSION(:), INTENT(IN), OPTIONAL :: pdz ! first model half level
532 INTEGER, INTENT(IN), OPTIONAL :: kdecade ! current month
533 !
534 !* 0.2 Declaration of local variables
535 ! ------------------------------
536 !
537 INTEGER :: icover ! number of cover classes
538 INTEGER :: jcover ! loop on cover classes
539 !
540 ! nbe of vegtype
541 ! nbre of patches
542 INTEGER :: jvegtype! loop on vegtype
543 INTEGER :: ipatch ! number of patches
544 INTEGER :: jpatch ! PATCH index
545 INTEGER :: jj, ji, jk
546 !
547 REAL :: zcover_weight
548 !
549 REAL, DIMENSION(SIZE(PCOVER,1)) :: zval
550 !
551 REAL, DIMENSION(SIZE(PCOVER,2),NVEGTYPE) :: zweight
552 !
553 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PFIELD,2)) :: zsum_cover_weight_patch
554 !
555 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PFIELD,2)) :: zwork
556 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PFIELD,2)) :: zdz
557 !
558 INTEGER, DIMENSION(SIZE(PCOVER,1),SIZE(PFIELD,2)) :: imask
559 INTEGER, DIMENSION(SIZE(PFIELD,2)) :: jcount
560 INTEGER :: patch_list(nvegtype)
561 REAL(KIND=JPRB) :: zhook_handle
562 
563 !-------------------------------------------------------------------------------
564 !
565 !* 1.1 field does not exist
566 ! --------------------
567 !
568 !IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PATCH_PGD_1D',0,ZHOOK_HANDLE)
569 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_1',0,zhook_handle)
570 IF (SIZE(pfield)==0 .AND. lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D',1,zhook_handle)
571 IF (SIZE(pfield)==0) RETURN
572 !
573 !-------------------------------------------------------------------------------
574 !
575 !* 1.2 Initializations
576 ! ---------------
577 !
578 icover=SIZE(ocover)
579 ipatch=SIZE(pfield,2)
580 !
581 IF (present(pdz)) THEN
582  DO jpatch=1,ipatch
583  zdz(:,jpatch)=pdz(:)
584  END DO
585 ELSE
586  zdz(:,:)=xcdref
587 END IF
588 !
589 pfield(:,:)=xundef
590 !
591 zwork(:,:) = 0.
592 zweight(:,:) = 0.0
593 zsum_cover_weight_patch(:,:) = 0.
594 !
595 DO jvegtype=1,nvegtype
596  patch_list(jvegtype) = vegtype_to_patch(jvegtype, ipatch)
597 ENDDO
598 !
599 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_1',1,zhook_handle)
600 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_2',0,zhook_handle)
601 !
602 IF (.NOT.ASSOCIATED(dtco%XDATA_WEIGHT)) THEN
603  !
604  ALLOCATE(dtco%XDATA_WEIGHT(SIZE(pcover,2),nvegtype,12))
605  dtco%XDATA_WEIGHT(:,:,:) = 0.
606  !
607  jcover=0
608  DO jj=1,icover
609  !
610  IF (.NOT.ocover(jj)) cycle
611  !
612  jcover = jcover+1
613  !
614  DO jvegtype=1,nvegtype
615  ! CASE('NAT')
616  IF (dtco%XDATA_VEGTYPE(jj,jvegtype)==0.) cycle
617  !
618  dtco%XDATA_WEIGHT(jcover,jvegtype,1)= dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,jvegtype)
619  !CASE('GRD')
620  dtco%XDATA_WEIGHT(jcover,jvegtype,2)= dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,jvegtype)
621  !CASE('VEG')
622  dtco%XDATA_WEIGHT(jcover,jvegtype,3)= dtco%XDATA_WEIGHT(jcover,jvegtype,1) * xdata_veg(jj,kdecade,jvegtype)
623  !CASE('BAR')
624  dtco%XDATA_WEIGHT(jcover,jvegtype,4)= dtco%XDATA_WEIGHT(jcover,jvegtype,1) * (1.-xdata_veg(jj,kdecade,jvegtype))
625  !CASE('GRV')
626  dtco%XDATA_WEIGHT(jcover,jvegtype,5)= dtco%XDATA_WEIGHT(jcover,jvegtype,2) * xdata_veg(jj,kdecade,jvegtype)
627  !CASE('GRB')
628  dtco%XDATA_WEIGHT(jcover,jvegtype,6)= dtco%XDATA_WEIGHT(jcover,jvegtype,2) * (1.-xdata_veg(jj,kdecade,jvegtype))
629  IF ( sum(xdata_lai(jj,:,jvegtype)) .GT. 0.0) THEN
630  !CASE('DVG') ! for diffusion scheme only
631  dtco%XDATA_WEIGHT(jcover,jvegtype,7)= dtco%XDATA_WEIGHT(jcover,jvegtype,1)
632  !CASE('GDV') ! for diffusion scheme only
633  dtco%XDATA_WEIGHT(jcover,jvegtype,8)= dtco%XDATA_WEIGHT(jcover,jvegtype,2)
634  ENDIF
635  !CASE('LAI')
636  dtco%XDATA_WEIGHT(jcover,jvegtype,9)= dtco%XDATA_WEIGHT(jcover,jvegtype,1) * xdata_lai(jj,kdecade,jvegtype)
637  !CASE('GRL')
638  dtco%XDATA_WEIGHT(jcover,jvegtype,10)= dtco%XDATA_WEIGHT(jcover,jvegtype,2) * xdata_lai(jj,kdecade,jvegtype)
639  !
640  !Tree vegtype
641  !
642  !CASE('TRE')
643  !CASE('GRT')
644  IF (jvegtype==nvt_tebd) THEN
645  dtco%XDATA_WEIGHT(jcover,nvt_tebd,11)= dtco%XDATA_WEIGHT(jcover,nvt_tebd,1)
646  dtco%XDATA_WEIGHT(jcover,nvt_tebd,12)= dtco%XDATA_WEIGHT(jcover,nvt_tebd,2)
647  ENDIF
648  IF (jvegtype==nvt_bone) THEN
649  dtco%XDATA_WEIGHT(jcover,nvt_bone,11)= dtco%XDATA_WEIGHT(jcover,nvt_bone,1)
650  dtco%XDATA_WEIGHT(jcover,nvt_bone,12)= dtco%XDATA_WEIGHT(jcover,nvt_bone,2)
651  ENDIF
652  IF (jvegtype==nvt_trbe) THEN
653  dtco%XDATA_WEIGHT(jcover,nvt_trbe,11)= dtco%XDATA_WEIGHT(jcover,nvt_trbe,1)
654  dtco%XDATA_WEIGHT(jcover,nvt_trbe,12)= dtco%XDATA_WEIGHT(jcover,nvt_trbe,2)
655  ENDIF
656  IF (jvegtype==nvt_trbd) THEN
657  dtco%XDATA_WEIGHT(jcover,nvt_trbd,11)= dtco%XDATA_WEIGHT(jcover,nvt_trbd,1)
658  dtco%XDATA_WEIGHT(jcover,nvt_trbd,12)= dtco%XDATA_WEIGHT(jcover,nvt_trbd,2)
659  ENDIF
660  IF (jvegtype==nvt_tebe) THEN
661  dtco%XDATA_WEIGHT(jcover,nvt_tebe,11)= dtco%XDATA_WEIGHT(jcover,nvt_tebe,1)
662  dtco%XDATA_WEIGHT(jcover,nvt_tebe,12)= dtco%XDATA_WEIGHT(jcover,nvt_tebe,2)
663  ENDIF
664  IF (jvegtype==nvt_tene) THEN
665  dtco%XDATA_WEIGHT(jcover,nvt_tene,11)= dtco%XDATA_WEIGHT(jcover,nvt_tene,1)
666  dtco%XDATA_WEIGHT(jcover,nvt_tene,12)= dtco%XDATA_WEIGHT(jcover,nvt_tene,2)
667  ENDIF
668  IF (jvegtype==nvt_bobd) THEN
669  dtco%XDATA_WEIGHT(jcover,nvt_bobd,11)= dtco%XDATA_WEIGHT(jcover,nvt_bobd,1)
670  dtco%XDATA_WEIGHT(jcover,nvt_bobd,12)= dtco%XDATA_WEIGHT(jcover,nvt_bobd,2)
671  ENDIF
672  IF (jvegtype==nvt_bond) THEN
673  dtco%XDATA_WEIGHT(jcover,nvt_bond,11)= dtco%XDATA_WEIGHT(jcover,nvt_bond,1)
674  dtco%XDATA_WEIGHT(jcover,nvt_bond,12)= dtco%XDATA_WEIGHT(jcover,nvt_bond,2)
675  ENDIF
676  IF (jvegtype==nvt_shrb) THEN
677  dtco%XDATA_WEIGHT(jcover,nvt_shrb,11)= dtco%XDATA_WEIGHT(jcover,nvt_shrb,1)
678  dtco%XDATA_WEIGHT(jcover,nvt_shrb,12)= dtco%XDATA_WEIGHT(jcover,nvt_shrb,2)
679  ENDIF
680  !
681  ENDDO
682  !
683  ENDDO
684  !
685 ENDIF
686 !
687 SELECT CASE (hsftype)
688  CASE('NAT')
689  zweight(:,:) = dtco%XDATA_WEIGHT(:,:,1)
690  CASE('GRD')
691  zweight(:,:) = dtco%XDATA_WEIGHT(:,:,2)
692  CASE('VEG')
693  zweight(:,:) = dtco%XDATA_WEIGHT(:,:,3)
694  CASE('BAR')
695  zweight(:,:) = dtco%XDATA_WEIGHT(:,:,4)
696  CASE('GRV')
697  zweight(:,:) = dtco%XDATA_WEIGHT(:,:,5)
698  CASE('GRB')
699  zweight(:,:) = dtco%XDATA_WEIGHT(:,:,6)
700  CASE('DVG')
701  zweight(:,:) = dtco%XDATA_WEIGHT(:,:,7)
702  CASE('GDV')
703  zweight(:,:) = dtco%XDATA_WEIGHT(:,:,8)
704  CASE('LAI')
705  zweight(:,:) = dtco%XDATA_WEIGHT(:,:,9)
706  CASE('GRL')
707  zweight(:,:) = dtco%XDATA_WEIGHT(:,:,10)
708  CASE('TRE')
709  zweight(:,:) = dtco%XDATA_WEIGHT(:,:,11)
710  CASE('GRT')
711  zweight(:,:) = dtco%XDATA_WEIGHT(:,:,12)
712  CASE default
713  CALL abor1_sfx('AV_PATCH_PGD_1D: WEIGHTING FUNCTION FOR VEGTYPE NOT ALLOWED')
714 END SELECT
715 !
716 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_2',1,zhook_handle)
717 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_3',0,zhook_handle)
718 !
719 !-------------------------------------------------------------------------------
720  !
721  !
722  !* 2. Selection of the weighting function for vegtype
723  ! -----------------------------------
724  !
725 jcover=0
726 !
727 DO jj=1,icover
728  !
729  IF (ocover(jj)) THEN
730  !
731  jcover = jcover+1
732  !
733  DO jvegtype=1,nvegtype
734  !
735  jpatch= patch_list(jvegtype)
736  !
737  IF (zweight(jcover,jvegtype)/=0.) THEN
738  !
739  IF (hatype=='ARI') THEN
740  zval(:) = pdata(jj,jvegtype)
741  ELSEIF (hatype=='INV') THEN
742  zval(:) = 1. / pdata(jj,jvegtype)
743  ELSEIF (hatype=='CDN') THEN
744  DO ji=1,SIZE(pcover,1)
745  zval(ji) = 1./(log(zdz(ji,jpatch)/pdata(jj,jvegtype)))**2
746  ENDDO
747  ELSE
748  CALL abor1_sfx('AV_PATCH_PGD_1D: (1) AVERAGING TYPE NOT ALLOWED')
749  ENDIF
750  !
751 !$OMP PARALLEL DO PRIVATE(JI,ZCOVER_WEIGHT)
752  DO ji=1,SIZE(pcover,1)
753  IF (pcover(ji,jcover)/=0.) THEN
754  zcover_weight = pcover(ji,jcover) * zweight(jcover,jvegtype)
755  zsum_cover_weight_patch(ji,jpatch) = zsum_cover_weight_patch(ji,jpatch) + zcover_weight
756  zwork(ji,jpatch) = zwork(ji,jpatch) + zval(ji) * zcover_weight
757  ENDIF
758  ENDDO
759 !$OMP END PARALLEL DO
760  !
761  ENDIF
762  !
763  ENDDO
764  !
765  ENDIF
766  !
767 ENDDO
768 !
769 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_3',1,zhook_handle)
770 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_4',0,zhook_handle)
771 !-------------------------------------------------------------------------------
772 !
773 !* 4. End of Averaging
774 ! ----------------
775 !
776 imask(:,:)=0
777 jcount(:)=0
778 DO jpatch=1,ipatch
779  DO ji=1,SIZE(pcover,1)
780  IF ( zsum_cover_weight_patch(ji,jpatch) >0.) THEN
781  jcount(jpatch)=jcount(jpatch)+1
782  imask(jcount(jpatch),jpatch)=ji
783  ENDIF
784  ENDDO
785 ENDDO
786 !
787 !-------------------------------------------------------------------------------
788 
789 !
790 !* 4.1 Selection of averaging type
791 ! ---------------------------
792 !
793  SELECT CASE (hatype)
794 !
795 !-------------------------------------------------------------------------------
796 !
797 !* 4.2 Arithmetic averaging
798 ! --------------------
799 !
800  CASE ('ARI')
801 !
802  DO jpatch=1,ipatch
803 !cdir nodep
804  DO jj=1,jcount(jpatch)
805  ji = imask(jj,jpatch)
806  pfield(ji,jpatch) = zwork(ji,jpatch) / zsum_cover_weight_patch(ji,jpatch)
807  ENDDO
808  ENDDO
809 !
810 !-------------------------------------------------------------------------------
811 !
812 !* 4.3 Inverse averaging
813 ! -----------------
814 !
815  CASE('INV' )
816 !
817  DO jpatch=1,ipatch
818 !cdir nodep
819  DO jj=1,jcount(jpatch)
820  ji = imask(jj,jpatch)
821  pfield(ji,jpatch) = zsum_cover_weight_patch(ji,jpatch) / zwork(ji,jpatch)
822  ENDDO
823  ENDDO
824 !-------------------------------------------------------------------------------!
825 !
826 !* 4.4 Roughness length averaging
827 ! --------------------------
828 
829 !
830  CASE('CDN')
831 !
832  DO jpatch=1,ipatch
833 !cdir nodep
834  DO jj=1,jcount(jpatch)
835  ji = imask(jj,jpatch)
836  pfield(ji,jpatch) = zdz(ji,jpatch) * exp( - sqrt(zsum_cover_weight_patch(ji,jpatch)/zwork(ji,jpatch)) )
837  ENDDO
838  ENDDO
839 !
840 !-------------------------------------------------------------------------------
841 !
842  CASE default
843  CALL abor1_sfx('AV_PATCH_PGD_1D: (2) AVERAGING TYPE NOT ALLOWED')
844 !
845 END SELECT
846 !
847 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_4',1,zhook_handle)
848 !
849 !IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PATCH_PGD_1D',1,ZHOOK_HANDLE)
850 !-------------------------------------------------------------------------------
851 !
852 END SUBROUTINE av_patch_pgd_1d
853 !
854 ! ################################################################
855  SUBROUTINE av_pgd_2d (DTCO, &
856  pfield,pcover,pdata,hsftype,hatype,ocover,pdz,kdecade)
857 ! ################################################################
858 !
859 !!**** *AV_PGD* average a secondary physiographic variable from the
860 !! fractions of coverage class.
861 !!
862 !! PURPOSE
863 !! -------
864 !!
865 !! METHOD
866 !! ------
867 !!
868 !! The averaging is performed with one way into three:
869 !!
870 !! - arithmetic averaging (HATYPE='ARI')
871 !!
872 !! - inverse averaging (HATYPE='INV')
873 !!
874 !! - inverse of square logarithm averaging (HATYPE='CDN') :
875 !!
876 !! 1 / ( ln (dz/data) )**2
877 !!
878 !! This latest uses (if available) the height of the first model mass
879 !! level. In the other case, 20m is chosen. It works for roughness lengths.
880 !!
881 !! EXTERNAL
882 !! --------
883 !!
884 !! IMPLICIT ARGUMENTS
885 !! ------------------
886 !!
887 !! REFERENCE
888 !! ---------
889 !!
890 !! AUTHOR
891 !! ------
892 !!
893 !! V. Masson Meteo-France
894 !!
895 !! MODIFICATION
896 !! ------------
897 !
898 ! F.Solmon patch modif: remove the case 'veg' as veg is defined for patches
899 !
900 !! Original 15/12/97
901 !! V. Masson 01/2004 Externalization
902 !! R. Alkama 05/2012 Add 6 tree vegtypes (9 rather than 3)
903 !!
904 !----------------------------------------------------------------------------
905 !
906 !* 0. DECLARATION
907 ! -----------
908 !
909 !
910 USE modd_data_cover_n, ONLY : data_cover_t
911 !
912 USE modd_surf_par, ONLY : xundef
913 USE modd_data_cover_par, ONLY : nvt_tebd, nvt_bone, nvt_trbe, xcdref, nvt_trbd, &
914  nvt_tebe, nvt_tene, nvt_bobd, nvt_bond, nvt_shrb
915 !
916 !
917 USE yomhook ,ONLY : lhook, dr_hook
918 USE parkind1 ,ONLY : jprb
919 !
920 USE modi_abor1_sfx
921 !
922 IMPLICIT NONE
923 !
924 !* 0.1 Declaration of arguments
925 ! ------------------------
926 !
927 !
928 TYPE(data_cover_t), INTENT(INOUT) :: dtco
929 !
930 REAL, DIMENSION(:,:), INTENT(OUT) :: pfield ! secondary field to construct
931 REAL, DIMENSION(:,:,:), INTENT(IN) :: pcover ! fraction of each cover class
932 REAL, DIMENSION(:), INTENT(IN) :: pdata ! secondary field value for each class
933  CHARACTER(LEN=3), INTENT(IN) :: hsftype ! Type of surface where the field
934  ! is defined
935  CHARACTER(LEN=3), INTENT(IN) :: hatype ! Type of averaging
936  LOGICAL, DIMENSION(:), INTENT(IN) :: ocover
937 REAL, DIMENSION(:,:), INTENT(IN), OPTIONAL :: pdz ! first model half level
938 INTEGER, INTENT(IN), OPTIONAL :: kdecade ! current month
939 !
940 !* 0.2 Declaration of local variables
941 ! ------------------------------
942 !
943 INTEGER :: jj
944 INTEGER :: icover ! number of cover classes
945 INTEGER :: jcover ! loop on cover classes
946 !
947 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2)) :: zwork, zdz
948 REAL :: zweight
949 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2)) :: zcover_weight
950 REAL :: zdata
951 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2)) :: zsum_cover_weight
952 REAL(KIND=JPRB) :: zhook_handle
953 !-------------------------------------------------------------------------------
954 !
955 !* 1.1 field does not exist
956 ! --------------------
957 !
958 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_2D',0,zhook_handle)
959 IF (SIZE(pfield)==0 .AND. lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_2D',1,zhook_handle)
960 IF (SIZE(pfield)==0) RETURN
961 !
962 !-------------------------------------------------------------------------------
963 !
964 !* 1.2 Initializations
965 ! ---------------
966 !
967 icover=SIZE(ocover)
968 !
969 IF (present(pdz)) THEN
970  zdz(:,:)=pdz(:,:)
971 ELSE
972  zdz(:,:)=xcdref
973 END IF
974 !
975 pfield(:,:)=xundef
976 !
977 zwork(:,:)=0.
978 zsum_cover_weight(:,:)=0.
979 !-------------------------------------------------------------------------------
980 jcover = 0
981 DO jj=1,icover
982  !
983  IF (.NOT.ocover(jj)) cycle
984  !
985  jcover = jcover + 1
986  !
987 !-------------------------------------------------------------------------------
988 !
989 !* 2. Selection of the weighting function
990 ! -----------------------------------
991 !
992  SELECT CASE (hsftype)
993  CASE('ALL')
994  zweight=1.
995 
996  CASE('NAT')
997  zweight=dtco%XDATA_NATURE(jj)
998 
999  CASE('GRD')
1000  zweight=dtco%XDATA_TOWN (jj) * dtco%XDATA_GARDEN(jj)
1001 
1002  CASE('TWN')
1003  zweight=dtco%XDATA_TOWN (jj)
1004 
1005  CASE('WAT')
1006  zweight=dtco%XDATA_WATER (jj)
1007 
1008  CASE('SEA')
1009  zweight=dtco%XDATA_SEA (jj)
1010 
1011  CASE('BLD')
1012  zweight=dtco%XDATA_TOWN (jj) * dtco%XDATA_BLD(jj)
1013 
1014  CASE('STR')
1015  zweight=dtco%XDATA_TOWN (jj) * ( 1. - dtco%XDATA_BLD(jj) )
1016 
1017  CASE('TRE')
1018  pfield(:,:)=0.
1019  zweight=dtco%XDATA_NATURE(jj) * ( dtco%XDATA_VEGTYPE(jj,nvt_tebd) &
1020  + dtco%XDATA_VEGTYPE(jj,nvt_trbe) &
1021  + dtco%XDATA_VEGTYPE(jj,nvt_trbd) &
1022  + dtco%XDATA_VEGTYPE(jj,nvt_tebe) &
1023  + dtco%XDATA_VEGTYPE(jj,nvt_tene) &
1024  + dtco%XDATA_VEGTYPE(jj,nvt_bobd) &
1025  + dtco%XDATA_VEGTYPE(jj,nvt_bond) &
1026  + dtco%XDATA_VEGTYPE(jj,nvt_shrb) &
1027  + dtco%XDATA_VEGTYPE(jj,nvt_bone) )
1028 
1029  CASE('GRT')
1030  pfield(:,:)=0.
1031  zweight=dtco%XDATA_TOWN (jj) * dtco%XDATA_GARDEN(jj) &
1032  * ( dtco%XDATA_VEGTYPE(jj,nvt_tebd) &
1033  + dtco%XDATA_VEGTYPE(jj,nvt_trbe) &
1034  + dtco%XDATA_VEGTYPE(jj,nvt_trbd) &
1035  + dtco%XDATA_VEGTYPE(jj,nvt_tebe) &
1036  + dtco%XDATA_VEGTYPE(jj,nvt_tene) &
1037  + dtco%XDATA_VEGTYPE(jj,nvt_bobd) &
1038  + dtco%XDATA_VEGTYPE(jj,nvt_bond) &
1039  + dtco%XDATA_VEGTYPE(jj,nvt_shrb) &
1040  + dtco%XDATA_VEGTYPE(jj,nvt_bone) )
1041 
1042  CASE default
1043  CALL abor1_sfx('AV_PGD: WEIGHTING FUNCTION NOT ALLOWED')
1044  END SELECT
1045 !
1046 !-------------------------------------------------------------------------------
1047 !
1048 !* 3. Averaging
1049 ! ---------
1050 !
1051 !* 3.1 Work arrays
1052 ! -----------
1053 !
1054  zcover_weight(:,:) = pcover(:,:,jcover) * zweight
1055 !
1056  zsum_cover_weight(:,:) = zsum_cover_weight(:,:) + zcover_weight(:,:)
1057 !
1058  zdata = pdata(jj)
1059 !
1060 !* 3.2 Selection of averaging type
1061 ! ---------------------------
1062 !
1063  SELECT CASE (hatype)
1064 !
1065 !-------------------------------------------------------------------------------
1066 !
1067 !* 3.4 Arithmetic averaging
1068 ! --------------------
1069 !
1070  CASE ('ARI')
1071 !
1072  zwork(:,:) = zwork(:,:) + zdata * zcover_weight(:,:)
1073 !
1074 !-------------------------------------------------------------------------------
1075 !
1076 !* 3.5 Inverse averaging
1077 ! -----------------
1078 !
1079  CASE('INV' )
1080 !
1081  zwork(:,:)= zwork(:,:) + 1./zdata * zcover_weight(:,:)
1082 !
1083 !-------------------------------------------------------------------------------!
1084 !
1085 !* 3.6 Roughness length averaging
1086 ! --------------------------
1087 
1088 !
1089  CASE('CDN')
1090 !
1091  zwork(:,:)= zwork(:,:) + 1./(log(zdz(:,:)/zdata))**2 * zcover_weight(:,:)
1092 !
1093 !-------------------------------------------------------------------------------
1094 !
1095  CASE default
1096  CALL abor1_sfx('AV_PGD: (1) AVERAGING TYPE NOT ALLOWED')
1097 !
1098  END SELECT
1099 !
1100 END DO
1101 !
1102 !-------------------------------------------------------------------------------
1103 !
1104 !* 4. End of Averaging
1105 ! ----------------
1106 !
1107 !* 4.1 Selection of averaging type
1108 ! ---------------------------
1109 !
1110  SELECT CASE (hatype)
1111 !
1112 !-------------------------------------------------------------------------------
1113 !
1114 !* 4.2 Arithmetic averaging
1115 ! --------------------
1116 !
1117  CASE ('ARI')
1118 !
1119  WHERE ( zsum_cover_weight(:,:) >0. )
1120  pfield(:,:) = zwork(:,:) / zsum_cover_weight(:,:)
1121  END WHERE
1122 !
1123 !-------------------------------------------------------------------------------
1124 !
1125 !* 4.3 Inverse averaging
1126 ! -----------------
1127 !
1128  CASE('INV' )
1129 !
1130  WHERE ( zsum_cover_weight(:,:) >0. )
1131  pfield(:,:) = zsum_cover_weight(:,:) / zwork(:,:)
1132  END WHERE
1133 !
1134 !-------------------------------------------------------------------------------!
1135 !
1136 !* 4.4 Roughness length averaging
1137 ! --------------------------
1138 
1139 !
1140  CASE('CDN')
1141 !
1142  WHERE ( zsum_cover_weight(:,:) >0. )
1143  pfield(:,:) = zdz(:,:) * exp( - sqrt(zsum_cover_weight(:,:)/zwork(:,:)) )
1144  END WHERE
1145 !
1146 !-------------------------------------------------------------------------------
1147 !
1148  CASE default
1149  CALL abor1_sfx('AV_PGD_2D: (2) AVERAGING TYPE NOT ALLOWED')
1150 !
1151 END SELECT
1152 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_2D',1,zhook_handle)
1153 !
1154 !
1155 !-------------------------------------------------------------------------------
1156 !
1157 END SUBROUTINE av_pgd_2d
1158 !
1159 !
1160 !
1161 ! ################################################################
1162  SUBROUTINE av_patch_pgd (DTCO, &
1163  pfield,pcover,pdata,hsftype,hatype,ocover,pdz,kdecade)
1164 ! ################################################################
1165 !
1166 !!**** *AV_PATCH_PGD* average for each surface patch a secondary physiographic
1167 !! variable from the
1168 !! fractions of coverage class.
1169 !!
1170 !! PURPOSE
1171 !! -------
1172 !!
1173 !! METHOD
1174 !! ------
1175 !!
1176 !! The averaging is performed with one way into three:
1177 !!
1178 !! - arithmetic averaging (HATYPE='ARI')
1179 !!
1180 !! - inverse averaging (HATYPE='INV')
1181 !!
1182 !! - inverse of square logarithm averaging (HATYPE='CDN') :
1183 !!
1184 !! 1 / ( ln (dz/data) )**2
1185 !!
1186 !! This latest uses (if available) the height of the first model mass
1187 !! level. In the other case, 20m is chosen. It works for roughness lengths.
1188 !!
1189 !! EXTERNAL
1190 !! --------
1191 !!
1192 !! IMPLICIT ARGUMENTS
1193 !! ------------------
1194 !!
1195 !! REFERENCE
1196 !! ---------
1197 !!
1198 !! AUTHOR
1199 !! ------
1200 !!
1201 !! F.Solmon /V. Masson
1202 !!
1203 !! MODIFICATION
1204 !! ------------
1205 !!
1206 !! Original 15/12/97
1207 !! V. Masson 01/2004 Externalization
1208 !! R. Alkama 05/2012 Add 6 tree vegtypes (9 rather than 3)
1209 !!
1210 !----------------------------------------------------------------------------
1211 !
1212 !* 0. DECLARATION
1213 ! -----------
1214 !
1215 !
1216 USE modd_data_cover_n, ONLY : data_cover_t
1217 !
1218 USE modd_surf_par, ONLY : xundef
1219 USE modd_data_cover, ONLY : xdata_veg, xdata_lai
1220 USE modd_data_cover_par, ONLY : nvt_tebd, nvt_bone, nvt_trbe, nvegtype, xcdref, nvt_trbd, &
1221  nvt_tebe, nvt_tene, nvt_bobd, nvt_bond, nvt_shrb
1222 !
1223 USE modi_vegtype_to_patch
1224 !
1225 !
1226 !
1227 USE yomhook ,ONLY : lhook, dr_hook
1228 USE parkind1 ,ONLY : jprb
1229 !
1230 USE modi_abor1_sfx
1231 !
1232 IMPLICIT NONE
1233 !
1234 !* 0.1 Declaration of arguments
1235 ! ------------------------
1236 !
1237 !
1238 TYPE(data_cover_t), INTENT(INOUT) :: dtco
1239 !
1240 REAL, DIMENSION(:,:,:), INTENT(OUT) :: pfield ! secondary field to construct
1241 REAL, DIMENSION(:,:,:), INTENT(IN) :: pcover ! fraction of each cover class
1242 REAL, DIMENSION(:,:), INTENT(IN) :: pdata ! secondary field value for each class
1243  CHARACTER(LEN=3), INTENT(IN) :: hsftype ! Type of surface where the field
1244  ! is defined
1245  CHARACTER(LEN=3), INTENT(IN) :: hatype ! Type of averaging
1246  LOGICAL, DIMENSION(:), INTENT(IN) :: ocover
1247 REAL, DIMENSION(:,:), INTENT(IN), OPTIONAL :: pdz ! first model half level
1248 INTEGER, INTENT(IN), OPTIONAL :: kdecade ! current month
1249 !
1250 !* 0.2 Declaration of local variables
1251 ! ------------------------------
1252 !
1253 INTEGER :: jj
1254 INTEGER :: icover ! number of cover classes
1255 INTEGER :: jcover ! loop on cover classes
1256 !
1257 ! nbe of vegtype
1258 ! nbre of patches
1259 INTEGER :: jvegtype! loop on vegtype
1260 INTEGER :: ipatch ! number of patches
1261 INTEGER :: jpatch ! PATCH index
1262 !
1263 REAL, DIMENSION(NVEGTYPE) :: zweight
1264 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),NVEGTYPE) :: zcover_weight
1265 !
1266 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),SIZE(PFIELD,3)):: zcover_weight_patch
1267 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),SIZE(PFIELD,3)):: zsum_cover_weight_patch
1268 REAL, DIMENSION(NVEGTYPE) :: zdata
1269 !
1270 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),SIZE(PFIELD,3)):: zwork
1271 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),SIZE(PFIELD,3)):: zdz
1272 REAL(KIND=JPRB) :: zhook_handle
1273 !-------------------------------------------------------------------------------
1274 !
1275 !* 1.1 field does not exist
1276 ! --------------------
1277 !
1278 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD',0,zhook_handle)
1279 IF (SIZE(pfield)==0 .AND. lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD',1,zhook_handle)
1280 IF (SIZE(pfield)==0) RETURN
1281 !
1282 !-------------------------------------------------------------------------------
1283 !
1284 !* 1.2 Initializations
1285 ! ---------------
1286 !
1287 icover=SIZE(ocover)
1288 ipatch=SIZE(pfield,3)
1289 !
1290 !
1291 !
1292 IF (present(pdz)) THEN
1293  DO jpatch=1,ipatch
1294  zdz(:,:,jpatch)=pdz(:,:)
1295  END DO
1296 ELSE
1297  zdz(:,:,:)=xcdref
1298 END IF
1299 !
1300 pfield(:,:,:)=xundef
1301 !
1302 zwork(:,:,:)=0.
1303 zsum_cover_weight_patch(:,:,:)=0.
1304 !
1305 !-------------------------------------------------------------------------------
1306 jcover = 0
1307 DO jj=1,icover
1308  !
1309  IF (.NOT.ocover(jj)) cycle
1310  !
1311  jcover = jcover + 1
1312  !
1313 !-------------------------------------------------------------------------------
1314 !
1315 !* 2. Selection of the weighting function for vegtype
1316 ! -----------------------------------
1317 !
1318  SELECT CASE (hsftype)
1319 
1320  CASE('NAT')
1321  DO jvegtype=1,nvegtype
1322  zweight(jvegtype)=dtco%XDATA_NATURE(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)
1323  END DO
1324 
1325  CASE('GRD')
1326  DO jvegtype=1,nvegtype
1327  zweight(jvegtype)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)
1328  END DO
1329 
1330  CASE('VEG')
1331  DO jvegtype=1,nvegtype
1332  zweight(jvegtype)=dtco%XDATA_NATURE(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)*&
1333  xdata_veg(jj,kdecade,jvegtype)
1334  END DO
1335 
1336  CASE('BAR')
1337  DO jvegtype=1,nvegtype
1338  zweight(jvegtype)=dtco%XDATA_NATURE(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)*&
1339  (1.-xdata_veg(jj,kdecade,jvegtype))
1340  END DO
1341 
1342  CASE('GRV')
1343  DO jvegtype=1,nvegtype
1344  zweight(jvegtype)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)*&
1345  xdata_veg(jj,kdecade,jvegtype)
1346  END DO
1347 
1348  CASE('GRB')
1349  DO jvegtype=1,nvegtype
1350  zweight(jvegtype)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)*&
1351  (1.-xdata_veg(jj,kdecade,jvegtype))
1352  ENDDO
1353 
1354  CASE('DVG') ! average only on vegetated area
1355  zweight(:) = 0.0
1356  DO jvegtype=1,nvegtype
1357  IF ( sum(xdata_lai(jj,:,jvegtype)).GT.0.) &
1358  zweight(jvegtype)=dtco%XDATA_NATURE(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)
1359  END DO
1360 
1361  CASE('GDV') ! average only on vegetated area
1362  zweight(:) = 0.0
1363  DO jvegtype=1,nvegtype
1364  IF ( sum(xdata_lai(jj,:,jvegtype)).GT.0.) &
1365  zweight(jvegtype)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)
1366  END DO
1367 
1368  CASE('LAI')
1369  DO jvegtype=1,nvegtype
1370  zweight(jvegtype)=dtco%XDATA_NATURE(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)*&
1371  xdata_lai(jj,kdecade,jvegtype)
1372  END DO
1373 
1374  CASE('GRL')
1375  DO jvegtype=1,nvegtype
1376  zweight(jvegtype)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)*&
1377  xdata_lai(jj,kdecade,jvegtype)
1378  END DO
1379 
1380  CASE('TRE')
1381  zweight(:)=0.
1382  IF (dtco%XDATA_VEGTYPE(jj,nvt_tebd)>0.) THEN
1383  zweight(nvt_tebd)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_tebd)
1384  END IF
1385  IF (dtco%XDATA_VEGTYPE(jj,nvt_bone)>0.) THEN
1386  zweight(nvt_bone)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_bone)
1387  END IF
1388  IF (dtco%XDATA_VEGTYPE(jj,nvt_trbe)>0.) THEN
1389  zweight(nvt_trbe)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_trbe)
1390  END IF
1391  IF (dtco%XDATA_VEGTYPE(jj,nvt_trbd)>0.) THEN
1392  zweight(nvt_trbd)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_trbd)
1393  END IF
1394  IF (dtco%XDATA_VEGTYPE(jj,nvt_tebe)>0.) THEN
1395  zweight(nvt_tebe)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_tebe)
1396  END IF
1397  IF (dtco%XDATA_VEGTYPE(jj,nvt_tene)>0.) THEN
1398  zweight(nvt_tene)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_tene)
1399  END IF
1400  IF (dtco%XDATA_VEGTYPE(jj,nvt_bobd)>0.) THEN
1401  zweight(nvt_bobd)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_bobd)
1402  END IF
1403  IF (dtco%XDATA_VEGTYPE(jj,nvt_bond)>0.) THEN
1404  zweight(nvt_bond)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_bond)
1405  END IF
1406  IF (dtco%XDATA_VEGTYPE(jj,nvt_shrb)>0.) THEN
1407  zweight(nvt_shrb)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_shrb)
1408  END IF
1409 
1410  CASE('GRT')
1411  zweight(:)=0.
1412  IF (dtco%XDATA_VEGTYPE(jj,nvt_tebd)>0.) THEN
1413  zweight(nvt_tebd)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_tebd)
1414  END IF
1415  IF (dtco%XDATA_VEGTYPE(jj,nvt_bone)>0.) THEN
1416  zweight(nvt_bone)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_bone)
1417  END IF
1418  IF (dtco%XDATA_VEGTYPE(jj,nvt_trbe)>0.) THEN
1419  zweight(nvt_trbe)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_trbe)
1420  END IF
1421  IF (dtco%XDATA_VEGTYPE(jj,nvt_trbd)>0.) THEN
1422  zweight(nvt_trbd)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_trbd)
1423  END IF
1424  IF (dtco%XDATA_VEGTYPE(jj,nvt_tebe)>0.) THEN
1425  zweight(nvt_tebe)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_tebe)
1426  END IF
1427  IF (dtco%XDATA_VEGTYPE(jj,nvt_tene)>0.) THEN
1428  zweight(nvt_tene)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_tene)
1429  END IF
1430  IF (dtco%XDATA_VEGTYPE(jj,nvt_bobd)>0.) THEN
1431  zweight(nvt_bobd)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_bobd)
1432  END IF
1433  IF (dtco%XDATA_VEGTYPE(jj,nvt_bond)>0.) THEN
1434  zweight(nvt_bond)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_bond)
1435  END IF
1436  IF (dtco%XDATA_VEGTYPE(jj,nvt_shrb)>0.) THEN
1437  zweight(nvt_shrb)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_shrb)
1438  END IF
1439 
1440  CASE default
1441  CALL abor1_sfx('AV_PATCH_PGD: WEIGHTING FUNCTION FOR VEGTYPE NOT ALLOWED')
1442  END SELECT
1443 !
1444 !-------------------------------------------------------------------------------
1445 !
1446 !* 3. Averaging
1447 ! ---------
1448 !
1449 !* 3.1 Work arrays given for each patch
1450 ! -----------
1451 !
1452  zcover_weight(:,:,:)=0.
1453  zcover_weight_patch(:,:,:)=0.
1454 
1455  DO jvegtype=1,nvegtype
1456  zcover_weight(:,:,jvegtype) = zcover_weight(:,:,jvegtype) +&
1457  pcover(:,:,jcover) * zweight(jvegtype)
1458 
1459  jpatch= vegtype_to_patch(jvegtype, ipatch)
1460 
1461  zcover_weight_patch(:,:,jpatch) = zcover_weight_patch(:,:,jpatch)+ &
1462  pcover(:,:,jcover) * zweight(jvegtype)
1463  END DO
1464 
1465 !
1466  zsum_cover_weight_patch(:,:,:) = zsum_cover_weight_patch(:,:,:) + zcover_weight_patch(:,:,:)
1467 
1468 
1469  zdata(:) = pdata(jj,:)
1470 
1471 !
1472 !* 3.2 Selection of averaging type
1473 ! ---------------------------
1474 !
1475  SELECT CASE (hatype)
1476 !
1477 !-------------------------------------------------------------------------------
1478 !
1479 !* 3.3 Arithmetic averaging
1480 ! --------------------
1481 !
1482  CASE ('ARI')
1483 !
1484  DO jvegtype=1,nvegtype
1485  jpatch= vegtype_to_patch(jvegtype,ipatch)
1486  zwork(:,:,jpatch) = zwork(:,:,jpatch) + zdata(jvegtype) * zcover_weight(:,:,jvegtype)
1487  END DO
1488 !
1489 !-------------------------------------------------------------------------------
1490 !
1491 !* 3.4 Inverse averaging
1492 ! -----------------
1493 !
1494  CASE('INV' )
1495 !
1496  DO jvegtype=1,nvegtype
1497  jpatch=vegtype_to_patch(jvegtype,ipatch)
1498  zwork(:,:,jpatch)= zwork(:,:,jpatch) + 1./ zdata(jvegtype)* zcover_weight(:,:,jvegtype)
1499  END DO
1500 !
1501 !-------------------------------------------------------------------------------!
1502 !
1503 !* 3.5 Roughness length averaging
1504 ! --------------------------
1505 
1506 !
1507  CASE('CDN')
1508 !
1509  DO jvegtype=1,nvegtype
1510  jpatch=vegtype_to_patch(jvegtype,ipatch)
1511  zwork(:,:,jpatch)= zwork(:,:,jpatch) + 1./(log(zdz(:,:,jpatch)/ zdata(jvegtype)))**2 &
1512  * zcover_weight(:,:,jvegtype)
1513  END DO
1514 !
1515 !-------------------------------------------------------------------------------
1516 !
1517  CASE default
1518  CALL abor1_sfx('AV_PATCH_PGD: (1) AVERAGING TYPE NOT ALLOWED')
1519 !
1520  END SELECT
1521 !
1522 END DO
1523 !-------------------------------------------------------------------------------
1524 !
1525 !* 4. End of Averaging
1526 ! ----------------
1527 !
1528 !* 4.1 Selection of averaging type
1529 ! ---------------------------
1530 !
1531 SELECT CASE (hatype)
1532 !
1533 !-------------------------------------------------------------------------------
1534 !
1535 !* 4.2 Arithmetic averaging
1536 ! --------------------
1537 !
1538  CASE ('ARI')
1539 !
1540  WHERE ( zsum_cover_weight_patch(:,:,:) >0. )
1541  pfield(:,:,:) = zwork(:,:,:) / zsum_cover_weight_patch(:,:,:)
1542  END WHERE
1543 !
1544 !-------------------------------------------------------------------------------
1545 !
1546 !* 4.3 Inverse averaging
1547 ! -----------------
1548 !
1549  CASE('INV' )
1550 !
1551  WHERE ( zsum_cover_weight_patch(:,:,:) >0. )
1552  pfield(:,:,:) = zsum_cover_weight_patch(:,:,:) / zwork(:,:,:)
1553  END WHERE
1554 !-------------------------------------------------------------------------------!
1555 !
1556 !* 4.4 Roughness length averaging
1557 ! --------------------------
1558 
1559 !
1560  CASE('CDN')
1561 !
1562  WHERE ( zsum_cover_weight_patch(:,:,:) >0. )
1563  pfield(:,:,:) = zdz(:,:,:) * exp( - sqrt(zsum_cover_weight_patch(:,:,:)/zwork(:,:,:)) )
1564  END WHERE
1565 !
1566 !-------------------------------------------------------------------------------
1567 !
1568  CASE default
1569  CALL abor1_sfx('AV_PATCH_PGD: (2) AVERAGING TYPE NOT ALLOWED')
1570 !
1571 END SELECT
1572 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD',1,zhook_handle)
1573 !-------------------------------------------------------------------------------
1574 !
1575 END SUBROUTINE av_patch_pgd
1576 !
1577 ! ################################################################
1578  SUBROUTINE major_patch_pgd_1d(TFIELD,PCOVER,TDATA,HSFTYPE,HATYPE,OCOVER,KDECADE)
1579 ! ################################################################
1580 !
1581 !!**** *MAJOR_PATCH_PGD* find the dominant date for each vegetation type
1582 !!
1583 !! PURPOSE
1584 !! -------
1585 !!
1586 !! METHOD
1587 !! ------
1588 !!
1589 !! EXTERNAL
1590 !! --------
1591 !!
1592 !! IMPLICIT ARGUMENTS
1593 !! ------------------
1594 !!
1595 !! REFERENCE
1596 !! ---------
1597 !!
1598 !! AUTHOR
1599 !! ------
1600 !!
1601 !! P. LE MOIGNE
1602 !!
1603 !! MODIFICATION
1604 !! ------------
1605 !!
1606 !! Original 06/2006
1607 !!
1608 !----------------------------------------------------------------------------
1609 !
1610 !* 0. DECLARATION
1611 ! -----------
1612 !
1613 USE modd_type_date_surf
1614 USE modd_surf_par, ONLY : xundef, nundef
1615 USE modd_data_cover_par, ONLY : nvegtype
1616 !
1617 USE modi_vegtype_to_patch
1618 !
1619 USE yomhook ,ONLY : lhook, dr_hook
1620 USE parkind1 ,ONLY : jprb
1621 !
1622 IMPLICIT NONE
1623 !
1624 !* 0.1 Declaration of arguments
1625 ! ------------------------
1626 !
1627 TYPE (date_time), DIMENSION(:,:), INTENT(OUT) :: tfield ! secondary field to construct
1628 REAL, DIMENSION(:,:), INTENT(IN) :: pcover ! fraction of each cover class
1629 TYPE (date_time), DIMENSION(:,:), INTENT(IN) :: tdata ! secondary field value for each class
1630  CHARACTER(LEN=3), INTENT(IN) :: hsftype ! Type of surface where the field
1631  ! is defined
1632  CHARACTER(LEN=3), INTENT(IN) :: hatype ! Type of averaging
1633 LOGICAL, DIMENSION(:), INTENT(IN) :: ocover
1634 INTEGER, INTENT(IN), OPTIONAL :: kdecade ! current month
1635 !
1636 !* 0.2 Declaration of local variables
1637 ! ------------------------------
1638 !
1639 INTEGER :: jj
1640 INTEGER :: icover ! number of cover classes
1641 INTEGER :: jcover ! loop on cover classes
1642 !
1643 INTEGER :: jvegtype! loop on vegtype
1644 !
1645 INTEGER, DIMENSION(SIZE(PCOVER,2),NVEGTYPE) :: idata_doy
1646 INTEGER, DIMENSION(SIZE(PCOVER,1)) :: idoy
1647 REAL, DIMENSION(365) :: zcount
1648 INTEGER :: jp, imonth, iday
1649 INTEGER :: ipatch, jpatch
1650 REAL(KIND=JPRB) :: zhook_handle
1651 !-------------------------------------------------------------------------------
1652 !
1653 !* 1.1 field does not exist
1654 ! --------------------
1655 !
1656 IF (lhook) CALL dr_hook('MODI_AV_PGD:MAJOR_PATCH_PGD_1D',0,zhook_handle)
1657 IF (SIZE(tfield)==0 .AND. lhook) CALL dr_hook('MODI_AV_PGD:MAJOR_PATCH_PGD_1D',1,zhook_handle)
1658 IF (SIZE(tfield)==0) RETURN
1659 !
1660 !-------------------------------------------------------------------------------
1661 !
1662 !* 1.2 Initializations
1663 ! ---------------
1664 !
1665 ipatch=SIZE(tfield,2)
1666 !
1667 tfield(:,:)%TDATE%YEAR = nundef
1668 tfield(:,:)%TDATE%MONTH = nundef
1669 tfield(:,:)%TDATE%DAY = nundef
1670 tfield(:,:)%TIME = xundef
1671 !
1672 idoy(:) = 0
1673 !
1674  CALL date2doy(tdata,idata_doy)
1675 !-------------------------------------------------------------------------------
1676 DO jp = 1,SIZE(pcover,1)
1677  !
1678  DO jpatch=1,ipatch
1679  !
1680  zcount(:) = 0.
1681  !
1682  DO jvegtype=1,nvegtype
1683  !
1684  IF(jpatch==vegtype_to_patch(jvegtype,ipatch)) THEN
1685  !
1686  DO jcover = 1,SIZE(pcover,2)
1687  !
1688  IF (idata_doy(jcover,jvegtype) /= nundef .AND. pcover(jp,jcover)/=0.) THEN
1689  !
1690  zcount(idata_doy(jcover,jvegtype)) = zcount(idata_doy(jcover,jvegtype)) + pcover(jp,jcover)
1691  !
1692  END IF
1693  !
1694  END DO
1695  !
1696  ENDIF
1697  !
1698  ENDDO
1699  !
1700  idoy(jp) = 0
1701  IF (any(zcount(:)/=0.)) idoy(jp) = maxloc(zcount,1)
1702  !
1703  CALL doy2date(idoy(jp),imonth,iday)
1704  !
1705  tfield(jp,jpatch)%TDATE%MONTH = imonth
1706  tfield(jp,jpatch)%TDATE%DAY = iday
1707  IF (imonth/=nundef) tfield(jp,jpatch)%TIME = 0.
1708  !
1709  END DO
1710  !
1711 END DO
1712 !
1713 !-------------------------------------------------------------------------------
1714 !
1715 IF (lhook) CALL dr_hook('MODI_AV_PGD:MAJOR_PATCH_PGD_1D',1,zhook_handle)
1716  CONTAINS
1717 
1718 SUBROUTINE date2doy(TPDATA, KDOY)
1719 TYPE (date_time), DIMENSION(:,:), INTENT(IN) :: tpdata
1720 INTEGER, DIMENSION(:,:), INTENT(OUT) :: kdoy
1721 INTEGER, DIMENSION(SIZE(OCOVER),NVEGTYPE) :: imonth, iday
1722 INTEGER, PARAMETER, DIMENSION(12) :: tab=(/1,32,60,91,121,152,182,213,244,274,305,335/)
1723 INTEGER :: jcover, jj
1724 REAL(KIND=JPRB) :: zhook_handle
1725 
1726 IF (lhook) CALL dr_hook('MODI_AV_PGD:DATE2DOY',0,zhook_handle)
1727 !
1728 imonth(:,:) = tpdata(:,:)%TDATE%MONTH
1729 iday(:,:) = tpdata(:,:)%TDATE%DAY
1730 !
1731 kdoy(:,:) = nundef
1732 !
1733 jcover = 0
1734 DO jj = 1, SIZE(ocover)
1735  IF (.NOT.ocover(jj)) cycle
1736  jcover = jcover + 1
1737  DO jvegtype = 1, nvegtype
1738  IF (imonth(jj,jvegtype)/=nundef .AND. iday(jj,jvegtype) /= nundef) THEN
1739  kdoy(jcover,jvegtype) = tab(imonth(jj,jvegtype)) + iday(jj,jvegtype) - 1
1740  ENDIF
1741  END DO
1742 END DO
1743 IF (lhook) CALL dr_hook('MODI_AV_PGD:DATE2DOY',1,zhook_handle)
1744 
1745 END SUBROUTINE date2doy
1746 
1747 SUBROUTINE doy2date(KDOY,KMONTH,KDAY)
1748 INTEGER, INTENT(IN) :: kdoy
1749 INTEGER, INTENT(OUT) :: kmonth, kday
1750 REAL :: zwork(12)
1751 INTEGER, PARAMETER, DIMENSION(12) :: ztab=(/31.,59.,90.,120.,151.,181.,212.,243.,273.,304.,334.,365./)
1752 INTEGER :: j
1753 REAL(KIND=JPRB) :: zhook_handle
1754 
1755 IF (lhook) CALL dr_hook('MODI_AV_PGD:DOY2DATE',0,zhook_handle)
1756 !
1757 kmonth = nundef
1758 kday = nundef
1759 !
1760 zwork(1) = REAL(KDOY) / ztab(1)
1761 IF ( int(zwork(1))==0 .AND. zwork(1)/=0.) THEN
1762  kmonth = 1
1763  kday = kdoy
1764 ENDIF
1765 !
1766 DO j = 2, 12
1767  zwork(j) = REAL(KDOY) / ztab(j)
1768  IF ( int(zwork(j))==0 .AND. int(zwork(j-1))==1 ) THEN
1769  kmonth = j
1770  kday = kdoy - int(ztab(j-1))
1771  ENDIF
1772 END DO
1773 IF (lhook) CALL dr_hook('MODI_AV_PGD:DOY2DATE',1,zhook_handle)
1774 
1775 END SUBROUTINE doy2date
1776 !-------------------------------------------------------------------------------
1777 !
1778 END SUBROUTINE major_patch_pgd_1d
av_pgd_2d
subroutine av_pgd_2d(DTCO, PFIELD, PCOVER, PDATA, HSFTYPE, HATYPE, OCOVER, PDZ, KDECADE)
Definition: av_pgd.F90:855
major_patch_pgd_1d
subroutine major_patch_pgd_1d(TFIELD, PCOVER, TDATA, HSFTYPE, HATYPE, OCOVER, KDECADE)
Definition: av_pgd.F90:1578
av_pgd_1d
subroutine av_pgd_1d(DTCO, PFIELD, PCOVER, PDATA, HSFTYPE, HATYPE, OCOVER, PDZ, KDECADE)
Definition: av_pgd.F90:108
date2doy
subroutine date2doy(TPDATA, KDOY)
Definition: av_pgd.F90:1718
modd_data_cover_n
Definition: modd_data_covern.F90:6
modd_data_cover_par
Definition: modd_data_cover_par.F90:6
modi_av_pgd::av_pgd
Definition: av_pgd.F90:8
vegtype_to_patch
integer function vegtype_to_patch(IVEGTYPE, INPATCH)
Definition: vegtype_to_patch.F90:6
abor1_sfx
subroutine abor1_sfx(YTEXT)
Definition: abor1_sfx.F90:6
modi_av_pgd
Definition: av_pgd.F90:6
doy2date
subroutine doy2date(KDOY, KMONTH, KDAY)
Definition: av_pgd.F90:1747
av_patch_pgd_1d
subroutine av_patch_pgd_1d(DTCO, PFIELD, PCOVER, PDATA, HSFTYPE, HATYPE, OCOVER, PDZ, KDECADE)
Definition: av_pgd.F90:445
modd_data_cover
Definition: modd_data_cover.F90:6
modd_type_date_surf::date_time
Definition: modd_type_date_surf.F90:46
av_patch_pgd
subroutine av_patch_pgd(DTCO, PFIELD, PCOVER, PDATA, HSFTYPE, HATYPE, OCOVER, PDZ, KDECADE)
Definition: av_pgd.F90:1162
modd_data_cover_n::data_cover_t
Definition: modd_data_covern.F90:43
modd_surf_par
Definition: modd_surf_par.F90:6
modd_type_date_surf
Definition: modd_type_date_surf.F90:6
Generated on Fri May 13 2016 09:31:00 for SURFEX by   doxygen 1.8.5