get_xyall_ign.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 get_xyall_ign(PX,PY,PDX,PDY,PXALL,PYALL,KDIMX,KDIMY)
!     ################################################################
!
!!****  *GET_XYALL_IGN* 
!!
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!      S. Faroux   *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    07/2011 
!-------------------------------------------------------------------------------
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
REAL, DIMENSION(:), INTENT(IN) :: px
REAL, DIMENSION(:), INTENT(IN) :: py
REAL, DIMENSION(:), INTENT(IN) :: pdx
REAL, DIMENSION(:), INTENT(IN) :: pdy
REAL, DIMENSION(:), INTENT(OUT) :: pxall
REAL, DIMENSION(:), INTENT(OUT) :: pyall
INTEGER, INTENT(OUT) :: kdimx
INTEGER, INTENT(OUT) :: kdimy
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
REAL, DIMENSION(MAX(SIZE(PXALL),SIZE(PYALL))*3) :: zall
REAL(KIND=JPRB) :: zhook_handle
!
!----------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('GET_XYALL_IGN',0,zhook_handle)
!
kdimx = 0
kdimy = 0
!
 CALL get_coord(px,pdx,zall,kdimx)
!sort values from lower to grower
 CALL sort(kdimx,zall,pxall)
!
 CALL get_coord(py,pdy,zall,kdimy)
!sort values from lower to grower
 CALL sort(kdimy,zall,pyall)
!
IF (lhook) CALL dr_hook('GET_XYALL_IGN',1,zhook_handle)
!-------------------------------------------------------------------------------
 CONTAINS
!
SUBROUTINE get_coord(PIN,PDIN,POUT,KSIZE)
!
IMPLICIT NONE
!
REAL, DIMENSION(:), INTENT(IN) :: pin
REAL, DIMENSION(:), INTENT(IN) :: pdin
REAL, DIMENSION(:), INTENT(OUT) :: pout
INTEGER, INTENT(INOUT) :: ksize
REAL, DIMENSION(SIZE(POUT)) :: zdout
INTEGER :: i, j
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('GET_XYALL_IGN:GET_COORD',0,zhook_handle)
!
zdout(:) = 0.
pout(:) = -9999.
IF (SIZE(pout)>0) THEN
  zdout(1) = pdin(1)/2.
  pout(1) = pin(1)
  IF (SIZE(pout)>1) pout(2) = pin(1)-pdin(1)
  IF (SIZE(pout)>2) pout(3) = pin(1)+pdin(1)
ENDIF
ksize = min(3,SIZE(pin))
!
DO i=1,SIZE(pin)
  !point
  DO j=1,ksize
    IF ( pout(j) == pin(i) ) EXIT
    IF ( j == ksize ) THEN
      ksize = ksize + 1
      pout(ksize) = pin(i)
      zdout(ksize) = pdin(i)/2.
    ENDIF
  ENDDO
  !limits of the mesh
   DO j=1,ksize
     IF ( pout(j)<pin(i) .AND. pout(j)+zdout(j)>=pin(i)-pdin(i) ) EXIT
     IF ( j == ksize ) THEN     
       ksize = ksize + 1
       pout(ksize) = pin(i)-pdin(i)
     ENDIF
   ENDDO
   DO j=1,ksize
     IF ( pout(j)>pin(i) .AND. pout(j)-zdout(j)<=pin(i)+pdin(i) ) EXIT
     IF ( j == ksize ) THEN     
       ksize = ksize + 1
       pout(ksize) = pin(i)+pdin(i)
     ENDIF
   ENDDO   
ENDDO
!
IF (lhook) CALL dr_hook('GET_XYALL_IGN:GET_COORD',1,zhook_handle)
!
END SUBROUTINE get_coord
!
SUBROUTINE sort(KSIZE,PIN,POUT)
!
IMPLICIT NONE
!
INTEGER, INTENT(INOUT) :: ksize
REAL, DIMENSION(:), INTENT(INOUT) :: pin
REAL, DIMENSION(:), INTENT(OUT) :: pout
REAL, DIMENSION(SIZE(PIN)) :: zout
REAL :: zmin, zmax
INTEGER,DIMENSION(1) :: idmin
INTEGER :: j
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('GET_XYALL_IGN:SORT',0,zhook_handle)
!
zmax  = maxval(pin(1:ksize))
DO j=1,ksize
  zmin  = minval(pin(1:ksize))
  zout(j) = zmin
  idmin = minloc(pin(1:ksize))
  pin(idmin(1)) = zmax+1
ENDDO
!
!to suppress fictive points at boundaries
pout(1:ksize-2) = zout(2:ksize-1)
ksize = max(0,ksize-2)
!
IF (lhook) CALL dr_hook('GET_XYALL_IGN:SORT',1,zhook_handle)
!
END SUBROUTINE sort
!
END SUBROUTINE get_xyall_ign