SURFEX v8.1
General documentation of Surfex
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  SUBROUTINE av_pgd_1d (DTCO, &
108  PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,OCOVER,PDZ,KDECADE)
109 ! ################################################################
110 !
111 !!**** *AV_PGD* average a secondary physiographic variable from the
112 !! fractions of coverage class.
113 !!
114 !! PURPOSE
115 !! -------
116 !!
117 !! METHOD
118 !! ------
119 !!
120 !! The averaging is performed with one way into three:
121 !!
122 !! - arithmetic averaging (HATYPE='ARI')
123 !!
124 !! - inverse averaging (HATYPE='INV')
125 !!
126 !! - inverse of square logarithm averaging (HATYPE='CDN') :
127 !!
128 !! 1 / ( ln (dz/data) )**2
129 !!
130 !! This latest uses (if available) the height of the first model mass
131 !! level. In the other case, 20m is chosen. It works for roughness lengths.
132 !!
133 !! EXTERNAL
134 !! --------
135 !!
136 !! IMPLICIT ARGUMENTS
137 !! ------------------
138 !!
139 !! REFERENCE
140 !! ---------
141 !!
142 !! AUTHOR
143 !! ------
144 !!
145 !! V. Masson Meteo-France
146 !!
147 !! MODIFICATION
148 !! ------------
149 !
150 ! F.Solmon patch modif: remove the case 'veg' as veg is defined for patches
151 !
152 !! Original 15/12/97
153 !! V. Masson 01/2004 Externalization
154 !! R. Alkama 05/2012 Add 6 tree vegtypes (9 rather than 3)
155 !!
156 !----------------------------------------------------------------------------
157 !
158 !* 0. DECLARATION
159 ! -----------
160 !
161 !
162 USE modd_data_cover_n, ONLY : data_cover_t
163 !
164 USE modd_surfex_omp, ONLY : nblocktot
165 USE modd_surfex_mpi, ONLY : nrank
166 USE modd_surf_par, ONLY : xundef
167 USE modd_data_cover, ONLY : xdata_bld_height
168 USE modd_data_cover_par, ONLY : nvt_tebd, nvt_bone, nvt_trbe, xcdref, nvt_trbd, &
169  nvt_tebe, nvt_tene, nvt_bobd, nvt_bond, nvt_shrb
170 !
171 !
172 USE mode_av_pgd
173 !
174 USE yomhook ,ONLY : lhook, dr_hook
175 USE parkind1 ,ONLY : jprb
176 !
177 USE modi_abor1_sfx
178 !
179 IMPLICIT NONE
180 !
181 !* 0.1 Declaration of arguments
182 ! ------------------------
183 !
184 !
185 TYPE(data_cover_t), INTENT(INOUT) :: DTCO
186 !
187 REAL, DIMENSION(:), INTENT(OUT) :: PFIELD ! secondary field to construct
188 REAL, DIMENSION(:,:), INTENT(IN) :: PCOVER ! fraction of each cover class
189 REAL, DIMENSION(:), INTENT(IN) :: PDATA ! secondary field value for each class
190  CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field
191  ! is defined
192  CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging
193 LOGICAL, DIMENSION(:), INTENT(IN) :: OCOVER
194 REAL, DIMENSION(:), INTENT(IN), OPTIONAL :: PDZ ! first model half level
195 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month
196 !
197 !* 0.2 Declaration of local variables
198 ! ------------------------------
199 !
200 INTEGER :: JJ, JI, ID0
201 INTEGER :: ICOVER ! number of cover classes
202 INTEGER :: JCOVER ! loop on cover classes
203 !
204 INTEGER :: ISIZE_OMP
205 INTEGER, DIMENSION(SIZE(PCOVER,2)) :: IMASK
206 REAL, DIMENSION(SIZE(PCOVER,1)) :: ZWORK, ZDZ, ZVAL
207 REAL, DIMENSION(SIZE(PCOVER,2)) :: ZWEIGHT
208 REAL :: ZCOVER_WEIGHT
209 REAL, DIMENSION(SIZE(PCOVER,1)) :: ZSUM_COVER_WEIGHT
210 REAL(KIND=JPRB) :: ZHOOK_HANDLE, ZHOOK_HANDLE_OMP
211 !-------------------------------------------------------------------------------
212 !
213 !* 1.1 field does not exist
214 ! --------------------
215 !
216 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_1D_1',0,zhook_handle)
217 IF (SIZE(pfield)==0 .AND. lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_1D_1',1,zhook_handle)
218 IF (SIZE(pfield)==0) RETURN
219 !
220 !-------------------------------------------------------------------------------
221 !
222 !* 1.2 Initializations
223 ! ---------------
224 !
225 icover=SIZE(pcover,2)
226 !
227 IF (PRESENT(pdz)) THEN
228  zdz(:)=pdz(:)
229 ELSE
230  zdz(:)=xcdref
231 END IF
232 !
233 pfield(:)=xundef
234 IF (hsftype=='TRE' .OR. hsftype=='GRT') pfield(:) = 0.
235 !
236 zwork(:)=0.
237 zsum_cover_weight(:)=0.
238 !
239 jcover = 0
240 DO jj = 1,SIZE(ocover)
241  IF (ocover(jj)) THEN
242  jcover=jcover+1
243  imask(jcover) = jj
244  ENDIF
245 ENDDO
246 !
247  CALL get_weight(dtco,icover,imask,hsftype,zweight)
248 !
249 !-------------------------------------------------------------------------------
250 !
251 !* 3. Averaging
252 ! ---------
253 !
254 !* 3.1 Work arrays
255 ! -----------
256 !
257  CALL dr_hook('MODI_AV_PGD:AV_PGD_1D_1',1,zhook_handle)
258 !
259 IF (hatype=='ARI' .OR. hatype=='INV' .OR. hatype=='CDN') THEN
260  !
261  isize_omp = max(1,icover/nblocktot)
262 !!$OMP PARALLEL PRIVATE(ZHOOK_HANDLE_OMP)
263  CALL dr_hook('MODI_AV_PGD:AV_PGD_1D_2',0,zhook_handle_omp)
264 !!$OMP DO SCHEDULE(STATIC,ISIZE_OMP) PRIVATE(JCOVER,JJ,ZVAL,JI,ZCOVER_WEIGHT) &
265 !!$OMP & REDUCTION(+:ZSUM_COVER_WEIGHT,ZWORK)
266  DO jcover=1,icover
267  IF (zweight(jcover)/=0.) THEN
268  !
269  jj = imask(jcover)
270  !
271  IF (hatype=='ARI') THEN
272  zval(:) = pdata(jj)
273  ELSEIF (hatype=='INV') THEN
274  zval(:) = 1./pdata(jj)
275  ELSEIF (hatype=='CDN') THEN
276  zval(:) = 1./(log(zdz(:)/pdata(jj)))**2
277  ENDIF
278  !
279  DO ji = 1,SIZE(pcover,1)
280  IF (pcover(ji,jcover)/=0.) THEN
281  zcover_weight = pcover(ji,jcover) * zweight(jcover)
282  zsum_cover_weight(ji) = zsum_cover_weight(ji) + zcover_weight
283  zwork(ji) = zwork(ji) + zval(ji) * zcover_weight
284  ENDIF
285  ENDDO
286  !
287  ENDIF
288  ENDDO
289 !!$OMP END DO
290  CALL dr_hook('MODI_AV_PGD:AV_PGD_1D_2',1,zhook_handle_omp)
291 !!$OMP END PARALLEL
292 ELSEIF (hatype=='MAJ') THEN
293  !
294 !!$OMP PARALLEL PRIVATE(ZHOOK_HANDLE_OMP)
295 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_1D_3',0,zhook_handle_omp)
296 !!$OMP DO SCHEDULE(DYNAMIC,1) PRIVATE(JI,ID0)
297  DO ji = 1,SIZE(pcover,1)
298  id0 = maxval(maxloc(pcover(ji,:)*zweight(:)))
299  zwork(ji) = pdata(imask(id0))
300  zsum_cover_weight(ji) = zsum_cover_weight(ji) + sum(pcover(ji,:)*zweight(:))
301  ENDDO
302 !!$OMP END DO
303 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_1D_3',1,zhook_handle_omp)
304 !!$OMP END PARALLEL
305  !
306 ELSE
307  CALL abor1_sfx('AV_PGD_1D: (1) AVERAGING TYPE NOT ALLOWED : "'//hatype//'"')
308 ENDIF
309 !
310 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_1D_4',0,zhook_handle)
311 !-------------------------------------------------------------------------------
312 !
313 !* 4. End of Averaging
314 ! ----------------
315 !
316 !* 4.1 Selection of averaging type
317 ! ---------------------------
318 !
319  SELECT CASE (hatype)
320 !
321 !-------------------------------------------------------------------------------
322 !
323 !* 4.2 Arithmetic averaging
324 ! --------------------
325 !
326  CASE ('ARI')
327 !
328  WHERE ( zsum_cover_weight(:) >0. )
329  pfield(:) = zwork(:) / zsum_cover_weight(:)
330  END WHERE
331 !
332 !-------------------------------------------------------------------------------
333 !
334 !* 4.3 Inverse averaging
335 ! -----------------
336 !
337  CASE('INV' )
338 !
339  WHERE ( zsum_cover_weight(:) >0. )
340  pfield(:) = zsum_cover_weight(:) / zwork(:)
341  END WHERE
342 !
343 !-------------------------------------------------------------------------------!
344 !
345 !* 4.4 Roughness length averaging
346 ! --------------------------
347 
348 !
349  CASE('CDN')
350 !
351  WHERE ( zsum_cover_weight(:) >0. )
352  pfield(:) = zdz(:) * exp( - sqrt(zsum_cover_weight(:)/zwork(:)) )
353  END WHERE
354 !
355 !-------------------------------------------------------------------------------
356 !
357 !* 4.4 Majoritary averaging
358 ! --------------------
359 !
360  CASE('MAJ' )
361 !
362  WHERE ( zsum_cover_weight(:) >0. )
363  pfield(:) = zwork(:)
364  END WHERE
365 !
366 !-------------------------------------------------------------------------------
367 !
368  CASE DEFAULT
369  CALL abor1_sfx('AV_PGD_1D: (2) AVERAGING TYPE NOT ALLOWED')
370 !
371 END SELECT
372 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_1D_4',1,zhook_handle)
373 !
374 !
375 !-------------------------------------------------------------------------------
376 !
377 END SUBROUTINE av_pgd_1d
378 !
379 ! ################################################################
380  SUBROUTINE av_patch_pgd_1d (DTCO, &
381  PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,OCOVER,PDZ,KDECADE)
382 ! ################################################################
383 !
384 !!**** *AV_PATCH_PGD* average for each surface patch a secondary physiographic
385 !! variable from the
386 !! fractions of coverage class.
387 !!
388 !! PURPOSE
389 !! -------
390 !!
391 !! METHOD
392 !! ------
393 !!
394 !! The averaging is performed with one way into three:
395 !!
396 !! - arithmetic averaging (HATYPE='ARI')
397 !!
398 !! - inverse averaging (HATYPE='INV')
399 !!
400 !! - inverse of square logarithm averaging (HATYPE='CDN') :
401 !!
402 !! 1 / ( ln (dz/data) )**2
403 !!
404 !! This latest uses (if available) the height of the first model mass
405 !! level. In the other case, 20m is chosen. It works for roughness lengths.
406 !!
407 !! EXTERNAL
408 !! --------
409 !!
410 !! IMPLICIT ARGUMENTS
411 !! ------------------
412 !!
413 !! REFERENCE
414 !! ---------
415 !!
416 !! AUTHOR
417 !! ------
418 !!
419 !! F.Solmon /V. Masson
420 !!
421 !! MODIFICATION
422 !! ------------
423 
424 !!
425 !! Original 15/12/97
426 !! V. Masson 01/2004 Externalization
427 !! R. Alkama 05/2012 Add 6 tree vegtypes (9 rather than 3)
428 !!
429 !----------------------------------------------------------------------------
430 !
431 !* 0. DECLARATION
432 ! -----------
433 !
434 !
435 USE modd_data_cover_n, ONLY : data_cover_t
436 !
437 USE modd_surf_par, ONLY : xundef
438 USE modd_data_cover, ONLY : xdata_veg, xdata_lai
439 USE modd_data_cover_par, ONLY : nvt_tebd, nvt_bone, nvt_trbe, nvegtype, xcdref, nvt_trbd, &
440  nvt_tebe, nvt_tene, nvt_bobd, nvt_bond, nvt_shrb
441 !
442 USE modi_vegtype_to_patch
443 USE mode_av_pgd
444 !
445 !
446 USE yomhook ,ONLY : lhook, dr_hook
447 USE parkind1 ,ONLY : jprb
448 !
449 USE modi_abor1_sfx
450 !
451 IMPLICIT NONE
452 !
453 !* 0.1 Declaration of arguments
454 ! ------------------------
455 !
456 !
457 TYPE(data_cover_t), INTENT(INOUT) :: DTCO
458 !
459 REAL, DIMENSION(:,:), INTENT(OUT) :: PFIELD ! secondary field to construct
460 REAL, DIMENSION(:,:), INTENT(IN) :: PCOVER ! fraction of each cover class
461 REAL, DIMENSION(:,:), INTENT(IN) :: PDATA ! secondary field value for each class
462  CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field
463  ! is defined
464  CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging
465 LOGICAL, DIMENSION(:), INTENT(IN) :: OCOVER
466 REAL, DIMENSION(:), INTENT(IN), OPTIONAL :: PDZ ! first model half level
467 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month
468 !
469 !* 0.2 Declaration of local variables
470 ! ------------------------------
471 !
472 INTEGER :: ICOVER ! number of cover classes
473 INTEGER :: JCOVER ! loop on cover classes
474 !
475 ! nbe of vegtype
476 ! nbre of patches
477 INTEGER :: JVEGTYPE! loop on vegtype
478 INTEGER :: IPATCH ! number of patches
479 INTEGER :: JPATCH ! PATCH index
480 INTEGER :: JJ, JI, JK
481 !
482 REAL :: ZCOVER_WEIGHT
483 !
484 INTEGER, DIMENSION(SIZE(PCOVER,2)) :: IMASK0
485 REAL, DIMENSION(SIZE(PCOVER,1)) :: ZVAL
486 !
487 REAL, DIMENSION(SIZE(PCOVER,2),NVEGTYPE) :: ZWEIGHT
488 !
489 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PFIELD,2)) :: ZSUM_COVER_WEIGHT_PATCH
490 !
491 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PFIELD,2)) :: ZWORK
492 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PFIELD,2)) :: ZDZ
493 !
494 INTEGER, DIMENSION(SIZE(PCOVER,1),SIZE(PFIELD,2)) :: IMASK
495 INTEGER, DIMENSION(SIZE(PFIELD,2)) :: JCOUNT
496 INTEGER :: PATCH_LIST(nvegtype)
497 REAL(KIND=JPRB) :: ZHOOK_HANDLE, ZHOOK_HANDLE_OMP
498 
499 !-------------------------------------------------------------------------------
500 !
501 !* 1.1 field does not exist
502 ! --------------------
503 !
504 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_1',0,zhook_handle)
505 IF (SIZE(pfield)==0 .AND. lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_1',1,zhook_handle)
506 IF (SIZE(pfield)==0) RETURN
507 !
508 !-------------------------------------------------------------------------------
509 !
510 !* 1.2 Initializations
511 ! ---------------
512 !
513 icover=SIZE(pcover,2)
514 ipatch=SIZE(pfield,2)
515 !
516 IF (PRESENT(pdz)) THEN
517  DO jpatch=1,ipatch
518  zdz(:,jpatch)=pdz(:)
519  END DO
520 ELSE
521  zdz(:,:)=xcdref
522 END IF
523 !
524 pfield(:,:)=xundef
525 !
526 zwork(:,:) = 0.
527 zweight(:,:) = 0.0
528 zsum_cover_weight_patch(:,:) = 0.
529 !
530 DO jvegtype=1,nvegtype
531  patch_list(jvegtype) = vegtype_to_patch(jvegtype, ipatch)
532 ENDDO
533 !
534 jcover = 0
535 DO jj = 1,SIZE(ocover)
536  IF (ocover(jj)) THEN
537  jcover=jcover+1
538  imask0(jcover) = jj
539  ENDIF
540 ENDDO
541 !
542 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_1',1,zhook_handle)
543 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_2',0,zhook_handle)
544 !
545  CALL get_weight_patch(dtco,icover,imask0,kdecade,hsftype,zweight)
546  !
547 !
548 !-------------------------------------------------------------------------------
549  !
550  !
551  !* 2. Selection of the weighting function for vegtype
552  ! -----------------------------------
553  !
554 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_2',1,zhook_handle)
555 !
556 !!$OMP PARALLEL PRIVATE(ZHOOK_HANDLE_OMP) REDUCTION(+:ZSUM_COVER_WEIGHT_PATCH,ZWORK)
557 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_3',0,zhook_handle_omp)
558 !!$OMP DO SCHEDULE(DYNAMIC,1) PRIVATE(JCOVER,JJ,JVEGTYPE,JPATCH, &
559 !!$OMP ZVAL,JI,ZCOVER_WEIGHT)
560 DO jcover=1,icover
561  !
562  jj = imask0(jcover)
563  !
564  DO jvegtype=1,nvegtype
565  !
566  jpatch= patch_list(jvegtype)
567  !
568  IF (zweight(jcover,jvegtype)/=0.) THEN
569  !
570  IF (hatype=='ARI') THEN
571  zval(:) = pdata(jj,jvegtype)
572  ELSEIF (hatype=='INV') THEN
573  zval(:) = 1. / pdata(jj,jvegtype)
574  ELSEIF (hatype=='CDN') THEN
575  DO ji=1,SIZE(pcover,1)
576  zval(ji) = 1./(log(zdz(ji,jpatch)/pdata(jj,jvegtype)))**2
577  ENDDO
578  ELSE
579  CALL abor1_sfx('AV_PATCH_PGD_1D: (1) AVERAGING TYPE NOT ALLOWED')
580  ENDIF
581  !
582  DO ji=1,SIZE(pcover,1)
583  IF (pcover(ji,jcover)/=0.) THEN
584  zcover_weight = pcover(ji,jcover) * zweight(jcover,jvegtype)
585  zsum_cover_weight_patch(ji,jpatch) = zsum_cover_weight_patch(ji,jpatch) + zcover_weight
586  zwork(ji,jpatch) = zwork(ji,jpatch) + zval(ji) * zcover_weight
587  ENDIF
588  ENDDO
589  !
590  ENDIF
591  !
592  ENDDO
593  !
594 ENDDO
595 !!$OMP END DO
596 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_3',1,zhook_handle_omp)
597 !!$OMP END PARALLEL
598 !
599 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_4',0,zhook_handle)
600 !-------------------------------------------------------------------------------
601 !
602 !* 4. End of Averaging
603 ! ----------------
604 !
605 imask(:,:)=0
606 jcount(:)=0
607 DO jpatch=1,ipatch
608  DO ji=1,SIZE(pcover,1)
609  IF ( zsum_cover_weight_patch(ji,jpatch) >0.) THEN
610  jcount(jpatch)=jcount(jpatch)+1
611  imask(jcount(jpatch),jpatch)=ji
612  ENDIF
613  ENDDO
614 ENDDO
615 !
616 !-------------------------------------------------------------------------------
617 
618 !
619 !* 4.1 Selection of averaging type
620 ! ---------------------------
621 !
622  SELECT CASE (hatype)
623 !
624 !-------------------------------------------------------------------------------
625 !
626 !* 4.2 Arithmetic averaging
627 ! --------------------
628 !
629  CASE ('ARI')
630 !
631  DO jpatch=1,ipatch
632 !cdir nodep
633  DO jj=1,jcount(jpatch)
634  ji = imask(jj,jpatch)
635  pfield(ji,jpatch) = zwork(ji,jpatch) / zsum_cover_weight_patch(ji,jpatch)
636  ENDDO
637  ENDDO
638 !
639 !-------------------------------------------------------------------------------
640 !
641 !* 4.3 Inverse averaging
642 ! -----------------
643 !
644  CASE('INV' )
645 !
646  DO jpatch=1,ipatch
647 !cdir nodep
648  DO jj=1,jcount(jpatch)
649  ji = imask(jj,jpatch)
650  pfield(ji,jpatch) = zsum_cover_weight_patch(ji,jpatch) / zwork(ji,jpatch)
651  ENDDO
652  ENDDO
653 !-------------------------------------------------------------------------------!
654 !
655 !* 4.4 Roughness length averaging
656 ! --------------------------
657 
658 !
659  CASE('CDN')
660 !
661  DO jpatch=1,ipatch
662 !cdir nodep
663  DO jj=1,jcount(jpatch)
664  ji = imask(jj,jpatch)
665  pfield(ji,jpatch) = zdz(ji,jpatch) * exp( - sqrt(zsum_cover_weight_patch(ji,jpatch)/zwork(ji,jpatch)) )
666  ENDDO
667  ENDDO
668 !
669 !-------------------------------------------------------------------------------
670 !
671  CASE DEFAULT
672  CALL abor1_sfx('AV_PATCH_PGD_1D: (2) AVERAGING TYPE NOT ALLOWED')
673 !
674 END SELECT
675 !
676 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD_1D_4',1,zhook_handle)
677 !
678 !IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PATCH_PGD_1D',1,ZHOOK_HANDLE)
679 !-------------------------------------------------------------------------------
680 !
681 END SUBROUTINE av_patch_pgd_1d
682 !
683 ! ################################################################
684  SUBROUTINE av_pgd_2d (DTCO, &
685  PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,OCOVER,PDZ,KDECADE)
686 ! ################################################################
687 !
688 !!**** *AV_PGD* average a secondary physiographic variable from the
689 !! fractions of coverage class.
690 !!
691 !! PURPOSE
692 !! -------
693 !!
694 !! METHOD
695 !! ------
696 !!
697 !! The averaging is performed with one way into three:
698 !!
699 !! - arithmetic averaging (HATYPE='ARI')
700 !!
701 !! - inverse averaging (HATYPE='INV')
702 !!
703 !! - inverse of square logarithm averaging (HATYPE='CDN') :
704 !!
705 !! 1 / ( ln (dz/data) )**2
706 !!
707 !! This latest uses (if available) the height of the first model mass
708 !! level. In the other case, 20m is chosen. It works for roughness lengths.
709 !!
710 !! EXTERNAL
711 !! --------
712 !!
713 !! IMPLICIT ARGUMENTS
714 !! ------------------
715 !!
716 !! REFERENCE
717 !! ---------
718 !!
719 !! AUTHOR
720 !! ------
721 !!
722 !! V. Masson Meteo-France
723 !!
724 !! MODIFICATION
725 !! ------------
726 !
727 ! F.Solmon patch modif: remove the case 'veg' as veg is defined for patches
728 !
729 !! Original 15/12/97
730 !! V. Masson 01/2004 Externalization
731 !! R. Alkama 05/2012 Add 6 tree vegtypes (9 rather than 3)
732 !!
733 !----------------------------------------------------------------------------
734 !
735 !* 0. DECLARATION
736 ! -----------
737 !
738 !
739 USE modd_data_cover_n, ONLY : data_cover_t
740 !
741 USE modd_surf_par, ONLY : xundef
742 USE modd_data_cover_par, ONLY : nvt_tebd, nvt_bone, nvt_trbe, xcdref, nvt_trbd, &
743  nvt_tebe, nvt_tene, nvt_bobd, nvt_bond, nvt_shrb
744 !
745 !
746 USE yomhook ,ONLY : lhook, dr_hook
747 USE parkind1 ,ONLY : jprb
748 !
749 USE modi_abor1_sfx
750 !
751 IMPLICIT NONE
752 !
753 !* 0.1 Declaration of arguments
754 ! ------------------------
755 !
756 !
757 TYPE(data_cover_t), INTENT(INOUT) :: DTCO
758 !
759 REAL, DIMENSION(:,:), INTENT(OUT) :: PFIELD ! secondary field to construct
760 REAL, DIMENSION(:,:,:), INTENT(IN) :: PCOVER ! fraction of each cover class
761 REAL, DIMENSION(:), INTENT(IN) :: PDATA ! secondary field value for each class
762  CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field
763  ! is defined
764  CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging
765  LOGICAL, DIMENSION(:), INTENT(IN) :: OCOVER
766 REAL, DIMENSION(:,:), INTENT(IN), OPTIONAL :: PDZ ! first model half level
767 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month
768 !
769 !* 0.2 Declaration of local variables
770 ! ------------------------------
771 !
772 INTEGER :: JJ
773 INTEGER :: ICOVER ! number of cover classes
774 INTEGER :: JCOVER ! loop on cover classes
775 !
776 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2)) :: ZWORK, ZDZ
777 REAL :: ZWEIGHT
778 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2)) :: ZCOVER_WEIGHT
779 REAL :: ZDATA
780 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2)) :: ZSUM_COVER_WEIGHT
781 REAL(KIND=JPRB) :: ZHOOK_HANDLE
782 !-------------------------------------------------------------------------------
783 !
784 !* 1.1 field does not exist
785 ! --------------------
786 !
787 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_2D',0,zhook_handle)
788 IF (SIZE(pfield)==0 .AND. lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_2D',1,zhook_handle)
789 IF (SIZE(pfield)==0) RETURN
790 !
791 !-------------------------------------------------------------------------------
792 !
793 !* 1.2 Initializations
794 ! ---------------
795 !
796 icover=SIZE(ocover)
797 !
798 IF (PRESENT(pdz)) THEN
799  zdz(:,:)=pdz(:,:)
800 ELSE
801  zdz(:,:)=xcdref
802 END IF
803 !
804 pfield(:,:)=xundef
805 !
806 zwork(:,:)=0.
807 zsum_cover_weight(:,:)=0.
808 !-------------------------------------------------------------------------------
809 jcover = 0
810 DO jj=1,icover
811  !
812  IF (.NOT.ocover(jj)) cycle
813  !
814  jcover = jcover + 1
815  !
816 !-------------------------------------------------------------------------------
817 !
818 !* 2. Selection of the weighting function
819 ! -----------------------------------
820 !
821  SELECT CASE (hsftype)
822  CASE('ALL')
823  zweight=1.
824 
825  CASE('NAT')
826  zweight=dtco%XDATA_NATURE(jj)
827 
828  CASE('GRD')
829  zweight=dtco%XDATA_TOWN (jj) * dtco%XDATA_GARDEN(jj)
830 
831  CASE('TWN')
832  zweight=dtco%XDATA_TOWN (jj)
833 
834  CASE('WAT')
835  zweight=dtco%XDATA_WATER (jj)
836 
837  CASE('SEA')
838  zweight=dtco%XDATA_SEA (jj)
839 
840  CASE('BLD')
841  zweight=dtco%XDATA_TOWN (jj) * dtco%XDATA_BLD(jj)
842 
843  CASE('STR')
844  zweight=dtco%XDATA_TOWN (jj) * ( 1. - dtco%XDATA_BLD(jj) )
845 
846  CASE('TRE')
847  pfield(:,:)=0.
848  zweight=dtco%XDATA_NATURE(jj) * ( dtco%XDATA_VEGTYPE(jj,nvt_tebd) &
849  + dtco%XDATA_VEGTYPE(jj,nvt_trbe) &
850  + dtco%XDATA_VEGTYPE(jj,nvt_trbd) &
851  + dtco%XDATA_VEGTYPE(jj,nvt_tebe) &
852  + dtco%XDATA_VEGTYPE(jj,nvt_tene) &
853  + dtco%XDATA_VEGTYPE(jj,nvt_bobd) &
854  + dtco%XDATA_VEGTYPE(jj,nvt_bond) &
855  + dtco%XDATA_VEGTYPE(jj,nvt_shrb) &
856  + dtco%XDATA_VEGTYPE(jj,nvt_bone) )
857 
858  CASE('GRT')
859  pfield(:,:)=0.
860  zweight=dtco%XDATA_TOWN (jj) * dtco%XDATA_GARDEN(jj) &
861  * ( dtco%XDATA_VEGTYPE(jj,nvt_tebd) &
862  + dtco%XDATA_VEGTYPE(jj,nvt_trbe) &
863  + dtco%XDATA_VEGTYPE(jj,nvt_trbd) &
864  + dtco%XDATA_VEGTYPE(jj,nvt_tebe) &
865  + dtco%XDATA_VEGTYPE(jj,nvt_tene) &
866  + dtco%XDATA_VEGTYPE(jj,nvt_bobd) &
867  + dtco%XDATA_VEGTYPE(jj,nvt_bond) &
868  + dtco%XDATA_VEGTYPE(jj,nvt_shrb) &
869  + dtco%XDATA_VEGTYPE(jj,nvt_bone) )
870 
871  CASE DEFAULT
872  CALL abor1_sfx('AV_PGD: WEIGHTING FUNCTION NOT ALLOWED')
873  END SELECT
874 !
875 !-------------------------------------------------------------------------------
876 !
877 !* 3. Averaging
878 ! ---------
879 !
880 !* 3.1 Work arrays
881 ! -----------
882 !
883  zcover_weight(:,:) = pcover(:,:,jcover) * zweight
884 !
885  zsum_cover_weight(:,:) = zsum_cover_weight(:,:) + zcover_weight(:,:)
886 !
887  zdata = pdata(jj)
888 !
889 !* 3.2 Selection of averaging type
890 ! ---------------------------
891 !
892  SELECT CASE (hatype)
893 !
894 !-------------------------------------------------------------------------------
895 !
896 !* 3.4 Arithmetic averaging
897 ! --------------------
898 !
899  CASE ('ARI')
900 !
901  zwork(:,:) = zwork(:,:) + zdata * zcover_weight(:,:)
902 !
903 !-------------------------------------------------------------------------------
904 !
905 !* 3.5 Inverse averaging
906 ! -----------------
907 !
908  CASE('INV' )
909 !
910  zwork(:,:)= zwork(:,:) + 1./zdata * zcover_weight(:,:)
911 !
912 !-------------------------------------------------------------------------------!
913 !
914 !* 3.6 Roughness length averaging
915 ! --------------------------
916 
917 !
918  CASE('CDN')
919 !
920  zwork(:,:)= zwork(:,:) + 1./(log(zdz(:,:)/zdata))**2 * zcover_weight(:,:)
921 !
922 !-------------------------------------------------------------------------------
923 !
924  CASE DEFAULT
925  CALL abor1_sfx('AV_PGD: (1) AVERAGING TYPE NOT ALLOWED')
926 !
927  END SELECT
928 !
929 END DO
930 !
931 !-------------------------------------------------------------------------------
932 !
933 !* 4. End of Averaging
934 ! ----------------
935 !
936 !* 4.1 Selection of averaging type
937 ! ---------------------------
938 !
939  SELECT CASE (hatype)
940 !
941 !-------------------------------------------------------------------------------
942 !
943 !* 4.2 Arithmetic averaging
944 ! --------------------
945 !
946  CASE ('ARI')
947 !
948  WHERE ( zsum_cover_weight(:,:) >0. )
949  pfield(:,:) = zwork(:,:) / zsum_cover_weight(:,:)
950  END WHERE
951 !
952 !-------------------------------------------------------------------------------
953 !
954 !* 4.3 Inverse averaging
955 ! -----------------
956 !
957  CASE('INV' )
958 !
959  WHERE ( zsum_cover_weight(:,:) >0. )
960  pfield(:,:) = zsum_cover_weight(:,:) / zwork(:,:)
961  END WHERE
962 !
963 !-------------------------------------------------------------------------------!
964 !
965 !* 4.4 Roughness length averaging
966 ! --------------------------
967 
968 !
969  CASE('CDN')
970 !
971  WHERE ( zsum_cover_weight(:,:) >0. )
972  pfield(:,:) = zdz(:,:) * exp( - sqrt(zsum_cover_weight(:,:)/zwork(:,:)) )
973  END WHERE
974 !
975 !-------------------------------------------------------------------------------
976 !
977  CASE DEFAULT
978  CALL abor1_sfx('AV_PGD_2D: (2) AVERAGING TYPE NOT ALLOWED')
979 !
980 END SELECT
981 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PGD_2D',1,zhook_handle)
982 !
983 !
984 !-------------------------------------------------------------------------------
985 !
986 END SUBROUTINE av_pgd_2d
987 !
988 !
989 !
990 ! ################################################################
991  SUBROUTINE av_patch_pgd (DTCO, &
992  PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,OCOVER,PDZ,KDECADE)
993 ! ################################################################
994 !
995 !!**** *AV_PATCH_PGD* average for each surface patch a secondary physiographic
996 !! variable from the
997 !! fractions of coverage class.
998 !!
999 !! PURPOSE
1000 !! -------
1001 !!
1002 !! METHOD
1003 !! ------
1004 !!
1005 !! The averaging is performed with one way into three:
1006 !!
1007 !! - arithmetic averaging (HATYPE='ARI')
1008 !!
1009 !! - inverse averaging (HATYPE='INV')
1010 !!
1011 !! - inverse of square logarithm averaging (HATYPE='CDN') :
1012 !!
1013 !! 1 / ( ln (dz/data) )**2
1014 !!
1015 !! This latest uses (if available) the height of the first model mass
1016 !! level. In the other case, 20m is chosen. It works for roughness lengths.
1017 !!
1018 !! EXTERNAL
1019 !! --------
1020 !!
1021 !! IMPLICIT ARGUMENTS
1022 !! ------------------
1023 !!
1024 !! REFERENCE
1025 !! ---------
1026 !!
1027 !! AUTHOR
1028 !! ------
1029 !!
1030 !! F.Solmon /V. Masson
1031 !!
1032 !! MODIFICATION
1033 !! ------------
1034 !!
1035 !! Original 15/12/97
1036 !! V. Masson 01/2004 Externalization
1037 !! R. Alkama 05/2012 Add 6 tree vegtypes (9 rather than 3)
1038 !!
1039 !----------------------------------------------------------------------------
1040 !
1041 !* 0. DECLARATION
1042 ! -----------
1043 !
1044 !
1045 USE modd_data_cover_n, ONLY : data_cover_t
1046 !
1047 USE modd_surf_par, ONLY : xundef
1048 USE modd_data_cover, ONLY : xdata_veg, xdata_lai
1049 USE modd_data_cover_par, ONLY : nvt_tebd, nvt_bone, nvt_trbe, nvegtype, xcdref, nvt_trbd, &
1050  nvt_tebe, nvt_tene, nvt_bobd, nvt_bond, nvt_shrb
1051 !
1052 USE modi_vegtype_to_patch
1053 !
1054 !
1055 !
1056 USE yomhook ,ONLY : lhook, dr_hook
1057 USE parkind1 ,ONLY : jprb
1058 !
1059 USE modi_abor1_sfx
1060 !
1061 IMPLICIT NONE
1062 !
1063 !* 0.1 Declaration of arguments
1064 ! ------------------------
1065 !
1066 !
1067 TYPE(data_cover_t), INTENT(INOUT) :: DTCO
1068 !
1069 REAL, DIMENSION(:,:,:), INTENT(OUT) :: PFIELD ! secondary field to construct
1070 REAL, DIMENSION(:,:,:), INTENT(IN) :: PCOVER ! fraction of each cover class
1071 REAL, DIMENSION(:,:), INTENT(IN) :: PDATA ! secondary field value for each class
1072  CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field
1073  ! is defined
1074  CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging
1075  LOGICAL, DIMENSION(:), INTENT(IN) :: OCOVER
1076 REAL, DIMENSION(:,:), INTENT(IN), OPTIONAL :: PDZ ! first model half level
1077 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month
1078 !
1079 !* 0.2 Declaration of local variables
1080 ! ------------------------------
1081 !
1082 INTEGER :: JJ
1083 INTEGER :: ICOVER ! number of cover classes
1084 INTEGER :: JCOVER ! loop on cover classes
1085 !
1086 ! nbe of vegtype
1087 ! nbre of patches
1088 INTEGER :: JVEGTYPE! loop on vegtype
1089 INTEGER :: IPATCH ! number of patches
1090 INTEGER :: JPATCH ! PATCH index
1091 !
1092 REAL, DIMENSION(NVEGTYPE) :: ZWEIGHT
1093 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),NVEGTYPE) :: ZCOVER_WEIGHT
1094 !
1095 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),SIZE(PFIELD,3)):: ZCOVER_WEIGHT_PATCH
1096 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),SIZE(PFIELD,3)):: ZSUM_COVER_WEIGHT_PATCH
1097 REAL, DIMENSION(NVEGTYPE) :: ZDATA
1098 !
1099 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),SIZE(PFIELD,3)):: ZWORK
1100 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),SIZE(PFIELD,3)):: ZDZ
1101 REAL(KIND=JPRB) :: ZHOOK_HANDLE
1102 !-------------------------------------------------------------------------------
1103 !
1104 !* 1.1 field does not exist
1105 ! --------------------
1106 !
1107 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD',0,zhook_handle)
1108 IF (SIZE(pfield)==0 .AND. lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD',1,zhook_handle)
1109 IF (SIZE(pfield)==0) RETURN
1110 !
1111 !-------------------------------------------------------------------------------
1112 !
1113 !* 1.2 Initializations
1114 ! ---------------
1115 !
1116 icover=SIZE(ocover)
1117 ipatch=SIZE(pfield,3)
1118 !
1119 !
1120 !
1121 IF (PRESENT(pdz)) THEN
1122  DO jpatch=1,ipatch
1123  zdz(:,:,jpatch)=pdz(:,:)
1124  END DO
1125 ELSE
1126  zdz(:,:,:)=xcdref
1127 END IF
1128 !
1129 pfield(:,:,:)=xundef
1130 !
1131 zwork(:,:,:)=0.
1132 zsum_cover_weight_patch(:,:,:)=0.
1133 !
1134 !-------------------------------------------------------------------------------
1135 jcover = 0
1136 DO jj=1,icover
1137  !
1138  IF (.NOT.ocover(jj)) cycle
1139  !
1140  jcover = jcover + 1
1141  !
1142 !-------------------------------------------------------------------------------
1143 !
1144 !* 2. Selection of the weighting function for vegtype
1145 ! -----------------------------------
1146 !
1147  SELECT CASE (hsftype)
1148 
1149  CASE('NAT')
1150  DO jvegtype=1,nvegtype
1151  zweight(jvegtype)=dtco%XDATA_NATURE(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)
1152  END DO
1153 
1154  CASE('GRD')
1155  DO jvegtype=1,nvegtype
1156  zweight(jvegtype)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)
1157  END DO
1158 
1159  CASE('VEG')
1160  DO jvegtype=1,nvegtype
1161  zweight(jvegtype)=dtco%XDATA_NATURE(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)*&
1162  xdata_veg(jj,kdecade,jvegtype)
1163  END DO
1164 
1165  CASE('BAR')
1166  DO jvegtype=1,nvegtype
1167  zweight(jvegtype)=dtco%XDATA_NATURE(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)*&
1168  (1.-xdata_veg(jj,kdecade,jvegtype))
1169  END DO
1170 
1171  CASE('GRV')
1172  DO jvegtype=1,nvegtype
1173  zweight(jvegtype)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)*&
1174  xdata_veg(jj,kdecade,jvegtype)
1175  END DO
1176 
1177  CASE('GRB')
1178  DO jvegtype=1,nvegtype
1179  zweight(jvegtype)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)*&
1180  (1.-xdata_veg(jj,kdecade,jvegtype))
1181  ENDDO
1182 
1183  CASE('DVG') ! average only on vegetated area
1184  zweight(:) = 0.0
1185  DO jvegtype=1,nvegtype
1186  IF ( sum(xdata_lai(jj,:,jvegtype)).GT.0.) &
1187  zweight(jvegtype)=dtco%XDATA_NATURE(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)
1188  END DO
1189 
1190  CASE('GDV') ! average only on vegetated area
1191  zweight(:) = 0.0
1192  DO jvegtype=1,nvegtype
1193  IF ( sum(xdata_lai(jj,:,jvegtype)).GT.0.) &
1194  zweight(jvegtype)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)
1195  END DO
1196 
1197  CASE('LAI')
1198  DO jvegtype=1,nvegtype
1199  zweight(jvegtype)=dtco%XDATA_NATURE(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)*&
1200  xdata_lai(jj,kdecade,jvegtype)
1201  END DO
1202 
1203  CASE('GRL')
1204  DO jvegtype=1,nvegtype
1205  zweight(jvegtype)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj)*dtco%XDATA_VEGTYPE(jj,jvegtype)*&
1206  xdata_lai(jj,kdecade,jvegtype)
1207  END DO
1208 
1209  CASE('TRE')
1210  zweight(:)=0.
1211  IF (dtco%XDATA_VEGTYPE(jj,nvt_tebd)>0.) THEN
1212  zweight(nvt_tebd)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_tebd)
1213  END IF
1214  IF (dtco%XDATA_VEGTYPE(jj,nvt_bone)>0.) THEN
1215  zweight(nvt_bone)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_bone)
1216  END IF
1217  IF (dtco%XDATA_VEGTYPE(jj,nvt_trbe)>0.) THEN
1218  zweight(nvt_trbe)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_trbe)
1219  END IF
1220  IF (dtco%XDATA_VEGTYPE(jj,nvt_trbd)>0.) THEN
1221  zweight(nvt_trbd)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_trbd)
1222  END IF
1223  IF (dtco%XDATA_VEGTYPE(jj,nvt_tebe)>0.) THEN
1224  zweight(nvt_tebe)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_tebe)
1225  END IF
1226  IF (dtco%XDATA_VEGTYPE(jj,nvt_tene)>0.) THEN
1227  zweight(nvt_tene)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_tene)
1228  END IF
1229  IF (dtco%XDATA_VEGTYPE(jj,nvt_bobd)>0.) THEN
1230  zweight(nvt_bobd)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_bobd)
1231  END IF
1232  IF (dtco%XDATA_VEGTYPE(jj,nvt_bond)>0.) THEN
1233  zweight(nvt_bond)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_bond)
1234  END IF
1235  IF (dtco%XDATA_VEGTYPE(jj,nvt_shrb)>0.) THEN
1236  zweight(nvt_shrb)=dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,nvt_shrb)
1237  END IF
1238 
1239  CASE('GRT')
1240  zweight(:)=0.
1241  IF (dtco%XDATA_VEGTYPE(jj,nvt_tebd)>0.) THEN
1242  zweight(nvt_tebd)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_tebd)
1243  END IF
1244  IF (dtco%XDATA_VEGTYPE(jj,nvt_bone)>0.) THEN
1245  zweight(nvt_bone)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_bone)
1246  END IF
1247  IF (dtco%XDATA_VEGTYPE(jj,nvt_trbe)>0.) THEN
1248  zweight(nvt_trbe)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_trbe)
1249  END IF
1250  IF (dtco%XDATA_VEGTYPE(jj,nvt_trbd)>0.) THEN
1251  zweight(nvt_trbd)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_trbd)
1252  END IF
1253  IF (dtco%XDATA_VEGTYPE(jj,nvt_tebe)>0.) THEN
1254  zweight(nvt_tebe)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_tebe)
1255  END IF
1256  IF (dtco%XDATA_VEGTYPE(jj,nvt_tene)>0.) THEN
1257  zweight(nvt_tene)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_tene)
1258  END IF
1259  IF (dtco%XDATA_VEGTYPE(jj,nvt_bobd)>0.) THEN
1260  zweight(nvt_bobd)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_bobd)
1261  END IF
1262  IF (dtco%XDATA_VEGTYPE(jj,nvt_bond)>0.) THEN
1263  zweight(nvt_bond)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_bond)
1264  END IF
1265  IF (dtco%XDATA_VEGTYPE(jj,nvt_shrb)>0.) THEN
1266  zweight(nvt_shrb)=dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,nvt_shrb)
1267  END IF
1268 
1269  CASE DEFAULT
1270  CALL abor1_sfx('AV_PATCH_PGD: WEIGHTING FUNCTION FOR VEGTYPE NOT ALLOWED')
1271  END SELECT
1272 !
1273 !-------------------------------------------------------------------------------
1274 !
1275 !* 3. Averaging
1276 ! ---------
1277 !
1278 !* 3.1 Work arrays given for each patch
1279 ! -----------
1280 !
1281  zcover_weight(:,:,:)=0.
1282  zcover_weight_patch(:,:,:)=0.
1283 
1284  DO jvegtype=1,nvegtype
1285  zcover_weight(:,:,jvegtype) = zcover_weight(:,:,jvegtype) +&
1286  pcover(:,:,jcover) * zweight(jvegtype)
1287 
1288  jpatch= vegtype_to_patch(jvegtype, ipatch)
1289 
1290  zcover_weight_patch(:,:,jpatch) = zcover_weight_patch(:,:,jpatch)+ &
1291  pcover(:,:,jcover) * zweight(jvegtype)
1292  END DO
1293 
1294 !
1295  zsum_cover_weight_patch(:,:,:) = zsum_cover_weight_patch(:,:,:) + zcover_weight_patch(:,:,:)
1296 
1297 
1298  zdata(:) = pdata(jj,:)
1299 
1300 !
1301 !* 3.2 Selection of averaging type
1302 ! ---------------------------
1303 !
1304  SELECT CASE (hatype)
1305 !
1306 !-------------------------------------------------------------------------------
1307 !
1308 !* 3.3 Arithmetic averaging
1309 ! --------------------
1310 !
1311  CASE ('ARI')
1312 !
1313  DO jvegtype=1,nvegtype
1314  jpatch= vegtype_to_patch(jvegtype,ipatch)
1315  zwork(:,:,jpatch) = zwork(:,:,jpatch) + zdata(jvegtype) * zcover_weight(:,:,jvegtype)
1316  END DO
1317 !
1318 !-------------------------------------------------------------------------------
1319 !
1320 !* 3.4 Inverse averaging
1321 ! -----------------
1322 !
1323  CASE('INV' )
1324 !
1325  DO jvegtype=1,nvegtype
1326  jpatch=vegtype_to_patch(jvegtype,ipatch)
1327  zwork(:,:,jpatch)= zwork(:,:,jpatch) + 1./ zdata(jvegtype)* zcover_weight(:,:,jvegtype)
1328  END DO
1329 !
1330 !-------------------------------------------------------------------------------!
1331 !
1332 !* 3.5 Roughness length averaging
1333 ! --------------------------
1334 
1335 !
1336  CASE('CDN')
1337 !
1338  DO jvegtype=1,nvegtype
1339  jpatch=vegtype_to_patch(jvegtype,ipatch)
1340  zwork(:,:,jpatch)= zwork(:,:,jpatch) + 1./(log(zdz(:,:,jpatch)/ zdata(jvegtype)))**2 &
1341  * zcover_weight(:,:,jvegtype)
1342  END DO
1343 !
1344 !-------------------------------------------------------------------------------
1345 !
1346  CASE DEFAULT
1347  CALL abor1_sfx('AV_PATCH_PGD: (1) AVERAGING TYPE NOT ALLOWED')
1348 !
1349  END SELECT
1350 !
1351 END DO
1352 !-------------------------------------------------------------------------------
1353 !
1354 !* 4. End of Averaging
1355 ! ----------------
1356 !
1357 !* 4.1 Selection of averaging type
1358 ! ---------------------------
1359 !
1360 SELECT CASE (hatype)
1361 !
1362 !-------------------------------------------------------------------------------
1363 !
1364 !* 4.2 Arithmetic averaging
1365 ! --------------------
1366 !
1367  CASE ('ARI')
1368 !
1369  WHERE ( zsum_cover_weight_patch(:,:,:) >0. )
1370  pfield(:,:,:) = zwork(:,:,:) / zsum_cover_weight_patch(:,:,:)
1371  END WHERE
1372 !
1373 !-------------------------------------------------------------------------------
1374 !
1375 !* 4.3 Inverse averaging
1376 ! -----------------
1377 !
1378  CASE('INV' )
1379 !
1380  WHERE ( zsum_cover_weight_patch(:,:,:) >0. )
1381  pfield(:,:,:) = zsum_cover_weight_patch(:,:,:) / zwork(:,:,:)
1382  END WHERE
1383 !-------------------------------------------------------------------------------!
1384 !
1385 !* 4.4 Roughness length averaging
1386 ! --------------------------
1387 
1388 !
1389  CASE('CDN')
1390 !
1391  WHERE ( zsum_cover_weight_patch(:,:,:) >0. )
1392  pfield(:,:,:) = zdz(:,:,:) * exp( - sqrt(zsum_cover_weight_patch(:,:,:)/zwork(:,:,:)) )
1393  END WHERE
1394 !
1395 !-------------------------------------------------------------------------------
1396 !
1397  CASE DEFAULT
1398  CALL abor1_sfx('AV_PATCH_PGD: (2) AVERAGING TYPE NOT ALLOWED')
1399 !
1400 END SELECT
1401 IF (lhook) CALL dr_hook('MODI_AV_PGD:AV_PATCH_PGD',1,zhook_handle)
1402 !-------------------------------------------------------------------------------
1403 !
1404 END SUBROUTINE av_patch_pgd
1405 !
1406 !
1407 ! ################################################################
1408  SUBROUTINE major_patch_pgd_1d(TFIELD,PCOVER,TDATA,HSFTYPE,HATYPE,OCOVER,KDECADE)
1409 ! ################################################################
1410 !
1411 !!**** *MAJOR_PATCH_PGD* find the dominant date for each vegetation type
1412 !!
1413 !! PURPOSE
1414 !! -------
1415 !!
1416 !! METHOD
1417 !! ------
1418 !!
1419 !! EXTERNAL
1420 !! --------
1421 !!
1422 !! IMPLICIT ARGUMENTS
1423 !! ------------------
1424 !!
1425 !! REFERENCE
1426 !! ---------
1427 !!
1428 !! AUTHOR
1429 !! ------
1430 !!
1431 !! P. LE MOIGNE
1432 !!
1433 !! MODIFICATION
1434 !! ------------
1435 !!
1436 !! Original 06/2006
1437 !!
1438 !----------------------------------------------------------------------------
1439 !
1440 !* 0. DECLARATION
1441 ! -----------
1442 !
1443 USE modd_type_date_surf
1444 USE modd_surf_par, ONLY : xundef, nundef
1445 USE modd_data_cover_par, ONLY : nvegtype
1446 !
1447 USE modi_vegtype_to_patch
1448 !
1449 USE mode_av_pgd
1450 !
1451 USE yomhook ,ONLY : lhook, dr_hook
1452 USE parkind1 ,ONLY : jprb
1453 !
1454 IMPLICIT NONE
1455 !
1456 !* 0.1 Declaration of arguments
1457 ! ------------------------
1458 !
1459 type(date_time), DIMENSION(:,:), INTENT(OUT) :: tfield ! secondary field to construct
1460 REAL, DIMENSION(:,:), INTENT(IN) :: PCOVER ! fraction of each cover class
1461 type(date_time), DIMENSION(:,:), INTENT(IN) :: tdata ! secondary field value for each class
1462  CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field
1463  ! is defined
1464  CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging
1465 LOGICAL, DIMENSION(:), INTENT(IN) :: OCOVER
1466 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month
1467 !
1468 !* 0.2 Declaration of local variables
1469 ! ------------------------------
1470 !
1471 INTEGER :: JJ
1472 INTEGER :: ICOVER ! number of cover classes
1473 INTEGER :: JCOVER ! loop on cover classes
1474 !
1475 INTEGER :: JVEGTYPE! loop on vegtype
1476 !
1477 INTEGER, DIMENSION(SIZE(PCOVER,2),NVEGTYPE) :: IDATA_DOY
1478 INTEGER, DIMENSION(SIZE(PCOVER,1)) :: IDOY
1479 REAL, DIMENSION(365) :: ZCOUNT
1480 INTEGER :: JP, IMONTH, IDAY
1481 INTEGER :: IPATCH, JPATCH
1482 REAL(KIND=JPRB) :: ZHOOK_HANDLE
1483 !-------------------------------------------------------------------------------
1484 !
1485 !* 1.1 field does not exist
1486 ! --------------------
1487 !
1488 IF (lhook) CALL dr_hook('MODI_AV_PGD:MAJOR_PATCH_PGD_1D',0,zhook_handle)
1489 IF (SIZE(tfield)==0 .AND. lhook) CALL dr_hook('MODI_AV_PGD:MAJOR_PATCH_PGD_1D',1,zhook_handle)
1490 IF (SIZE(tfield)==0) RETURN
1491 !
1492 !-------------------------------------------------------------------------------
1493 !
1494 !* 1.2 Initializations
1495 ! ---------------
1496 !
1497 ipatch=SIZE(tfield,2)
1498 !
1499 tfield(:,:)%TDATE%YEAR = nundef
1500 tfield(:,:)%TDATE%MONTH = nundef
1501 tfield(:,:)%TDATE%DAY = nundef
1502 tfield(:,:)%TIME = xundef
1503 !
1504 idoy(:) = 0
1505 !
1506  CALL date2doy(tdata,ocover,idata_doy)
1507 !-------------------------------------------------------------------------------
1508 DO jp = 1,SIZE(pcover,1)
1509  !
1510  DO jpatch=1,ipatch
1511  !
1512  zcount(:) = 0.
1513  !
1514  DO jvegtype=1,nvegtype
1515  !
1516  IF(jpatch==vegtype_to_patch(jvegtype,ipatch)) THEN
1517  !
1518  DO jcover = 1,SIZE(pcover,2)
1519  !
1520  IF (idata_doy(jcover,jvegtype) /= nundef .AND. pcover(jp,jcover)/=0.) THEN
1521  !
1522  zcount(idata_doy(jcover,jvegtype)) = zcount(idata_doy(jcover,jvegtype)) + pcover(jp,jcover)
1523  !
1524  END IF
1525  !
1526  END DO
1527  !
1528  ENDIF
1529  !
1530  ENDDO
1531  !
1532  idoy(jp) = 0
1533  IF (any(zcount(:)/=0.)) idoy(jp) = maxloc(zcount,1)
1534  !
1535  CALL doy2date(idoy(jp),imonth,iday)
1536  !
1537  tfield(jp,jpatch)%TDATE%MONTH = imonth
1538  tfield(jp,jpatch)%TDATE%DAY = iday
1539  IF (imonth/=nundef) tfield(jp,jpatch)%TIME = 0.
1540  !
1541  END DO
1542  !
1543 END DO
1544 !
1545 !-------------------------------------------------------------------------------
1546 !
1547 IF (lhook) CALL dr_hook('MODI_AV_PGD:MAJOR_PATCH_PGD_1D',1,zhook_handle)
1548 !
1549 END SUBROUTINE major_patch_pgd_1d
1550 !-------------------------------------------------------------------------------
1551 !
mode_av_pgd::get_weight_patch
subroutine get_weight_patch(DTCO, KCOVER, KMASK, KDECADE, HSFTYPE, PWEIGHT)
Definition: mode_av_pgd.F90:175
modd_data_cover
Definition: modd_data_cover.F90:6
modd_surf_par
Definition: modd_surf_par.F90:6
modd_surfex_mpi::nrank
integer nrank
Definition: modd_surfex_mpi.F90:58
av_pgd_2d
subroutine av_pgd_2d(DTCO, PFIELD, PCOVER, PDATA, HSFTYPE, HATYPE, OCOVER, PD
Definition: av_pgd.F90:686
yomhook::dr_hook
Definition: yomhook.F90:20
major_patch_pgd_1d
subroutine major_patch_pgd_1d(TFIELD, PCOVER, TDATA, HSFTYPE, HATYPE, O
Definition: av_pgd.F90:1409
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:7
abor1_sfx
subroutine abor1_sfx(YTEXT)
Definition: abor1_sfx.F90:7
modd_surf_par::xundef
real, parameter xundef
Definition: modd_surf_par.F90:43
modd_surfex_omp
Definition: modd_surfex_omp.F90:6
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
modi_av_pgd
Definition: av_pgd.F90:6
av_patch_pgd
subroutine av_patch_pgd(DTCO, PFIELD, PCOVER, PDATA, HSFTYPE, HATYPE, OCOVER
Definition: av_pgd.F90:993
modd_surf_par::nundef
integer, parameter nundef
Definition: modd_surf_par.F90:51
mode_av_pgd::get_weight
subroutine get_weight(DTCO, KCOVER, KMASK, HSFTYPE, PWEIGHT)
Definition: mode_av_pgd.F90:81
modd_data_cover_n
Definition: modd_data_covern.F90:6
mode_av_pgd
Definition: mode_av_pgd.F90:5
modd_surfex_omp::nblocktot
integer nblocktot
Definition: modd_surfex_omp.F90:52
modd_data_cover::xdata_veg
real, dimension(:,:,:), allocatable xdata_veg
Definition: modd_data_cover.F90:87
modd_type_date_surf::date_time
Definition: modd_type_date_surf.F90:46
sum
intent(out) overrides sub arrays one Sort by the least significant key first sum(iindex(1:n))
mode_av_pgd::date2doy
subroutine date2doy(TPDATA, OCOVER, KDOY)
Definition: mode_av_pgd.F90:17
modd_surfex_mpi
Definition: modd_surfex_mpi.F90:6
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
modd_data_cover::xdata_lai
real, dimension(:,:,:), allocatable xdata_lai
Definition: modd_data_cover.F90:149
modd_data_cover_n::data_cover_t
Definition: modd_data_covern.F90:43
modd_data_cover::xdata_bld_height
real, dimension(:), allocatable xdata_bld_height
Definition: modd_data_cover.F90:174
av_pgd_1d
subroutine av_pgd_1d(DTCO, PFIELD, PCOVER, PDATA, HSFTYPE, HATYPE, OCOVER, PD
Definition: av_pgd.F90:109
maxloc
static ll_t maxloc
Definition: getcurheap.c:48
modd_type_date_surf
Definition: modd_type_date_surf.F90:6
av_patch_pgd_1d
subroutine av_patch_pgd_1d(DTCO, PFIELD, PCOVER, PDATA, HSFTYPE, HATYPE, OCO
Definition: av_pgd.F90:382
mode_av_pgd::doy2date
subroutine doy2date(KDOY, KMONTH, KDAY)
Definition: mode_av_pgd.F90:50
Generated on Tue Jan 16 2018 16:23:22 for SURFEX v8.1 by   doxygen 1.8.13