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