Sort_Utility.f90

Go to the documentation of this file.

!
! Sort_Utility
!
! Module containing routines for sorting
!
!
! CREATION HISTORY:
!       Written by: Paul van Delst, 30-May-2006
!                   paul.vandelst@noaa.gov
!

MODULE sort_utility

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Module usage
  USE type_kinds
  ! Diable implicit typing
  IMPLICIT NONE


  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Public routines in this module
  PUBLIC :: insertionsort
  PUBLIC :: uniquecount
  PUBLIC :: unique


  ! ---------------------
  ! Procedure overloading
  ! ---------------------
  INTERFACE insertionsort
    MODULE PROCEDURE isort_long
    MODULE PROCEDURE isortidx_long
    MODULE PROCEDURE isort_char
    MODULE PROCEDURE isortidx_char
!    MODULE PROCEDURE iSort_Single
!    MODULE PROCEDURE iSort_Double
  END INTERFACE insertionsort

  INTERFACE uniquecount
    MODULE PROCEDURE uniquecount_long
    MODULE PROCEDURE uniquecount_char
  END INTERFACE uniquecount
  
  INTERFACE unique
    MODULE PROCEDURE unique_long
    MODULE PROCEDURE unique_char
  END INTERFACE unique
  
  
CONTAINS


  PURE SUBROUTINE isort_long( x )
    INTEGER(Long), DIMENSION(:), INTENT(IN OUT) :: x
    INTEGER(Long) :: t
    INTEGER :: n, i, j
    n=SIZE(x)
    DO i = 2, n
      t = x(i)
      j = i
      DO
        IF (    j   < 2 ) EXIT
        IF ( x(j-1) < t ) EXIT  ! Separate exit since no short circuit
        x(j) = x(j-1)
        j = j-1
      END DO
      x(j) = t
    END DO
  END SUBROUTINE isort_long

  PURE SUBROUTINE isortidx_long( x, Idx )
    INTEGER(Long), DIMENSION(:),       INTENT(IN)  :: x
    INTEGER,       DIMENSION(SIZE(x)), INTENT(OUT) :: idx
    INTEGER(Long) :: t
    INTEGER :: u
    INTEGER :: n, i, j
    n=SIZE(x)
    idx=(/(i,i=1,n)/)
    DO i = 2, n
      u = idx(i)
      t = x(u)
      j = i
      DO 
        IF (     j       < 2 ) EXIT
        IF ( x(idx(j-1)) < t ) EXIT  ! Separate exit since no short circuit
        idx(j)   = idx(j-1)
        j = j-1
      END DO
      idx(j) = u
    END DO
  END SUBROUTINE isortidx_long


  PURE SUBROUTINE isort_char( x )
    CHARACTER(*), DIMENSION(:), INTENT(IN OUT) :: x
    CHARACTER(LEN(x(1))) :: t
    INTEGER :: n, i, j
    n=SIZE(x)
    DO i = 2, n
      t = x(i)
      j = i
      DO
        IF (      j < 2    ) EXIT
        IF ( llt(x(j-1),t) ) EXIT  ! Separate exit since no short circuit
        x(j) = x(j-1)
        j = j-1
      END DO
      x(j) = t
    END DO
  END SUBROUTINE isort_char


  PURE SUBROUTINE isortidx_char( x, Idx )
    CHARACTER(*), DIMENSION(:),       INTENT(IN)  :: x
    INTEGER,      DIMENSION(SIZE(x)), INTENT(OUT) :: idx
    CHARACTER(LEN(x(1))) :: t
    INTEGER :: u
    INTEGER :: n, i, j
    n=SIZE(x)
    idx=(/(i,i=1,n)/)
    DO i = 2, n
      u = idx(i)
      t = x(u)
      j = i
      DO 
        IF (        j < 2       ) EXIT
        IF ( llt(x(idx(j-1)),t) ) EXIT  ! Separate exit since no short circuit
        idx(j)   = idx(j-1)
        j = j-1
      END DO
      idx(j) = u
    END DO
  END SUBROUTINE isortidx_char


  PURE FUNCTION uniquecount_long( x ) RESULT( n )
    INTEGER(Long), INTENT(IN) :: x(:)
    INTEGER(Long) :: n
    INTEGER(Long) :: lx(size(x))
    n = SIZE(x)
    IF ( n < 2 ) RETURN
    lx = x
    CALL insertionsort(lx)
    n = count(lx /= cshift(lx,-1))
  END FUNCTION uniquecount_long


  PURE FUNCTION uniquecount_char( x ) RESULT( n )
    CHARACTER(*), INTENT(IN) :: x(:)
    INTEGER(Long) :: n
    CHARACTER(LEN(x)) :: lx(size(x))
    n = SIZE(x)
    IF ( n < 2 ) RETURN
    lx = x
    CALL insertionsort(lx)
    n = count(lx /= cshift(lx,-1))
  END FUNCTION uniquecount_char


  PURE FUNCTION unique_long( x ) RESULT( ux )
    INTEGER(Long), INTENT(IN) :: x(:)
    INTEGER(Long) :: ux(uniquecount(x))
    INTEGER(Long) :: lx(size(x))
    IF ( SIZE(x) == 1 ) THEN
      ux = x
      RETURN
    END IF
    lx = x
    CALL insertionsort(lx)
    ux = pack(lx, lx /= cshift(lx,-1))
  END FUNCTION unique_long


  PURE FUNCTION unique_char( x ) RESULT( ux )
    CHARACTER(*), INTENT(IN) :: x(:)
    CHARACTER(LEN(x)) :: ux(uniquecount(x))
    CHARACTER(LEN(x)) :: lx(size(x))
    IF ( SIZE(x) == 1 ) THEN
      ux = x
      RETURN
    END IF
    lx = x
    CALL insertionsort(lx)
    ux = pack(lx, lx /= cshift(lx,-1))
  END FUNCTION unique_char

END MODULE sort_utility