From 8960fc02a16efc4f81698e3dccf33bcde2016574 Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Fri, 23 Jul 2021 20:48:27 +0200 Subject: [PATCH 1/2] sort_simp: remove subroutine specific to character, and are now generated by fypp --- src/stdlib_sorting.fypp | 74 ++--- src/stdlib_sorting_ord_sort.fypp | 406 ++------------------------ src/stdlib_sorting_sort.fypp | 220 ++------------- src/stdlib_sorting_sort_index.fypp | 440 ++--------------------------- 4 files changed, 88 insertions(+), 1052 deletions(-) diff --git a/src/stdlib_sorting.fypp b/src/stdlib_sorting.fypp index eeb5317f5..a748d88e3 100644 --- a/src/stdlib_sorting.fypp +++ b/src/stdlib_sorting.fypp @@ -1,5 +1,10 @@ #:include "common.fypp" -#:set IRS_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES + STRING_KINDS_TYPES + +#:set INT_TYPES_ALT_NAME = list(zip(INT_TYPES, INT_TYPES, INT_KINDS)) +#:set REAL_TYPES_ALT_NAME = list(zip(REAL_TYPES, REAL_TYPES, REAL_KINDS)) +#:set STRING_TYPES_ALT_NAME = list(zip(STRING_TYPES, STRING_TYPES, STRING_KINDS)) +#:set CHAR_TYPES_ALT_NAME = list(zip(["character(len=*)"], ["character(len=len(array))"], ["char"])) +#:set IRSC_TYPES_ALT_NAME = INT_TYPES_ALT_NAME + REAL_TYPES_ALT_NAME + STRING_TYPES_ALT_NAME + CHAR_TYPES_ALT_NAME !! Licensing: !! @@ -353,30 +358,19 @@ module stdlib_sorting !! sorted data, having O(N) performance on uniformly non-increasing or !! non-decreasing data. -#:for k1, t1 in IRS_KINDS_TYPES - module subroutine ${k1}$_ord_sort( array, work, reverse ) +#:for t1, t2, name1 in IRSC_TYPES_ALT_NAME + module subroutine ${name1}$_ord_sort( array, work, reverse ) !! Version: experimental !! -!! `${k1}$_ord_sort( array )` sorts the input `ARRAY` of type `${t1}$` +!! `${name1}$_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:) + ${t2}$, intent(out), optional :: work(0:) logical, intent(in), optional :: reverse - end subroutine ${k1}$_ord_sort + end subroutine ${name1}$_ord_sort #:endfor - module subroutine char_ord_sort( array, work, reverse ) -!! Version: experimental -!! -!! `char_ord_sort( array[, work, reverse] )` 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 interface sort @@ -386,33 +380,21 @@ module stdlib_sorting !! on the `introsort` of David Musser. !! ([Specification](../page/specs/stdlib_sorting.html#sort-sorts-an-input-array)) -#:for k1, t1 in IRS_KINDS_TYPES - pure module subroutine ${k1}$_sort( array, reverse ) +#:for t1, t2, name1 in IRSC_TYPES_ALT_NAME + pure module subroutine ${name1}$_sort( array, reverse ) !! Version: experimental !! -!! `${k1}$_sort( array[, reverse] )` sorts the input `ARRAY` of type `${t1}$` +!! `${name1}$_sort( array[, reverse] )` 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:) logical, intent(in), optional :: reverse - end subroutine ${k1}$_sort + end subroutine ${name1}$_sort #:endfor - pure module subroutine char_sort( array, reverse ) -!! Version: experimental -!! -!! `char_sort( array[, reverse] )` sorts the input `ARRAY` of type -!! `CHARACTER(*)` 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. - character(len=*), intent(inout) :: array(0:) - logical, intent(in), optional :: reverse - end subroutine char_sort - end interface sort interface sort_index @@ -429,41 +411,25 @@ module stdlib_sorting !! non-decreasing sort, but if the optional argument `REVERSE` is present !! with a value of `.TRUE.` the indices correspond to a non-increasing sort. -#:for k1, t1 in IRS_KINDS_TYPES - module subroutine ${k1}$_sort_index( array, index, work, iwork, & +#:for t1, t2, name1 in IRSC_TYPES_ALT_NAME + module subroutine ${name1}$_sort_index( array, index, work, iwork, & reverse ) !! Version: experimental !! -!! `${k1}$_sort_index( array, index[, work, iwork, reverse] )` sorts +!! `${name1}$_sort_index( array, index[, work, iwork, reverse] )` sorts !! an input `ARRAY` of type `${t1}$` !! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` !! and returns the sorted `ARRAY` and an array `INDEX of indices in the !! order that would sort the input `ARRAY` in the desired direction. ${t1}$, intent(inout) :: array(0:) integer(int_size), intent(out) :: index(0:) - ${t1}$, intent(out), optional :: work(0:) + ${t2}$, intent(out), optional :: work(0:) integer(int_size), intent(out), optional :: iwork(0:) logical, intent(in), optional :: reverse - end subroutine ${k1}$_sort_index + end subroutine ${name1}$_sort_index #:endfor - module subroutine char_sort_index( array, index, work, iwork, & - reverse ) -!! Version: experimental -!! -!! `char_sort_index( array, index[, work, iwork, reverse] )` sorts -!! an input `ARRAY` of type `CHARACTER(*)` -!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` -!! and returns the sorted `ARRAY` and an array `INDEX of indices in the -!! order that would sort the input `ARRAY` in the desired direction. - character(len=*), intent(inout) :: array(0:) - integer(int_size), intent(out) :: index(0:) - character(len=len(array)), intent(out), optional :: work(0:) - integer(int_size), intent(out), optional :: iwork(0:) - logical, intent(in), optional :: reverse - end subroutine char_sort_index - end interface sort_index diff --git a/src/stdlib_sorting_ord_sort.fypp b/src/stdlib_sorting_ord_sort.fypp index 668e2bc12..26e9ccbb1 100644 --- a/src/stdlib_sorting_ord_sort.fypp +++ b/src/stdlib_sorting_ord_sort.fypp @@ -1,5 +1,9 @@ #:include "common.fypp" -#:set IRS_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES + STRING_KINDS_TYPES +#:set INT_TYPES_ALT_NAME = list(zip(INT_TYPES, INT_TYPES, INT_TYPES, INT_KINDS)) +#:set REAL_TYPES_ALT_NAME = list(zip(REAL_TYPES, REAL_TYPES, REAL_TYPES, REAL_KINDS)) +#:set STRING_TYPES_ALT_NAME = list(zip(STRING_TYPES, STRING_TYPES, STRING_TYPES, STRING_KINDS)) +#:set CHAR_TYPES_ALT_NAME = list(zip(["character(len=*)"], ["character(len=:)"], ["character(len=len(array))"], ["char"])) +#:set IRSC_TYPES_ALT_NAME = INT_TYPES_ALT_NAME + REAL_TYPES_ALT_NAME + STRING_TYPES_ALT_NAME + CHAR_TYPES_ALT_NAME #:set SIGN_NAME = ["increase", "decrease"] #:set SIGN_TYPE = [">", "<"] @@ -61,10 +65,10 @@ submodule(stdlib_sorting) stdlib_sorting_ord_sort contains -#:for k1, t1 in IRS_KINDS_TYPES - module subroutine ${k1}$_ord_sort( array, work, reverse ) +#:for t1, t2, t3, name1 in IRSC_TYPES_ALT_NAME + module subroutine ${name1}$_ord_sort( array, work, reverse ) ${t1}$, intent(inout) :: array(0:) - ${t1}$, intent(out), optional :: work(0:) + ${t3}$, intent(out), optional :: work(0:) logical, intent(in), optional :: reverse logical :: reverse_ @@ -73,18 +77,18 @@ contains if(present(reverse)) reverse_ = reverse if (reverse_) then - call ${k1}$_decrease_ord_sort(array, work) + call ${name1}$_decrease_ord_sort(array, work) else - call ${k1}$_increase_ord_sort(array, work) + call ${name1}$_increase_ord_sort(array, work) endif - end subroutine ${k1}$_ord_sort + end subroutine ${name1}$_ord_sort #:endfor #:for sname, signt, signoppt in SIGN_NAME_TYPE -#:for k1, t1 in IRS_KINDS_TYPES +#:for t1, t2, t3, name1 in IRSC_TYPES_ALT_NAME - subroutine ${k1}$_${sname}$_ord_sort( array, work ) + subroutine ${name1}$_${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 @@ -105,23 +109,28 @@ contains ! original `listsort.txt`, and an optional `work` array to be used as ! scratch memory. ${t1}$, intent(inout) :: array(0:) - ${t1}$, intent(out), optional :: work(0:) + ${t3}$, intent(out), optional :: work(0:) - ${t1}$, allocatable :: buf(:) + ${t2}$, allocatable :: buf(:) integer(int_size) :: array_size integer :: stat array_size = size( array, kind=int_size ) if ( present(work) ) then if ( size( work, kind=int_size) < array_size/2 ) then - error stop "${k1}$_${sname}$_ord_sort: work array is too small." + error stop "${name1}$_${sname}$_ord_sort: work array is too small." endif ! Use the work array as scratch memory call merge_sort( array, work ) else ! Allocate a buffer to use as scratch memory. + #:if t1[0] == "c" + allocate( ${t3}$ :: buf(0:array_size/2-1), & + stat=stat ) + #:else allocate( buf(0:array_size/2-1), stat=stat ) - if ( stat /= 0 ) error stop "${k1}$_${sname}$_ord_sort: Allocation of buffer failed." + #:endif + if ( stat /= 0 ) error stop "${name1}$_${sname}$_ord_sort: Allocation of buffer failed." call merge_sort( array, buf ) end if @@ -153,7 +162,7 @@ contains ${t1}$, intent(inout) :: array(0:) integer(int_size) :: i, j - ${t1}$ :: key + ${t3}$ :: key do j=1, size(array, kind=int_size)-1 key = array(j) @@ -229,7 +238,7 @@ contains ${t1}$, intent(inout) :: array(0:) - ${t1}$ :: tmp + ${t3}$ :: tmp integer(int_size) :: i tmp = array(0) @@ -263,7 +272,7 @@ contains ! worst-case. ${t1}$, intent(inout) :: array(0:) - ${t1}$, intent(inout) :: buf(0:) + ${t3}$, intent(inout) :: buf(0:) integer(int_size) :: array_size, finish, min_run, r, r_count, & start @@ -352,7 +361,7 @@ contains ! must be long enough to hold the shorter of the two runs. ${t1}$, intent(inout) :: array(0:) integer(int_size), intent(in) :: mid - ${t1}$, intent(inout) :: buf(0:) + ${t3}$, intent(inout) :: buf(0:) integer(int_size) :: array_len, i, j, k @@ -408,7 +417,7 @@ contains ${t1}$, intent(inout) :: array(0:) integer(int_size) :: lo, hi - ${t1}$ :: temp + ${t3}$ :: temp lo = 0 hi = size( array, kind=int_size ) - 1 @@ -422,369 +431,10 @@ contains end subroutine reverse_segment - end subroutine ${k1}$_${sname}$_ord_sort + end subroutine ${name1}$_${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 - - -#: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 -! The Rust version in turn is a simplification of the Timsort algorithm -! described in -! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as -! it drops both the use of 'galloping' to identify bounds of regions to be -! sorted and the estimation of the optimal `run size`. However it remains -! a hybrid sorting algorithm combining an iterative Merge sort controlled -! by a stack of `RUNS` identified by regions of uniformly decreasing or -! non-decreasing sequences that may be expanded to a minimum run size and -! initially processed by an insertion sort. -! -! Note the Fortran implementation simplifies the logic as it only has to -! deal with Fortran arrays of intrinsic types and not the full generality -! of Rust's arrays and lists for arbitrary types. It also adds the -! estimation of the optimal `run size` as suggested in Tim Peters' -! original `listsort.txt`, and an optional `work` array to be used as -! scratch memory. - character(len=*), intent(inout) :: array(0:) - character(len=len(array)), intent(out), optional :: work(0:) - - character(len=:), allocatable :: buf(:) - integer(int_size) :: array_size - integer :: stat - - if ( present(work) ) then -! Use the work array as scratch memory - call merge_sort( array, work ) - else -! Allocate a buffer to use as scratch memory. - 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}$_${sname}$_ord_sort: Allocation of buffer failed." - call merge_sort( array, buf ) - end if - - contains - - pure function calc_min_run( n ) result(min_run) -!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is -!! less than or equal to a power of two. See -!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt - integer(int_size) :: min_run - integer(int_size), intent(in) :: n - - integer(int_size) :: num, r - - num = n - r = 0_int_size - - do while( num >= 64 ) - r = ior( r, iand(num, 1_int_size) ) - num = ishft(num, -1_int_size) - end do - min_run = num + r - - end function calc_min_run - - - pure subroutine insertion_sort( array ) -! Sorts `ARRAY` using an insertion sort. - character(len=*), intent(inout) :: array(0:) - - integer(int_size) :: i, j - character(len=len(array)) :: key - - do j=1, size(array, kind=int_size)-1 - key = array(j) - i = j - 1 - do while( i >= 0 ) - if ( array(i) ${signoppt}$= key ) exit - array(i+1) = array(i) - i = i - 1 - end do - array(i+1) = key - end do - - end subroutine insertion_sort - - - pure function collapse( runs ) result ( r ) -! Examine the stack of runs waiting to be merged, identifying adjacent runs -! to be merged until the stack invariants are restablished: -! -! 1. len(-3) > len(-2) + len(-1) -! 2. len(-2) > len(-1) - integer(int_size) :: r - type(run_type), intent(in), target :: runs(0:) - - integer(int_size) :: n - logical :: test - - n = size(runs, kind=int_size) - test = .false. - if (n >= 2) then - if ( runs( n-1 ) % base == 0 .or. & - runs( n-2 ) % len <= runs(n-1) % len ) then - test = .true. - else if ( n >= 3 ) then ! X exists - if ( runs(n-3) % len <= & - runs(n-2) % len + runs(n-1) % len ) then - test = .true. -! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 - else if( n >= 4 ) then - if ( runs(n-4) % len <= & - runs(n-3) % len + runs(n-2) % len ) then - test = .true. -! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 - end if - end if - end if - end if - if ( test ) then -! By default merge Y & Z, rho2 or rho3 - if ( n >= 3 ) then - if ( runs(n-3) % len < runs(n-1) % len ) then - r = n - 3 -! |X| < |Z| => merge X & Y, rho1 - return - end if - end if - r = n - 2 -! |Y| <= |Z| => merge Y & Z, rho4 - return - else - r = -1 - end if - - end function collapse - - - pure subroutine insert_head( array ) -! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the -! whole `array(0:)` becomes sorted, copying the first element into -! a temporary variable, iterating until the right place for it is found. -! copying every traversed element into the slot preceding it, and finally, -! copying data from the temporary variable into the resulting hole. - - character(len=*), intent(inout) :: array(0:) - - character(len=len(array)) :: tmp - integer(int_size) :: i - - tmp = array(0) - find_hole: do i=1, size(array, kind=int_size)-1 - if ( array(i) ${signt}$= tmp ) exit find_hole - array(i-1) = array(i) - end do find_hole - array(i-1) = tmp - - end subroutine insert_head - - - subroutine merge_sort( array, buf ) -! The Rust merge sort borrows some (but not all) of the ideas from TimSort, -! which is described in detail at -! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). -! -! The algorithm identifies strictly descending and non-descending -! subsequences, which are called natural runs. Where these runs are less -! than a minimum run size they are padded by adding additional samples -! using an insertion sort. The merge process is driven by a stack of -! pending unmerged runs. Each newly found run is pushed onto the stack, -! and then pairs of adjacentd runs are merged until these two invariants -! are satisfied: -! -! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` -! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > -! runs(i - 1)%len + runs(i)%len` -! -! The invariants ensure that the total running time is `O(n log n)` -! worst-case. - - character(len=*), intent(inout) :: array(0:) - character(len=len(array)), intent(inout) :: buf(0:) - - integer(int_size) :: array_size, finish, min_run, r, r_count, & - start - type(run_type) :: runs(0:max_merge_stack-1), left, right - - array_size = size(array, kind=int_size) - -! Very short runs are extended using insertion sort to span at least -! min_run elements. Slices of up to this length are sorted using insertion -! sort. - min_run = calc_min_run( array_size ) - - if ( array_size <= min_run ) then - if ( array_size >= 2 ) call insertion_sort( array ) - return - end if - -! Following Rust sort, natural runs in `array` are identified by traversing -! it backwards. By traversing it backward, merges more often go in the -! opposite direction (forwards). According to developers of Rust sort, -! merging forwards is slightly faster than merging backwards. Therefore -! identifying runs by traversing backwards should improve performance. - r_count = 0 - finish = array_size - 1 - do while ( finish >= 0 ) -! Find the next natural run, and reverse it if it's strictly descending. - start = finish - if ( start > 0 ) then - start = start - 1 - if ( array(start+1) ${signoppt}$ array(start) ) then - Descending: do while ( start > 0 ) - 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) ${signoppt}$ array(start-1) ) exit Ascending - start = start - 1 - end do Ascending - end if - end if - -! If the run is too short insert some more elements using an insertion sort. - Insert: do while ( start > 0 ) - if ( finish - start >= min_run - 1 ) exit Insert - start = start - 1 - call insert_head( array(start:finish) ) - end do Insert - if ( start == 0 .and. finish == array_size - 1 ) return - - runs(r_count) = run_type( base = start, & - len = finish - start + 1 ) - finish = start-1 - r_count = r_count + 1 - -! Determine whether pairs of adjacent runs need to be merged to satisfy -! the invariants, and, if so, merge them. - Merge_loop: do - r = collapse( runs(0:r_count - 1) ) - if ( r < 0 .or. r_count <= 1 ) exit Merge_loop - left = runs( r + 1 ) - right = runs( r ) - call merge( array( left % base: & - right % base + right % len - 1 ), & - left % len, buf ) - - runs(r) = run_type( base = left % base, & - len = left % len + right % len ) - if ( r == r_count - 3 ) runs(r+1) = runs(r+2) - r_count = r_count - 1 - - end do Merge_loop - end do - if ( r_count /= 1 ) & - error stop "MERGE_SORT completed without RUN COUNT == 1." - - end subroutine merge_sort - - - pure subroutine merge( array, mid, buf ) -! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` -! using `BUF` as temporary storage, and stores the merged runs into -! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` -! must be long enough to hold the shorter of the two runs. - character(len=*), intent(inout) :: array(0:) - integer(int_size), intent(in) :: mid - character(len=len(array)), intent(inout) :: buf(0:) - - integer(int_size) :: array_len, i, j, k - - array_len = size(array, kind=int_size) - -! Merge first copies the shorter run into `buf`. Then, depending on which -! run was shorter, it traces the copied run and the longer run forwards -! (or backwards), comparing their next unprocessed elements and then -! copying the lesser (or greater) one into `array`. - - if ( mid <= array_len - mid ) then ! The left run is shorter. - buf(0:mid-1) = array(0:mid-1) - i = 0 - j = mid - merge_lower: do k = 0, array_len-1 - if ( buf(i) ${signoppt}$= array(j) ) then - array(k) = buf(i) - i = i + 1 - if ( i >= mid ) exit merge_lower - else - array(k) = array(j) - j = j + 1 - if ( j >= array_len ) then - array(k+1:) = buf(i:mid-1) - exit merge_lower - end if - end if - end do merge_lower - else ! The right run is shorter ! check that it is stable - buf(0:array_len-mid-1) = array(mid:array_len-1) - i = mid - 1 - j = array_len - mid -1 - merge_upper: do k = array_len-1, 0, -1 - if ( buf(j) ${signt}$= array(i) ) then - array(k) = buf(j) - j = j - 1 - if ( j < 0 ) exit merge_upper - else - array(k) = array(i) - i = i - 1 - if ( i < 0 ) then - array(0:k-1) = buf(0:j) - exit merge_upper - end if - end if - end do merge_upper - end if - end subroutine merge - - - pure subroutine reverse_segment( array ) -! Reverse a segment of an array in place - character(len=*), intent(inout) :: array(0:) - - integer(int_size) :: lo, hi - character(len=len(array)) :: temp - - lo = 0 - hi = size( array, kind=int_size ) - 1 - do while( lo < hi ) - temp = array(lo) - array(lo) = array(hi) - array(hi) = temp - lo = lo + 1 - hi = hi - 1 - end do - - end subroutine reverse_segment - - end subroutine char_${sname}$_ord_sort -#:endfor - end submodule stdlib_sorting_ord_sort diff --git a/src/stdlib_sorting_sort.fypp b/src/stdlib_sorting_sort.fypp index 7e5bd2ee4..89b2c70c9 100644 --- a/src/stdlib_sorting_sort.fypp +++ b/src/stdlib_sorting_sort.fypp @@ -1,5 +1,9 @@ #:include "common.fypp" -#:set IRS_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES + STRING_KINDS_TYPES +#:set INT_TYPES_ALT_NAME = list(zip(INT_TYPES, INT_TYPES, INT_KINDS)) +#:set REAL_TYPES_ALT_NAME = list(zip(REAL_TYPES, REAL_TYPES, REAL_KINDS)) +#:set STRING_TYPES_ALT_NAME = list(zip(STRING_TYPES, STRING_TYPES, STRING_KINDS)) +#:set CHAR_TYPES_ALT_NAME = list(zip(["character(len=*)"], ["character(len=len(array))"], ["char"])) +#:set IRSC_TYPES_ALT_NAME = INT_TYPES_ALT_NAME + REAL_TYPES_ALT_NAME + STRING_TYPES_ALT_NAME + CHAR_TYPES_ALT_NAME #:set SIGN_NAME = ["increase", "decrease"] #:set SIGN_TYPE = [">", "<"] @@ -65,8 +69,8 @@ submodule(stdlib_sorting) stdlib_sorting_sort contains -#:for k1, t1 in IRS_KINDS_TYPES - pure module subroutine ${k1}$_sort( array, reverse ) +#:for t1, t2, name1 in IRSC_TYPES_ALT_NAME + pure module subroutine ${name1}$_sort( array, reverse ) ${t1}$, intent(inout) :: array(0:) logical, intent(in), optional :: reverse @@ -76,20 +80,20 @@ contains if(present(reverse)) reverse_ = reverse if(reverse_)then - call ${k1}$_decrease_sort(array) + call ${name1}$_decrease_sort(array) else - call ${k1}$_increase_sort(array) + call ${name1}$_increase_sort(array) endif - end subroutine ${k1}$_sort + end subroutine ${name1}$_sort #:endfor #:for sname, signt, signoppt in SIGN_NAME_TYPE -#:for k1, t1 in IRS_KINDS_TYPES +#:for t1, t2, name1 in IRSC_TYPES_ALT_NAME - pure subroutine ${k1}$_${sname}$_sort( array ) -! `${k1}$_${sname}$_sort( array )` sorts the input `ARRAY` of type `${t1}$` + pure subroutine ${name1}$_${sname}$_sort( array ) +! `${name1}$_${sname}$_sort( array )` sorts the input `ARRAY` of type `${t1}$` ! using a hybrid sort based on the `introsort` of David Musser. As with -! `introsort`, `${k1}$_${sname}$_sort( array )` is an unstable hybrid comparison +! `introsort`, `${name1}$_${sname}$_sort( array )` is an unstable hybrid comparison ! algorithm using `quicksort` for the main body of the sort tree, ! supplemented by `insertion sort` for the outer branches, but if ! `quicksort` is converging too slowly the algorithm resorts @@ -142,7 +146,7 @@ contains ${t1}$, intent(inout) :: array(0:) integer(int_size), intent(out) :: index - ${t1}$ :: u, v, w, x, y + ${t2}$ :: u, v, w, x, y integer(int_size) :: i, j ! Determine median of three and exchange it with the end. @@ -185,7 +189,7 @@ contains ${t1}$, intent(inout) :: array(0:) integer(int_size) :: i, j - ${t1}$ :: key + ${t2}$ :: key do j=1_int_size, size(array, kind=int_size)-1 key = array(j) @@ -205,7 +209,7 @@ contains ${t1}$, intent(inout) :: array(0:) integer(int_size) :: i, heap_size - ${t1}$ :: y + ${t2}$ :: y heap_size = size( array, kind=int_size ) ! Build the max heap @@ -229,7 +233,7 @@ contains integer(int_size), intent(in) :: i, heap_size integer(int_size) :: l, r, largest - ${t1}$ :: y + ${t2}$ :: y largest = i l = 2_int_size * i + 1_int_size @@ -249,195 +253,9 @@ contains end subroutine max_heapify - end subroutine ${k1}$_${sname}$_sort + end subroutine ${name1}$_${sname}$_sort #:endfor #:endfor - - pure module subroutine char_sort( array, reverse ) - character(len=*), intent(inout) :: array(0:) - logical, intent(in), optional :: reverse - - logical :: reverse_ - - reverse_ = .false. - if(present(reverse)) reverse_ = reverse - - if(reverse_)then - call char_decrease_sort(array) - else - call char_increase_sort(array) - endif - end subroutine char_sort - - - -#:for sname, signt, signoppt in SIGN_NAME_TYPE - pure subroutine char_${sname}$_sort( array ) -! `char_${sname}$_sort( array )` sorts the input `ARRAY` of type `CHARACTER(*)` -! using a hybrid sort based on the `introsort` of David Musser. As with -! `introsort`, `char_${sname}$_sort( array )` is an unstable hybrid comparison -! algorithm using `quicksort` for the main body of the sort tree, -! supplemented by `insertion sort` for the outer branches, but if -! `quicksort` is converging too slowly the algorithm resorts -! to `heapsort`. 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 typically small compared to other sorting algorithms. - - character(len=*), intent(inout) :: array(0:) - - integer(int32) :: depth_limit - - depth_limit = 2 * int( floor( log( real( size( array, kind=int_size ), & - kind=dp) ) / log(2.0_dp) ), & - kind=int32 ) - call introsort(array, depth_limit) - - contains - - pure recursive subroutine introsort( array, depth_limit ) -! It devolves to `insertionsort` if the remaining number of elements -! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion -! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, -! otherwise sorting is done by a `quicksort`. - character(len=*), intent(inout) :: array(0:) - integer(int32), intent(in) :: depth_limit - - integer(int_size), parameter :: insert_size = 16_int_size - integer(int_size) :: index - - if ( size(array, kind=int_size) <= insert_size ) then - ! May be best at the end of SORT processing the whole array - ! See Musser, D.R., “Introspective Sorting and Selection - ! Algorithms,” Software—Practice and Experience, Vol. 27(8), - ! 983–993 (August 1997). - - call insertion_sort( array ) - else if ( depth_limit == 0 ) then - call heap_sort( array ) - else - call partition( array, index ) - call introsort( array(0:index-1), depth_limit-1 ) - call introsort( array(index+1:), depth_limit-1 ) - end if - - end subroutine introsort - - - pure subroutine partition( array, index ) -! quicksort partition using median of three. - character(len=*), intent(inout) :: array(0:) - integer(int_size), intent(out) :: index - - integer(int_size) :: i, j - character(len=len(array)) :: u, v, w, x, y - -! Determine median of three and exchange it with the end. - u = array( 0 ) - v = array( size(array, kind=int_size)/2-1 ) - w = array( size(array, kind=int_size)-1 ) - if ( (u ${signt}$ v) .neqv. (u ${signt}$ w) ) then - x = u - y = array(0) - array(0) = array( size( array, kind=int_size ) - 1 ) - array( size( array, kind=int_size ) - 1 ) = y - else if ( (v ${signoppt}$ u) .neqv. (v ${signoppt}$ w) ) then - x = v - y = array(size( array, kind=int_size )/2-1) - array( size( array, kind=int_size )/2-1 ) = & - array( size( array, kind=int_size )-1 ) - array( size( array, kind=int_size )-1 ) = y - else - x = w - end if -! Partition the array. - i = -1_int_size - do j = 0_int_size, size(array, kind=int_size)-2 - if ( array(j) ${signoppt}$= x ) then - i = i + 1 - y = array(i) - array(i) = array(j) - array(j) = y - end if - end do - y = array(i+1) - array(i+1) = array(size(array, kind=int_size)-1) - array(size(array, kind=int_size)-1) = y - index = i + 1 - - end subroutine partition - - pure subroutine insertion_sort( array ) -! Bog standard insertion sort. - character(len=*), intent(inout) :: array(0:) - - integer(int_size) :: i, j - character(len=len(array)) :: key - - do j=1_int_size, size(array, kind=int_size)-1 - key = array(j) - i = j - 1 - do while( i >= 0 ) - if ( array(i) ${signoppt}$= key ) exit - array(i+1) = array(i) - i = i - 1 - end do - array(i+1) = key - end do - - end subroutine insertion_sort - - pure subroutine heap_sort( array ) -! A bog standard heap sort - character(len=*), intent(inout) :: array(0:) - - integer(int_size) :: i, heap_size - character(len=len(array)) :: y - - heap_size = size( array, kind=int_size ) -! Build the max heap - do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size - call max_heapify( array, i, heap_size ) - end do - do i = heap_size-1, 1_int_size, -1_int_size -! Swap the first element with the current final element - y = array(0) - array(0) = array(i) - array(i) = y -! Sift down using max_heapify - call max_heapify( array, 0_int_size, i ) - end do - - end subroutine heap_sort - - pure recursive subroutine max_heapify( array, i, heap_size ) -! Transform the array into a max heap - character(len=*), intent(inout) :: array(0:) - integer(int_size), intent(in) :: i, heap_size - - integer(int_size) :: l, r, largest - character(len=len(array)) :: y - - largest = i - l = 2_int_size * i + 1_int_size - r = l + 1_int_size - if ( l < heap_size ) then - if ( array(l) ${signt}$ array(largest) ) largest = l - end if - if ( r < heap_size ) then - if ( array(r) ${signt}$ array(largest) ) largest = r - end if - if ( largest /= i ) then - y = array(i) - array(i) = array(largest) - array(largest) = y - call max_heapify( array, largest, heap_size ) - end if - - end subroutine max_heapify - - end subroutine char_${sname}$_sort -#:endfor - end submodule stdlib_sorting_sort diff --git a/src/stdlib_sorting_sort_index.fypp b/src/stdlib_sorting_sort_index.fypp index 9b9f16ca4..e16875d7f 100644 --- a/src/stdlib_sorting_sort_index.fypp +++ b/src/stdlib_sorting_sort_index.fypp @@ -1,5 +1,9 @@ #:include "common.fypp" -#:set IRS_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES + STRING_KINDS_TYPES +#:set INT_TYPES_ALT_NAME = list(zip(INT_TYPES, INT_TYPES, INT_TYPES, INT_KINDS)) +#:set REAL_TYPES_ALT_NAME = list(zip(REAL_TYPES, REAL_TYPES, REAL_TYPES, REAL_KINDS)) +#:set STRING_TYPES_ALT_NAME = list(zip(STRING_TYPES, STRING_TYPES, STRING_TYPES, STRING_KINDS)) +#:set CHAR_TYPES_ALT_NAME = list(zip(["character(len=*)"], ["character(len=:)"], ["character(len=len(array))"], ["char"])) +#:set IRSC_TYPES_ALT_NAME = INT_TYPES_ALT_NAME + REAL_TYPES_ALT_NAME + STRING_TYPES_ALT_NAME + CHAR_TYPES_ALT_NAME !! Licensing: !! @@ -56,10 +60,10 @@ submodule(stdlib_sorting) stdlib_sorting_sort_index contains -#:for k1, t1 in IRS_KINDS_TYPES +#:for t1, t2, t3, name1 in IRSC_TYPES_ALT_NAME - module subroutine ${k1}$_sort_index( array, index, work, iwork, reverse ) -! A modification of `${k1}$_ord_sort` to return an array of indices that + module subroutine ${name1}$_sort_index( array, index, work, iwork, reverse ) +! A modification of `${name1}$_ord_sort` to return an array of indices that ! would perform a stable sort of the `ARRAY` as input, and also sort `ARRAY` ! as desired. The indices by default ! correspond to a non-decreasing sort, but if the optional argument @@ -85,12 +89,12 @@ contains ${t1}$, intent(inout) :: array(0:) integer(int_size), intent(out) :: index(0:) - ${t1}$, intent(out), optional :: work(0:) + ${t3}$, intent(out), optional :: work(0:) integer(int_size), intent(out), optional :: iwork(0:) logical, intent(in), optional :: reverse integer(int_size) :: array_size, i, stat - ${t1}$, allocatable :: buf(:) + ${t2}$, allocatable :: buf(:) integer(int_size), allocatable :: ibuf(:) array_size = size(array, kind=int_size) @@ -121,7 +125,12 @@ contains call merge_sort( array, index, work, ibuf ) end if else + #:if t1[0] == "c" + allocate( ${t3}$ :: buf(0:array_size/2-1), & + stat=stat ) + #:else allocate( buf(0:array_size/2-1), stat=stat ) + #:endif if ( stat /= 0 ) error stop "Allocation of array buffer failed." if ( present(iwork) ) then if ( size(iwork, kind=int_size) < array_size/2 ) then @@ -171,7 +180,7 @@ contains integer(int_size), intent(inout) :: index(0:) integer(int_size) :: i, j, key_index - ${t1}$ :: key + ${t3}$ :: key do j=1, size(array, kind=int_size)-1 key = array(j) @@ -254,7 +263,7 @@ contains ${t1}$, intent(inout) :: array(0:) integer(int_size), intent(inout) :: index(0:) - ${t1}$ :: tmp + ${t3}$ :: tmp integer(int_size) :: i, tmp_index tmp = array(0) @@ -293,7 +302,7 @@ contains ${t1}$, intent(inout) :: array(0:) integer(int_size), intent(inout) :: index(0:) - ${t1}$, intent(inout) :: buf(0:) + ${t3}$, intent(inout) :: buf(0:) integer(int_size), intent(inout) :: ibuf(0:) integer(int_size) :: array_size, finish, min_run, r, r_count, & @@ -386,7 +395,7 @@ contains ! must be long enough to hold the shorter of the two runs. ${t1}$, intent(inout) :: array(0:) integer(int_size), intent(in) :: mid - ${t1}$, intent(inout) :: buf(0:) + ${t3}$, intent(inout) :: buf(0:) integer(int_size), intent(inout) :: index(0:) integer(int_size), intent(inout) :: ibuf(0:) @@ -453,7 +462,7 @@ contains integer(int_size), intent(inout) :: index(0:) integer(int_size) :: itemp, lo, hi - ${t1}$ :: temp + ${t3}$ :: temp lo = 0 hi = size( array, kind=int_size ) - 1 @@ -470,415 +479,8 @@ contains end subroutine reverse_segment - end subroutine ${k1}$_sort_index + end subroutine ${name1}$_sort_index #:endfor - - module subroutine char_sort_index( array, index, work, iwork, reverse ) -! A modification of `char_ord_sort` to return an array of indices that -! would perform a stable sort of the `ARRAY` as input, and also sort `ARRAY` -! as desired. The indices by default -! correspond to a non-decreasing sort, but if the optional argument -! `REVERSE` is present with a value of `.TRUE.` the indices correspond to -! a non-increasing sort. The logic of the determination of indexing largely -! follows the `"Rust" sort` found in `slice.rs`: -! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 -! The Rust version is a simplification of the Timsort algorithm described -! in https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as -! it drops both the use of 'galloping' to identify bounds of regions to be -! sorted and the estimation of the optimal `run size`. However it remains -! a hybrid sorting algorithm combining an iterative Merge sort controlled -! by a stack of `RUNS` identified by regions of uniformly decreasing or -! non-decreasing sequences that may be expanded to a minimum run size, with -! an insertion sort. -! -! Note the Fortran implementation simplifies the logic as it only has to -! deal with Fortran arrays of intrinsic types and not the full generality -! of Rust's arrays and lists for arbitrary types. It also adds the -! estimation of the optimal `run size` as suggested in Tim Peters' -! original listsort.txt, and the optional `work` and `iwork` arraya to be -! used as scratch memory. - - character(len=*), intent(inout) :: array(0:) - integer(int_size), intent(out) :: index(0:) - character(len=len(array)), intent(out), optional :: work(0:) - integer(int_size), intent(out), optional :: iwork(0:) - logical, intent(in), optional :: reverse - - integer(int_size) :: array_size, i, stat - character(len=:), allocatable :: buf(:) - integer(int_size), allocatable :: ibuf(:) - - array_size = size(array, kind=int_size) - - do i = 0, array_size-1 - index(i) = i+1 - end do - - if ( present(reverse) ) then - if ( reverse ) then - call reverse_segment( array, index ) - end if - end if - -! If necessary allocate buffers to serve as scratch memory. - if ( present(work) ) then - if ( present(iwork) ) then - call merge_sort( array, index, work, iwork ) - else - allocate( ibuf(0:array_size/2-1), stat=stat ) - if ( stat /= 0 ) error stop "Allocation of index buffer failed." - call merge_sort( array, index, work, ibuf ) - end if - else - allocate( character(len=len(array)) :: buf(0:array_size/2-1), & - stat=stat ) - if ( stat /= 0 ) error stop "Allocation of array buffer failed." - if ( present(iwork) ) then - call merge_sort( array, index, buf, iwork ) - else - allocate( ibuf(0:array_size/2-1), stat=stat ) - if ( stat /= 0 ) error stop "Allocation of index buffer failed." - call merge_sort( array, index, buf, ibuf ) - end if - end if - - if ( present(reverse) ) then - if ( reverse ) then - call reverse_segment( array, index ) - end if - end if - - contains - - pure function calc_min_run( n ) result(min_run) -!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is -!! less than or equal to a power of two. See -!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt - integer(int_size) :: min_run - integer(int_size), intent(in) :: n - - integer(int_size) :: num, r - - num = n - r = 0_int_size - - do while( num >= 64 ) - r = ior( r, iand(num, 1_int_size) ) - num = ishft(num, -1_int_size) - end do - min_run = num + r - - end function calc_min_run - - - pure subroutine insertion_sort( array, index ) -! Sorts `ARRAY` using an insertion sort, while maintaining consistency in -! location of the indices in `INDEX` to the elements of `ARRAY`. - character(len=*), intent(inout) :: array(0:) - integer(int_size), intent(inout) :: index(0:) - - integer(int_size) :: i, j, key_index - character(len=len(array)) :: key - - do j=1, size(array, kind=int_size)-1 - key = array(j) - key_index = index(j) - i = j - 1 - do while( i >= 0 ) - if ( array(i) <= key ) exit - array(i+1) = array(i) - index(i+1) = index(i) - i = i - 1 - end do - array(i+1) = key - index(i+1) = key_index - end do - - end subroutine insertion_sort - - - pure function collapse( runs ) result ( r ) -! Examine the stack of runs waiting to be merged, identifying adjacent runs -! to be merged until the stack invariants are restablished: -! -! 1. len(-3) > len(-2) + len(-1) -! 2. len(-2) > len(-1) - - integer(int_size) :: r - type(run_type), intent(in), target :: runs(0:) - - integer(int_size) :: n - logical :: test - - n = size(runs, kind=int_size) - test = .false. - if (n >= 2) then - if ( runs( n-1 ) % base == 0 .or. & - runs( n-2 ) % len <= runs(n-1) % len ) then - test = .true. - else if ( n >= 3 ) then ! X exists - if ( runs(n-3) % len <= & - runs(n-2) % len + runs(n-1) % len ) then - test = .true. -! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 - else if( n >= 4 ) then - if ( runs(n-4) % len <= & - runs(n-3) % len + runs(n-2) % len ) then - test = .true. -! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 - end if - end if - end if - end if - if ( test ) then -! By default merge Y & Z, rho2 or rho3 - if ( n >= 3 ) then - if ( runs(n-3) % len < runs(n-1) % len ) then - r = n - 3 -! |X| < |Z| => merge X & Y, rho1 - return - end if - end if - r = n - 2 -! |Y| <= |Z| => merge Y & Z, rho4 - return - else - r = -1 - end if - - end function collapse - - - pure subroutine insert_head( array, index ) -! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the -! whole `array(0:)` becomes sorted, copying the first element into -! a temporary variable, iterating until the right place for it is found. -! copying every traversed element into the slot preceding it, and finally, -! copying data from the temporary variable into the resulting hole. -! Consistency of the indices in `index` with the elements of `array` -! are maintained. - - character(len=*), intent(inout) :: array(0:) - integer(int_size), intent(inout) :: index(0:) - - character(len=len(array)) :: tmp - integer(int_size) :: i, tmp_index - - tmp = array(0) - tmp_index = index(0) - find_hole: do i=1, size(array, kind=int_size)-1 - if ( array(i) >= tmp ) exit find_hole - array(i-1) = array(i) - index(i-1) = index(i) - end do find_hole - array(i-1) = tmp - index(i-1) = tmp_index - - end subroutine insert_head - - - subroutine merge_sort( array, index, buf, ibuf ) -! The Rust merge sort borrows some (but not all) of the ideas from TimSort, -! which is described in detail at -! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). -! -! The algorithm identifies strictly descending and non-descending -! subsequences, which are called natural runs. Where these runs are less -! than a minimum run size they are padded by adding additional samples -! using an insertion sort. The merge process is driven by a stack of -! pending unmerged runs. Each newly found run is pushed onto the stack, -! and then pairs of adjacentd runs are merged until these two invariants -! are satisfied: -! -! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` -! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > -! runs(i - 1)%len + runs(i)%len` -! -! The invariants ensure that the total running time is `O(n log n)` -! worst-case. Consistency of the indices in `index` with the elements of -! `array` are maintained. - - character(len=*), intent(inout) :: array(0:) - integer(int_size), intent(inout) :: index(0:) - character(len=len(array)), intent(inout) :: buf(0:) - integer(int_size), intent(inout) :: ibuf(0:) - - integer(int_size) :: array_size, finish, min_run, r, r_count, & - start - type(run_type) :: runs(0:max_merge_stack-1), left, right - - array_size = size(array, kind=int_size) - -! Very short runs are extended using insertion sort to span at least this -! many elements. Slices of up to this length are sorted using insertion sort. - min_run = calc_min_run( array_size ) - - if ( array_size <= min_run ) then - if ( array_size >= 2 ) call insertion_sort( array, index ) - return - end if - - -! Following Rust sort, natural runs in `array` are identified by traversing -! it backwards. By traversing it backward, merges more often go in the -! opposite direction (forwards). According to developers of Rust sort, -! merging forwards is slightly faster than merging backwards. Therefore -! identifying runs by traversing backwards should improve performance. - r_count = 0 - finish = array_size - 1 - do while ( finish >= 0 ) -! Find the next natural run, and reverse it if it's strictly descending. - start = finish - if ( start > 0 ) then - start = start - 1 - if ( array(start+1) < array(start) ) then - Descending: do while ( start > 0 ) - if ( array(start) >= array(start-1) ) & - exit Descending - start = start - 1 - end do Descending - call reverse_segment( array(start:finish), & - index(start:finish) ) - else - Ascending: do while( start > 0 ) - if ( array(start) < array(start-1) ) exit Ascending - start = start - 1 - end do Ascending - end if - end if - -! If the run is too short insert some more elements using an insertion sort. - Insert: do while ( start > 0 ) - if ( finish - start >= min_run - 1 ) exit Insert - start = start - 1 - call insert_head( array(start:finish), index(start:finish) ) - end do Insert - if ( start == 0 .and. finish == array_size - 1 ) return - - runs(r_count) = run_type( base = start, & - len = finish - start + 1 ) - finish = start-1 - r_count = r_count + 1 - -! Determine whether pairs of adjacent runs need to be merged to satisfy -! the invariants, and, if so, merge them. - Merge_loop: do - r = collapse( runs(0:r_count - 1) ) - if ( r < 0 .or. r_count <= 1 ) exit Merge_loop - left = runs( r + 1 ) - right = runs( r ) - call merge( array( left % base: & - right % base + right % len - 1 ), & - left % len, buf, & - index( left % base: & - right % base + right % len - 1 ), ibuf ) - - runs(r) = run_type( base = left % base, & - len = left % len + right % len ) - if ( r == r_count - 3 ) runs(r+1) = runs(r+2) - r_count = r_count - 1 - - end do Merge_loop - end do - if ( r_count /= 1 ) & - error stop "MERGE_SORT completed without RUN COUNT == 1." - - end subroutine merge_sort - - - pure subroutine merge( array, mid, buf, index, ibuf ) -! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` -! using `BUF` as temporary storage, and stores the merged runs into -! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` -! must be long enough to hold the shorter of the two runs. - character(len=*), intent(inout) :: array(0:) - integer(int_size), intent(in) :: mid - character(len=len(array)), intent(inout) :: buf(0:) - integer(int_size), intent(inout) :: index(0:) - integer(int_size), intent(inout) :: ibuf(0:) - - integer(int_size) :: array_len, i, j, k - - array_len = size(array, kind=int_size) - -! Merge first copies the shorter run into `buf`. Then, depending on which -! run was shorter, it traces the copied run and the longer run forwards -! (or backwards), comparing their next unprocessed elements and then -! copying the lesser (or greater) one into `array`. - - if ( mid <= array_len - mid ) then ! The left run is shorter. - buf(0:mid-1) = array(0:mid-1) - ibuf(0:mid-1) = index(0:mid-1) - i = 0 - j = mid - merge_lower: do k = 0, array_len-1 - if ( buf(i) <= array(j) ) then - array(k) = buf(i) - index(k) = ibuf(i) - i = i + 1 - if ( i >= mid ) exit merge_lower - else - array(k) = array(j) - index(k) = index(j) - j = j + 1 - if ( j >= array_len ) then - array(k+1:) = buf(i:mid-1) - index(k+1:) = ibuf(i:mid-1) - exit merge_lower - end if - end if - end do merge_lower - else ! The right run is shorter - buf(0:array_len-mid-1) = array(mid:array_len-1) - ibuf(0:array_len-mid-1) = index(mid:array_len-1) - i = mid - 1 - j = array_len - mid -1 - merge_upper: do k = array_len-1, 0, -1 - if ( buf(j) >= array(i) ) then - array(k) = buf(j) - index(k) = ibuf(j) - j = j - 1 - if ( j < 0 ) exit merge_upper - else - array(k) = array(i) - index(k) = index(i) - i = i - 1 - if ( i < 0 ) then - array(0:k-1) = buf(0:j) - index(0:k-1) = ibuf(0:j) - exit merge_upper - end if - end if - end do merge_upper - end if - end subroutine merge - - - pure subroutine reverse_segment( array, index ) -! Reverse a segment of an array in place - character(len=*), intent(inout) :: array(0:) - integer(int_size), intent(inout) :: index(0:) - - integer(int_size) :: itemp, lo, hi - character(len=len(array)) :: temp - - lo = 0 - hi = size( array, kind=int_size ) - 1 - do while( lo < hi ) - temp = array(lo) - array(lo) = array(hi) - array(hi) = temp - itemp = index(lo) - index(lo) = index(hi) - index(hi) = itemp - lo = lo + 1 - hi = hi - 1 - end do - - end subroutine reverse_segment - - end subroutine char_sort_index - end submodule stdlib_sorting_sort_index From c409d5d949fe18ef2ab172d6b4df3f9b7a75f744 Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Sun, 22 Aug 2021 17:10:01 +0200 Subject: [PATCH 2/2] applied suggestions by @gareth-nx --- src/stdlib_sorting.fypp | 4 ++++ src/stdlib_sorting_ord_sort.fypp | 6 +++++- src/stdlib_sorting_sort.fypp | 4 ++++ src/stdlib_sorting_sort_index.fypp | 6 +++++- 4 files changed, 18 insertions(+), 2 deletions(-) diff --git a/src/stdlib_sorting.fypp b/src/stdlib_sorting.fypp index a748d88e3..c4cd56b89 100644 --- a/src/stdlib_sorting.fypp +++ b/src/stdlib_sorting.fypp @@ -4,6 +4,10 @@ #:set REAL_TYPES_ALT_NAME = list(zip(REAL_TYPES, REAL_TYPES, REAL_KINDS)) #:set STRING_TYPES_ALT_NAME = list(zip(STRING_TYPES, STRING_TYPES, STRING_KINDS)) #:set CHAR_TYPES_ALT_NAME = list(zip(["character(len=*)"], ["character(len=len(array))"], ["char"])) + +#! For better code reuse in fypp, make lists that contain the input types, +#! with each having output types and a separate name prefix for subroutines +#! This approach allows us to have the same code for all input types. #:set IRSC_TYPES_ALT_NAME = INT_TYPES_ALT_NAME + REAL_TYPES_ALT_NAME + STRING_TYPES_ALT_NAME + CHAR_TYPES_ALT_NAME !! Licensing: diff --git a/src/stdlib_sorting_ord_sort.fypp b/src/stdlib_sorting_ord_sort.fypp index 26e9ccbb1..0aaf9b4f4 100644 --- a/src/stdlib_sorting_ord_sort.fypp +++ b/src/stdlib_sorting_ord_sort.fypp @@ -3,6 +3,10 @@ #:set REAL_TYPES_ALT_NAME = list(zip(REAL_TYPES, REAL_TYPES, REAL_TYPES, REAL_KINDS)) #:set STRING_TYPES_ALT_NAME = list(zip(STRING_TYPES, STRING_TYPES, STRING_TYPES, STRING_KINDS)) #:set CHAR_TYPES_ALT_NAME = list(zip(["character(len=*)"], ["character(len=:)"], ["character(len=len(array))"], ["char"])) + +#! For better code reuse in fypp, make lists that contain the input types, +#! with each having output types and a separate name prefix for subroutines +#! This approach allows us to have the same code for all input types. #:set IRSC_TYPES_ALT_NAME = INT_TYPES_ALT_NAME + REAL_TYPES_ALT_NAME + STRING_TYPES_ALT_NAME + CHAR_TYPES_ALT_NAME #:set SIGN_NAME = ["increase", "decrease"] @@ -124,7 +128,7 @@ contains call merge_sort( array, work ) else ! Allocate a buffer to use as scratch memory. - #:if t1[0] == "c" + #:if t1[0:4] == "char" allocate( ${t3}$ :: buf(0:array_size/2-1), & stat=stat ) #:else diff --git a/src/stdlib_sorting_sort.fypp b/src/stdlib_sorting_sort.fypp index 89b2c70c9..c6d23ae83 100644 --- a/src/stdlib_sorting_sort.fypp +++ b/src/stdlib_sorting_sort.fypp @@ -3,6 +3,10 @@ #:set REAL_TYPES_ALT_NAME = list(zip(REAL_TYPES, REAL_TYPES, REAL_KINDS)) #:set STRING_TYPES_ALT_NAME = list(zip(STRING_TYPES, STRING_TYPES, STRING_KINDS)) #:set CHAR_TYPES_ALT_NAME = list(zip(["character(len=*)"], ["character(len=len(array))"], ["char"])) + +#! For better code reuse in fypp, make lists that contain the input types, +#! with each having output types and a separate name prefix for subroutines +#! This approach allows us to have the same code for all input types. #:set IRSC_TYPES_ALT_NAME = INT_TYPES_ALT_NAME + REAL_TYPES_ALT_NAME + STRING_TYPES_ALT_NAME + CHAR_TYPES_ALT_NAME #:set SIGN_NAME = ["increase", "decrease"] diff --git a/src/stdlib_sorting_sort_index.fypp b/src/stdlib_sorting_sort_index.fypp index e16875d7f..30c9620c3 100644 --- a/src/stdlib_sorting_sort_index.fypp +++ b/src/stdlib_sorting_sort_index.fypp @@ -3,6 +3,10 @@ #:set REAL_TYPES_ALT_NAME = list(zip(REAL_TYPES, REAL_TYPES, REAL_TYPES, REAL_KINDS)) #:set STRING_TYPES_ALT_NAME = list(zip(STRING_TYPES, STRING_TYPES, STRING_TYPES, STRING_KINDS)) #:set CHAR_TYPES_ALT_NAME = list(zip(["character(len=*)"], ["character(len=:)"], ["character(len=len(array))"], ["char"])) + +#! For better code reuse in fypp, make lists that contain the input types, +#! with each having output types and a separate name prefix for subroutines +#! This approach allows us to have the same code for all input types. #:set IRSC_TYPES_ALT_NAME = INT_TYPES_ALT_NAME + REAL_TYPES_ALT_NAME + STRING_TYPES_ALT_NAME + CHAR_TYPES_ALT_NAME !! Licensing: @@ -125,7 +129,7 @@ contains call merge_sort( array, index, work, ibuf ) end if else - #:if t1[0] == "c" + #:if t1[0:4] == "char" allocate( ${t3}$ :: buf(0:array_size/2-1), & stat=stat ) #:else