Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 0c254ab

Browse files
committed
Addition of test_real_sort_adjoint
1 parent 1a9d04c commit 0c254ab

File tree

1 file changed

+134
-1
lines changed

1 file changed

+134
-1
lines changed

‎test/sorting/test_sorting.fypp

Lines changed: 134 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,7 @@
77
module test_sorting
88

99
use, intrinsic :: iso_fortran_env, only: compiler_version, error_unit
10-
use stdlib_kinds, only: int8, int16, int32, int64, dp, sp
10+
use stdlib_kinds, only: int8, int16, int32, int64, dp, sp, xdp, qp
1111
use stdlib_sorting, only: sort, sort_index, sort_adjoint, ord_sort, radix_sort, int_index, int_index_low
1212
use stdlib_string_type, only: string_type, assignment(=), operator(>), &
1313
operator(<), write(formatted)
@@ -115,6 +115,9 @@ contains
115115
new_unittest('string_sort_adjointes_${namei}$', test_string_sort_adjointes_${namei}$), &
116116
new_unittest('bitset_large_sort_adjointes_${namei}$', test_bitsetl_sort_adjointes_${namei}$), &
117117
new_unittest('bitset_64_sort_adjointes_${namei}$', test_bitset64_sort_adjointes_${namei}$), &
118+
#:endfor
119+
#:for ki, ti, namei in REAL_TYPES_ALT_NAME
120+
new_unittest('real_sort_adjointes_${namei}$', test_real_sort_adjointes_${namei}$), &
118121
#:endfor
119122
new_unittest('int_ord_sorts', test_int_ord_sorts) &
120123
]
@@ -1896,6 +1899,119 @@ contains
18961899
end subroutine test_bitset64_sort_adjoint_${namei}$
18971900
#:endfor
18981901

1902+
#:for ki, ti, namei in REAL_TYPES_ALT_NAME
1903+
subroutine test_real_sort_adjointes_${namei}$(error)
1904+
!> Error handling
1905+
type(error_type), allocatable, intent(out) :: error
1906+
logical :: ltest
1907+
1908+
call test_real_sort_adjoint_${namei}$( blocks, "Blocks", ltest )
1909+
call check(error, ltest)
1910+
if (allocated(error)) return
1911+
1912+
call test_real_sort_adjoint_${namei}$( decrease, "Decreasing", ltest )
1913+
call check(error, ltest)
1914+
if (allocated(error)) return
1915+
1916+
call test_real_sort_adjoint_${namei}$( identical, "Identical", ltest )
1917+
call check(error, ltest)
1918+
if (allocated(error)) return
1919+
1920+
call test_real_sort_adjoint_${namei}$( increase, "Increasing", ltest )
1921+
call check(error, ltest)
1922+
if (allocated(error)) return
1923+
1924+
call test_real_sort_adjoint_${namei}$( rand1, "Random dense", ltest )
1925+
call check(error, ltest)
1926+
if (allocated(error)) return
1927+
1928+
call test_real_sort_adjoint_${namei}$( rand2, "Random order", ltest )
1929+
call check(error, ltest)
1930+
if (allocated(error)) return
1931+
1932+
call test_real_sort_adjoint_${namei}$( rand0, "Random sparse", ltest )
1933+
call check(error, ltest)
1934+
if (allocated(error)) return
1935+
1936+
call test_real_sort_adjoint_${namei}$( rand3, "Random 3", ltest )
1937+
call check(error, ltest)
1938+
if (allocated(error)) return
1939+
1940+
call test_real_sort_adjoint_${namei}$( rand10, "Random 10", ltest )
1941+
call check(error, ltest)
1942+
if (allocated(error)) return
1943+
1944+
end subroutine test_real_sort_adjointes_${namei}$
1945+
1946+
subroutine test_real_sort_adjoint_${namei}$( a, a_name, ltest )
1947+
integer(int32), intent(inout) :: a(:)
1948+
character(*), intent(in) :: a_name
1949+
logical, intent(out) :: ltest
1950+
1951+
integer(int64) :: t0, t1, tdiff
1952+
real(dp) :: rate
1953+
${ti}$ :: adjoint(size(a))
1954+
${ti}$ :: iwork(size(a))
1955+
integer(int64) :: i, j
1956+
integer(int64) :: i_adj
1957+
logical :: valid
1958+
logical :: valid_adj
1959+
1960+
ltest = .true.
1961+
1962+
tdiff = 0
1963+
do i = 1, repeat
1964+
dummy = a
1965+
adjoint = real(dummy, kind=${namei}$)
1966+
call system_clock( t0, rate )
1967+
call sort_adjoint( dummy, adjoint, work, iwork )
1968+
call system_clock( t1, rate )
1969+
tdiff = tdiff + t1 - t0
1970+
end do
1971+
tdiff = tdiff/repeat
1972+
1973+
call verify_sort( dummy, valid, i )
1974+
call verify_adjoint(int(adjoint, kind=int32), dummy, valid_adj, i_adj )
1975+
1976+
ltest = (ltest .and. valid .and. valid_adj)
1977+
if ( .not. valid ) then
1978+
write( *, * ) "SORT_ADJOINT did not sort " // a_name // "."
1979+
write(*,*) 'i = ', i
1980+
write(*,'(a18, 2i7)') 'a(i-1:i) = ', a(i-1:i)
1981+
end if
1982+
if ( .not. valid_adj ) then
1983+
write( *, * ) "SORT_ADJOINT did not sort " // a_name // "."
1984+
write(*,*) 'i_adj = ', i_adj
1985+
write(*,'(a18, 2i7)') 'a(i_adj-1:i_adj) = ', a(i_adj-1:i_adj)
1986+
end if
1987+
write( lun, '("| Integer |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
1988+
'a12, " |", F10.6, " |" )' ) &
1989+
test_size, a_name, "Sort_adjoint", tdiff/rate
1990+
1991+
!reverse
1992+
dummy = a
1993+
adjoint = real(dummy, kind=${namei}$)
1994+
call sort_adjoint( dummy, adjoint, work, iwork, reverse=.true. )
1995+
1996+
call verify_reverse_sort( dummy, valid, i )
1997+
call verify_adjoint(int(adjoint, kind=int32), dummy, valid_adj, i_adj )
1998+
ltest = (ltest .and. valid .and. valid_adj)
1999+
if ( .not. valid ) then
2000+
write( *, * ) "SORT_ADJOINT did not reverse sort " // &
2001+
a_name // "."
2002+
write(*,*) 'i = ', i
2003+
write(*,'(a18, 2i7)') 'a(i-1:i) = ', a(i-1:i)
2004+
end if
2005+
if ( .not. valid_adj ) then
2006+
write( *, * ) "SORT_ADJOINT did not reverse sort " // &
2007+
a_name // "."
2008+
write(*,*) 'i_adj = ', i_adj
2009+
write(*,'(a18, 2i7)') 'a(i_adj-1:i_adj) = ', a(i_adj-1:i_adj)
2010+
end if
2011+
2012+
end subroutine test_real_sort_adjoint_${namei}$
2013+
#:endfor
2014+
18992015
subroutine verify_sort( a, valid, i )
19002016
integer(int32), intent(in) :: a(0:)
19012017
logical, intent(out) :: valid
@@ -1912,6 +2028,23 @@ contains
19122028

19132029
end subroutine verify_sort
19142030

2031+
subroutine verify_adjoint( a, true, valid, i )
2032+
integer(int32), intent(in) :: a(:)
2033+
integer(int32), intent(in) :: true(:)
2034+
logical, intent(out) :: valid
2035+
integer(int64), intent(out) :: i
2036+
2037+
integer(int64) :: n
2038+
2039+
n = size( a, kind=int64 )
2040+
valid = .false.
2041+
do i=1, n
2042+
if ( a(i) /= true(i) ) return
2043+
end do
2044+
valid = .true.
2045+
2046+
end subroutine verify_adjoint
2047+
19152048
subroutine verify_real_sort( a, valid, i )
19162049
real(sp), intent(in) :: a(0:)
19172050
logical, intent(out) :: valid

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /