!Program to test NEAREST intrinsic function.
|
!Program to test NEAREST intrinsic function.
|
|
|
program test_nearest
|
program test_nearest
|
real s, r, x, y, inf, max
|
real s, r, x, y, inf, max
|
integer i, infi, maxi
|
integer i, infi, maxi
|
equivalence (s,i)
|
equivalence (s,i)
|
equivalence (inf,infi)
|
equivalence (inf,infi)
|
equivalence (max,maxi)
|
equivalence (max,maxi)
|
|
|
r = 2.0
|
r = 2.0
|
s = 3.0
|
s = 3.0
|
call test_n (s, r)
|
call test_n (s, r)
|
|
|
i = z'00800000'
|
i = z'00800000'
|
call test_n (s, r)
|
call test_n (s, r)
|
|
|
i = z'007fffff'
|
i = z'007fffff'
|
call test_n (s, r)
|
call test_n (s, r)
|
|
|
i = z'00800100'
|
i = z'00800100'
|
call test_n (s, r)
|
call test_n (s, r)
|
|
|
s = 0
|
s = 0
|
x = nearest(s, r)
|
x = nearest(s, r)
|
y = nearest(s, -r)
|
y = nearest(s, -r)
|
if (.not. (x .gt. s .and. y .lt. s )) call abort()
|
if (.not. (x .gt. s .and. y .lt. s )) call abort()
|
|
|
! ??? This is pretty sketchy, but passes on most targets.
|
! ??? This is pretty sketchy, but passes on most targets.
|
infi = z'7f800000'
|
infi = z'7f800000'
|
maxi = z'7f7fffff'
|
maxi = z'7f7fffff'
|
|
|
call test_up(max, inf)
|
call test_up(max, inf)
|
call test_up(-inf, -max)
|
call test_up(-inf, -max)
|
call test_down(inf, max)
|
call test_down(inf, max)
|
call test_down(-max, -inf)
|
call test_down(-max, -inf)
|
|
|
! ??? Here we require the F2003 IEEE_ARITHMETIC module to
|
! ??? Here we require the F2003 IEEE_ARITHMETIC module to
|
! determine if denormals are supported. If they are, then
|
! determine if denormals are supported. If they are, then
|
! nearest(0,1) is the minimum denormal. If they are not,
|
! nearest(0,1) is the minimum denormal. If they are not,
|
! then it's the minimum normalized number, TINY. This fails
|
! then it's the minimum normalized number, TINY. This fails
|
! much more often than the infinity test above, so it's
|
! much more often than the infinity test above, so it's
|
! disabled for now.
|
! disabled for now.
|
|
|
! call test_up(0, min)
|
! call test_up(0, min)
|
! call test_up(-min, 0)
|
! call test_up(-min, 0)
|
! call test_down(0, -min)
|
! call test_down(0, -min)
|
! call test_down(min, 0)
|
! call test_down(min, 0)
|
end
|
end
|
|
|
subroutine test_up(s, e)
|
subroutine test_up(s, e)
|
real s, e, x
|
real s, e, x
|
|
|
x = nearest(s, 1.0)
|
x = nearest(s, 1.0)
|
if (x .ne. e) call abort()
|
if (x .ne. e) call abort()
|
end
|
end
|
|
|
subroutine test_down(s, e)
|
subroutine test_down(s, e)
|
real s, e, x
|
real s, e, x
|
|
|
x = nearest(s, -1.0)
|
x = nearest(s, -1.0)
|
if (x .ne. e) call abort()
|
if (x .ne. e) call abort()
|
end
|
end
|
|
|
subroutine test_n(s1, r)
|
subroutine test_n(s1, r)
|
real r, s1, x
|
real r, s1, x
|
|
|
x = nearest(s1, r)
|
x = nearest(s1, r)
|
if (nearest(x, -r) .ne. s1) call abort()
|
if (nearest(x, -r) .ne. s1) call abort()
|
x = nearest(s1, -r)
|
x = nearest(s1, -r)
|
if (nearest(x, r) .ne. s1) call abort()
|
if (nearest(x, r) .ne. s1) call abort()
|
|
|
s1 = -s1
|
s1 = -s1
|
x = nearest(s1, r)
|
x = nearest(s1, r)
|
if (nearest(x, -r) .ne. s1) call abort()
|
if (nearest(x, -r) .ne. s1) call abort()
|
x = nearest(s1, -r)
|
x = nearest(s1, -r)
|
if (nearest(x, r) .ne. s1) call abort()
|
if (nearest(x, r) .ne. s1) call abort()
|
end
|
end
|
|
|
