av_pgd_1p.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.
!     ##################
      MODULE modi_av_pgd_1p
!     ##################
INTERFACE av_pgd_1p
!
      SUBROUTINE av_pgd_1d_1p (DTCO, &
                            PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,OCOVER,KMASK,KPATCH,KNPATCH,PDZ,KDECADE)
!
USE modd_data_cover_n, ONLY : data_cover_t
!
TYPE(data_cover_t), INTENT(INOUT) :: DTCO
!
REAL, DIMENSION(:),     INTENT(OUT) :: PFIELD  ! secondary field to construct
REAL, DIMENSION(:,:),   INTENT(IN)  :: PCOVER  ! 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
LOGICAL, DIMENSION(:),  INTENT(IN) :: OCOVER
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
!
END SUBROUTINE av_pgd_1d_1p
!     ################################################################
      SUBROUTINE av_patch_pgd_1d_1p (DTCO, &
                                  PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,OCOVER,KMASK,KNPATCH,KPATCH,PDZ,KDECADE)
!     ################################################################
!
!
USE modd_data_cover_n, ONLY : data_cover_t
!
!*    0.1    Declaration of arguments
!            ------------------------
!
!
TYPE(data_cover_t), INTENT(INOUT) :: DTCO
!
REAL, DIMENSION(:), INTENT(OUT) :: PFIELD  ! secondary field to construct
REAL, DIMENSION(:,:), INTENT(IN)  :: PCOVER  ! 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
LOGICAL, DIMENSION(:), INTENT(IN)  :: OCOVER
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
!
END SUBROUTINE av_patch_pgd_1d_1p
!
!     ################################################################
      SUBROUTINE major_patch_pgd_1d_1p(TFIELD,PCOVER,TDATA,HSFTYPE,HATYPE,&
                      OCOVER,KMASK,KNPATCH,KPATCH,KDECADE)
!     ################################################################
!
!*    0.     DECLARATION
!            -----------
!
USE modd_type_date_surf
!
IMPLICIT NONE
!
!*    0.1    Declaration of arguments
!            ------------------------
!
type(date_time), DIMENSION(:), INTENT(OUT) :: tfield  ! secondary field to construct
REAL, DIMENSION(:,:), INTENT(IN)  :: PCOVER  ! fraction of each cover class
type(date_time), DIMENSION(:,:), INTENT(IN)  :: tdata   ! 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
LOGICAL, DIMENSION(:), INTENT(IN) :: OCOVER
INTEGER, DIMENSION(:), INTENT(IN) :: KMASK
INTEGER, INTENT(IN) :: KNPATCH
INTEGER, INTENT(IN) :: KPATCH
INTEGER,     INTENT(IN), OPTIONAL :: KDECADE ! current month
!
END SUBROUTINE major_patch_pgd_1d_1p
!
END INTERFACE
END MODULE modi_av_pgd_1p
!
!     ################################################################
      SUBROUTINE av_pgd_1d_1p (DTCO, PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,OCOVER,&
                               KMASK, KPATCH, KNPATCH, PDZ, KDECADE)
!     ################################################################
!
!!**** *AV_PGD* average 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
!!    ------
!!
!!    V. Masson        Meteo-France
!!
!!    MODIFICATION
!!    ------------
!
!     F.Solmon patch modif: remove the case 'veg' as veg is defined for patches 
!
!!    Original    15/12/97
!!    V. Masson   01/2004  Externalization
!!    R. Alkama   05/2012  Add 6 tree vegtypes (9 rather than 3)
!!
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------
!
USE modd_data_cover_par, ONLY : xcdref
!
USE modd_data_cover_n, ONLY : data_cover_t
!
USE modd_surf_par,       ONLY : xundef
!
USE mode_av_pgd
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
IMPLICIT NONE
!
!*    0.1    Declaration of arguments
!            ------------------------
!
!
TYPE(data_cover_t), INTENT(INOUT) :: DTCO
!
REAL, DIMENSION(:),     INTENT(OUT) :: PFIELD  ! secondary field to construct
REAL, DIMENSION(:,:),   INTENT(IN)  :: PCOVER  ! 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
LOGICAL, DIMENSION(:),  INTENT(IN) :: OCOVER
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 :: JJ, JI, ID0, IMASK0
INTEGER :: ICOVER  ! number of cover classes
INTEGER :: JCOVER  ! loop on cover classes
!
INTEGER, DIMENSION(SIZE(PCOVER,2)) :: IMASK
REAL, DIMENSION(SIZE(PFIELD)) :: ZWORK, ZDZ, ZVAL
REAL, DIMENSION(SIZE(PCOVER,2)) :: ZWEIGHT
REAL :: ZCOVER_WEIGHT
REAL, DIMENSION(SIZE(PFIELD)) :: ZSUM_COVER_WEIGHT
REAL(KIND=JPRB) :: ZHOOK_HANDLE, ZHOOK_HANDLE_OMP
!-------------------------------------------------------------------------------
!
!*    1.1    field does not exist
!            --------------------
!
IF (lhook) CALL dr_hook('MODI_AV_PGD_1P:AV_PGD_1D_1P',0,zhook_handle)
IF (SIZE(pfield)==0 .AND. lhook) CALL dr_hook('MODI_AV_PGD_1P:AV_PGD_1D_1P',1,zhook_handle)
IF (SIZE(pfield)==0) RETURN
!
!-------------------------------------------------------------------------------
!
!*    1.2    Initializations
!            ---------------
!
icover=SIZE(pcover,2)
!
IF (PRESENT(pdz)) THEN
  zdz(:)=pdz(:)
ELSE
  zdz(:)=xcdref
END IF
!
pfield(:)=xundef
IF (hsftype=='TRE' .OR. hsftype=='GRT') pfield(:) = 0.
!
zwork(:)=0.
zsum_cover_weight(:)=0.
!
jcover = 0
DO jj = 1,SIZE(ocover)
  IF (ocover(jj)) THEN
    jcover=jcover+1
    imask(jcover) = jj
  ENDIF
ENDDO
!
 CALL get_weight(dtco,icover,imask,hsftype,zweight)
!
!-------------------------------------------------------------------------------
!
!*    3.     Averaging
!            ---------
!
!*    3.1    Work arrays
!            -----------
!
IF (hatype=='ARI' .OR. hatype=='INV' .OR. hatype=='CDN') THEN
  !
  DO jcover=1,icover
    IF (zweight(jcover)/=0.) THEN
      !
      jj = imask(jcover)
      !
      IF (hatype=='ARI') THEN
        zval(:) = pdata(jj)
      ELSEIF (hatype=='INV') THEN
        zval(:) = 1./pdata(jj)
      ELSEIF (hatype=='CDN') THEN
        zval(:) = 1./(log(zdz(:)/pdata(jj)))**2 
      ENDIF
      !
      DO ji = 1,SIZE(kmask)
        !
        imask0 = kmask(ji)
        !
        IF (pcover(imask0,jcover)/=0.) THEN
          zcover_weight = pcover(imask0,jcover) * zweight(jcover)
          zsum_cover_weight(ji) = zsum_cover_weight(ji) + zcover_weight
          zwork(ji) = zwork(ji) + zval(ji) * zcover_weight
        ENDIF
        !
      ENDDO
      !
    ENDIF
  ENDDO
ELSEIF (hatype=='MAJ') THEN
  !
  DO ji = 1,SIZE(kmask)
    !
    imask0 = kmask(ji)
    !
    id0 = maxval(maxloc(pcover(imask0,:)*zweight(:)))
    zwork(ji) = pdata(imask(id0))
    zsum_cover_weight(ji) = zsum_cover_weight(ji) + sum(pcover(imask0,:)*zweight(:))
    !
  ENDDO
  !
ELSE
  CALL abor1_sfx('AV_PGD_1D_1P: (1) AVERAGING TYPE NOT ALLOWED : "'//hatype//'"')
ENDIF
!
IF (lhook) CALL dr_hook('MODI_AV_PGD_1P:AV_PGD_1D_1P',0,zhook_handle)
!-------------------------------------------------------------------------------
!
!*    4.     End of Averaging
!            ----------------
!
!*    4.1    Selection of averaging type
!            ---------------------------
!
  SELECT CASE (hatype)
!
!-------------------------------------------------------------------------------
!
!*    4.2    Arithmetic averaging
!            --------------------
!
  CASE ('ARI')
!
    WHERE ( zsum_cover_weight(:) >0. )
      pfield(:) = zwork(:) / zsum_cover_weight(:)
    END WHERE
!
!-------------------------------------------------------------------------------
!
!*    4.3    Inverse averaging
!            -----------------
!
  CASE('INV' )
!
    WHERE ( zsum_cover_weight(:) >0. )
      pfield(:) = zsum_cover_weight(:) / zwork(:)
    END WHERE
!
!-------------------------------------------------------------------------------!
!
!*    4.4    Roughness length averaging
!            --------------------------

!
  CASE('CDN')
!
    WHERE ( zsum_cover_weight(:) >0. )
      pfield(:) = zdz(:) * exp( - sqrt(zsum_cover_weight(:)/zwork(:)) )
    END WHERE
!
!-------------------------------------------------------------------------------
!
!*    4.4    Majoritary averaging
!            --------------------
!
  CASE('MAJ' )
!
    WHERE ( zsum_cover_weight(:) >0. )
      pfield(:) = zwork(:)
    END WHERE
!
!-------------------------------------------------------------------------------
!
  CASE DEFAULT
    CALL abor1_sfx('AV_PGD_1D_1P: (2) AVERAGING TYPE NOT ALLOWED')
!
END SELECT
IF (lhook) CALL dr_hook('MODI_AV_PGD_1P:AV_PGD_1D_1P_4',1,zhook_handle)
! 
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE av_pgd_1d_1p
!
!     ################################################################
      SUBROUTINE av_patch_pgd_1d_1p (DTCO, PFIELD,PCOVER,PDATA,HSFTYPE,HATYPE,OCOVER,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   05/2012  Add 6 tree vegtypes (9 rather than 3)
!!
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------
!
!
USE modd_data_cover_n, ONLY : data_cover_t
!
USE modd_data_cover_par, ONLY : nvegtype, xcdref
USE modd_surf_par,       ONLY : xundef
!
USE mode_av_pgd
!
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
!            ------------------------
!
!
TYPE(data_cover_t), INTENT(INOUT) :: DTCO
!
REAL, DIMENSION(:), INTENT(OUT) :: PFIELD  ! secondary field to construct
REAL, DIMENSION(:,:), INTENT(IN)  :: PCOVER  ! 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
LOGICAL, DIMENSION(:), INTENT(IN)  :: OCOVER
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 :: JVEG! loop on vegtype
INTEGER :: JJ, JI, JK
!
REAL         :: ZCOVER_WEIGHT
!
REAL, DIMENSION(SIZE(PFIELD)) :: ZVAL
!
REAL, DIMENSION(SIZE(PCOVER,2),NVEGTYPE)         :: ZWEIGHT
!
REAL, DIMENSION(SIZE(PFIELD))   :: ZSUM_COVER_WEIGHT_PATCH
!
REAL, DIMENSION(SIZE(PFIELD))   :: ZWORK
REAL, DIMENSION(SIZE(PFIELD))   :: ZDZ
!
INTEGER  :: IMASK, JP
INTEGER, DIMENSION(SIZE(PCOVER,2))  :: IMASK0
INTEGER ::  PATCH_LIST(nvegtype)
REAL(KIND=JPRB) :: ZHOOK_HANDLE, ZHOOK_HANDLE_OMP

!-------------------------------------------------------------------------------
!
!*    1.1    field does not exist
!            --------------------
!
IF (lhook) CALL dr_hook('MODI_AV_PGD_1P:AV_PATCH_PGD_1D_1P',0,zhook_handle)
IF (SIZE(pfield)==0 .AND. lhook) CALL dr_hook('MODI_AV_PGD_1P:AV_PATCH_PGD_1D_1P',1,zhook_handle)
IF (SIZE(pfield)==0) RETURN
!
!-------------------------------------------------------------------------------
!
!*    1.2    Initializations
!            ---------------
!
icover=SIZE(pcover,2)
!
IF (PRESENT(pdz)) THEN
  zdz(:)=pdz(:)
ELSE
  zdz(:)=xcdref
END IF
!
pfield(:)=xundef
!
zwork(:) = 0.
zweight(:,:) = 0.0
zsum_cover_weight_patch(:) = 0.
!
DO jveg=1,nvegtype
  patch_list(jveg) = vegtype_to_patch(jveg, knpatch)
ENDDO
!
jcover = 0
DO jj = 1,SIZE(ocover)
  IF (ocover(jj)) THEN
    jcover=jcover+1
    imask0(jcover) = jj
  ENDIF
ENDDO
!
 CALL get_weight_patch(dtco,icover,imask0,kdecade,hsftype,zweight)
!
!-------------------------------------------------------------------------------
  !
  !
  !*    2.     Selection of the weighting function for vegtype
  !            -----------------------------------
  !
jcover=0
!
DO jcover=1,icover
  !
  jj = imask0(jcover)
  !
  DO jveg=1,nvegtype
    !
    jp= patch_list(jveg)
    IF (jp/=kpatch) cycle
    !
    IF (zweight(jcover,jveg)/=0.) THEN
      !
      IF (hatype=='ARI') THEN
        zval(:) = pdata(jj,jveg)
      ELSEIF (hatype=='INV') THEN
        zval(:) = 1. / pdata(jj,jveg)
      ELSEIF (hatype=='CDN') THEN
        DO ji=1,SIZE(zval)
          zval(ji) = 1./(log(zdz(ji)/pdata(jj,jveg)))**2 
        ENDDO
      ELSE
        CALL abor1_sfx('AV_1PATCH_PGD_1D: (1) AVERAGING TYPE NOT ALLOWED')
      ENDIF
      !
      DO ji=1,SIZE(pfield)

        imask = kmask(ji)

        IF (pcover(imask,jcover)/=0.) THEN
          zcover_weight =  pcover(imask,jcover) * zweight(jcover,jveg)      
          zsum_cover_weight_patch(ji) = zsum_cover_weight_patch(ji) + zcover_weight
          zwork(ji) = zwork(ji) + zval(ji) * zcover_weight
        ENDIF
      ENDDO
      !
    ENDIF
    !
  ENDDO
  !
ENDDO
!
!-------------------------------------------------------------------------------
  
!
!*    4.1    Selection of averaging type
!            ---------------------------
!
  SELECT CASE (hatype)
!
!-------------------------------------------------------------------------------
!
!*    4.2    Arithmetic averaging
!            --------------------
!
  CASE ('ARI')
!   
    DO ji=1,SIZE(pfield)
      IF (zsum_cover_weight_patch(ji)>0.) pfield(ji) =  zwork(ji) / zsum_cover_weight_patch(ji)
    ENDDO
!
!-------------------------------------------------------------------------------
!
!*    4.3    Inverse averaging
!            -----------------
!
  CASE('INV' )
!
    DO ji=1,SIZE(pfield)
      IF (zsum_cover_weight_patch(ji)>0.) pfield(ji) = zsum_cover_weight_patch(ji) / zwork(ji)
    ENDDO
!-------------------------------------------------------------------------------!
!
!*    4.4    Roughness length averaging
!            --------------------------

!
  CASE('CDN')
!
    DO ji=1,SIZE(pfield)
      IF (zsum_cover_weight_patch(ji)>0.) pfield(ji) = zdz(ji) * exp( - sqrt(zsum_cover_weight_patch(ji)/zwork(ji)) )
    ENDDO
!
!-------------------------------------------------------------------------------
!
  CASE DEFAULT
    CALL abor1_sfx('AV_1PATCH_PGD_1D_1P: (2) AVERAGING TYPE NOT ALLOWED')
!
END SELECT
!
IF (lhook) CALL dr_hook('MODI_AV_PGD_1P:AV_1PATCH_PGD_1D_1P',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!   
END SUBROUTINE av_patch_pgd_1d_1p
!
!     ################################################################
      SUBROUTINE major_patch_pgd_1d_1p(TFIELD,PCOVER,TDATA,HSFTYPE,HATYPE,&
                      OCOVER,KMASK,KNPATCH,KPATCH,KDECADE)
!     ################################################################
!
!!**** *MAJOR_PATCH_PGD* find the dominant date for each vegetation type
!!
!!    PURPOSE
!!    -------
!!
!!    METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    P. LE MOIGNE
!!
!!    MODIFICATION
!!    ------------
!!
!!    Original    06/2006
!!
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------
!
USE modd_type_date_surf
USE modd_surf_par,       ONLY : xundef, nundef
USE modd_data_cover_par, ONLY : nvegtype
!
USE modi_vegtype_to_patch
USE mode_av_pgd
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*    0.1    Declaration of arguments
!            ------------------------
!
type(date_time), DIMENSION(:), INTENT(OUT) :: tfield  ! secondary field to construct
REAL, DIMENSION(:,:), INTENT(IN)  :: PCOVER  ! fraction of each cover class
type(date_time), DIMENSION(:,:), INTENT(IN)  :: tdata   ! 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
LOGICAL, DIMENSION(:), INTENT(IN) :: OCOVER
INTEGER, DIMENSION(:), INTENT(IN) :: KMASK
INTEGER, INTENT(IN) :: KNPATCH
INTEGER, INTENT(IN) :: KPATCH
INTEGER,     INTENT(IN), OPTIONAL :: KDECADE ! current month
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
INTEGER :: JJ, IMASK
INTEGER :: ICOVER  ! number of cover classes
INTEGER :: JCOVER  ! loop on cover classes
!
INTEGER :: JVEG! loop on vegtype
!
INTEGER, DIMENSION(SIZE(PCOVER,2),NVEGTYPE)      :: IDATA_DOY
INTEGER, DIMENSION(SIZE(PCOVER,1))               :: IDOY
REAL,    DIMENSION(365)                          :: ZCOUNT
INTEGER                                          :: JP, IMONTH, IDAY
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!-------------------------------------------------------------------------------
!
!*    1.1    field does not exist
!            --------------------
!
IF (lhook) CALL dr_hook('MODI_AV_PGD_1P:MAJOR_PATCH_PGD_1D_1P',0,zhook_handle)
IF (SIZE(tfield)==0 .AND. lhook) CALL dr_hook('MODI_AV_PGD_1P:MAJOR_PATCH_PGD_1D_1P',1,zhook_handle)
IF (SIZE(tfield)==0) RETURN
!
!-------------------------------------------------------------------------------
!
!*    1.2    Initializations
!            ---------------
!
tfield(:)%TDATE%YEAR  = nundef
tfield(:)%TDATE%MONTH = nundef
tfield(:)%TDATE%DAY   = nundef
tfield(:)%TIME        = xundef
!
idoy(:) = 0
!
 CALL date2doy(tdata,ocover,idata_doy)
!-------------------------------------------------------------------------------
DO jp = 1,SIZE(tfield)
  !
  imask = kmask(jp)
  !
  zcount(:) = 0.
  !
  DO jveg=1,nvegtype
    !
    IF(kpatch==vegtype_to_patch(jveg,knpatch)) THEN
      !
      DO jcover = 1,SIZE(pcover,2)
        !
        IF (idata_doy(jcover,jveg) /= nundef .AND. pcover(imask,jcover)/=0.) THEN
          !
          zcount(idata_doy(jcover,jveg)) = zcount(idata_doy(jcover,jveg)) + pcover(imask,jcover)
          !
        END IF
        !
      END DO
      !
    ENDIF
    !
  ENDDO
  !
  idoy(jp) = 0
  IF (any(zcount(:)/=0.)) idoy(jp) = maxloc(zcount,1)
  !
  CALL doy2date(idoy(jp),imonth,iday)
  !
  tfield(jp)%TDATE%MONTH = imonth
  tfield(jp)%TDATE%DAY   = iday
  IF (imonth/=nundef) tfield(jp)%TIME   = 0.
  !
END DO
!
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('MODI_AV_PGD_1P:MAJOR_PATCH_PGD_1D_1P',1,zhook_handle)
!
END SUBROUTINE major_patch_pgd_1d_1p
!
!-------------------------------------------------------------------------------
!