|
SURFEX v7.3
General documentation of Surfex
|
|
SURFEX v7.3
General documentation of Surfex
|
00001 ! ################## 00002 MODULE MODI_AV_PGD 00003 ! ################## 00004 INTERFACE AV_PGD 00005 ! 00006 SUBROUTINE AV_PGD(PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,PDZ,KDECADE) 00007 00008 ! 00009 REAL, DIMENSION(:,:), INTENT(OUT) :: PFIELD ! secondary field to construct 00010 REAL, DIMENSION(:,:,:), INTENT(IN) :: PCOVER ! fraction of each cover class 00011 REAL, DIMENSION(:), INTENT(IN) :: PDATA ! secondary field value for each class 00012 CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field 00013 ! is defined 00014 CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging 00015 REAL, DIMENSION(:,:), INTENT(IN), OPTIONAL :: PDZ ! first model half level 00016 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month 00017 ! 00018 END SUBROUTINE AV_PGD 00019 ! 00020 SUBROUTINE AV_PATCH_PGD(PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,PDZ,KDECADE) 00021 00022 ! 00023 REAL, DIMENSION(:,:,:), INTENT(OUT) :: PFIELD ! secondary field to construct for each patch 00024 REAL, DIMENSION(:,:,:), INTENT(IN) :: PCOVER ! fraction of each cover class 00025 REAL, DIMENSION(:,:), INTENT(IN) :: PDATA ! secondary field value for each class in each vegtype 00026 CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field 00027 ! is defined 00028 CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging 00029 REAL, DIMENSION(:,:), INTENT(IN), OPTIONAL :: PDZ ! first model half level 00030 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month 00031 ! 00032 END SUBROUTINE AV_PATCH_PGD 00033 ! 00034 SUBROUTINE AV_PGD_1D(PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,PDZ,KDECADE) 00035 00036 ! 00037 REAL, DIMENSION(:), INTENT(OUT) :: PFIELD ! secondary field to construct 00038 REAL, DIMENSION(:,:), INTENT(IN) :: PCOVER ! fraction of each cover class 00039 REAL, DIMENSION(:), INTENT(IN) :: PDATA ! secondary field value for each class 00040 CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field 00041 ! is defined 00042 CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging 00043 REAL, DIMENSION(:), INTENT(IN), OPTIONAL :: PDZ ! first model half level 00044 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month 00045 ! 00046 END SUBROUTINE AV_PGD_1D 00047 ! 00048 SUBROUTINE AV_PATCH_PGD_1D(PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,PDZ,KDECADE) 00049 00050 ! 00051 REAL, DIMENSION(:,:), INTENT(OUT) :: PFIELD ! secondary field to construct for each patch 00052 REAL, DIMENSION(:,:), INTENT(IN) :: PCOVER ! fraction of each cover class 00053 REAL, DIMENSION(:,:), INTENT(IN) :: PDATA ! secondary field value for each class in each vegtype 00054 CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field 00055 ! is defined 00056 CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging 00057 REAL, DIMENSION(:), INTENT(IN), OPTIONAL :: PDZ ! first model half level 00058 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month 00059 ! 00060 END SUBROUTINE AV_PATCH_PGD_1D 00061 ! 00062 SUBROUTINE MAJOR_PATCH_PGD_1D(TFIELD,PCOVER,TDATA,HSFTYPE,HATYPE,KDECADE) 00063 00064 ! 00065 USE MODD_TYPE_DATE_SURF 00066 TYPE (DATE_TIME), DIMENSION(:,:), INTENT(OUT) :: TFIELD ! secondary field to construct for each patch 00067 REAL, DIMENSION(:,:), INTENT(IN) :: PCOVER ! fraction of each cover class 00068 TYPE (DATE_TIME), DIMENSION(:,:), INTENT(IN) :: TDATA ! secondary field to construct for each patch 00069 CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field 00070 ! is defined 00071 CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging 00072 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month 00073 ! 00074 END SUBROUTINE MAJOR_PATCH_PGD_1D 00075 ! 00076 00077 ! 00078 END INTERFACE 00079 END MODULE MODI_AV_PGD 00080 ! 00081 ! 00082 ! ################################################################ 00083 SUBROUTINE AV_PGD_1D(PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,PDZ,KDECADE) 00084 ! ################################################################ 00085 ! 00086 !!**** *AV_PGD* average a secondary physiographic variable from the 00087 !! fractions of coverage class. 00088 !! 00089 !! PURPOSE 00090 !! ------- 00091 !! 00092 !! METHOD 00093 !! ------ 00094 !! 00095 !! The averaging is performed with one way into three: 00096 !! 00097 !! - arithmetic averaging (HATYPE='ARI') 00098 !! 00099 !! - inverse averaging (HATYPE='INV') 00100 !! 00101 !! - inverse of square logarithm averaging (HATYPE='CDN') : 00102 !! 00103 !! 1 / ( ln (dz/data) )**2 00104 !! 00105 !! This latest uses (if available) the height of the first model mass 00106 !! level. In the other case, 20m is chosen. It works for roughness lengths. 00107 !! 00108 !! EXTERNAL 00109 !! -------- 00110 !! 00111 !! IMPLICIT ARGUMENTS 00112 !! ------------------ 00113 !! 00114 !! REFERENCE 00115 !! --------- 00116 !! 00117 !! AUTHOR 00118 !! ------ 00119 !! 00120 !! V. Masson Meteo-France 00121 !! 00122 !! MODIFICATION 00123 !! ------------ 00124 ! 00125 ! F.Solmon patch modif: remove the case 'veg' as veg is defined for patches 00126 ! 00127 !! Original 15/12/97 00128 !! V. Masson 01/2004 Externalization 00129 !! 00130 !---------------------------------------------------------------------------- 00131 ! 00132 !* 0. DECLARATION 00133 ! ----------- 00134 ! 00135 USE MODD_SURF_PAR, ONLY : XUNDEF 00136 USE MODD_DATA_COVER, ONLY : XDATA_SEA, XDATA_WATER, XDATA_VEGTYPE, XDATA_BLD_HEIGHT 00137 USE MODD_DATA_COVER_n, ONLY : XDATA_NATURE, XDATA_TOWN, XDATA_BLD, XDATA_GARDEN 00138 USE MODD_DATA_COVER_PAR, ONLY : NVT_TREE, NVT_CONI, NVT_EVER, XCDREF 00139 ! 00140 ! 00141 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00142 USE PARKIND1 ,ONLY : JPRB 00143 ! 00144 USE MODI_ABOR1_SFX 00145 ! 00146 IMPLICIT NONE 00147 ! 00148 !* 0.1 Declaration of arguments 00149 ! ------------------------ 00150 ! 00151 REAL, DIMENSION(:), INTENT(OUT) :: PFIELD ! secondary field to construct 00152 REAL, DIMENSION(:,:), INTENT(IN) :: PCOVER ! fraction of each cover class 00153 REAL, DIMENSION(:), INTENT(IN) :: PDATA ! secondary field value for each class 00154 CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field 00155 ! is defined 00156 CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging 00157 REAL, DIMENSION(:), INTENT(IN), OPTIONAL :: PDZ ! first model half level 00158 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month 00159 ! 00160 !* 0.2 Declaration of local variables 00161 ! ------------------------------ 00162 ! 00163 ! 00164 INTEGER :: ICOVER ! number of cover classes 00165 INTEGER :: JCOVER ! loop on cover classes 00166 ! 00167 REAL, DIMENSION(SIZE(PCOVER,1)) :: ZWORK, ZDZ 00168 REAL :: ZWEIGHT 00169 REAL, DIMENSION(SIZE(PCOVER,1)) :: ZCOVER_WEIGHT 00170 REAL :: ZDATA 00171 REAL, DIMENSION(SIZE(PCOVER,1)) :: ZSUM_COVER_WEIGHT 00172 REAL, DIMENSION(SIZE(PCOVER,1)) :: ZWEIGHT_MAX 00173 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00174 !------------------------------------------------------------------------------- 00175 ! 00176 !* 1.1 field does not exist 00177 ! -------------------- 00178 ! 00179 IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PGD_1D',0,ZHOOK_HANDLE) 00180 IF (SIZE(PFIELD)==0 .AND. LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PGD_1D',1,ZHOOK_HANDLE) 00181 IF (SIZE(PFIELD)==0) RETURN 00182 ! 00183 !------------------------------------------------------------------------------- 00184 ! 00185 !* 1.2 Initializations 00186 ! --------------- 00187 ! 00188 ICOVER=SIZE(PCOVER,2) 00189 ! 00190 IF (PRESENT(PDZ)) THEN 00191 ZDZ(:)=PDZ(:) 00192 ELSE 00193 ZDZ(:)=XCDREF 00194 END IF 00195 ! 00196 PFIELD(:)=XUNDEF 00197 ! 00198 ZWORK(:)=0. 00199 ZWEIGHT_MAX(:)=0. 00200 ZSUM_COVER_WEIGHT(:)=0. 00201 !------------------------------------------------------------------------------- 00202 DO JCOVER=1,ICOVER 00203 !------------------------------------------------------------------------------- 00204 ! 00205 !* 2. Selection of the weighting function 00206 ! ----------------------------------- 00207 ! 00208 SELECT CASE (HSFTYPE) 00209 CASE('ALL') 00210 ZWEIGHT=1. 00211 00212 CASE('NAT') 00213 ZWEIGHT=XDATA_NATURE(JCOVER) 00214 00215 CASE('GRD') 00216 ZWEIGHT=XDATA_TOWN (JCOVER) * XDATA_GARDEN(JCOVER) 00217 00218 CASE('TWN') 00219 ZWEIGHT=XDATA_TOWN (JCOVER) 00220 00221 CASE('WAT') 00222 ZWEIGHT=XDATA_WATER (JCOVER) 00223 00224 CASE('SEA') 00225 ZWEIGHT=XDATA_SEA (JCOVER) 00226 00227 CASE('BLD') 00228 ZWEIGHT=XDATA_TOWN (JCOVER) * XDATA_BLD(JCOVER) 00229 00230 CASE('BLV') !* building Volume 00231 ZWEIGHT=XDATA_TOWN (JCOVER) * XDATA_BLD(JCOVER) & 00232 * XDATA_BLD_HEIGHT(JCOVER) 00233 00234 CASE('STR') 00235 ZWEIGHT=XDATA_TOWN (JCOVER) * ( 1. - XDATA_BLD(JCOVER) ) 00236 00237 CASE('TRE') 00238 PFIELD(:)=0. 00239 ZWEIGHT=XDATA_NATURE(JCOVER) * ( XDATA_VEGTYPE(JCOVER,NVT_TREE) & 00240 + XDATA_VEGTYPE(JCOVER,NVT_EVER) & 00241 + XDATA_VEGTYPE(JCOVER,NVT_CONI) ) 00242 00243 CASE('GRT') 00244 PFIELD(:)=0. 00245 ZWEIGHT=XDATA_TOWN(JCOVER) * XDATA_GARDEN(JCOVER) & 00246 * ( XDATA_VEGTYPE(JCOVER,NVT_TREE) & 00247 + XDATA_VEGTYPE(JCOVER,NVT_EVER) & 00248 + XDATA_VEGTYPE(JCOVER,NVT_CONI) ) 00249 00250 CASE DEFAULT 00251 CALL ABOR1_SFX('AV_PGD_1D: WEIGHTING FUNCTION NOT ALLOWED '//HSFTYPE) 00252 END SELECT 00253 ! 00254 !------------------------------------------------------------------------------- 00255 ! 00256 !* 3. Averaging 00257 ! --------- 00258 ! 00259 !* 3.1 Work arrays 00260 ! ----------- 00261 ! 00262 ZCOVER_WEIGHT(:) = PCOVER(:,JCOVER) * ZWEIGHT 00263 ! 00264 ZSUM_COVER_WEIGHT(:) = ZSUM_COVER_WEIGHT(:) + ZCOVER_WEIGHT(:) 00265 ! 00266 ZDATA = PDATA(JCOVER) 00267 ! 00268 !* 3.2 Selection of averaging type 00269 ! --------------------------- 00270 ! 00271 SELECT CASE (HATYPE) 00272 ! 00273 !------------------------------------------------------------------------------- 00274 ! 00275 !* 3.4 Arithmetic averaging 00276 ! -------------------- 00277 ! 00278 CASE ('ARI') 00279 ! 00280 ZWORK(:) = ZWORK(:) + ZDATA * ZCOVER_WEIGHT(:) 00281 ! 00282 !------------------------------------------------------------------------------- 00283 ! 00284 !* 3.5 Inverse averaging 00285 ! ----------------- 00286 ! 00287 CASE('INV' ) 00288 ! 00289 ZWORK (:)= ZWORK(:) + 1./ZDATA * ZCOVER_WEIGHT(:) 00290 ! 00291 !-------------------------------------------------------------------------------! 00292 ! 00293 !* 3.6 Roughness length averaging 00294 ! -------------------------- 00295 00296 ! 00297 CASE('CDN') 00298 ! 00299 ZWORK (:)= ZWORK(:) + 1./(LOG(ZDZ(:)/ZDATA))**2 * ZCOVER_WEIGHT(:) 00300 ! 00301 !------------------------------------------------------------------------------- 00302 ! 00303 !* 3.7 Majoritary averaging 00304 ! -------------------- 00305 ! 00306 CASE('MAJ' ) 00307 ! 00308 WHERE(ZCOVER_WEIGHT(:)>ZWEIGHT_MAX(:)) 00309 ZWEIGHT_MAX(:) = ZCOVER_WEIGHT(:) 00310 ZWORK (:) = ZDATA 00311 END WHERE 00312 ! 00313 !------------------------------------------------------------------------------- 00314 ! 00315 CASE DEFAULT 00316 CALL ABOR1_SFX('AV_PGD_1D: (1) AVERAGING TYPE NOT ALLOWED : "'//HATYPE//'"') 00317 ! 00318 END SELECT 00319 ! 00320 END DO 00321 ! 00322 !------------------------------------------------------------------------------- 00323 ! 00324 !* 4. End of Averaging 00325 ! ---------------- 00326 ! 00327 !* 4.1 Selection of averaging type 00328 ! --------------------------- 00329 ! 00330 SELECT CASE (HATYPE) 00331 ! 00332 !------------------------------------------------------------------------------- 00333 ! 00334 !* 4.2 Arithmetic averaging 00335 ! -------------------- 00336 ! 00337 CASE ('ARI') 00338 ! 00339 WHERE ( ZSUM_COVER_WEIGHT(:) >0. ) 00340 PFIELD(:) = ZWORK(:) / ZSUM_COVER_WEIGHT(:) 00341 END WHERE 00342 ! 00343 !------------------------------------------------------------------------------- 00344 ! 00345 !* 4.3 Inverse averaging 00346 ! ----------------- 00347 ! 00348 CASE('INV' ) 00349 ! 00350 WHERE ( ZSUM_COVER_WEIGHT(:) >0. ) 00351 PFIELD(:) = ZSUM_COVER_WEIGHT(:) / ZWORK(:) 00352 END WHERE 00353 ! 00354 !-------------------------------------------------------------------------------! 00355 ! 00356 !* 4.4 Roughness length averaging 00357 ! -------------------------- 00358 00359 ! 00360 CASE('CDN') 00361 ! 00362 WHERE ( ZSUM_COVER_WEIGHT(:) >0. ) 00363 PFIELD(:) = ZDZ(:) * EXP( - SQRT(ZSUM_COVER_WEIGHT(:)/ZWORK(:)) ) 00364 END WHERE 00365 ! 00366 !------------------------------------------------------------------------------- 00367 ! 00368 !* 4.4 Majoritary averaging 00369 ! -------------------- 00370 ! 00371 CASE('MAJ' ) 00372 ! 00373 WHERE ( ZSUM_COVER_WEIGHT(:) >0. ) 00374 PFIELD(:) = ZWORK(:) 00375 END WHERE 00376 ! 00377 !------------------------------------------------------------------------------- 00378 ! 00379 CASE DEFAULT 00380 CALL ABOR1_SFX('AV_PGD_1D: (2) AVERAGING TYPE NOT ALLOWED') 00381 ! 00382 END SELECT 00383 IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PGD_1D',1,ZHOOK_HANDLE) 00384 ! 00385 ! 00386 !------------------------------------------------------------------------------- 00387 ! 00388 END SUBROUTINE AV_PGD_1D 00389 ! 00390 ! 00391 ! 00392 ! ################################################################ 00393 SUBROUTINE AV_PATCH_PGD_1D(PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,PDZ,KDECADE) 00394 ! ################################################################ 00395 ! 00396 !!**** *AV_PATCH_PGD* average for each surface patch a secondary physiographic 00397 !! variable from the 00398 !! fractions of coverage class. 00399 !! 00400 !! PURPOSE 00401 !! ------- 00402 !! 00403 !! METHOD 00404 !! ------ 00405 !! 00406 !! The averaging is performed with one way into three: 00407 !! 00408 !! - arithmetic averaging (HATYPE='ARI') 00409 !! 00410 !! - inverse averaging (HATYPE='INV') 00411 !! 00412 !! - inverse of square logarithm averaging (HATYPE='CDN') : 00413 !! 00414 !! 1 / ( ln (dz/data) )**2 00415 !! 00416 !! This latest uses (if available) the height of the first model mass 00417 !! level. In the other case, 20m is chosen. It works for roughness lengths. 00418 !! 00419 !! EXTERNAL 00420 !! -------- 00421 !! 00422 !! IMPLICIT ARGUMENTS 00423 !! ------------------ 00424 !! 00425 !! REFERENCE 00426 !! --------- 00427 !! 00428 !! AUTHOR 00429 !! ------ 00430 !! 00431 !! F.Solmon /V. Masson 00432 !! 00433 !! MODIFICATION 00434 !! ------------ 00435 !! 00436 !! Original 15/12/97 00437 !! V. Masson 01/2004 Externalization 00438 !! 00439 !---------------------------------------------------------------------------- 00440 ! 00441 !* 0. DECLARATION 00442 ! ----------- 00443 ! 00444 USE MODD_SURF_PAR, ONLY : XUNDEF 00445 USE MODD_DATA_COVER, ONLY : XDATA_SEA, XDATA_WATER, XDATA_VEGTYPE, XDATA_VEG, XDATA_LAI 00446 USE MODD_DATA_COVER_n, ONLY : XDATA_NATURE, XDATA_TOWN, XDATA_BLD, XDATA_GARDEN 00447 USE MODD_DATA_COVER_PAR, ONLY : NVT_TREE, NVT_CONI, NVT_EVER, NVEGTYPE, XCDREF 00448 ! 00449 USE MODI_VEGTYPE_TO_PATCH 00450 ! 00451 ! 00452 ! 00453 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00454 USE PARKIND1 ,ONLY : JPRB 00455 ! 00456 USE MODI_ABOR1_SFX 00457 ! 00458 IMPLICIT NONE 00459 ! 00460 !* 0.1 Declaration of arguments 00461 ! ------------------------ 00462 ! 00463 REAL, DIMENSION(:,:), INTENT(OUT) :: PFIELD ! secondary field to construct 00464 REAL, DIMENSION(:,:), INTENT(IN) :: PCOVER ! fraction of each cover class 00465 REAL, DIMENSION(:,:), INTENT(IN) :: PDATA ! secondary field value for each class 00466 CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field 00467 ! is defined 00468 CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging 00469 REAL, DIMENSION(:), INTENT(IN), OPTIONAL :: PDZ ! first model half level 00470 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month 00471 ! 00472 !* 0.2 Declaration of local variables 00473 ! ------------------------------ 00474 ! 00475 ! 00476 INTEGER :: ICOVER ! number of cover classes 00477 INTEGER :: JCOVER ! loop on cover classes 00478 ! 00479 ! nbe of vegtype 00480 ! nbre of patches 00481 INTEGER :: JVEGTYPE! loop on vegtype 00482 INTEGER :: IPATCH ! number of patches 00483 INTEGER :: JPATCH ! PATCH index 00484 INTEGER :: JJ, JI 00485 ! 00486 00487 ! 00488 REAL, DIMENSION(SIZE(PCOVER,2),NVEGTYPE) :: ZWEIGHT 00489 REAL, DIMENSION(SIZE(PCOVER,1),NVEGTYPE) :: ZCOVER_WEIGHT 00490 ! 00491 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PFIELD,2)) :: ZSUM_COVER_WEIGHT_PATCH 00492 REAL, DIMENSION(NVEGTYPE) :: ZDATA 00493 ! 00494 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PFIELD,2)) :: ZWORK 00495 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PFIELD,2)) :: ZDZ 00496 ! 00497 INTEGER, DIMENSION(SIZE(PCOVER,1),SIZE(PFIELD,2)) :: NMASK 00498 INTEGER, DIMENSION(SIZE(PFIELD,2)) :: JCOUNT 00499 INTEGER :: PATCH_LIST(NVEGTYPE) 00500 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00501 00502 !------------------------------------------------------------------------------- 00503 ! 00504 !* 1.1 field does not exist 00505 ! -------------------- 00506 ! 00507 IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PATCH_PGD_1D',0,ZHOOK_HANDLE) 00508 IF (SIZE(PFIELD)==0 .AND. LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PATCH_PGD_1D',1,ZHOOK_HANDLE) 00509 IF (SIZE(PFIELD)==0) RETURN 00510 ! 00511 !------------------------------------------------------------------------------- 00512 ! 00513 !* 1.2 Initializations 00514 ! --------------- 00515 ! 00516 ICOVER=SIZE(PCOVER,2) 00517 IPATCH=SIZE(PFIELD,2) 00518 ! 00519 ! 00520 ! 00521 IF (PRESENT(PDZ)) THEN 00522 DO JPATCH=1,IPATCH 00523 ZDZ(:,JPATCH)=PDZ(:) 00524 END DO 00525 ELSE 00526 ZDZ(:,:)=XCDREF 00527 END IF 00528 ! 00529 PFIELD(:,:)=XUNDEF 00530 ! 00531 ZWORK(:,:) = 0. 00532 ZWEIGHT(:,:) = 0.0 00533 ZSUM_COVER_WEIGHT_PATCH(:,:) = 0. 00534 ! 00535 DO JVEGTYPE=1,NVEGTYPE 00536 PATCH_LIST(JVEGTYPE) = VEGTYPE_TO_PATCH (JVEGTYPE, IPATCH) 00537 ENDDO 00538 00539 !------------------------------------------------------------------------------- 00540 !------------------------------------------------------------------------------- 00541 ! 00542 !* 2. Selection of the weighting function for vegtype 00543 ! ----------------------------------- 00544 ! 00545 SELECT CASE (HSFTYPE) 00546 00547 CASE('NAT') 00548 DO JVEGTYPE=1,NVEGTYPE 00549 ZWEIGHT(:,JVEGTYPE)=XDATA_NATURE(:)*XDATA_VEGTYPE(:,JVEGTYPE) 00550 END DO 00551 00552 CASE('GRD') 00553 DO JVEGTYPE=1,NVEGTYPE 00554 ZWEIGHT(:,JVEGTYPE)=XDATA_TOWN(:)*XDATA_GARDEN(:)*XDATA_VEGTYPE(:,JVEGTYPE) 00555 END DO 00556 00557 CASE('VEG') 00558 DO JVEGTYPE=1,NVEGTYPE 00559 ZWEIGHT(:,JVEGTYPE)=XDATA_NATURE(:)*XDATA_VEGTYPE(:,JVEGTYPE)*& 00560 XDATA_VEG(:,KDECADE,JVEGTYPE) 00561 END DO 00562 00563 CASE('BAR') 00564 DO JVEGTYPE=1,NVEGTYPE 00565 ZWEIGHT(:,JVEGTYPE)=XDATA_NATURE(:)*XDATA_VEGTYPE(:,JVEGTYPE)*& 00566 (1.-XDATA_VEG(:,KDECADE,JVEGTYPE)) 00567 END DO 00568 00569 CASE('GRV') 00570 DO JVEGTYPE=1,NVEGTYPE 00571 ZWEIGHT(:,JVEGTYPE)=XDATA_TOWN(:)*XDATA_GARDEN(:)*XDATA_VEGTYPE(:,JVEGTYPE)* & 00572 XDATA_VEG(:,KDECADE,JVEGTYPE) 00573 END DO 00574 00575 CASE('GRB') 00576 DO JVEGTYPE=1,NVEGTYPE 00577 ZWEIGHT(:,JVEGTYPE)=XDATA_TOWN(:)*XDATA_GARDEN(:)*XDATA_VEGTYPE(:,JVEGTYPE)* & 00578 (1.-XDATA_VEG(:,KDECADE,JVEGTYPE)) 00579 END DO 00580 00581 CASE('DVG') ! for diffusion scheme only 00582 DO JVEGTYPE=1,NVEGTYPE 00583 WHERE ( SUM(XDATA_LAI(:,:,JVEGTYPE),2) .GT. 0.0) & 00584 ZWEIGHT(:,JVEGTYPE)=XDATA_NATURE(:)*XDATA_VEGTYPE(:,JVEGTYPE) 00585 END DO 00586 00587 CASE('GDV') ! for diffusion scheme only 00588 DO JVEGTYPE=1,NVEGTYPE 00589 WHERE ( SUM(XDATA_LAI(:,:,JVEGTYPE),2) .GT. 0.0) & 00590 ZWEIGHT(:,JVEGTYPE)=XDATA_TOWN(:)*XDATA_GARDEN(:)*XDATA_VEGTYPE(:,JVEGTYPE) 00591 END DO 00592 00593 CASE('LAI') 00594 DO JVEGTYPE=1,NVEGTYPE 00595 ZWEIGHT(:,JVEGTYPE)=XDATA_NATURE(:)*XDATA_VEGTYPE(:,JVEGTYPE)*& 00596 XDATA_LAI(:,KDECADE,JVEGTYPE) 00597 END DO 00598 00599 CASE('GRL') 00600 DO JVEGTYPE=1,NVEGTYPE 00601 ZWEIGHT(:,JVEGTYPE)=XDATA_TOWN(:)*XDATA_GARDEN(:)*XDATA_VEGTYPE(:,JVEGTYPE)* & 00602 XDATA_LAI(:,KDECADE,JVEGTYPE) 00603 END DO 00604 00605 CASE('TRE') 00606 ZWEIGHT(:,:)=0. 00607 WHERE (XDATA_VEGTYPE(:,NVT_TREE)>0.) 00608 ZWEIGHT(:,NVT_TREE)=XDATA_NATURE(:) * XDATA_VEGTYPE(:,NVT_TREE) 00609 ENDWHERE 00610 WHERE (XDATA_VEGTYPE(:,NVT_CONI)>0.) 00611 ZWEIGHT(:,NVT_CONI)=XDATA_NATURE(:) * XDATA_VEGTYPE(:,NVT_CONI) 00612 ENDWHERE 00613 WHERE (XDATA_VEGTYPE(:,NVT_EVER)>0.) 00614 ZWEIGHT(:,NVT_EVER)=XDATA_NATURE(:) * XDATA_VEGTYPE(:,NVT_EVER) 00615 ENDWHERE 00616 00617 CASE('GRT') 00618 ZWEIGHT(:,:)=0. 00619 WHERE (XDATA_VEGTYPE(:,NVT_TREE)>0.) 00620 ZWEIGHT(:,NVT_TREE)=XDATA_TOWN(:)*XDATA_GARDEN(:) * XDATA_VEGTYPE(:,NVT_TREE) 00621 ENDWHERE 00622 WHERE (XDATA_VEGTYPE(:,NVT_CONI)>0.) 00623 ZWEIGHT(:,NVT_CONI)=XDATA_TOWN(:)*XDATA_GARDEN(:) * XDATA_VEGTYPE(:,NVT_CONI) 00624 ENDWHERE 00625 WHERE (XDATA_VEGTYPE(:,NVT_EVER)>0.) 00626 ZWEIGHT(:,NVT_EVER)=XDATA_TOWN(:)*XDATA_GARDEN(:) * XDATA_VEGTYPE(:,NVT_EVER) 00627 ENDWHERE 00628 00629 CASE DEFAULT 00630 CALL ABOR1_SFX('AV_PATCH_PGD_1D: WEIGHTING FUNCTION FOR VEGTYPE NOT ALLOWED') 00631 END SELECT 00632 ! 00633 !------------------------------------------------------------------------------- 00634 DO JCOVER=1,ICOVER 00635 !------------------------------------------------------------------------------- 00636 ! 00637 !* 3. Averaging 00638 ! --------- 00639 ! 00640 !* 3.1 Work arrays given for each patch 00641 ! ----------- 00642 ! 00643 00644 ZDATA(:) = PDATA(JCOVER,:) 00645 00646 ! 00647 !* 3.2 Selection of averaging type 00648 ! --------------------------- 00649 ! 00650 SELECT CASE (HATYPE) 00651 ! 00652 !------------------------------------------------------------------------------- 00653 ! 00654 !* 3.3 Arithmetic averaging 00655 ! -------------------- 00656 ! 00657 CASE ('ARI') 00658 ! 00659 DO JVEGTYPE=1,NVEGTYPE 00660 JPATCH= PATCH_LIST(JVEGTYPE) 00661 DO JJ=1,SIZE(PCOVER,1) 00662 ZCOVER_WEIGHT(JJ,JVEGTYPE) = PCOVER(JJ,JCOVER) * ZWEIGHT(JCOVER,JVEGTYPE) 00663 ZSUM_COVER_WEIGHT_PATCH(JJ,JPATCH) = ZSUM_COVER_WEIGHT_PATCH(JJ,JPATCH) + ZCOVER_WEIGHT(JJ,JVEGTYPE) 00664 ZWORK(JJ,JPATCH) = ZWORK(JJ,JPATCH) + ZDATA(JVEGTYPE) * ZCOVER_WEIGHT(JJ,JVEGTYPE) 00665 ENDDO 00666 END DO 00667 ! 00668 !------------------------------------------------------------------------------- 00669 ! 00670 !* 3.4 Inverse averaging 00671 ! ----------------- 00672 ! 00673 CASE('INV' ) 00674 ! 00675 DO JVEGTYPE=1,NVEGTYPE 00676 JPATCH=PATCH_LIST(JVEGTYPE) 00677 DO JJ=1,SIZE(PCOVER,1) 00678 ZCOVER_WEIGHT(JJ,JVEGTYPE) = PCOVER(JJ,JCOVER) * ZWEIGHT(JCOVER,JVEGTYPE) 00679 ZSUM_COVER_WEIGHT_PATCH(JJ,JPATCH) = ZSUM_COVER_WEIGHT_PATCH(JJ,JPATCH)+ ZCOVER_WEIGHT(JJ,JVEGTYPE) 00680 ZWORK(JJ,JPATCH)= ZWORK(JJ,JPATCH) + 1./ ZDATA(JVEGTYPE) * ZCOVER_WEIGHT(JJ,JVEGTYPE) 00681 ENDDO 00682 END DO 00683 ! 00684 !-------------------------------------------------------------------------------! 00685 ! 00686 !* 3.5 Roughness length averaging 00687 ! -------------------------- 00688 00689 ! 00690 CASE('CDN') 00691 ! 00692 DO JVEGTYPE=1,NVEGTYPE 00693 JPATCH=PATCH_LIST(JVEGTYPE) 00694 DO JJ=1,SIZE(PCOVER,1) 00695 ZCOVER_WEIGHT(JJ,JVEGTYPE) = PCOVER(JJ,JCOVER) * ZWEIGHT(JCOVER,JVEGTYPE) 00696 ZSUM_COVER_WEIGHT_PATCH(JJ,JPATCH) = ZSUM_COVER_WEIGHT_PATCH(JJ,JPATCH)+ ZCOVER_WEIGHT(JJ,JVEGTYPE) 00697 ZWORK(JJ,JPATCH)= ZWORK(JJ,JPATCH) + 1./(LOG(ZDZ(JJ,JPATCH)/ ZDATA(JVEGTYPE)))**2 & 00698 * ZCOVER_WEIGHT(JJ,JVEGTYPE) 00699 ENDDO 00700 END DO 00701 ! 00702 !------------------------------------------------------------------------------- 00703 ! 00704 CASE DEFAULT 00705 CALL ABOR1_SFX('AV_PATCH_PGD_1D: (1) AVERAGING TYPE NOT ALLOWED') 00706 ! 00707 END SELECT 00708 ! 00709 END DO 00710 !------------------------------------------------------------------------------- 00711 ! 00712 !* 4. End of Averaging 00713 ! ---------------- 00714 ! 00715 NMASK(:,:)=0 00716 JCOUNT(:)=0 00717 DO JPATCH=1,IPATCH 00718 DO JJ=1,SIZE(PCOVER,1) 00719 IF ( ZSUM_COVER_WEIGHT_PATCH(JJ,JPATCH) >0.) THEN 00720 JCOUNT(JPATCH)=JCOUNT(JPATCH)+1 00721 NMASK(JCOUNT(JPATCH),JPATCH)=JJ 00722 ENDIF 00723 ENDDO 00724 ENDDO 00725 ! 00726 !* 4.1 Selection of averaging type 00727 ! --------------------------- 00728 ! 00729 SELECT CASE (HATYPE) 00730 ! 00731 !------------------------------------------------------------------------------- 00732 ! 00733 !* 4.2 Arithmetic averaging 00734 ! -------------------- 00735 ! 00736 CASE ('ARI') 00737 ! 00738 DO JPATCH=1,IPATCH 00739 !cdir nodep 00740 DO JJ=1,JCOUNT(JPATCH) 00741 JI = NMASK(JJ,JPATCH) 00742 PFIELD(JI,JPATCH) = ZWORK(JI,JPATCH) / ZSUM_COVER_WEIGHT_PATCH(JI,JPATCH) 00743 ENDDO 00744 ENDDO 00745 ! 00746 !------------------------------------------------------------------------------- 00747 ! 00748 !* 4.3 Inverse averaging 00749 ! ----------------- 00750 ! 00751 CASE('INV' ) 00752 ! 00753 DO JPATCH=1,IPATCH 00754 !cdir nodep 00755 DO JJ=1,JCOUNT(JPATCH) 00756 JI = NMASK(JJ,JPATCH) 00757 PFIELD(JI,JPATCH) = ZSUM_COVER_WEIGHT_PATCH(JI,JPATCH) / ZWORK(JI,JPATCH) 00758 ENDDO 00759 ENDDO 00760 !-------------------------------------------------------------------------------! 00761 ! 00762 !* 4.4 Roughness length averaging 00763 ! -------------------------- 00764 00765 ! 00766 CASE('CDN') 00767 ! 00768 DO JPATCH=1,IPATCH 00769 !cdir nodep 00770 DO JJ=1,JCOUNT(JPATCH) 00771 JI=NMASK(JJ,JPATCH) 00772 PFIELD(JI,JPATCH) = ZDZ(JI,JPATCH) * EXP( - SQRT(ZSUM_COVER_WEIGHT_PATCH(JI,JPATCH)/ZWORK(JI,JPATCH)) ) 00773 ENDDO 00774 ENDDO 00775 ! 00776 !------------------------------------------------------------------------------- 00777 ! 00778 CASE DEFAULT 00779 CALL ABOR1_SFX('AV_PATCH_PGD_1D: (2) AVERAGING TYPE NOT ALLOWED') 00780 ! 00781 END SELECT 00782 IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PATCH_PGD_1D',1,ZHOOK_HANDLE) 00783 !------------------------------------------------------------------------------- 00784 ! 00785 END SUBROUTINE AV_PATCH_PGD_1D 00786 ! 00787 ! ################################################################ 00788 SUBROUTINE AV_PGD(PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,PDZ,KDECADE) 00789 ! ################################################################ 00790 ! 00791 !!**** *AV_PGD* average a secondary physiographic variable from the 00792 !! fractions of coverage class. 00793 !! 00794 !! PURPOSE 00795 !! ------- 00796 !! 00797 !! METHOD 00798 !! ------ 00799 !! 00800 !! The averaging is performed with one way into three: 00801 !! 00802 !! - arithmetic averaging (HATYPE='ARI') 00803 !! 00804 !! - inverse averaging (HATYPE='INV') 00805 !! 00806 !! - inverse of square logarithm averaging (HATYPE='CDN') : 00807 !! 00808 !! 1 / ( ln (dz/data) )**2 00809 !! 00810 !! This latest uses (if available) the height of the first model mass 00811 !! level. In the other case, 20m is chosen. It works for roughness lengths. 00812 !! 00813 !! EXTERNAL 00814 !! -------- 00815 !! 00816 !! IMPLICIT ARGUMENTS 00817 !! ------------------ 00818 !! 00819 !! REFERENCE 00820 !! --------- 00821 !! 00822 !! AUTHOR 00823 !! ------ 00824 !! 00825 !! V. Masson Meteo-France 00826 !! 00827 !! MODIFICATION 00828 !! ------------ 00829 ! 00830 ! F.Solmon patch modif: remove the case 'veg' as veg is defined for patches 00831 ! 00832 !! Original 15/12/97 00833 !! V. Masson 01/2004 Externalization 00834 !! 00835 !---------------------------------------------------------------------------- 00836 ! 00837 !* 0. DECLARATION 00838 ! ----------- 00839 ! 00840 USE MODD_SURF_PAR, ONLY : XUNDEF 00841 USE MODD_DATA_COVER, ONLY : XDATA_SEA, XDATA_WATER, XDATA_VEGTYPE 00842 USE MODD_DATA_COVER_n, ONLY : XDATA_NATURE, XDATA_TOWN, XDATA_BLD, XDATA_GARDEN 00843 USE MODD_DATA_COVER_PAR, ONLY : NVT_TREE, NVT_CONI, NVT_EVER, XCDREF 00844 ! 00845 ! 00846 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00847 USE PARKIND1 ,ONLY : JPRB 00848 ! 00849 USE MODI_ABOR1_SFX 00850 ! 00851 IMPLICIT NONE 00852 ! 00853 !* 0.1 Declaration of arguments 00854 ! ------------------------ 00855 ! 00856 REAL, DIMENSION(:,:), INTENT(OUT) :: PFIELD ! secondary field to construct 00857 REAL, DIMENSION(:,:,:), INTENT(IN) :: PCOVER ! fraction of each cover class 00858 REAL, DIMENSION(:), INTENT(IN) :: PDATA ! secondary field value for each class 00859 CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field 00860 ! is defined 00861 CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging 00862 REAL, DIMENSION(:,:), INTENT(IN), OPTIONAL :: PDZ ! first model half level 00863 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month 00864 ! 00865 !* 0.2 Declaration of local variables 00866 ! ------------------------------ 00867 ! 00868 ! 00869 INTEGER :: ICOVER ! number of cover classes 00870 INTEGER :: JCOVER ! loop on cover classes 00871 ! 00872 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2)) :: ZWORK, ZDZ 00873 REAL :: ZWEIGHT 00874 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2)) :: ZCOVER_WEIGHT 00875 REAL :: ZDATA 00876 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2)) :: ZSUM_COVER_WEIGHT 00877 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00878 !------------------------------------------------------------------------------- 00879 ! 00880 !* 1.1 field does not exist 00881 ! -------------------- 00882 ! 00883 IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PGD',0,ZHOOK_HANDLE) 00884 IF (SIZE(PFIELD)==0 .AND. LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PGD',1,ZHOOK_HANDLE) 00885 IF (SIZE(PFIELD)==0) RETURN 00886 ! 00887 !------------------------------------------------------------------------------- 00888 ! 00889 !* 1.2 Initializations 00890 ! --------------- 00891 ! 00892 ICOVER=SIZE(PCOVER,3) 00893 ! 00894 IF (PRESENT(PDZ)) THEN 00895 ZDZ(:,:)=PDZ(:,:) 00896 ELSE 00897 ZDZ(:,:)=XCDREF 00898 END IF 00899 ! 00900 PFIELD(:,:)=XUNDEF 00901 ! 00902 ZWORK(:,:)=0. 00903 ZSUM_COVER_WEIGHT(:,:)=0. 00904 !------------------------------------------------------------------------------- 00905 DO JCOVER=1,ICOVER 00906 !------------------------------------------------------------------------------- 00907 ! 00908 !* 2. Selection of the weighting function 00909 ! ----------------------------------- 00910 ! 00911 SELECT CASE (HSFTYPE) 00912 CASE('ALL') 00913 ZWEIGHT=1. 00914 00915 CASE('NAT') 00916 ZWEIGHT=XDATA_NATURE(JCOVER) 00917 00918 CASE('GRD') 00919 ZWEIGHT=XDATA_TOWN (JCOVER) * XDATA_GARDEN(JCOVER) 00920 00921 CASE('TWN') 00922 ZWEIGHT=XDATA_TOWN (JCOVER) 00923 00924 CASE('WAT') 00925 ZWEIGHT=XDATA_WATER (JCOVER) 00926 00927 CASE('SEA') 00928 ZWEIGHT=XDATA_SEA (JCOVER) 00929 00930 CASE('BLD') 00931 ZWEIGHT=XDATA_TOWN (JCOVER) * XDATA_BLD(JCOVER) 00932 00933 CASE('STR') 00934 ZWEIGHT=XDATA_TOWN (JCOVER) * ( 1. - XDATA_BLD(JCOVER) ) 00935 00936 CASE('TRE') 00937 PFIELD(:,:)=0. 00938 ZWEIGHT=XDATA_NATURE(JCOVER) * ( XDATA_VEGTYPE(JCOVER,NVT_TREE) & 00939 + XDATA_VEGTYPE(JCOVER,NVT_EVER) & 00940 + XDATA_VEGTYPE(JCOVER,NVT_CONI) ) 00941 00942 CASE('GRT') 00943 PFIELD(:,:)=0. 00944 ZWEIGHT=XDATA_TOWN (JCOVER) * XDATA_GARDEN(JCOVER) & 00945 * ( XDATA_VEGTYPE(JCOVER,NVT_TREE) & 00946 + XDATA_VEGTYPE(JCOVER,NVT_EVER) & 00947 + XDATA_VEGTYPE(JCOVER,NVT_CONI) ) 00948 00949 CASE DEFAULT 00950 CALL ABOR1_SFX('AV_PGD: WEIGHTING FUNCTION NOT ALLOWED') 00951 END SELECT 00952 ! 00953 !------------------------------------------------------------------------------- 00954 ! 00955 !* 3. Averaging 00956 ! --------- 00957 ! 00958 !* 3.1 Work arrays 00959 ! ----------- 00960 ! 00961 ZCOVER_WEIGHT(:,:) = PCOVER(:,:,JCOVER) * ZWEIGHT 00962 ! 00963 ZSUM_COVER_WEIGHT(:,:) = ZSUM_COVER_WEIGHT(:,:) + ZCOVER_WEIGHT(:,:) 00964 ! 00965 ZDATA = PDATA(JCOVER) 00966 ! 00967 !* 3.2 Selection of averaging type 00968 ! --------------------------- 00969 ! 00970 SELECT CASE (HATYPE) 00971 ! 00972 !------------------------------------------------------------------------------- 00973 ! 00974 !* 3.4 Arithmetic averaging 00975 ! -------------------- 00976 ! 00977 CASE ('ARI') 00978 ! 00979 ZWORK(:,:) = ZWORK(:,:) + ZDATA * ZCOVER_WEIGHT(:,:) 00980 ! 00981 !------------------------------------------------------------------------------- 00982 ! 00983 !* 3.5 Inverse averaging 00984 ! ----------------- 00985 ! 00986 CASE('INV' ) 00987 ! 00988 ZWORK (:,:)= ZWORK(:,:) + 1./ZDATA * ZCOVER_WEIGHT(:,:) 00989 ! 00990 !-------------------------------------------------------------------------------! 00991 ! 00992 !* 3.6 Roughness length averaging 00993 ! -------------------------- 00994 00995 ! 00996 CASE('CDN') 00997 ! 00998 ZWORK (:,:)= ZWORK(:,:) + 1./(LOG(ZDZ(:,:)/ZDATA))**2 * ZCOVER_WEIGHT(:,:) 00999 ! 01000 !------------------------------------------------------------------------------- 01001 ! 01002 CASE DEFAULT 01003 CALL ABOR1_SFX('AV_PGD: (1) AVERAGING TYPE NOT ALLOWED') 01004 ! 01005 END SELECT 01006 ! 01007 END DO 01008 ! 01009 !------------------------------------------------------------------------------- 01010 ! 01011 !* 4. End of Averaging 01012 ! ---------------- 01013 ! 01014 !* 4.1 Selection of averaging type 01015 ! --------------------------- 01016 ! 01017 SELECT CASE (HATYPE) 01018 ! 01019 !------------------------------------------------------------------------------- 01020 ! 01021 !* 4.2 Arithmetic averaging 01022 ! -------------------- 01023 ! 01024 CASE ('ARI') 01025 ! 01026 WHERE ( ZSUM_COVER_WEIGHT(:,:) >0. ) 01027 PFIELD(:,:) = ZWORK(:,:) / ZSUM_COVER_WEIGHT(:,:) 01028 END WHERE 01029 ! 01030 !------------------------------------------------------------------------------- 01031 ! 01032 !* 4.3 Inverse averaging 01033 ! ----------------- 01034 ! 01035 CASE('INV' ) 01036 ! 01037 WHERE ( ZSUM_COVER_WEIGHT(:,:) >0. ) 01038 PFIELD(:,:) = ZSUM_COVER_WEIGHT(:,:) / ZWORK(:,:) 01039 END WHERE 01040 ! 01041 !-------------------------------------------------------------------------------! 01042 ! 01043 !* 4.4 Roughness length averaging 01044 ! -------------------------- 01045 01046 ! 01047 CASE('CDN') 01048 ! 01049 WHERE ( ZSUM_COVER_WEIGHT(:,:) >0. ) 01050 PFIELD(:,:) = ZDZ(:,:) * EXP( - SQRT(ZSUM_COVER_WEIGHT(:,:)/ZWORK(:,:)) ) 01051 END WHERE 01052 ! 01053 !------------------------------------------------------------------------------- 01054 ! 01055 CASE DEFAULT 01056 CALL ABOR1_SFX('AV_PGD: (2) AVERAGING TYPE NOT ALLOWED') 01057 ! 01058 END SELECT 01059 IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PGD',1,ZHOOK_HANDLE) 01060 ! 01061 ! 01062 !------------------------------------------------------------------------------- 01063 ! 01064 END SUBROUTINE AV_PGD 01065 ! 01066 ! 01067 ! 01068 ! ################################################################ 01069 SUBROUTINE AV_PATCH_PGD(PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,PDZ,KDECADE) 01070 ! ################################################################ 01071 ! 01072 !!**** *AV_PATCH_PGD* average for each surface patch a secondary physiographic 01073 !! variable from the 01074 !! fractions of coverage class. 01075 !! 01076 !! PURPOSE 01077 !! ------- 01078 !! 01079 !! METHOD 01080 !! ------ 01081 !! 01082 !! The averaging is performed with one way into three: 01083 !! 01084 !! - arithmetic averaging (HATYPE='ARI') 01085 !! 01086 !! - inverse averaging (HATYPE='INV') 01087 !! 01088 !! - inverse of square logarithm averaging (HATYPE='CDN') : 01089 !! 01090 !! 1 / ( ln (dz/data) )**2 01091 !! 01092 !! This latest uses (if available) the height of the first model mass 01093 !! level. In the other case, 20m is chosen. It works for roughness lengths. 01094 !! 01095 !! EXTERNAL 01096 !! -------- 01097 !! 01098 !! IMPLICIT ARGUMENTS 01099 !! ------------------ 01100 !! 01101 !! REFERENCE 01102 !! --------- 01103 !! 01104 !! AUTHOR 01105 !! ------ 01106 !! 01107 !! F.Solmon /V. Masson 01108 !! 01109 !! MODIFICATION 01110 !! ------------ 01111 !! 01112 !! Original 15/12/97 01113 !! V. Masson 01/2004 Externalization 01114 !! 01115 !---------------------------------------------------------------------------- 01116 ! 01117 !* 0. DECLARATION 01118 ! ----------- 01119 ! 01120 USE MODD_SURF_PAR, ONLY : XUNDEF 01121 USE MODD_DATA_COVER, ONLY : XDATA_SEA, XDATA_WATER, XDATA_VEGTYPE, XDATA_VEG, XDATA_LAI 01122 USE MODD_DATA_COVER_n, ONLY : XDATA_NATURE, XDATA_TOWN, XDATA_BLD, XDATA_GARDEN 01123 USE MODD_DATA_COVER_PAR, ONLY : NVT_TREE, NVT_CONI, NVT_EVER, NVEGTYPE, XCDREF 01124 ! 01125 USE MODI_VEGTYPE_TO_PATCH 01126 ! 01127 ! 01128 ! 01129 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 01130 USE PARKIND1 ,ONLY : JPRB 01131 ! 01132 USE MODI_ABOR1_SFX 01133 ! 01134 IMPLICIT NONE 01135 ! 01136 !* 0.1 Declaration of arguments 01137 ! ------------------------ 01138 ! 01139 REAL, DIMENSION(:,:,:), INTENT(OUT) :: PFIELD ! secondary field to construct 01140 REAL, DIMENSION(:,:,:), INTENT(IN) :: PCOVER ! fraction of each cover class 01141 REAL, DIMENSION(:,:), INTENT(IN) :: PDATA ! secondary field value for each class 01142 CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field 01143 ! is defined 01144 CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging 01145 REAL, DIMENSION(:,:), INTENT(IN), OPTIONAL :: PDZ ! first model half level 01146 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month 01147 ! 01148 !* 0.2 Declaration of local variables 01149 ! ------------------------------ 01150 ! 01151 ! 01152 INTEGER :: ICOVER ! number of cover classes 01153 INTEGER :: JCOVER ! loop on cover classes 01154 ! 01155 ! nbe of vegtype 01156 ! nbre of patches 01157 INTEGER :: JVEGTYPE! loop on vegtype 01158 INTEGER :: IPATCH ! number of patches 01159 INTEGER :: JPATCH ! PATCH index 01160 ! 01161 REAL, DIMENSION(NVEGTYPE) :: ZWEIGHT 01162 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),NVEGTYPE) :: ZCOVER_WEIGHT 01163 ! 01164 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),SIZE(PFIELD,3)):: ZCOVER_WEIGHT_PATCH 01165 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),SIZE(PFIELD,3)):: ZSUM_COVER_WEIGHT_PATCH 01166 REAL, DIMENSION(NVEGTYPE) :: ZDATA 01167 ! 01168 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),SIZE(PFIELD,3)):: ZWORK 01169 REAL, DIMENSION(SIZE(PCOVER,1),SIZE(PCOVER,2),SIZE(PFIELD,3)):: ZDZ 01170 REAL(KIND=JPRB) :: ZHOOK_HANDLE 01171 !------------------------------------------------------------------------------- 01172 ! 01173 !* 1.1 field does not exist 01174 ! -------------------- 01175 ! 01176 IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PATCH_PGD',0,ZHOOK_HANDLE) 01177 IF (SIZE(PFIELD)==0 .AND. LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PATCH_PGD',1,ZHOOK_HANDLE) 01178 IF (SIZE(PFIELD)==0) RETURN 01179 ! 01180 !------------------------------------------------------------------------------- 01181 ! 01182 !* 1.2 Initializations 01183 ! --------------- 01184 ! 01185 ICOVER=SIZE(PCOVER,3) 01186 IPATCH=SIZE(PFIELD,3) 01187 ! 01188 ! 01189 ! 01190 IF (PRESENT(PDZ)) THEN 01191 DO JPATCH=1,IPATCH 01192 ZDZ(:,:,JPATCH)=PDZ(:,:) 01193 END DO 01194 ELSE 01195 ZDZ(:,:,:)=XCDREF 01196 END IF 01197 ! 01198 PFIELD(:,:,:)=XUNDEF 01199 ! 01200 ZWORK(:,:,:)=0. 01201 ZSUM_COVER_WEIGHT_PATCH(:,:,:)=0. 01202 ! 01203 !------------------------------------------------------------------------------- 01204 DO JCOVER=1,ICOVER 01205 !------------------------------------------------------------------------------- 01206 ! 01207 !* 2. Selection of the weighting function for vegtype 01208 ! ----------------------------------- 01209 ! 01210 SELECT CASE (HSFTYPE) 01211 01212 CASE('NAT') 01213 DO JVEGTYPE=1,NVEGTYPE 01214 ZWEIGHT(JVEGTYPE)=XDATA_NATURE(JCOVER)*XDATA_VEGTYPE(JCOVER,JVEGTYPE) 01215 END DO 01216 01217 CASE('GRD') 01218 DO JVEGTYPE=1,NVEGTYPE 01219 ZWEIGHT(JVEGTYPE)=XDATA_TOWN(JCOVER)*XDATA_GARDEN(JCOVER)*XDATA_VEGTYPE(JCOVER,JVEGTYPE) 01220 END DO 01221 01222 CASE('VEG') 01223 DO JVEGTYPE=1,NVEGTYPE 01224 ZWEIGHT(JVEGTYPE)=XDATA_NATURE(JCOVER)*XDATA_VEGTYPE(JCOVER,JVEGTYPE)*& 01225 XDATA_VEG(JCOVER,KDECADE,JVEGTYPE) 01226 END DO 01227 01228 CASE('BAR') 01229 DO JVEGTYPE=1,NVEGTYPE 01230 ZWEIGHT(JVEGTYPE)=XDATA_NATURE(JCOVER)*XDATA_VEGTYPE(JCOVER,JVEGTYPE)*& 01231 (1.-XDATA_VEG(JCOVER,KDECADE,JVEGTYPE)) 01232 END DO 01233 01234 CASE('GRV') 01235 DO JVEGTYPE=1,NVEGTYPE 01236 ZWEIGHT(JVEGTYPE)=XDATA_TOWN(JCOVER)*XDATA_GARDEN(JCOVER)*XDATA_VEGTYPE(JCOVER,JVEGTYPE)*& 01237 XDATA_VEG(JCOVER,KDECADE,JVEGTYPE) 01238 END DO 01239 01240 CASE('GRB') 01241 DO JVEGTYPE=1,NVEGTYPE 01242 ZWEIGHT(JVEGTYPE)=XDATA_TOWN(JCOVER)*XDATA_GARDEN(JCOVER)*XDATA_VEGTYPE(JCOVER,JVEGTYPE)*& 01243 (1.-XDATA_VEG(JCOVER,KDECADE,JVEGTYPE)) 01244 ENDDO 01245 01246 CASE('DVG') ! average only on vegetated area 01247 ZWEIGHT(:) = 0.0 01248 DO JVEGTYPE=1,NVEGTYPE 01249 IF ( SUM(XDATA_LAI(JCOVER,:,JVEGTYPE)).GT.0.) & 01250 ZWEIGHT(JVEGTYPE)=XDATA_NATURE(JCOVER)*XDATA_VEGTYPE(JCOVER,JVEGTYPE) 01251 END DO 01252 01253 CASE('GDV') ! average only on vegetated area 01254 ZWEIGHT(:) = 0.0 01255 DO JVEGTYPE=1,NVEGTYPE 01256 IF ( SUM(XDATA_LAI(JCOVER,:,JVEGTYPE)).GT.0.) & 01257 ZWEIGHT(JVEGTYPE)=XDATA_TOWN(JCOVER)*XDATA_GARDEN(JCOVER)*XDATA_VEGTYPE(JCOVER,JVEGTYPE) 01258 END DO 01259 01260 CASE('LAI') 01261 DO JVEGTYPE=1,NVEGTYPE 01262 ZWEIGHT(JVEGTYPE)=XDATA_NATURE(JCOVER)*XDATA_VEGTYPE(JCOVER,JVEGTYPE)*& 01263 XDATA_LAI(JCOVER,KDECADE,JVEGTYPE) 01264 END DO 01265 01266 CASE('GRL') 01267 DO JVEGTYPE=1,NVEGTYPE 01268 ZWEIGHT(JVEGTYPE)=XDATA_TOWN(JCOVER)*XDATA_GARDEN(JCOVER)*XDATA_VEGTYPE(JCOVER,JVEGTYPE)*& 01269 XDATA_LAI(JCOVER,KDECADE,JVEGTYPE) 01270 END DO 01271 01272 CASE('TRE') 01273 ZWEIGHT(:)=0. 01274 IF (XDATA_VEGTYPE(JCOVER,NVT_TREE)>0.) THEN 01275 ZWEIGHT(NVT_TREE)=XDATA_NATURE(JCOVER) * XDATA_VEGTYPE(JCOVER,NVT_TREE) 01276 END IF 01277 IF (XDATA_VEGTYPE(JCOVER,NVT_CONI)>0.) THEN 01278 ZWEIGHT(NVT_CONI)=XDATA_NATURE(JCOVER) * XDATA_VEGTYPE(JCOVER,NVT_CONI) 01279 END IF 01280 IF (XDATA_VEGTYPE(JCOVER,NVT_EVER)>0.) THEN 01281 ZWEIGHT(NVT_EVER)=XDATA_NATURE(JCOVER) * XDATA_VEGTYPE(JCOVER,NVT_EVER) 01282 END IF 01283 01284 CASE('GRT') 01285 ZWEIGHT(:)=0. 01286 IF (XDATA_VEGTYPE(JCOVER,NVT_TREE)>0.) THEN 01287 ZWEIGHT(NVT_TREE)=XDATA_TOWN(JCOVER)*XDATA_GARDEN(JCOVER) * XDATA_VEGTYPE(JCOVER,NVT_TREE) 01288 END IF 01289 IF (XDATA_VEGTYPE(JCOVER,NVT_CONI)>0.) THEN 01290 ZWEIGHT(NVT_CONI)=XDATA_TOWN(JCOVER)*XDATA_GARDEN(JCOVER) * XDATA_VEGTYPE(JCOVER,NVT_CONI) 01291 END IF 01292 IF (XDATA_VEGTYPE(JCOVER,NVT_EVER)>0.) THEN 01293 ZWEIGHT(NVT_EVER)=XDATA_TOWN(JCOVER)*XDATA_GARDEN(JCOVER) * XDATA_VEGTYPE(JCOVER,NVT_EVER) 01294 END IF 01295 01296 CASE DEFAULT 01297 CALL ABOR1_SFX('AV_PATCH_PGD: WEIGHTING FUNCTION FOR VEGTYPE NOT ALLOWED') 01298 END SELECT 01299 ! 01300 !------------------------------------------------------------------------------- 01301 ! 01302 !* 3. Averaging 01303 ! --------- 01304 ! 01305 !* 3.1 Work arrays given for each patch 01306 ! ----------- 01307 ! 01308 ZCOVER_WEIGHT(:,:,:)=0. 01309 ZCOVER_WEIGHT_PATCH(:,:,:)=0. 01310 01311 DO JVEGTYPE=1,NVEGTYPE 01312 ZCOVER_WEIGHT(:,:,JVEGTYPE) = ZCOVER_WEIGHT(:,:,JVEGTYPE) +& 01313 PCOVER(:,:,JCOVER) * ZWEIGHT(JVEGTYPE) 01314 01315 JPATCH= VEGTYPE_TO_PATCH (JVEGTYPE, IPATCH) 01316 01317 ZCOVER_WEIGHT_PATCH(:,:,JPATCH) = ZCOVER_WEIGHT_PATCH(:,:,JPATCH)+ & 01318 PCOVER(:,:,JCOVER) * ZWEIGHT(JVEGTYPE) 01319 END DO 01320 01321 ! 01322 ZSUM_COVER_WEIGHT_PATCH(:,:,:) = ZSUM_COVER_WEIGHT_PATCH(:,:,:) + ZCOVER_WEIGHT_PATCH(:,:,:) 01323 01324 01325 ZDATA(:) = PDATA(JCOVER,:) 01326 01327 ! 01328 !* 3.2 Selection of averaging type 01329 ! --------------------------- 01330 ! 01331 SELECT CASE (HATYPE) 01332 ! 01333 !------------------------------------------------------------------------------- 01334 ! 01335 !* 3.3 Arithmetic averaging 01336 ! -------------------- 01337 ! 01338 CASE ('ARI') 01339 ! 01340 DO JVEGTYPE=1,NVEGTYPE 01341 JPATCH= VEGTYPE_TO_PATCH (JVEGTYPE,IPATCH) 01342 ZWORK(:,:,JPATCH) = ZWORK(:,:,JPATCH) + ZDATA(JVEGTYPE) & 01343 * ZCOVER_WEIGHT(:,:,JVEGTYPE) 01344 END DO 01345 ! 01346 !------------------------------------------------------------------------------- 01347 ! 01348 !* 3.4 Inverse averaging 01349 ! ----------------- 01350 ! 01351 CASE('INV' ) 01352 ! 01353 DO JVEGTYPE=1,NVEGTYPE 01354 JPATCH=VEGTYPE_TO_PATCH (JVEGTYPE,IPATCH) 01355 ZWORK(:,:,JPATCH)= ZWORK(:,:,JPATCH) + 1./ ZDATA(JVEGTYPE) & 01356 * ZCOVER_WEIGHT(:,:,JVEGTYPE) 01357 END DO 01358 ! 01359 !-------------------------------------------------------------------------------! 01360 ! 01361 !* 3.5 Roughness length averaging 01362 ! -------------------------- 01363 01364 ! 01365 CASE('CDN') 01366 ! 01367 DO JVEGTYPE=1,NVEGTYPE 01368 JPATCH=VEGTYPE_TO_PATCH (JVEGTYPE,IPATCH) 01369 ZWORK(:,:,JPATCH)= ZWORK(:,:,JPATCH) + 1./(LOG(ZDZ(:,:,JPATCH)/ ZDATA(JVEGTYPE)))**2 & 01370 * ZCOVER_WEIGHT(:,:,JVEGTYPE) 01371 END DO 01372 ! 01373 !------------------------------------------------------------------------------- 01374 ! 01375 CASE DEFAULT 01376 CALL ABOR1_SFX('AV_PATCH_PGD: (1) AVERAGING TYPE NOT ALLOWED') 01377 ! 01378 END SELECT 01379 ! 01380 END DO 01381 !------------------------------------------------------------------------------- 01382 ! 01383 !* 4. End of Averaging 01384 ! ---------------- 01385 ! 01386 !* 4.1 Selection of averaging type 01387 ! --------------------------- 01388 ! 01389 SELECT CASE (HATYPE) 01390 ! 01391 !------------------------------------------------------------------------------- 01392 ! 01393 !* 4.2 Arithmetic averaging 01394 ! -------------------- 01395 ! 01396 CASE ('ARI') 01397 ! 01398 WHERE ( ZSUM_COVER_WEIGHT_PATCH(:,:,:) >0. ) 01399 PFIELD(:,:,:) = ZWORK(:,:,:) / ZSUM_COVER_WEIGHT_PATCH(:,:,:) 01400 END WHERE 01401 ! 01402 !------------------------------------------------------------------------------- 01403 ! 01404 !* 4.3 Inverse averaging 01405 ! ----------------- 01406 ! 01407 CASE('INV' ) 01408 ! 01409 WHERE ( ZSUM_COVER_WEIGHT_PATCH(:,:,:) >0. ) 01410 PFIELD(:,:,:) = ZSUM_COVER_WEIGHT_PATCH(:,:,:) / ZWORK(:,:,:) 01411 END WHERE 01412 !-------------------------------------------------------------------------------! 01413 ! 01414 !* 4.4 Roughness length averaging 01415 ! -------------------------- 01416 01417 ! 01418 CASE('CDN') 01419 ! 01420 WHERE ( ZSUM_COVER_WEIGHT_PATCH(:,:,:) >0. ) 01421 PFIELD(:,:,:) = ZDZ(:,:,:) * EXP( - SQRT(ZSUM_COVER_WEIGHT_PATCH(:,:,:)/ZWORK(:,:,:)) ) 01422 END WHERE 01423 ! 01424 !------------------------------------------------------------------------------- 01425 ! 01426 CASE DEFAULT 01427 CALL ABOR1_SFX('AV_PATCH_PGD: (2) AVERAGING TYPE NOT ALLOWED') 01428 ! 01429 END SELECT 01430 IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:AV_PATCH_PGD',1,ZHOOK_HANDLE) 01431 !------------------------------------------------------------------------------- 01432 ! 01433 END SUBROUTINE AV_PATCH_PGD 01434 ! 01435 ! ################################################################ 01436 SUBROUTINE MAJOR_PATCH_PGD_1D(TFIELD,PCOVER,TDATA,HSFTYPE,HATYPE,KDECADE) 01437 ! ################################################################ 01438 ! 01439 !!**** *MAJOR_PATCH_PGD* find the dominant date for each vegetation type 01440 !! 01441 !! PURPOSE 01442 !! ------- 01443 !! 01444 !! METHOD 01445 !! ------ 01446 !! 01447 !! EXTERNAL 01448 !! -------- 01449 !! 01450 !! IMPLICIT ARGUMENTS 01451 !! ------------------ 01452 !! 01453 !! REFERENCE 01454 !! --------- 01455 !! 01456 !! AUTHOR 01457 !! ------ 01458 !! 01459 !! P. LE MOIGNE 01460 !! 01461 !! MODIFICATION 01462 !! ------------ 01463 !! 01464 !! Original 06/2006 01465 !! 01466 !---------------------------------------------------------------------------- 01467 ! 01468 !* 0. DECLARATION 01469 ! ----------- 01470 ! 01471 USE MODD_TYPE_DATE_SURF 01472 USE MODD_SURF_PAR, ONLY : XUNDEF, NUNDEF 01473 USE MODD_DATA_COVER_PAR, ONLY : NVT_TREE, NVT_CONI, NVT_EVER, NVEGTYPE, XCDREF 01474 ! 01475 USE MODI_VEGTYPE_TO_PATCH 01476 ! 01477 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 01478 USE PARKIND1 ,ONLY : JPRB 01479 ! 01480 IMPLICIT NONE 01481 ! 01482 !* 0.1 Declaration of arguments 01483 ! ------------------------ 01484 ! 01485 TYPE (DATE_TIME), DIMENSION(:,:), INTENT(OUT) :: TFIELD ! secondary field to construct 01486 REAL, DIMENSION(:,:), INTENT(IN) :: PCOVER ! fraction of each cover class 01487 TYPE (DATE_TIME), DIMENSION(:,:), INTENT(IN) :: TDATA ! secondary field value for each class 01488 CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE ! Type of surface where the field 01489 ! is defined 01490 CHARACTER(LEN=3), INTENT(IN) :: HATYPE ! Type of averaging 01491 INTEGER, INTENT(IN), OPTIONAL :: KDECADE ! current month 01492 ! 01493 !* 0.2 Declaration of local variables 01494 ! ------------------------------ 01495 ! 01496 ! 01497 INTEGER :: ICOVER ! number of cover classes 01498 INTEGER :: JCOVER ! loop on cover classes 01499 ! 01500 INTEGER :: JVEGTYPE! loop on vegtype 01501 ! 01502 INTEGER, DIMENSION(SIZE(PCOVER,2),NVEGTYPE) :: IDATA_DOY 01503 INTEGER, DIMENSION(SIZE(PCOVER,1)) :: IDOY 01504 REAL, DIMENSION(365) :: ZCOUNT 01505 INTEGER :: JP, IMONTH, IDAY 01506 INTEGER :: IPATCH, JPATCH 01507 REAL(KIND=JPRB) :: ZHOOK_HANDLE 01508 !------------------------------------------------------------------------------- 01509 ! 01510 !* 1.1 field does not exist 01511 ! -------------------- 01512 ! 01513 IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:MAJOR_PATCH_PGD_1D',0,ZHOOK_HANDLE) 01514 IF (SIZE(TFIELD)==0 .AND. LHOOK) CALL DR_HOOK('MODI_AV_PGD:MAJOR_PATCH_PGD_1D',1,ZHOOK_HANDLE) 01515 IF (SIZE(TFIELD)==0) RETURN 01516 ! 01517 !------------------------------------------------------------------------------- 01518 ! 01519 !* 1.2 Initializations 01520 ! --------------- 01521 ! 01522 ICOVER=SIZE(PCOVER,2) 01523 IPATCH=SIZE(TFIELD,2) 01524 ! 01525 TFIELD(:,:)%TDATE%YEAR = NUNDEF 01526 TFIELD(:,:)%TDATE%MONTH = NUNDEF 01527 TFIELD(:,:)%TDATE%DAY = NUNDEF 01528 TFIELD(:,:)%TIME = 0. 01529 ! 01530 CALL DATE2DOY(TDATA,IDATA_DOY) 01531 !------------------------------------------------------------------------------- 01532 DO JP = 1, SIZE(PCOVER,1) 01533 01534 DO JPATCH=1,IPATCH 01535 ! 01536 ZCOUNT(:) = 0. 01537 ! 01538 DO JVEGTYPE=1,NVEGTYPE 01539 ! 01540 IF(JPATCH==VEGTYPE_TO_PATCH(JVEGTYPE,IPATCH)) THEN 01541 ! 01542 DO JCOVER=1,ICOVER 01543 ! 01544 IF (IDATA_DOY(JCOVER,JVEGTYPE) /= NUNDEF) THEN 01545 ! 01546 ZCOUNT(IDATA_DOY(JCOVER,JVEGTYPE)) = ZCOUNT(IDATA_DOY(JCOVER,JVEGTYPE)) + PCOVER(JP,JCOVER) 01547 ! 01548 END IF 01549 ! 01550 END DO 01551 ! 01552 ENDIF 01553 ! 01554 IDOY(JP) = MAXLOC(ZCOUNT,1) 01555 CALL DOY2DATE(IDOY(JP),IMONTH,IDAY) 01556 ! 01557 TFIELD(JP,JPATCH)%TDATE%MONTH = IMONTH 01558 TFIELD(JP,JPATCH)%TDATE%DAY = IDAY 01559 ! 01560 END DO 01561 ! 01562 END DO 01563 ! 01564 END DO 01565 ! 01566 !------------------------------------------------------------------------------- 01567 ! 01568 IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:MAJOR_PATCH_PGD_1D',1,ZHOOK_HANDLE) 01569 CONTAINS 01570 01571 SUBROUTINE DATE2DOY(TPDATA, KDOY) 01572 TYPE (DATE_TIME), DIMENSION(SIZE(PCOVER,2),NVEGTYPE) :: TPDATA 01573 INTEGER, DIMENSION(SIZE(PCOVER,2),NVEGTYPE) :: KDOY 01574 INTEGER, DIMENSION(SIZE(PCOVER,2),NVEGTYPE) :: IMONTH, IDAY 01575 INTEGER, PARAMETER, DIMENSION(12) :: TAB=(/1,32,60,91,121,152,182,213,244,274,305,335/) 01576 INTEGER :: JCOVER 01577 REAL(KIND=JPRB) :: ZHOOK_HANDLE 01578 01579 IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:DATE2DOY',0,ZHOOK_HANDLE) 01580 IMONTH(:,:) = TPDATA(:,:)%TDATE%MONTH 01581 IDAY(:,:) = TPDATA(:,:)%TDATE%DAY 01582 KDOY(:,:) = NUNDEF 01583 01584 DO JCOVER = 1, SIZE(PCOVER,2) 01585 DO JVEGTYPE = 1, NVEGTYPE 01586 IF (IMONTH(JCOVER,JVEGTYPE)/=NUNDEF .AND. IDAY(JCOVER,JVEGTYPE) /= NUNDEF) THEN 01587 KDOY(JCOVER,JVEGTYPE) = TAB(IMONTH(JCOVER,JVEGTYPE)) + IDAY(JCOVER,JVEGTYPE) - 1 01588 ENDIF 01589 END DO 01590 END DO 01591 IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:DATE2DOY',1,ZHOOK_HANDLE) 01592 01593 END SUBROUTINE DATE2DOY 01594 01595 SUBROUTINE DOY2DATE(KDOY,KMONTH,KDAY) 01596 INTEGER :: KDOY, KMONTH, KDAY 01597 REAL :: ZWORK(12) 01598 INTEGER, PARAMETER, DIMENSION(12) :: ZTAB=(/31.,59.,90.,120.,151.,181.,212.,243.,273.,304.,334.,365./) 01599 INTEGER :: J 01600 REAL(KIND=JPRB) :: ZHOOK_HANDLE 01601 01602 IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:DOY2DATE',0,ZHOOK_HANDLE) 01603 KMONTH = NUNDEF 01604 KDAY = NUNDEF 01605 01606 ZWORK(1) = REAL(KDOY) / ZTAB(1) 01607 DO J = 2, 12 01608 ZWORK(J) = REAL(KDOY) / ZTAB(J) 01609 IF ( INT(ZWORK(J))==0 .AND. INT(ZWORK(J-1))==1 ) THEN 01610 KMONTH = J 01611 KDAY = KDOY - INT(ZTAB(J-1)) 01612 ENDIF 01613 END DO 01614 IF (LHOOK) CALL DR_HOOK('MODI_AV_PGD:DOY2DATE',1,ZHOOK_HANDLE) 01615 01616 END SUBROUTINE DOY2DATE 01617 !------------------------------------------------------------------------------- 01618 ! 01619 END SUBROUTINE MAJOR_PATCH_PGD_1D
1.8.0
