av_pgd_param.F90

Go to the documentation of this file.

!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
!SFX_LIC for details. version 1.
!     ################################################################
      SUBROUTINE av_pgd_param (PLAI_IN, PVEG_IN, &
                               PFIELD,PVEGTYPE,PDATA,HSFTYPE,HATYPE,KMASK,KNPATCH,KPATCH,PDZ,KDECADE)
!     ################################################################
!
!!**** *AV_PATCH_PGD* average for each surface patch a secondary physiographic 
!!                    variable from the
!!              fractions of coverage class.
!!
!!    PURPOSE
!!    -------
!!
!!    METHOD
!!    ------
!!
!!    The averaging is performed with one way into three:
!!
!!    - arithmetic averaging (HATYPE='ARI')
!!
!!    - inverse    averaging (HATYPE='INV')
!!
!!    - inverse of square logarithm averaging (HATYPE='CDN') :
!!
!!      1 / ( ln (dz/data) )**2
!!
!!      This latest uses (if available) the height of the first model mass
!!      level. In the other case, 20m is chosen. It works for roughness lengths.
!!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    F.Solmon /V. Masson       
!!
!!    MODIFICATION
!!    ------------
!!
!!    Original    15/12/97
!!    V. Masson   01/2004  Externalization
!!    R. Alkama   04/2012  add 6 new tree vegtype (9 instead 3)
!
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------
!
USE modd_surf_par,       ONLY : xundef, nundef
USE modd_data_cover_par, ONLY : nvt_tebd, nvt_bone, nvt_trbe, nvt_trbd, nvt_tebe,  &
                                nvt_tene, nvt_bobd, nvt_bond, nvt_shrb, nvegtype,  &
                                xcdref
!
USE modi_vegtype_to_patch 
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
IMPLICIT NONE
!
!*    0.1    Declaration of arguments
!            ------------------------
!
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PLAI_IN
REAL, DIMENSION(:,:,:), INTENT(IN) :: PVEG_IN
!
REAL, DIMENSION(:), INTENT(OUT) :: PFIELD  ! secondary field to construct
REAL, DIMENSION(:,:), INTENT(IN)  :: PVEGTYPE  ! fraction of each cover class
REAL, DIMENSION(:,:), INTENT(IN)  :: PDATA   ! secondary field value for each class
 CHARACTER(LEN=3),     INTENT(IN)  :: HSFTYPE ! Type of surface where the field
                                               ! is defined
 CHARACTER(LEN=3),     INTENT(IN) :: HATYPE  ! Type of averaging
INTEGER, DIMENSION(:), INTENT(IN) :: KMASK
INTEGER, INTENT(IN) :: KNPATCH
INTEGER, INTENT(IN) :: KPATCH
REAL, DIMENSION(:),   INTENT(IN), OPTIONAL :: PDZ    ! first model half level
INTEGER,              INTENT(IN), OPTIONAL :: KDECADE ! current month
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
!
INTEGER :: ICOVER  ! number of cover classes
INTEGER :: JCOVER  ! loop on cover classes
!
! nbe of vegtype
! nbre of patches
INTEGER :: JV! loop on vegtype
INTEGER :: JJ, JI, JP, IMASK
!
REAL, DIMENSION(SIZE(PFIELD,1),NVEGTYPE)  :: ZWEIGHT
!
REAL, DIMENSION(SIZE(PFIELD,1))   :: ZSUM_WEIGHT_PATCH
!
REAL, DIMENSION(SIZE(PFIELD,1))   :: ZWORK
REAL, DIMENSION(SIZE(PFIELD,1))   :: ZDZ
!
REAL, DIMENSION(31) :: ZCOUNT
INTEGER, DIMENSION(SIZE(PFIELD,1))  :: NMASK
INTEGER ::  PATCH_LIST(nvegtype)
REAL(KIND=JPRB) :: ZHOOK_HANDLE

!-------------------------------------------------------------------------------
!
!*    1.1    field does not exist
!            --------------------
!
IF (lhook) CALL dr_hook('AV_PGD_PARAM',0,zhook_handle)
IF (SIZE(pfield)==0 .AND. lhook) CALL dr_hook('AV_PGD_PARAM',1,zhook_handle)
IF (SIZE(pfield)==0) RETURN
!
!-------------------------------------------------------------------------------
!
!*    1.2    Initializations
!            ---------------
!
!
IF (PRESENT(pdz)) THEN
  zdz(:)=pdz(:)
ELSE
  zdz(:)=xcdref
END IF
!
pfield(:)=xundef
!
zwork(:)=0.
zweight(:,:)=0.
zsum_weight_patch(:)=0.
!
DO jv=1,nvegtype
  patch_list(jv) = vegtype_to_patch(jv, knpatch)
ENDDO

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
!*    2.     Selection of the weighting function for vegtype
!            -----------------------------------
!
DO jv=1,nvegtype
  jp= patch_list(jv)
  IF (jp/=kpatch) cycle
  DO ji=1,SIZE(pfield)
    imask = kmask(ji)
    
    IF (hsftype=='NAT'.OR.hsftype=='GRD') THEN
      zweight(ji,jv) = pvegtype(imask,jv)
    ELSEIF (hsftype=='VEG'.OR.hsftype=='GRV') THEN
      zweight(ji,jv) = pvegtype(imask,jv)*pveg_in(imask,kdecade,jv)
    ELSEIF (hsftype=='BAR'.OR.hsftype=='GRB') THEN
      zweight(ji,jv)=pvegtype(imask,jv)*(1.-pveg_in(imask,kdecade,jv))
    ELSEIF (hsftype=='DVG'.OR.hsftype=='GDV') THEN
      IF (sum(plai_in(ji,:,jv)).GT.0.) zweight(ji,jv) = pvegtype(imask,jv)
    ELSEIF (hsftype=='LAI'.OR.hsftype=='GRL') THEN
      IF (jv>=4) zweight(ji,jv)=pvegtype(imask,jv)*plai_in(imask,kdecade,jv)
    ELSEIF (hsftype=='TRE'.OR.hsftype=='GRT') THEN
      IF (jv==nvt_tebd.OR.jv==nvt_bone.OR.jv==nvt_trbe.OR.jv==nvt_trbd.OR.&
          jv==nvt_tebe.OR.jv==nvt_tene.OR.jv==nvt_bobd.OR.jv==nvt_bond.OR.&
          jv==nvt_shrb) zweight(ji,jv) = pvegtype(ji,jv)
    ELSE
      CALL abor1_sfx('AV_PGD_PARAM_1D: WEIGHTING FUNCTION FOR VEGTYPE NOT ALLOWED')
    ENDIF

  ENDDO
ENDDO
!
!-------------------------------------------------------------------------------
!
!*    3.     Averaging
!            ---------
!
!*    3.1    Work arrays given for each patch
!            -----------
!
!*    3.2    Selection of averaging type
!            ---------------------------
!
SELECT CASE (hatype)
!
!-------------------------------------------------------------------------------
!
!*    3.3    Arithmetic averaging
!            --------------------
!
  CASE ('ARI')
!
    DO jv=1,nvegtype
      jp= patch_list(jv)
      IF (jp/=kpatch) cycle
      DO jj=1,SIZE(pfield)
        imask = kmask(jj)
        zsum_weight_patch(jj) = zsum_weight_patch(jj) + zweight(jj,jv)
        zwork(jj) =  zwork(jj) + pdata(imask,jv)  * zweight(jj,jv)
      ENDDO
    END DO
!
!-------------------------------------------------------------------------------
!
!*    3.4    Inverse averaging
!            -----------------
!
  CASE('INV' )
!
   DO jv=1,nvegtype 
     jp=patch_list(jv) 
     IF (jp/=kpatch) cycle
     DO jj=1,SIZE(pfield)
       imask = kmask(jj)     
       zsum_weight_patch(jj) = zsum_weight_patch(jj)+zweight(jj,jv)
       IF (pdata(imask,jv).NE.0.) THEN
         zwork(jj)= zwork(jj) + 1./ pdata(imask,jv) * zweight(jj,jv)
       ENDIF
     ENDDO
   END DO
!
!-------------------------------------------------------------------------------!
!
!*    3.5    Roughness length averaging
!            --------------------------

!
  CASE('CDN')
!
    DO jv=1,nvegtype
      jp=patch_list(jv)
      IF (jp/=kpatch) cycle
      DO jj=1,SIZE(pfield)
        imask = kmask(jj)        
        zsum_weight_patch(jj) =  zsum_weight_patch(jj)+ zweight(jj,jv)
        IF (pdata(jj,jv).NE.0.) THEN
          zwork(jj)= zwork(jj) + 1./(log(zdz(jj)/ pdata(imask,jv)))**2    &
                            * zweight(jj,jv)
        ENDIF
      ENDDO
    END DO   
!
  CASE ('MAJ')
!
    zwork(:) = 0.
    DO jj=1,SIZE(pfield)
      zcount(:) = 0.
      DO jv=1,nvegtype
        jp= patch_list(jv)
        IF (jp/=kpatch) cycle
        imask = kmask(jj)
        IF (nint(pdata(imask,jv))/=nundef) &
                zcount(nint(pdata(imask,jv))) = zcount(nint(pdata(imask,jv))) + zweight(jj,jv)
      ENDDO
      IF (all(zcount(:)==0.)) THEN
        zwork(jj) = nundef
      ELSE
        zwork(jj) = float(maxloc(zcount,1))
      ENDIF
    END DO
!
!-------------------------------------------------------------------------------
!
  CASE DEFAULT
    CALL abor1_sfx('AV_PGD_PARAM_1D: (1) AVERAGING TYPE NOT ALLOWED')
!
END SELECT
!
!*    4.1    Selection of averaging type
!            ---------------------------
!
SELECT CASE (hatype)
!
!-------------------------------------------------------------------------------
!
!*    4.2    Arithmetic averaging
!            --------------------
!
  CASE ('ARI')
!   
    DO ji=1,SIZE(pfield)
      IF (zsum_weight_patch(ji)>0.) pfield(ji) = zwork(ji) / zsum_weight_patch(ji)
    ENDDO
!
!-------------------------------------------------------------------------------
!
!*    4.3    Inverse averaging
!            -----------------
!
  CASE('INV' )
!
    DO ji=1,SIZE(pfield)
      IF (zsum_weight_patch(ji)>0.) pfield(ji) = zsum_weight_patch(ji) / zwork(ji)
    ENDDO
!-------------------------------------------------------------------------------!
!
!*    4.4    Roughness length averaging
!            --------------------------

!
  CASE('CDN')
!
    DO ji=1,SIZE(pfield)
      IF (zsum_weight_patch(ji)>0.) THEN
        pfield(ji) = zdz(ji) * exp( - sqrt(zsum_weight_patch(ji)/zwork(ji)) )
      ENDIF
    ENDDO
!
  CASE ('MAJ')
!   
    DO ji=1,SIZE(pfield)
      pfield(ji) = zwork(ji)
    ENDDO
!-------------------------------------------------------------------------------
!
  CASE DEFAULT
    CALL abor1_sfx('AV_PGD_PARAM: (2) AVERAGING TYPE NOT ALLOWED')
!
END SELECT
IF (lhook) CALL dr_hook('AV_PGD_PARAM',1,zhook_handle)
!-------------------------------------------------------------------------------
!   
END SUBROUTINE av_pgd_param