1!Program to test NEAREST intrinsic function.
2
3program test_nearest
4  real s, r, x, y, inf, max
5  integer i, infi, maxi
6  equivalence (s,i)
7  equivalence (inf,infi)
8  equivalence (max,maxi)
9
10  r = 2.0
11  s = 3.0
12  call test_n (s, r)
13
14  i = z'00800000'
15  call test_n (s, r)
16
17  i = z'007fffff'
18  call test_n (s, r)
19
20  i = z'00800100'
21  call test_n (s, r)
22
23  s = 0
24  x = nearest(s, r)
25  y = nearest(s, -r)
26  if (.not. (x .gt. s .and. y .lt. s )) call abort()
27
28! ??? This is pretty sketchy, but passes on most targets.
29  infi = z'7f800000'
30  maxi = z'7f7fffff'
31
32  call test_up(max, inf)
33  call test_up(-inf, -max)
34  call test_down(inf, max)
35  call test_down(-max, -inf)
36
37! ??? Here we require the F2003 IEEE_ARITHMETIC module to
38! determine if denormals are supported.  If they are, then
39! nearest(0,1) is the minimum denormal.  If they are not,
40! then it's the minimum normalized number, TINY.  This fails
41! much more often than the infinity test above, so it's
42! disabled for now.
43
44! call test_up(0, min)
45! call test_up(-min, 0)
46! call test_down(0, -min)
47! call test_down(min, 0)
48end
49
50subroutine test_up(s, e)
51  real s, e, x
52
53  x = nearest(s, 1.0)
54  if (x .ne. e) call abort()
55end
56
57subroutine test_down(s, e)
58  real s, e, x
59
60  x = nearest(s, -1.0)
61  if (x .ne. e) call abort()
62end
63
64subroutine test_n(s1, r)
65  real r, s1, x
66
67  x = nearest(s1, r)
68  if (nearest(x, -r) .ne. s1) call abort()
69  x = nearest(s1, -r)
70  if (nearest(x, r) .ne. s1) call abort()
71
72  s1 = -s1
73  x = nearest(s1, r)
74  if (nearest(x, -r) .ne. s1) call abort()
75  x = nearest(s1, -r)
76  if (nearest(x, r) .ne. s1) call abort()
77end
78