Addition of test_real_sort_adjoint

Author: jvdp1

test/sorting/test_sorting.fypp

@@ -7,7 +7,7 @@
 module test_sorting
 
     use, intrinsic :: iso_fortran_env, only: compiler_version, error_unit
-    use stdlib_kinds, only: int8, int16, int32, int64, dp, sp
+    use stdlib_kinds, only: int8, int16, int32, int64, dp, sp, xdp, qp
     use stdlib_sorting, only: sort, sort_index, sort_adjoint, ord_sort, radix_sort, int_index, int_index_low
     use stdlib_string_type, only: string_type, assignment(=), operator(>), &
         operator(<), write(formatted)
@@ -115,6 +115,9 @@ contains
             new_unittest('string_sort_adjointes_${namei}$', test_string_sort_adjointes_${namei}$), &
             new_unittest('bitset_large_sort_adjointes_${namei}$', test_bitsetl_sort_adjointes_${namei}$), &
             new_unittest('bitset_64_sort_adjointes_${namei}$', test_bitset64_sort_adjointes_${namei}$), &
+#:endfor
+#:for ki, ti, namei in REAL_TYPES_ALT_NAME
+            new_unittest('real_sort_adjointes_${namei}$', test_real_sort_adjointes_${namei}$), &
 #:endfor
             new_unittest('int_ord_sorts', test_int_ord_sorts) &
         ]
@@ -1896,6 +1899,119 @@ contains
     end subroutine test_bitset64_sort_adjoint_${namei}$
 #:endfor
 
+#:for ki, ti, namei in REAL_TYPES_ALT_NAME
+    subroutine test_real_sort_adjointes_${namei}$(error)
+        !> Error handling
+        type(error_type), allocatable, intent(out) :: error
+        logical                     :: ltest
+
+        call test_real_sort_adjoint_${namei}$( blocks, "Blocks", ltest )
+        call check(error, ltest)
+        if (allocated(error)) return
+
+        call test_real_sort_adjoint_${namei}$( decrease, "Decreasing", ltest )
+        call check(error, ltest)
+        if (allocated(error)) return
+
+        call test_real_sort_adjoint_${namei}$( identical, "Identical", ltest )
+        call check(error, ltest)
+        if (allocated(error)) return
+
+        call test_real_sort_adjoint_${namei}$( increase, "Increasing", ltest )
+        call check(error, ltest)
+        if (allocated(error)) return
+
+        call test_real_sort_adjoint_${namei}$( rand1, "Random dense", ltest )
+        call check(error, ltest)
+        if (allocated(error)) return
+
+        call test_real_sort_adjoint_${namei}$( rand2, "Random order", ltest )
+        call check(error, ltest)
+        if (allocated(error)) return
+
+        call test_real_sort_adjoint_${namei}$( rand0, "Random sparse", ltest )
+        call check(error, ltest)
+        if (allocated(error)) return
+
+        call test_real_sort_adjoint_${namei}$( rand3, "Random 3", ltest )
+        call check(error, ltest)
+        if (allocated(error)) return
+
+        call test_real_sort_adjoint_${namei}$( rand10, "Random 10", ltest )
+        call check(error, ltest)
+        if (allocated(error)) return
+
+    end subroutine test_real_sort_adjointes_${namei}$
+
+    subroutine test_real_sort_adjoint_${namei}$( a, a_name, ltest )
+        integer(int32), intent(inout) :: a(:)
+        character(*), intent(in)      :: a_name
+        logical, intent(out)          :: ltest
+
+        integer(int64)                 :: t0, t1, tdiff
+        real(dp)                       :: rate
+        ${ti}$                         :: adjoint(size(a))
+        ${ti}$                         :: iwork(size(a))
+        integer(int64)                 :: i, j
+        integer(int64)                 :: i_adj
+        logical                        :: valid
+        logical                        :: valid_adj
+
+        ltest = .true.
+
+        tdiff = 0
+        do i = 1, repeat
+            dummy = a
+            adjoint = real(dummy, kind=${namei}$)
+            call system_clock( t0, rate )
+            call sort_adjoint( dummy, adjoint, work, iwork )
+            call system_clock( t1, rate )
+            tdiff = tdiff + t1 - t0
+        end do
+        tdiff = tdiff/repeat
+
+        call verify_sort( dummy, valid, i )
+        call verify_adjoint(int(adjoint, kind=int32), dummy, valid_adj, i_adj )
+
+        ltest = (ltest .and. valid .and. valid_adj)
+        if ( .not. valid ) then
+            write( *, * ) "SORT_ADJOINT did not sort " // a_name // "."
+            write(*,*) 'i = ', i
+            write(*,'(a18, 2i7)') 'a(i-1:i) = ', a(i-1:i)
+        end if
+        if ( .not. valid_adj ) then
+            write( *, * ) "SORT_ADJOINT did not sort " // a_name // "."
+            write(*,*) 'i_adj = ', i_adj
+            write(*,'(a18, 2i7)') 'a(i_adj-1:i_adj) = ', a(i_adj-1:i_adj)
+        end if
+        write( lun, '("|      Integer |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
+            'a12, " |",  F10.6, " |" )' ) &
+            test_size, a_name, "Sort_adjoint", tdiff/rate
+
+        !reverse
+        dummy = a
+        adjoint = real(dummy, kind=${namei}$)
+        call sort_adjoint( dummy, adjoint, work, iwork, reverse=.true. )
+
+        call verify_reverse_sort( dummy, valid, i )
+        call verify_adjoint(int(adjoint, kind=int32), dummy, valid_adj, i_adj )
+        ltest = (ltest .and. valid .and. valid_adj)
+        if ( .not. valid ) then
+            write( *, * ) "SORT_ADJOINT did not reverse sort " // &
+                a_name // "."
+            write(*,*) 'i = ', i
+            write(*,'(a18, 2i7)') 'a(i-1:i) = ', a(i-1:i)
+        end if
+        if ( .not. valid_adj ) then
+            write( *, * ) "SORT_ADJOINT did not reverse sort " // &
+                a_name // "."
+            write(*,*) 'i_adj = ', i_adj
+            write(*,'(a18, 2i7)') 'a(i_adj-1:i_adj) = ', a(i_adj-1:i_adj)
+        end if
+
+    end subroutine test_real_sort_adjoint_${namei}$
+#:endfor
+
     subroutine verify_sort( a, valid, i )
         integer(int32), intent(in) :: a(0:)
         logical, intent(out) :: valid
@@ -1912,6 +2028,23 @@ contains
 
     end subroutine verify_sort
 
+    subroutine verify_adjoint( a, true, valid, i )
+        integer(int32), intent(in) :: a(:)
+        integer(int32), intent(in) :: true(:)
+        logical, intent(out) :: valid
+        integer(int64), intent(out) :: i
+
+        integer(int64) :: n
+
+        n = size( a, kind=int64 )
+        valid = .false.
+        do i=1, n
+            if ( a(i) /= true(i) ) return
+        end do
+        valid = .true.
+
+    end subroutine verify_adjoint
+
     subroutine verify_real_sort( a, valid, i )
         real(sp), intent(in) :: a(0:)
         logical, intent(out) :: valid