tools_qsort.F90

Go to the documentation of this file.

# 1 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
# 1 "/Users/miesch/JEDI/code/working_copy/public/fv3-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
!----------------------------------------------------------------------
 
# 56 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/../generics.fypp"
# 2 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp" 2
# 1 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/../instrumentation.fypp" 1
# 1 "/Users/miesch/JEDI/code/working_copy/public/fv3-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
!----------------------------------------------------------------------
 
# 726 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/../subr_list.fypp"
# 2 "/Users/miesch/JEDI/code/working_copy/public/fv3-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/public/fv3-bundle/saber/src/saber/external/../instrumentation.fypp"
# 3 "/Users/miesch/JEDI/code/working_copy/public/fv3-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: inf,sup
 
 
implicit none
 
interface qsort
# 24 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
     module procedure qsort_qsort_int
# 24 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
     module procedure qsort_qsort_real
# 26 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
end interface
interface quick_sort
# 29 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
     module procedure qsort_quick_sort_int
# 29 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
     module procedure qsort_quick_sort_real
# 31 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
end interface
interface interchange_sort
# 34 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
     module procedure qsort_interchange_sort_int
# 34 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
     module procedure qsort_interchange_sort_real
# 36 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
end interface
 
private
public :: qsort
 
contains
 
# 44 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
!----------------------------------------------------------------------
! Subroutine: qsort_qsort_int
!> Sort a subvector
!----------------------------------------------------------------------
recursive subroutine qsort_qsort_int(n,list,order)
 
implicit none
 
! Passed variables
integer, intent(in) :: n                   !< Input vector size
integer(kind_int),intent(inout) :: list(n)  !< Vector to sort
integer,intent(inout),optional :: order(n) !< Positions of the elements in the original order
 
! Local variable
integer :: i
integer :: lorder(n)
 
do i=1,n
  lorder(i) = i
end do
 
call quick_sort(n,1,n,list,lorder)
 
if (present(order)) order = lorder
 
end subroutine qsort_qsort_int
# 44 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
!----------------------------------------------------------------------
! Subroutine: qsort_qsort_real
!> Sort a subvector
!----------------------------------------------------------------------
recursive subroutine qsort_qsort_real(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(inout),optional :: order(n) !< Positions of the elements in the original order
 
! Local variable
integer :: i
integer :: lorder(n)
 
do i=1,n
  lorder(i) = i
end do
 
call quick_sort(n,1,n,list,lorder)
 
if (present(order)) order = lorder
 
end subroutine qsort_qsort_real
# 71 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
 
# 73 "/Users/miesch/JEDI/code/working_copy/public/fv3-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.inf(list(i),reference)) exit
    end do
    ! Scan list from right end until element <= reference is found
    do
      j = j-1
      if (.not.sup(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
# 73 "/Users/miesch/JEDI/code/working_copy/public/fv3-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.inf(list(i),reference)) exit
    end do
    ! Scan list from right end until element <= reference is found
    do
      j = j-1
      if (.not.sup(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
# 135 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
 
# 137 "/Users/miesch/JEDI/code/working_copy/public/fv3-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 (sup(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
# 137 "/Users/miesch/JEDI/code/working_copy/public/fv3-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 (sup(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
# 180 "/Users/miesch/JEDI/code/working_copy/public/fv3-bundle/saber/src/saber/external/tools_qsort.fypp"
 
end module tools_qsort