average1_mesh.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_mesh(UG,KLUOUT,KNBLINES,PLAT,PLON,PVALUE,OMULTITYPE,KFACT,PNODATA)
!     #######################################################
!
!!**** *AVERAGE1_MESH* computes the sum of orography, squared orography
!!                              and subgrid orography characteristics
!!
!!    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_pgdwork,       ONLY : xall, nsize_all, catype, &
                               nvalnbr, nvalcount, xvallist, jpvalmax
USE modd_data_cover_par,ONLY : xcdref
!
USE modi_get_mesh_index
USE modd_point_overlay
USE modi_abor1_sfx
!
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
!
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
LOGICAL, INTENT(IN) :: OMULTITYPE
INTEGER, INTENT(IN) :: KFACT
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
INTEGER :: JVAL, JTY, IDX       ! loop counter on encoutered values
INTEGER :: JL, JOV        ! loop index on input arrays
REAL    :: ZEPS=1.e-10  ! a small value
LOGICAL :: GFOUND       ! T : Value already found in this grid point
!
LOGICAL, DIMENSION(SIZE(PLAT)) :: GFLAG
REAL, DIMENSION(SIZE(PLAT)) :: ZVALUE
REAL :: ZNODATA
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!----------------------------------------------------------------------------
!
!*    1.     Get position
!            ------------
! 
IF (lhook) CALL dr_hook('AVERAGE1_MESH',0,zhook_handle)
!
! to calculate the mesh indexes only where pvalue /= pnodata
IF (PRESENT(pnodata)) THEN
  znodata = pnodata
  zvalue(:) = pvalue(:)
ELSE
  znodata = 0.
  zvalue(:) = 1.
ENDIF
!
 CALL get_mesh_index(ug,kluout,knblines,plat,plon,iindex,zvalue,znodata)
!
IF (.NOT.PRESENT(pnodata)) zvalue(:) = pvalue(:)
!
!*    2.     Loop on all input data points
!            -----------------------------
! 
DO jov = 1, novmx
  !
  bloop: &
  DO jl = 1 , SIZE(plat)
    !
!*    3.     Tests on position
!            -----------------
!
    idx = iindex(jov,jl)
 
    IF (idx==0) cycle bloop
!
!*    4.     Summation
!            ---------
!
    IF (PRESENT(pnodata)) THEN
      IF (zvalue(jl)==znodata) cycle
    ENDIF
!
! the type of the point and the true value
    IF (omultitype) THEN
      jty = floor(zvalue(jl)/100.)
      zvalue(jl) = (zvalue(jl) - jty*100.) / float(kfact)
    ELSE
      jty = 1
    ENDIF

    nsize_all(idx,jty) = nsize_all(idx,jty)+1
!
!*    5.     Choice of type of summation
!            ---------------------------
!
    SELECT CASE (catype)

      CASE ('ARI')
        xall(idx,jty,1) = xall(idx,jty,1) +   zvalue(jl)

      CASE ('INV')
        xall(idx,jty,1) = xall(idx,jty,1) + 1./zvalue(jl)

      CASE ('CDN')
        xall(idx,jty,1) = xall(idx,jty,1) + 1./(log(xcdref/zvalue(jl)))**2

      CASE ('MAJ')

        gfound=.false.
        DO jval=1,nvalnbr(idx,jty)
          IF (abs( xvallist(idx,jval,jty) - zvalue(jl)) < zeps) THEN
            nvalcount(idx,jval,jty) = nvalcount(idx,jval,jty) + 1
            gfound=.true.
            EXIT
          END IF
        END DO

        IF (.NOT. gfound) THEN
          IF (nvalnbr(idx,jty)==jpvalmax) &
            CALL abor1_sfx('TOO MANY DIFFERENT VALUES TO AGGREGATE WITH THE MAJORITY RULE')
          nvalnbr(idx,jty) = nvalnbr(idx,jty) +1
          jval = nvalnbr(idx,jty)
          nvalcount(idx,jval,jty) = 1
          xvallist(idx,jval,jty) = zvalue(jl)
        END IF

    END SELECT
    !
  ENDDO bloop
  !
ENDDO
!
IF (lhook) CALL dr_hook('AVERAGE1_MESH',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE average1_mesh