Skip to content

Commit

Permalink
Merge pull request #2 from jvdp1/sort_sign
Browse files Browse the repository at this point in the history 
Add option for reverse sort in `sort` and `ord_sort`
  • Loading branch information
@wclodius2
wclodius2 authored May 29, 2021
2 parents 8e59d2f + 41b8b8e commit 5a6f463
Show file tree
Hide file tree
Showing 4 changed files with 489 additions and 120 deletions.
14 changes: 9 additions & 5 deletions src/stdlib_sorting.fypp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -336,24 +336,26 @@ module stdlib_sorting
!! non-decreasing data.
#:for k1, t1 in IRS_KINDS_TYPES
module subroutine ${k1}$_ord_sort( array, work )
module subroutine ${k1}$_ord_sort( array, work, reverse )
!! Version: experimental
!!
!! `${k1}$_ord_sort( array )` sorts the input `ARRAY` of type `${t1}$`
!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs`
${t1}$, intent(inout) :: array(0:)
${t1}$, intent(out), optional :: work(0:)
logical, intent(in), optional :: reverse
end subroutine ${k1}$_ord_sort
#:endfor
module subroutine char_ord_sort( array, work )
module subroutine char_ord_sort( array, work, reverse )
!! Version: experimental
!!
!! `char_ord_sort( array )` sorts the input `ARRAY` of type `CHARACTER(*)`
!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs`
character(len=*), intent(inout) :: array(0:)
character(len=len(array)), intent(out), optional :: work(0:)
logical, intent(in), optional :: reverse
end subroutine char_ord_sort

end interface ord_sort
Expand All @@ -365,20 +367,21 @@ module stdlib_sorting
!! on the `introsort` of David Musser.

#:for k1, t1 in IRS_KINDS_TYPES
pure module subroutine ${k1}$_sort( array )
pure module subroutine ${k1}$_sort( array, reverse )
!! Version: experimental
!!
!! `${k1}$_sort( array )` sorts the input `ARRAY` of type `${t1}$`
!! using a hybrid sort based on the `introsort` of David Musser.
!! The algorithm is of order O(N Ln(N)) for all inputs.
!! Because it relies on `quicksort`, the coefficient of the O(N Ln(N))
!! behavior is small for random data compared to other sorting algorithms.
${t1}$, intent(inout) :: array(0:)
${t1}$, intent(inout) :: array(0:)
logical, intent(in), optional :: reverse
end subroutine ${k1}$_sort

#:endfor

pure module subroutine char_sort( array )
pure module subroutine char_sort( array, reverse )
!! Version: experimental
!!
!! `char_sort( array )` sorts the input `ARRAY` of type `CHARACTER(*)`
Expand All @@ -387,6 +390,7 @@ module stdlib_sorting
!! Because it relies on `quicksort`, the coefficient of the O(N Ln(N))
!! behavior is small for random data compared to other sorting algorithms.
character(len=*), intent(inout) :: array(0:)
logical, intent(in), optional :: reverse
end subroutine char_sort

end interface sort
Expand Down
87 changes: 67 additions & 20 deletions src/stdlib_sorting_ord_sort.fypp
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,11 @@
#:include "common.fypp"
#:set IRS_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES + STRING_KINDS_TYPES

#:set SIGN_NAME = ["increase", "decrease"]
#:set SIGN_TYPE = [">", "<"]
#:set SIGN_OPP_TYPE = ["<", ">"]
#:set SIGN_NAME_TYPE = list(zip(SIGN_NAME, SIGN_TYPE, SIGN_OPP_TYPE))

!! Licensing:
!!
!! This file is subjec† both to the Fortran Standard Library license, and
Expand Down Expand Up @@ -57,8 +62,29 @@ submodule(stdlib_sorting) stdlib_sorting_ord_sort
contains
#:for k1, t1 in IRS_KINDS_TYPES
module subroutine ${k1}$_ord_sort( array, work, reverse )
${t1}$, intent(inout) :: array(0:)
${t1}$, intent(out), optional :: work(0:)
logical, intent(in), optional :: reverse
logical :: reverse_
reverse_ = .false.
if(present(reverse)) reverse_ = reverse
if (reverse_) then
call ${k1}$_decrease_ord_sort(array, work)
else
call ${k1}$_increase_ord_sort(array, work)
endif
module subroutine ${k1}$_ord_sort( array, work )
end subroutine ${k1}$_ord_sort
#:endfor
#:for sname, signt, signoppt in SIGN_NAME_TYPE
#:for k1, t1 in IRS_KINDS_TYPES
subroutine ${k1}$_${sname}$_ord_sort( array, work )
! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in
! `slice.rs`
! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159
Expand Down Expand Up @@ -92,7 +118,7 @@ contains
! Allocate a buffer to use as scratch memory.
array_size = size( array, kind=int_size )
allocate( buf(0:array_size/2-1), stat=stat )
if ( stat /= 0 ) error stop "${k1}$_ord_sort: Allocation of buffer failed."
if ( stat /= 0 ) error stop "${k1}$_${sname}$_ord_sort: Allocation of buffer failed."
call merge_sort( array, buf )
end if
Expand Down Expand Up @@ -129,7 +155,7 @@ contains
do j=1, size(array, kind=int_size)-1
key = array(j)
i = j - 1
do while( i >= 0 .and. array(i) > key )
do while( i >= 0 .and. array(i) ${signt}$ key )
array(i+1) = array(i)
i = i - 1
end do
Expand Down Expand Up @@ -204,7 +230,7 @@ contains
tmp = array(0)
find_hole: do i=1, size(array, kind=int_size)-1
if ( array(i) >= tmp ) exit find_hole
if ( array(i) ${signt}$= tmp ) exit find_hole
array(i-1) = array(i)
end do find_hole
array(i-1) = tmp
Expand Down Expand Up @@ -263,16 +289,16 @@ contains
start = finish
if ( start > 0 ) then
start = start - 1
if ( array(start+1) < array(start) ) then
if ( array(start+1) ${signoppt}$ array(start) ) then
Descending: do while ( start > 0 )
if ( array(start) >= array(start-1) ) &
if ( array(start) ${signt}$= array(start-1) ) &
exit Descending
start = start - 1
end do Descending
call reverse_segment( array(start:finish) )
else
Ascending: do while( start > 0 )
if ( array(start) < array(start-1) ) exit Ascending
if ( array(start) ${signoppt}$ array(start-1) ) exit Ascending
start = start - 1
end do Ascending
end if
Expand Down Expand Up @@ -338,7 +364,7 @@ contains
i = 0
j = mid
merge_lower: do k = 0, array_len-1
if ( buf(i) <= array(j) ) then
if ( buf(i) ${signoppt}$= array(j) ) then
array(k) = buf(i)
i = i + 1
if ( i >= mid ) exit merge_lower
Expand All @@ -356,7 +382,7 @@ contains
i = mid - 1
j = array_len - mid -1
merge_upper: do k = array_len-1, 0, -1
if ( buf(j) >= array(i) ) then
if ( buf(j) ${signt}$= array(i) ) then
array(k) = buf(j)
j = j - 1
if ( j < 0 ) exit merge_upper
Expand Down Expand Up @@ -392,12 +418,32 @@ contains

end subroutine reverse_segment

end subroutine ${k1}$_ord_sort
end subroutine ${k1}$_${sname}$_ord_sort

#:endfor
#:endfor

module subroutine char_ord_sort( array, work, reverse )
character(len=*), intent(inout) :: array(0:)
character(len=len(array)), intent(out), optional :: work(0:)
logical, intent(in), optional :: reverse

logical :: reverse_

reverse_ = .false.
if(present(reverse)) reverse_ = reverse

if (reverse_) then
call char_decrease_ord_sort(array, work)
else
call char_increase_ord_sort(array, work)
endif

end subroutine char_ord_sort

module subroutine char_ord_sort( array, work )

#:for sname, signt, signoppt in SIGN_NAME_TYPE
subroutine char_${sname}$_ord_sort( array, work )
! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in
! `slice.rs`
! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159
Expand Down Expand Up @@ -432,7 +478,7 @@ contains
array_size = size( array, kind=int_size )
allocate( character(len=len(array)) :: buf(0:array_size/2-1), &
stat=stat )
if ( stat /= 0 ) error stop "${k1}$_ord_sort: Allocation of buffer failed."
if ( stat /= 0 ) error stop "${k1}$_${sname}$_ord_sort: Allocation of buffer failed."
call merge_sort( array, buf )
end if

Expand Down Expand Up @@ -469,7 +515,7 @@ contains
do j=1, size(array, kind=int_size)-1
key = array(j)
i = j - 1
do while( i >= 0 .and. array(i) > key )
do while( i >= 0 .and. array(i) ${signt}$ key )
array(i+1) = array(i)
i = i - 1
end do
Expand Down Expand Up @@ -544,7 +590,7 @@ contains

tmp = array(0)
find_hole: do i=1, size(array, kind=int_size)-1
if ( array(i) >= tmp ) exit find_hole
if ( array(i) ${signt}$= tmp ) exit find_hole
array(i-1) = array(i)
end do find_hole
array(i-1) = tmp
Expand Down Expand Up @@ -603,16 +649,16 @@ contains
start = finish
if ( start > 0 ) then
start = start - 1
if ( array(start+1) < array(start) ) then
if ( array(start+1) ${signoppt}$ array(start) ) then
Descending: do while ( start > 0 )
if ( array(start) >= array(start-1) ) &
if ( array(start) ${signt}$= array(start-1) ) &
exit Descending
start = start - 1
end do Descending
call reverse_segment( array(start:finish) )
else
Ascending: do while( start > 0 )
if ( array(start) < array(start-1) ) exit Ascending
if ( array(start) ${signoppt}$ array(start-1) ) exit Ascending
start = start - 1
end do Ascending
end if
Expand Down Expand Up @@ -678,7 +724,7 @@ contains
i = 0
j = mid
merge_lower: do k = 0, array_len-1
if ( buf(i) <= array(j) ) then
if ( buf(i) ${signoppt}$= array(j) ) then
array(k) = buf(i)
i = i + 1
if ( i >= mid ) exit merge_lower
Expand All @@ -696,7 +742,7 @@ contains
i = mid - 1
j = array_len - mid -1
merge_upper: do k = array_len-1, 0, -1
if ( buf(j) >= array(i) ) then
if ( buf(j) ${signt}$= array(i) ) then
array(k) = buf(j)
j = j - 1
if ( j < 0 ) exit merge_upper
Expand Down Expand Up @@ -732,7 +778,8 @@ contains
end subroutine reverse_segment
end subroutine char_ord_sort
end subroutine char_${sname}$_ord_sort
#:endfor
end submodule stdlib_sorting_ord_sort
Loading

0 comments on commit 5a6f463

Please sign in to comment.