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)
pxall(1:kdimx) = zall(1:kdimx)
!
 CALL get_coord(py,pdy,zall,kdimy)
pyall(1:kdimy) = zall(1:kdimy) 
!
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, ZOUT, ZDOUT2
REAL :: ZMAX, ZMIN
INTEGER :: I, J, IDMIN, ICPT, ISIZE
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('GET_XYALL_IGN:GET_COORD',0,zhook_handle)
!
ksize = SIZE(pin)
zout(1:ksize) = pin(:)
zdout(1:ksize) = pdin(:)
!
zmax  = maxval(zout(1:ksize))
DO j=1,ksize
  zmin  = minval(zout(1:ksize))
  pout(j) = zmin
  idmin = minloc(zout(1:ksize),1)
  zdout2(j) = zdout(idmin)  
  zout(idmin) = zmax+1
ENDDO
!
zout(1:ksize) = pout(1:ksize)
zdout(1:ksize) = zdout2(1:ksize)
!
icpt = 1
isize = ksize
DO j=1,isize-1
  IF (zout(j)==zout(j+1)) THEN
    IF (j<isize-1) THEN
      pout(icpt+1:ksize-1) = zout(j+2:isize)
      zdout(icpt+1:ksize-1) = zdout2(j+2:isize)
    ENDIF
    ksize = ksize - 1
  ELSE
    icpt = icpt + 1
  ENDIF
ENDDO
!
isize = ksize
DO j=1,isize-1
  IF (pout(j)+zdout(j)/2.<pout(j+1)-zdout(j+1)/2.) THEN
    icpt = 0
    ksize = ksize + 1
    pout(ksize) = pout(j) + zdout(j)
    zdout(ksize) = zdout(j)
    DO WHILE ( pout(ksize)+zdout(ksize)/2. < pout(j+1)-zdout(j+1)/2. )
      pout(ksize+1) = pout(ksize) + zdout(ksize)
      zdout(ksize+1) = zdout(ksize)
      ksize = ksize + 1
    ENDDO
  ENDIF
ENDDO
!
zout(1:ksize) = pout(1:ksize)
!
zmax  = maxval(zout(1:ksize))
DO j=1,ksize
  zmin  = minval(zout(1:ksize))
  pout(j) = zmin
  idmin = minloc(zout(1:ksize),1)
  zout(idmin) = zmax+1
ENDDO
!
IF (lhook) CALL dr_hook('GET_XYALL_IGN:GET_COORD',1,zhook_handle)
!
END SUBROUTINE get_coord
!
END SUBROUTINE get_xyall_ign