average1_cover.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 average1_cover(UG,U,KLUOUT,KNBLINES,PLAT,PLON,PVALUE,PNODATA)
!     #######################################################
!
!!**** *AVERAGE1_COVER* computes the sum of values of a cover fractions
!!                              and the nature of terrain on the grid
!!                              from a data in land-cover file
!!
!!    PURPOSE
!!    -------
!!
!!    METHOD
!!    ------
!!   
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    V. Masson         Meteo-France
!!
!!    MODIFICATION
!!    ------------
!!
!!    Original    12/09/95
!!
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------
!
USE modd_surf_atm_grid_n, ONLY : surf_atm_grid_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_surfex_mpi, ONLY : nrank
USE modd_pgdwork, ONLY : xall, nsize_all
USE modd_data_cover_par, ONLY : jpcover
!
USE modi_get_mesh_index
USE modd_point_overlay
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*    0.1    Declaration of arguments
!            ------------------------
!
TYPE(surf_atm_grid_t), INTENT(INOUT) :: UG
TYPE(surf_atm_t), INTENT(INOUT) :: U
!
INTEGER,                 INTENT(IN)    :: KLUOUT
INTEGER,                 INTENT(IN)    :: KNBLINES
REAL, DIMENSION(:),      INTENT(IN)    :: PLAT    ! latitude of the point to add
REAL, DIMENSION(:),      INTENT(IN)    :: PLON    ! longitude of the point to add
REAL, DIMENSION(:),      INTENT(IN)    :: PVALUE  ! value of the point to add
REAL, OPTIONAL, INTENT(IN) :: PNODATA
!
!*    0.2    Declaration of other local variables
!            ------------------------------------
!
INTEGER, DIMENSION(NOVMX,SIZE(PLAT)) :: IINDEX ! mesh index of all input points
                                         ! 0 indicates the point is out of the domain                              
!
REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZALL
REAL, DIMENSION(SIZE(PLAT)) :: ZVALUE
REAL :: ZNODATA
INTEGER :: JL, JOV, JCOV, IFOUND, ICOV, IND        ! loop index on input arrays
INTEGER :: ICOVERCLASS  ! class of cover type
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!----------------------------------------------------------------------------
!
!
!*    1.     Get position
!            ------------
!     
IF (lhook) CALL dr_hook('AVERAGE1_COVER',0,zhook_handle)
!
icov = SIZE(xall,2)
!
IF (PRESENT(pnodata)) THEN
  zvalue(:) = pvalue(:)
  znodata = pnodata
  CALL get_mesh_index(ug,kluout,knblines,plat,plon,iindex,zvalue,znodata)
ELSE
  zvalue(:) = 1.
  znodata = 0.
  CALL get_mesh_index(ug,kluout,knblines,plat,plon,iindex)
ENDIF
!
!*    2.     Loop on all input data points
!            -----------------------------
!     
bloop: &
DO jl = 1 , SIZE(plat)
!
!*    3.     Tests on position
!            -----------------
!    
  DO jov = 1, novmx

    IF (iindex(jov,jl)==0) cycle bloop
!
!*    4.     Test on value meaning
!            ---------------------
!
    icoverclass = nint(pvalue(jl))
!
    u%LCOVER(icoverclass) = .true.
!
    IF (icoverclass<1 .OR. icoverclass > jpcover )  cycle
!
!*    5.     Summation
!            ---------
!
    nsize_all(iindex(jov,jl),1)=nsize_all(iindex(jov,jl),1)+1
!
!*    6.     Fraction of cover type
!            ----------------------
!
    ifound = 0
    !ICOV: number of covers already found in the domain
    DO jcov=1,icov
      !if the cover read is already in the array
      IF (xall(iindex(jov,jl),jcov,1)==icoverclass*1.) THEN
        !the number of points found is increased of 1
        xall(iindex(jov,jl),jcov,2) = xall(iindex(jov,jl),jcov,2) + 1.
        ifound=1
        EXIT
      ENDIF
    ENDDO
    !if the cover is not in the array 
    IF (ifound==0) THEN
      !if we already have some covers for this point
      IF (xall(iindex(jov,jl),icov,2)/=0.) THEN
        !to save the current array
        ALLOCATE(zall(SIZE(xall,1),icov,SIZE(xall,3)))
        zall(:,:,:) = xall(:,:,:)
        DEALLOCATE(xall)
        !we add one cover to the size of the array
        ALLOCATE(xall(SIZE(zall,1),icov+1,SIZE(zall,3)))
        xall(:,1:icov,:) = zall(:,:,:)
        DEALLOCATE(zall)
        xall(:,icov+1,:) = 0.
        !the number of covers already found increases
        icov = icov + 1
      ENDIF
      !first index for this point where no cover is defined
      ind = minloc(xall(iindex(jov,jl),:,2),1,xall(iindex(jov,jl),:,2)==0.)
      !the new cover is registered
      xall(iindex(jov,jl),ind,1) = icoverclass*1.
      xall(iindex(jov,jl),ind,2) = 1.
    ENDIF
    !
  ENDDO
!
END DO bloop
!
IF (lhook) CALL dr_hook('AVERAGE1_COVER',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE average1_cover