blob: 222da0a70834f4801d51a6e2dddbb145d25156ec [file] [log] [blame]
!Program to test NEAREST intrinsic function.
program test_nearest
real s, r, x, y, inf, max
integer i, infi, maxi
equivalence (s,i)
equivalence (inf,infi)
equivalence (max,maxi)
r = 2.0
s = 3.0
call test_n (s, r)
i = int(z'00800000')
call test_n (s, r)
i = int(z'007fffff')
call test_n (s, r)
i = int(z'00800100')
call test_n (s, r)
s = 0
x = nearest(s, r)
y = nearest(s, -r)
if (.not. (x .gt. s .and. y .lt. s )) STOP 1
infi = int(z'7f800000')
maxi = int(z'7f7fffff')
call test_up(max, inf)
call test_up(-inf, -max)
call test_down(inf, max)
call test_down(-max, -inf)
! ??? Here we require the F2003 IEEE_ARITHMETIC module to
! determine if denormals are supported. If they are, then
! nearest(0,1) is the minimum denormal. If they are not,
! then it's the minimum normalized number, TINY. This fails
! much more often than the infinity test above, so it's
! disabled for now.
! call test_up(0, min)
! call test_up(-min, 0)
! call test_down(0, -min)
! call test_down(min, 0)
end
subroutine test_up(s, e)
real s, e, x
x = nearest(s, 1.0)
if (x .ne. e) STOP 2
end
subroutine test_down(s, e)
real s, e, x
x = nearest(s, -1.0)
if (x .ne. e) STOP 3
end
subroutine test_n(s1, r)
real r, s1, x
x = nearest(s1, r)
if (nearest(x, -r) .ne. s1) STOP 4
x = nearest(s1, -r)
if (nearest(x, r) .ne. s1) STOP 5
s1 = -s1
x = nearest(s1, r)
if (nearest(x, -r) .ne. s1) STOP 6
x = nearest(s1, -r)
if (nearest(x, r) .ne. s1) STOP 7
end