tools_qsort.F90

Go to the documentation of this file.

# 1 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
# 1 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/../generics.fypp" 1
!----------------------------------------------------------------------
! Header: generics
!> Generic ranks, dimensions and types
! Author: Benjamin Menetrier
! Licensing: this code is distributed under the CeCILL-C license
! Copyright 2015-... UCAR, CERFACS, METEO-FRANCE and IRIT
!----------------------------------------------------------------------
 
# 57 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/../generics.fypp"
# 2 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp" 2
# 1 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/../instrumentation.fypp" 1
# 1 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/../subr_list.fypp" 1
!----------------------------------------------------------------------
! Header: subr_list
!> Subroutines/functions list
! Author: Benjamin Menetrier
! Licensing: this code is distributed under the CeCILL-C license
! Copyright 2015-... UCAR, CERFACS, METEO-FRANCE and IRIT
!----------------------------------------------------------------------
 
# 926 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/../subr_list.fypp"
# 2 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/../instrumentation.fypp" 2
!----------------------------------------------------------------------
! Header: instrumentation
!> Instrumentation functions
! Author: Benjamin Menetrier
! Licensing: this code is distributed under the CeCILL-C license
! Copyright 2015-... UCAR, CERFACS, METEO-FRANCE and IRIT
!----------------------------------------------------------------------
 
# 112 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/../instrumentation.fypp"
# 3 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp" 2
!----------------------------------------------------------------------
! Module: tools_qsort
!> Qsort routines
! Source: http://jblevins.org/mirror/amiller/qsort.f90
! Author: Brainerd, W.S., Goldberg, C.H. & Adams, J.C. (1990) "Programmer's Guide to Fortran 90", McGraw-Hill  ISBN 0-07-000248-7, pages 149-150.
! Original licensing: none
! Modified by Alan Miller
! Modified by Benjamin Menetrier for BUMP
! Licensing: this code is distributed under the CeCILL-C license
! Copyright 2015-... UCAR, CERFACS, METEO-FRANCE and IRIT
!----------------------------------------------------------------------
module tools_qsort
 
use tools_kinds, only: kind_int,kind_real
use tools_repro, only: eq,inf
 
 
implicit none
 
interface qsort
# 24 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
     module procedure qsort_qsort_int
     module procedure qsort_qsort_pair_int
# 24 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
     module procedure qsort_qsort_real
     module procedure qsort_qsort_pair_real
# 27 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
end interface
interface quick_sort
# 30 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
     module procedure qsort_quick_sort_int
# 30 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
     module procedure qsort_quick_sort_real
# 32 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
end interface
interface interchange_sort
# 35 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
     module procedure qsort_interchange_sort_int
# 35 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
     module procedure qsort_interchange_sort_real
# 37 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
end interface
interface reorder_eq
  module procedure qsort_reorder_eq
end interface
 
private
public :: qsort
 
contains
 
# 48 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
!----------------------------------------------------------------------
! Subroutine: qsort_qsort_int
!> Sort a vector
!----------------------------------------------------------------------
recursive subroutine qsort_qsort_int(n,list,order,order_list)
 
implicit none
 
! Passed variables
integer, intent(in) :: n                  !< Input vector size
integer(kind_int),intent(inout) :: list(n) !< Vector to sort
integer,intent(out) :: order(n)           !< Positions of the elements in the original order
logical,intent(in),optional :: order_list !< Flag to reorder the list (default: .true.)
 
! Local variables
integer :: i
integer(kind_int),allocatable :: list_tmp(:)
logical :: lorder_list
 
! Local flag
lorder_list = .true.
if (present(order_list)) lorder_list = order_list
 
! Initialize order
do i=1,n
  order(i) = i
end do
 
if (lorder_list) then
   ! Sort
   call quick_sort(n,1,n,list,order)
 
   ! Reorder equal values
   
else
   ! Allocation
   allocate(list_tmp(n))
 
   ! Copy list
   list = list_tmp
 
   ! Sort
   call quick_sort(n,1,n,list_tmp,order)
 
   ! Reorder equal values
   
 
   ! Release memory
   deallocate(list_tmp)
end if
 
end subroutine qsort_qsort_int
# 48 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
!----------------------------------------------------------------------
! Subroutine: qsort_qsort_real
!> Sort a vector
!----------------------------------------------------------------------
recursive subroutine qsort_qsort_real(n,list,order,order_list)
 
implicit none
 
! Passed variables
integer, intent(in) :: n                  !< Input vector size
real(kind_real),intent(inout) :: list(n) !< Vector to sort
integer,intent(out) :: order(n)           !< Positions of the elements in the original order
logical,intent(in),optional :: order_list !< Flag to reorder the list (default: .true.)
 
! Local variables
integer :: i
real(kind_real),allocatable :: list_tmp(:)
logical :: lorder_list
 
! Local flag
lorder_list = .true.
if (present(order_list)) lorder_list = order_list
 
! Initialize order
do i=1,n
  order(i) = i
end do
 
if (lorder_list) then
   ! Sort
   call quick_sort(n,1,n,list,order)
 
   ! Reorder equal values
    call reorder_eq(n,list,order) 
else
   ! Allocation
   allocate(list_tmp(n))
 
   ! Copy list
   list = list_tmp
 
   ! Sort
   call quick_sort(n,1,n,list_tmp,order)
 
   ! Reorder equal values
    call reorder_eq(n,list_tmp,order) 
 
   ! Release memory
   deallocate(list_tmp)
end if
 
end subroutine qsort_qsort_real
# 101 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
 
# 103 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
!----------------------------------------------------------------------
! Subroutine: qsort_qsort_pair_int
!> Sort two joint vectors
!----------------------------------------------------------------------
recursive subroutine qsort_qsort_pair_int(n,list1,list2,order,order_list)
 
implicit none
 
! Passed variables
integer, intent(in) :: n                   !< Input vector size
integer(kind_int),intent(inout) :: list1(n) !< First vector to sort
integer(kind_int),intent(inout) :: list2(n) !< Second vector to sort
integer,intent(out) :: order(n)            !< Positions of the elements in the original order
logical,intent(in),optional :: order_list  !< Flag to reorder the list (default: .true.)
 
! Local variables
integer :: i_s,i_e,ntmp,i
integer,allocatable :: order_tmp(:)
integer(kind_int) :: list1_tmp(n),list2_tmp(n)
logical :: lorder_list,chain,diff
 
! Local flag
lorder_list = .true.
if (present(order_list)) lorder_list = order_list
 
! Initialize order
do i=1,n
  order(i) = i
end do
 
! Copy first vector
list1_tmp = list1
 
! Sort first vector
call quick_sort(n,1,n,list1_tmp,order)
 
! Reorder equal values
 
 
! Order second vector
list2_tmp = list2(order)
 
! Initialization
i_s = 1
chain = .false.
do i_e=2,n+1
   if (i_e==n+1) then
      diff = .true.
   else
      diff = inf(list1_tmp(i_s),list1_tmp(i_e))
   end if
   if (diff) then
      ! Different value
      if (chain) then
         ! Allocation
         ntmp = i_e-i_s
         allocate(order_tmp(ntmp))
 
         ! Initialize order
         do i=1,ntmp
           order_tmp(i) = i
         end do
 
         ! Sort second vector
         call quick_sort(ntmp,1,ntmp,list2_tmp(i_s:i_e-1),order_tmp)
 
         ! Reorder equal values
         
 
         ! Offset temporary order
         order_tmp = order_tmp+i_s-1
 
         ! Sorder order
         order(i_s:i_e-1) = order(order_tmp)
 
         ! Chain done
         chain = .false.
 
         ! Release memory
         deallocate(order_tmp)
      end if
 
      ! Update
      i_s = i_e
   else
      ! Same value, this is a chain
      chain = .true.
   endif
end do
 
if (lorder_list) then
   ! Reorder vectors
   list1 = list1(order)
   list2 = list2(order)
end if
 
end subroutine qsort_qsort_pair_int
# 103 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
!----------------------------------------------------------------------
! Subroutine: qsort_qsort_pair_real
!> Sort two joint vectors
!----------------------------------------------------------------------
recursive subroutine qsort_qsort_pair_real(n,list1,list2,order,order_list)
 
implicit none
 
! Passed variables
integer, intent(in) :: n                   !< Input vector size
real(kind_real),intent(inout) :: list1(n) !< First vector to sort
real(kind_real),intent(inout) :: list2(n) !< Second vector to sort
integer,intent(out) :: order(n)            !< Positions of the elements in the original order
logical,intent(in),optional :: order_list  !< Flag to reorder the list (default: .true.)
 
! Local variables
integer :: i_s,i_e,ntmp,i
integer,allocatable :: order_tmp(:)
real(kind_real) :: list1_tmp(n),list2_tmp(n)
logical :: lorder_list,chain,diff
 
! Local flag
lorder_list = .true.
if (present(order_list)) lorder_list = order_list
 
! Initialize order
do i=1,n
  order(i) = i
end do
 
! Copy first vector
list1_tmp = list1
 
! Sort first vector
call quick_sort(n,1,n,list1_tmp,order)
 
! Reorder equal values
 call reorder_eq(n,list1_tmp,order) 
 
! Order second vector
list2_tmp = list2(order)
 
! Initialization
i_s = 1
chain = .false.
do i_e=2,n+1
   if (i_e==n+1) then
      diff = .true.
   else
      diff = inf(list1_tmp(i_s),list1_tmp(i_e))
   end if
   if (diff) then
      ! Different value
      if (chain) then
         ! Allocation
         ntmp = i_e-i_s
         allocate(order_tmp(ntmp))
 
         ! Initialize order
         do i=1,ntmp
           order_tmp(i) = i
         end do
 
         ! Sort second vector
         call quick_sort(ntmp,1,ntmp,list2_tmp(i_s:i_e-1),order_tmp)
 
         ! Reorder equal values
          call reorder_eq(ntmp,list2_tmp(i_s:i_e-1),order_tmp) 
 
         ! Offset temporary order
         order_tmp = order_tmp+i_s-1
 
         ! Sorder order
         order(i_s:i_e-1) = order(order_tmp)
 
         ! Chain done
         chain = .false.
 
         ! Release memory
         deallocate(order_tmp)
      end if
 
      ! Update
      i_s = i_e
   else
      ! Same value, this is a chain
      chain = .true.
   endif
end do
 
if (lorder_list) then
   ! Reorder vectors
   list1 = list1(order)
   list2 = list2(order)
end if
 
end subroutine qsort_qsort_pair_real
# 201 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
 
# 203 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
!----------------------------------------------------------------------
! Subroutine: qsort_quick_sort_int
!> Sort an integer subvector
!----------------------------------------------------------------------
recursive subroutine qsort_quick_sort_int(n,left_end,right_end,list,order)
 
implicit none
 
! Passed variables
integer,intent(in) :: n                   !< Input vector size
integer,intent(in) :: left_end            !< Left end of the vector
integer,intent(in) :: right_end           !< Right end of the vector
integer(kind_int),intent(inout) :: list(n) !< Vector to sort
integer,intent(inout) :: order(n)         !< Positions of the elements in the original order
 
! Local variables
integer,parameter :: max_simple_sort_size = 6
integer :: i,j,itemp
integer(kind_int) :: reference,temp
 
if (right_end<left_end+max_simple_sort_size) then
  ! Use interchange sort for small lists
  call interchange_sort(n,left_end,right_end,list,order)
else
  ! Use partition ("quick") sort
  reference = list((left_end+right_end)/2)
  i = left_end-1
  j = right_end+1
  do
    ! Scan list from left end until element >= reference is found
    do
      i = i+1
      if (.not.(list(i)<reference)) exit
    end do
    ! Scan list from right end until element <= reference is found
    do
      j = j-1
      if (.not.(list(j)>reference)) exit
    end do
 
    if (i<j) then
      ! Swap two out-of-order elements
      temp = list(i)
      list(i) = list(j)
      list(j) = temp
      itemp = order(i)
      order(i) = order(j)
      order(j) = itemp
    elseif (i==j) then
      i = i+1
      exit
    else
      exit
    end if
  end do
 
  if (left_end<j) call quick_sort(n,left_end,j,list,order)
  if (i<right_end) call quick_sort(n,i,right_end,list,order)
end if
 
end subroutine qsort_quick_sort_int
# 203 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
!----------------------------------------------------------------------
! Subroutine: qsort_quick_sort_real
!> Sort an integer subvector
!----------------------------------------------------------------------
recursive subroutine qsort_quick_sort_real(n,left_end,right_end,list,order)
 
implicit none
 
! Passed variables
integer,intent(in) :: n                   !< Input vector size
integer,intent(in) :: left_end            !< Left end of the vector
integer,intent(in) :: right_end           !< Right end of the vector
real(kind_real),intent(inout) :: list(n) !< Vector to sort
integer,intent(inout) :: order(n)         !< Positions of the elements in the original order
 
! Local variables
integer,parameter :: max_simple_sort_size = 6
integer :: i,j,itemp
real(kind_real) :: reference,temp
 
if (right_end<left_end+max_simple_sort_size) then
  ! Use interchange sort for small lists
  call interchange_sort(n,left_end,right_end,list,order)
else
  ! Use partition ("quick") sort
  reference = list((left_end+right_end)/2)
  i = left_end-1
  j = right_end+1
  do
    ! Scan list from left end until element >= reference is found
    do
      i = i+1
      if (.not.(list(i)<reference)) exit
    end do
    ! Scan list from right end until element <= reference is found
    do
      j = j-1
      if (.not.(list(j)>reference)) exit
    end do
 
    if (i<j) then
      ! Swap two out-of-order elements
      temp = list(i)
      list(i) = list(j)
      list(j) = temp
      itemp = order(i)
      order(i) = order(j)
      order(j) = itemp
    elseif (i==j) then
      i = i+1
      exit
    else
      exit
    end if
  end do
 
  if (left_end<j) call quick_sort(n,left_end,j,list,order)
  if (i<right_end) call quick_sort(n,i,right_end,list,order)
end if
 
end subroutine qsort_quick_sort_real
# 265 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
 
# 267 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
!----------------------------------------------------------------------
! Subroutine: qsort_interchange_sort_int
!> Interchange integers
!----------------------------------------------------------------------
subroutine qsort_interchange_sort_int(n,left_end,right_end,list,order)
 
implicit none
 
! Passed variables
integer,intent(in) :: n                   !< Input vector size
integer,intent(in) :: left_end            !< Left end of the vector
integer,intent(in) :: right_end           !< Right end of the vector
integer(kind_int),intent(inout) :: list(n) !< Vector to sort
integer,intent(inout) :: order(n)         !< Positions of the elements in the original order
 
! Local variables
integer :: i,j,itemp
integer(kind_int) :: temp
 
! Set name
 
 
! Probe in
 
 
do i=left_end,right_end-1
   do j=i+1,right_end
      if (list(i)>list(j)) then
         temp = list(i)
         list(i) = list(j)
         list(j) = temp
         itemp = order(i)
         order(i) = order(j)
         order(j) = itemp
      end if
   end do
end do
 
! Probe out
 
 
end subroutine qsort_interchange_sort_int
# 267 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
!----------------------------------------------------------------------
! Subroutine: qsort_interchange_sort_real
!> Interchange integers
!----------------------------------------------------------------------
subroutine qsort_interchange_sort_real(n,left_end,right_end,list,order)
 
implicit none
 
! Passed variables
integer,intent(in) :: n                   !< Input vector size
integer,intent(in) :: left_end            !< Left end of the vector
integer,intent(in) :: right_end           !< Right end of the vector
real(kind_real),intent(inout) :: list(n) !< Vector to sort
integer,intent(inout) :: order(n)         !< Positions of the elements in the original order
 
! Local variables
integer :: i,j,itemp
real(kind_real) :: temp
 
! Set name
 
 
! Probe in
 
 
do i=left_end,right_end-1
   do j=i+1,right_end
      if (list(i)>list(j)) then
         temp = list(i)
         list(i) = list(j)
         list(j) = temp
         itemp = order(i)
         order(i) = order(j)
         order(j) = itemp
      end if
   end do
end do
 
! Probe out
 
 
end subroutine qsort_interchange_sort_real
# 310 "/Users/miesch/JEDI/code/working_copy/internal/mpas-bundle/saber/src/saber/external/tools_qsort.fypp"
 
!----------------------------------------------------------------------
! Subroutine: qsort_reorder_eq
!> Reorder equal values
!----------------------------------------------------------------------
recursive subroutine qsort_reorder_eq(n,list,order)
 
implicit none
 
! Passed variables
integer, intent(in) :: n                 !< Input vector size
real(kind_real),intent(inout) :: list(n) !< Vector to sort
integer,intent(out) :: order(n)          !< Positions of the elements in the original order
 
! Local variables
integer :: i_s,i_e,ntmp,i
integer,allocatable :: order_tmp(:)
logical :: chain,diff
 
! Initialization
i_s = 1
chain = .false.
do i_e=2,n+1
   if (i_e==n+1) then
      diff = .true.
   else
      diff = .not.eq(list(i_s),list(i_e))
   end if
   if (diff) then
      ! Different value
      if (chain) then
         ! Allocation
         ntmp = i_e-i_s
         allocate(order_tmp(ntmp))
 
         ! Initialize order
         do i=1,ntmp
           order_tmp(i) = i
         end do
 
         ! Sort second vector
         call quick_sort(ntmp,1,ntmp,order(i_s:i_e-1),order_tmp)
         order_tmp = order_tmp+i_s-1
         list(i_s:i_e-1) = list(order_tmp)
 
         ! Chain done
         chain = .false.
 
         ! Release memory
         deallocate(order_tmp)
      end if
 
      ! Update
      i_s = i_e
   else
      ! Same value, this is a chain
      chain = .true.
   endif
end do
 
end subroutine qsort_reorder_eq
 
end module tools_qsort