Skip to content

Commit 5a6f463

Browse files
wclodius2wclodius2
authored
Merge pull request #2 from jvdp1/sort_sign
Add option for reverse sort in `sort` and `ord_sort`
2 parents 8e59d2f + 41b8b8e commit 5a6f463

File tree

4 files changed

+489
-120
lines changed

4 files changed

+489
-120
lines changed

Diff for: ‎src/stdlib_sorting.fypp

+9-5
Original file line numberDiff line numberDiff line change
@@ -336,24 +336,26 @@ module stdlib_sorting
336336
!! non-decreasing data.
337337

338338
#:for k1, t1 in IRS_KINDS_TYPES
339-
module subroutine ${k1}$_ord_sort( array, work )
339+
module subroutine ${k1}$_ord_sort( array, work, reverse )
340340
!! Version: experimental
341341
!!
342342
!! `${k1}$_ord_sort( array )` sorts the input `ARRAY` of type `${t1}$`
343343
!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs`
344344
${t1}$, intent(inout) :: array(0:)
345345
${t1}$, intent(out), optional :: work(0:)
346+
logical, intent(in), optional :: reverse
346347
end subroutine ${k1}$_ord_sort
347348

348349
#:endfor
349350

350-
module subroutine char_ord_sort( array, work )
351+
module subroutine char_ord_sort( array, work, reverse )
351352
!! Version: experimental
352353
!!
353354
!! `char_ord_sort( array )` sorts the input `ARRAY` of type `CHARACTER(*)`
354355
!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs`
355356
character(len=*), intent(inout) :: array(0:)
356357
character(len=len(array)), intent(out), optional :: work(0:)
358+
logical, intent(in), optional :: reverse
357359
end subroutine char_ord_sort
358360

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

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

379382
#:endfor
380383

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

392396
end interface sort

Diff for: ‎src/stdlib_sorting_ord_sort.fypp

+67-20
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,11 @@
11
#:include "common.fypp"
22
#:set IRS_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES + STRING_KINDS_TYPES
33

4+
#:set SIGN_NAME = ["increase", "decrease"]
5+
#:set SIGN_TYPE = [">", "<"]
6+
#:set SIGN_OPP_TYPE = ["<", ">"]
7+
#:set SIGN_NAME_TYPE = list(zip(SIGN_NAME, SIGN_TYPE, SIGN_OPP_TYPE))
8+
49
!! Licensing:
510
!!
611
!! This file is subjec† both to the Fortran Standard Library license, and
@@ -57,8 +62,29 @@ submodule(stdlib_sorting) stdlib_sorting_ord_sort
5762
contains
5863

5964
#:for k1, t1 in IRS_KINDS_TYPES
65+
module subroutine ${k1}$_ord_sort( array, work, reverse )
66+
${t1}$, intent(inout) :: array(0:)
67+
${t1}$, intent(out), optional :: work(0:)
68+
logical, intent(in), optional :: reverse
69+
70+
logical :: reverse_
71+
72+
reverse_ = .false.
73+
if(present(reverse)) reverse_ = reverse
74+
75+
if (reverse_) then
76+
call ${k1}$_decrease_ord_sort(array, work)
77+
else
78+
call ${k1}$_increase_ord_sort(array, work)
79+
endif
6080

61-
module subroutine ${k1}$_ord_sort( array, work )
81+
end subroutine ${k1}$_ord_sort
82+
#:endfor
83+
84+
#:for sname, signt, signoppt in SIGN_NAME_TYPE
85+
#:for k1, t1 in IRS_KINDS_TYPES
86+
87+
subroutine ${k1}$_${sname}$_ord_sort( array, work )
6288
! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in
6389
! `slice.rs`
6490
! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159
@@ -92,7 +118,7 @@ contains
92118
! Allocate a buffer to use as scratch memory.
93119
array_size = size( array, kind=int_size )
94120
allocate( buf(0:array_size/2-1), stat=stat )
95-
if ( stat /= 0 ) error stop "${k1}$_ord_sort: Allocation of buffer failed."
121+
if ( stat /= 0 ) error stop "${k1}$_${sname}$_ord_sort: Allocation of buffer failed."
96122
call merge_sort( array, buf )
97123
end if
98124

@@ -129,7 +155,7 @@ contains
129155
do j=1, size(array, kind=int_size)-1
130156
key = array(j)
131157
i = j - 1
132-
do while( i >= 0 .and. array(i) > key )
158+
do while( i >= 0 .and. array(i) ${signt}$ key )
133159
array(i+1) = array(i)
134160
i = i - 1
135161
end do
@@ -204,7 +230,7 @@ contains
204230

205231
tmp = array(0)
206232
find_hole: do i=1, size(array, kind=int_size)-1
207-
if ( array(i) >= tmp ) exit find_hole
233+
if ( array(i) ${signt}$= tmp ) exit find_hole
208234
array(i-1) = array(i)
209235
end do find_hole
210236
array(i-1) = tmp
@@ -263,16 +289,16 @@ contains
263289
start = finish
264290
if ( start > 0 ) then
265291
start = start - 1
266-
if ( array(start+1) < array(start) ) then
292+
if ( array(start+1) ${signoppt}$ array(start) ) then
267293
Descending: do while ( start > 0 )
268-
if ( array(start) >= array(start-1) ) &
294+
if ( array(start) ${signt}$= array(start-1) ) &
269295
exit Descending
270296
start = start - 1
271297
end do Descending
272298
call reverse_segment( array(start:finish) )
273299
else
274300
Ascending: do while( start > 0 )
275-
if ( array(start) < array(start-1) ) exit Ascending
301+
if ( array(start) ${signoppt}$ array(start-1) ) exit Ascending
276302
start = start - 1
277303
end do Ascending
278304
end if
@@ -338,7 +364,7 @@ contains
338364
i = 0
339365
j = mid
340366
merge_lower: do k = 0, array_len-1
341-
if ( buf(i) <= array(j) ) then
367+
if ( buf(i) ${signoppt}$= array(j) ) then
342368
array(k) = buf(i)
343369
i = i + 1
344370
if ( i >= mid ) exit merge_lower
@@ -356,7 +382,7 @@ contains
356382
i = mid - 1
357383
j = array_len - mid -1
358384
merge_upper: do k = array_len-1, 0, -1
359-
if ( buf(j) >= array(i) ) then
385+
if ( buf(j) ${signt}$= array(i) ) then
360386
array(k) = buf(j)
361387
j = j - 1
362388
if ( j < 0 ) exit merge_upper
@@ -392,12 +418,32 @@ contains
392418

393419
end subroutine reverse_segment
394420

395-
end subroutine ${k1}$_ord_sort
421+
end subroutine ${k1}$_${sname}$_ord_sort
396422

397423
#:endfor
424+
#:endfor
425+
426+
module subroutine char_ord_sort( array, work, reverse )
427+
character(len=*), intent(inout) :: array(0:)
428+
character(len=len(array)), intent(out), optional :: work(0:)
429+
logical, intent(in), optional :: reverse
430+
431+
logical :: reverse_
432+
433+
reverse_ = .false.
434+
if(present(reverse)) reverse_ = reverse
398435

436+
if (reverse_) then
437+
call char_decrease_ord_sort(array, work)
438+
else
439+
call char_increase_ord_sort(array, work)
440+
endif
441+
442+
end subroutine char_ord_sort
399443

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

@@ -469,7 +515,7 @@ contains
469515
do j=1, size(array, kind=int_size)-1
470516
key = array(j)
471517
i = j - 1
472-
do while( i >= 0 .and. array(i) > key )
518+
do while( i >= 0 .and. array(i) ${signt}$ key )
473519
array(i+1) = array(i)
474520
i = i - 1
475521
end do
@@ -544,7 +590,7 @@ contains
544590

545591
tmp = array(0)
546592
find_hole: do i=1, size(array, kind=int_size)-1
547-
if ( array(i) >= tmp ) exit find_hole
593+
if ( array(i) ${signt}$= tmp ) exit find_hole
548594
array(i-1) = array(i)
549595
end do find_hole
550596
array(i-1) = tmp
@@ -603,16 +649,16 @@ contains
603649
start = finish
604650
if ( start > 0 ) then
605651
start = start - 1
606-
if ( array(start+1) < array(start) ) then
652+
if ( array(start+1) ${signoppt}$ array(start) ) then
607653
Descending: do while ( start > 0 )
608-
if ( array(start) >= array(start-1) ) &
654+
if ( array(start) ${signt}$= array(start-1) ) &
609655
exit Descending
610656
start = start - 1
611657
end do Descending
612658
call reverse_segment( array(start:finish) )
613659
else
614660
Ascending: do while( start > 0 )
615-
if ( array(start) < array(start-1) ) exit Ascending
661+
if ( array(start) ${signoppt}$ array(start-1) ) exit Ascending
616662
start = start - 1
617663
end do Ascending
618664
end if
@@ -678,7 +724,7 @@ contains
678724
i = 0
679725
j = mid
680726
merge_lower: do k = 0, array_len-1
681-
if ( buf(i) <= array(j) ) then
727+
if ( buf(i) ${signoppt}$= array(j) ) then
682728
array(k) = buf(i)
683729
i = i + 1
684730
if ( i >= mid ) exit merge_lower
@@ -696,7 +742,7 @@ contains
696742
i = mid - 1
697743
j = array_len - mid -1
698744
merge_upper: do k = array_len-1, 0, -1
699-
if ( buf(j) >= array(i) ) then
745+
if ( buf(j) ${signt}$= array(i) ) then
700746
array(k) = buf(j)
701747
j = j - 1
702748
if ( j < 0 ) exit merge_upper
@@ -732,7 +778,8 @@ contains
732778

733779
end subroutine reverse_segment
734780

735-
end subroutine char_ord_sort
781+
end subroutine char_${sname}$_ord_sort
782+
#:endfor
736783

737784
end submodule stdlib_sorting_ord_sort
738785

0 commit comments

Comments
 (0)