SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/SURFEX/av_pgd

Go to the documentation of this file.
00001 !     ################################################################
00002       SUBROUTINE AV_PGD_PARAM(PFIELD,PVEGTYPE,PDATA,HSFTYPE,HATYPE,PDZ,KDECADE)
00003 !     ################################################################
00004 !
00005 !!**** *AV_PATCH_PGD* average for each surface patch a secondary physiographic 
00006 !!                    variable from the
00007 !!              fractions of coverage class.
00008 !!
00009 !!    PURPOSE
00010 !!    -------
00011 !!
00012 !!    METHOD
00013 !!    ------
00014 !!
00015 !!    The averaging is performed with one way into three:
00016 !!
00017 !!    - arithmetic averaging (HATYPE='ARI')
00018 !!
00019 !!    - inverse    averaging (HATYPE='INV')
00020 !!
00021 !!    - inverse of square logarithm averaging (HATYPE='CDN') :
00022 !!
00023 !!      1 / ( ln (dz/data) )**2
00024 !!
00025 !!      This latest uses (if available) the height of the first model mass
00026 !!      level. In the other case, 20m is chosen. It works for roughness lengths.
00027 !!
00028 !!    EXTERNAL
00029 !!    --------
00030 !!
00031 !!    IMPLICIT ARGUMENTS
00032 !!    ------------------
00033 !!
00034 !!    REFERENCE
00035 !!    ---------
00036 !!
00037 !!    AUTHOR
00038 !!    ------
00039 !!
00040 !!    F.Solmon /V. Masson       
00041 !!
00042 !!    MODIFICATION
00043 !!    ------------
00044 !!
00045 !!    Original    15/12/97
00046 !!    V. Masson   01/2004  Externalization
00047 !!
00048 !----------------------------------------------------------------------------
00049 !
00050 !*    0.     DECLARATION
00051 !            -----------
00052 !
00053 USE MODD_SURF_PAR,       ONLY : XUNDEF
00054 USE MODD_DATA_ISBA_n, ONLY : XPAR_VEG, XPAR_LAI
00055 USE MODD_DATA_COVER_PAR, ONLY : NVT_TREE, NVT_CONI, NVT_EVER, NVEGTYPE, XCDREF
00056 !
00057 USE MODI_VEGTYPE_TO_PATCH 
00058 !
00059 !
00060 !
00061 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00062 USE PARKIND1  ,ONLY : JPRB
00063 !
00064 USE MODI_ABOR1_SFX
00065 !
00066 IMPLICIT NONE
00067 !
00068 !*    0.1    Declaration of arguments
00069 !            ------------------------
00070 !
00071 REAL, DIMENSION(:,:), INTENT(OUT) :: PFIELD  ! secondary field to construct
00072 REAL, DIMENSION(:,:), INTENT(IN)  :: PVEGTYPE  ! fraction of each cover class
00073 REAL, DIMENSION(:,:), INTENT(IN)  :: PDATA   ! secondary field value for each class
00074  CHARACTER(LEN=3),     INTENT(IN)  :: HSFTYPE ! Type of surface where the field
00075                                                ! is defined
00076  CHARACTER(LEN=3),     INTENT(IN)  :: HATYPE  ! Type of averaging
00077 REAL, DIMENSION(:),   INTENT(IN), OPTIONAL :: PDZ    ! first model half level
00078 INTEGER,              INTENT(IN), OPTIONAL :: KDECADE ! current month
00079 !
00080 !*    0.2    Declaration of local variables
00081 !            ------------------------------
00082 !
00083 !
00084 INTEGER :: ICOVER  ! number of cover classes
00085 INTEGER :: JCOVER  ! loop on cover classes
00086 !
00087 ! nbe of vegtype
00088 ! nbre of patches
00089 INTEGER :: JVEGTYPE! loop on vegtype
00090 INTEGER :: IPATCH  ! number of patches
00091 INTEGER :: JPATCH  ! PATCH index
00092 INTEGER :: JJ, JI
00093 !
00094 REAL, DIMENSION(SIZE(PFIELD,1),NVEGTYPE)  :: ZWEIGHT
00095 !
00096 REAL, DIMENSION(SIZE(PFIELD,1),SIZE(PFIELD,2))   :: ZSUM_WEIGHT_PATCH
00097 !
00098 REAL, DIMENSION(SIZE(PFIELD,1),SIZE(PFIELD,2))   :: ZWORK
00099 REAL, DIMENSION(SIZE(PFIELD,1),SIZE(PFIELD,2))   :: ZDZ
00100 !
00101 INTEGER, DIMENSION(SIZE(PFIELD,1),SIZE(PFIELD,2))  :: NMASK
00102 INTEGER, DIMENSION(SIZE(PFIELD,2)) :: JCOUNT
00103 INTEGER ::  PATCH_LIST(NVEGTYPE)
00104 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00105 
00106 !-------------------------------------------------------------------------------
00107 !
00108 !*    1.1    field does not exist
00109 !            --------------------
00110 !
00111 IF (LHOOK) CALL DR_HOOK('AV_PGD_PARAM',0,ZHOOK_HANDLE)
00112 IF (SIZE(PFIELD)==0 .AND. LHOOK) CALL DR_HOOK('AV_PGD_PARAM',1,ZHOOK_HANDLE)
00113 IF (SIZE(PFIELD)==0) RETURN
00114 !
00115 !-------------------------------------------------------------------------------
00116 !
00117 !*    1.2    Initializations
00118 !            ---------------
00119 !
00120 IPATCH=SIZE(PFIELD,2)
00121 !
00122 !
00123 IF (PRESENT(PDZ)) THEN
00124   DO JPATCH=1,IPATCH
00125       ZDZ(:,JPATCH)=PDZ(:)
00126   END DO
00127 ELSE
00128   ZDZ(:,:)=XCDREF
00129 END IF
00130 !
00131 PFIELD(:,:)=XUNDEF
00132 !
00133 ZWORK(:,:)=0.
00134 ZWEIGHT(:,:)=0.
00135 ZSUM_WEIGHT_PATCH(:,:)=0.
00136 !
00137 DO JVEGTYPE=1,NVEGTYPE
00138   PATCH_LIST(JVEGTYPE) = VEGTYPE_TO_PATCH (JVEGTYPE, IPATCH)
00139 ENDDO
00140 
00141 !-------------------------------------------------------------------------------
00142 !-------------------------------------------------------------------------------
00143 !
00144 !*    2.     Selection of the weighting function for vegtype
00145 !            -----------------------------------
00146 !
00147 SELECT CASE (HSFTYPE)
00148 
00149    CASE('NAT','GRD')
00150      DO JVEGTYPE=1,NVEGTYPE
00151        ZWEIGHT(:,JVEGTYPE)=PVEGTYPE(:,JVEGTYPE)
00152      END DO
00153 
00154    CASE('VEG','GRV')
00155      DO JVEGTYPE=1,NVEGTYPE
00156        ZWEIGHT(:,JVEGTYPE)=PVEGTYPE(:,JVEGTYPE)*XPAR_VEG(:,KDECADE,JVEGTYPE)
00157      END DO
00158 
00159    CASE('BAR','GRB')
00160      DO JVEGTYPE=1,NVEGTYPE
00161        ZWEIGHT(:,JVEGTYPE)=PVEGTYPE(:,JVEGTYPE)*(1.-XPAR_VEG(:,KDECADE,JVEGTYPE))
00162      END DO
00163      
00164     CASE('DVG','GDV') ! for diffusion scheme only, average only on vegetated area
00165      DO JVEGTYPE=1,NVEGTYPE
00166        WHERE ( SUM(XPAR_LAI(:,:,JVEGTYPE),2) .GT. 0.0) &
00167         ZWEIGHT(:,JVEGTYPE)=PVEGTYPE(:,JVEGTYPE)
00168      END DO
00169 
00170    CASE('LAI','GRL')
00171      DO JVEGTYPE=4,NVEGTYPE
00172        ZWEIGHT(:,JVEGTYPE)=PVEGTYPE(:,JVEGTYPE)*XPAR_LAI(:,KDECADE,JVEGTYPE)
00173      END DO
00174 
00175     CASE('TRE','GRT')
00176       ZWEIGHT(:,:)=0.
00177       WHERE (PVEGTYPE(:,NVT_TREE)>0.)
00178         ZWEIGHT(:,NVT_TREE)=PVEGTYPE(:,NVT_TREE)
00179       ENDWHERE
00180       WHERE (PVEGTYPE(:,NVT_CONI)>0.)
00181         ZWEIGHT(:,NVT_CONI)=PVEGTYPE(:,NVT_CONI)
00182       ENDWHERE
00183       WHERE (PVEGTYPE(:,NVT_EVER)>0.)
00184         ZWEIGHT(:,NVT_EVER)=PVEGTYPE(:,NVT_EVER)
00185       ENDWHERE
00186 
00187     CASE DEFAULT
00188        CALL ABOR1_SFX('AV_PGD_PARAM: WEIGHTING FUNCTION FOR VEGTYPE NOT ALLOWED')
00189 END SELECT
00190 !
00191 !-------------------------------------------------------------------------------
00192 !
00193 !*    3.     Averaging
00194 !            ---------
00195 !
00196 !*    3.1    Work arrays given for each patch
00197 !            -----------
00198 !
00199 !*    3.2    Selection of averaging type
00200 !            ---------------------------
00201 !
00202 SELECT CASE (HATYPE)
00203 !
00204 !-------------------------------------------------------------------------------
00205 !
00206 !*    3.3    Arithmetic averaging
00207 !            --------------------
00208 !
00209   CASE ('ARI')
00210 !
00211     DO JVEGTYPE=1,NVEGTYPE
00212       JPATCH= PATCH_LIST(JVEGTYPE)
00213       DO JJ=1,SIZE(PDATA,1)
00214         ZSUM_WEIGHT_PATCH(JJ,JPATCH) = ZSUM_WEIGHT_PATCH(JJ,JPATCH) + ZWEIGHT(JJ,JVEGTYPE)
00215         ZWORK(JJ,JPATCH) =  ZWORK(JJ,JPATCH) + PDATA(JJ,JVEGTYPE)  * ZWEIGHT(JJ,JVEGTYPE)
00216       ENDDO
00217     END DO
00218 !
00219 !-------------------------------------------------------------------------------
00220 !
00221 !*    3.4    Inverse averaging
00222 !            -----------------
00223 !
00224   CASE('INV' )
00225 !
00226    DO JVEGTYPE=1,NVEGTYPE 
00227      JPATCH=PATCH_LIST(JVEGTYPE) 
00228      DO JJ=1,SIZE(PDATA,1)
00229        ZSUM_WEIGHT_PATCH(JJ,JPATCH) = ZSUM_WEIGHT_PATCH(JJ,JPATCH)+ZWEIGHT(JJ,JVEGTYPE)
00230        IF (PDATA(JJ,JVEGTYPE).NE.0.) THEN
00231          ZWORK(JJ,JPATCH)= ZWORK(JJ,JPATCH) + 1./ PDATA(JJ,JVEGTYPE) * ZWEIGHT(JJ,JVEGTYPE)
00232        ENDIF
00233      ENDDO
00234    END DO
00235 !
00236 !-------------------------------------------------------------------------------!
00237 !
00238 !*    3.5    Roughness length averaging
00239 !            --------------------------
00240 
00241 !
00242   CASE('CDN')
00243 !
00244     DO JVEGTYPE=1,NVEGTYPE
00245       JPATCH=PATCH_LIST(JVEGTYPE)
00246       DO JJ=1,SIZE(PDATA,1)
00247         ZSUM_WEIGHT_PATCH(JJ,JPATCH) =  ZSUM_WEIGHT_PATCH(JJ,JPATCH)+ ZWEIGHT(JJ,JVEGTYPE)
00248         IF (PDATA(JJ,JVEGTYPE).NE.0.) THEN
00249           ZWORK(JJ,JPATCH)= ZWORK(JJ,JPATCH) + 1./(LOG(ZDZ(JJ,JPATCH)/ PDATA(JJ,JVEGTYPE)))**2    &
00250                             * ZWEIGHT(JJ,JVEGTYPE)  
00251         ENDIF
00252       ENDDO
00253     END DO   
00254 !
00255 !-------------------------------------------------------------------------------
00256 !
00257   CASE DEFAULT
00258     CALL ABOR1_SFX('AV_PGD_PARAM: (1) AVERAGING TYPE NOT ALLOWED')
00259 !
00260 END SELECT
00261 !
00262 !-------------------------------------------------------------------------------
00263 !
00264 !*    4.     End of Averaging
00265 !            ----------------
00266 !
00267 NMASK(:,:)=0
00268 JCOUNT(:)=0
00269 DO JPATCH=1,IPATCH
00270   DO JJ=1,SIZE(ZWORK,1)
00271     IF ( ZSUM_WEIGHT_PATCH(JJ,JPATCH) >0.) THEN
00272       JCOUNT(JPATCH)=JCOUNT(JPATCH)+1
00273       NMASK(JCOUNT(JPATCH),JPATCH)=JJ
00274     ENDIF
00275   ENDDO
00276 ENDDO
00277 
00278 !*    4.1    Selection of averaging type
00279 !            ---------------------------
00280 !
00281 SELECT CASE (HATYPE)
00282 !
00283 !-------------------------------------------------------------------------------
00284 !
00285 !*    4.2    Arithmetic averaging
00286 !            --------------------
00287 !
00288   CASE ('ARI')
00289 !   
00290     DO JPATCH=1,IPATCH
00291 !cdir nodep
00292       DO JJ=1,JCOUNT(JPATCH)
00293           JI = NMASK(JJ,JPATCH)
00294           PFIELD(JI,JPATCH) =  ZWORK(JI,JPATCH) / ZSUM_WEIGHT_PATCH(JI,JPATCH)
00295       ENDDO
00296     ENDDO
00297 !
00298 !-------------------------------------------------------------------------------
00299 !
00300 !*    4.3    Inverse averaging
00301 !            -----------------
00302 !
00303   CASE('INV' )
00304 !
00305     DO JPATCH=1,IPATCH
00306 !cdir nodep
00307       DO JJ=1,JCOUNT(JPATCH)
00308         JI = NMASK(JJ,JPATCH)
00309         PFIELD(JI,JPATCH) = ZSUM_WEIGHT_PATCH(JI,JPATCH) / ZWORK(JI,JPATCH)
00310       ENDDO
00311     ENDDO
00312 !-------------------------------------------------------------------------------!
00313 !
00314 !*    4.4    Roughness length averaging
00315 !            --------------------------
00316 
00317 !
00318   CASE('CDN')
00319 !
00320     DO JPATCH=1,IPATCH
00321 !cdir nodep
00322       DO JJ=1,JCOUNT(JPATCH)
00323         JI=NMASK(JJ,JPATCH)
00324         PFIELD(JI,JPATCH) = ZDZ(JI,JPATCH) * EXP( - SQRT(ZSUM_WEIGHT_PATCH(JI,JPATCH)/ZWORK(JI,JPATCH)) )
00325       ENDDO
00326     ENDDO
00327 !
00328 !-------------------------------------------------------------------------------
00329 !
00330   CASE DEFAULT
00331     CALL ABOR1_SFX('AV_PGD_PARAM: (2) AVERAGING TYPE NOT ALLOWED')
00332 !
00333 END SELECT
00334 IF (LHOOK) CALL DR_HOOK('AV_PGD_PARAM',1,ZHOOK_HANDLE)
00335 !-------------------------------------------------------------------------------
00336 !   
00337 END SUBROUTINE AV_PGD_PARAM