| !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 = z'00800000' |
| call test_n (s, r) |
| |
| i = z'007fffff' |
| call test_n (s, r) |
| |
| i = 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 )) call abort() |
| |
| ! ??? This is pretty sketchy, but passes on most targets. |
| infi = z'7f800000' |
| maxi = 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) call abort() |
| end |
| |
| subroutine test_down(s, e) |
| real s, e, x |
| |
| x = nearest(s, -1.0) |
| if (x .ne. e) call abort() |
| end |
| |
| subroutine test_n(s1, r) |
| real r, s1, x |
| |
| x = nearest(s1, r) |
| if (nearest(x, -r) .ne. s1) call abort() |
| x = nearest(s1, -r) |
| if (nearest(x, r) .ne. s1) call abort() |
| |
| s1 = -s1 |
| x = nearest(s1, r) |
| if (nearest(x, -r) .ne. s1) call abort() |
| x = nearest(s1, -r) |
| if (nearest(x, r) .ne. s1) call abort() |
| end |