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 = int(z'00800000')
15  call test_n (s, r)
16
17  i = int(z'007fffff')
18  call test_n (s, r)
19
20  i = int(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 )) STOP 1
27
28  infi = int(z'7f800000')
29  maxi = int(z'7f7fffff')
30
31  call test_up(max, inf)
32  call test_up(-inf, -max)
33  call test_down(inf, max)
34  call test_down(-max, -inf)
35
36! ??? Here we require the F2003 IEEE_ARITHMETIC module to
37! determine if denormals are supported.  If they are, then
38! nearest(0,1) is the minimum denormal.  If they are not,
39! then it's the minimum normalized number, TINY.  This fails
40! much more often than the infinity test above, so it's
41! disabled for now.
42
43! call test_up(0, min)
44! call test_up(-min, 0)
45! call test_down(0, -min)
46! call test_down(min, 0)
47end
48
49subroutine test_up(s, e)
50  real s, e, x
51
52  x = nearest(s, 1.0)
53  if (x .ne. e) STOP 2
54end
55
56subroutine test_down(s, e)
57  real s, e, x
58
59  x = nearest(s, -1.0)
60  if (x .ne. e) STOP 3
61end
62
63subroutine test_n(s1, r)
64  real r, s1, x
65
66  x = nearest(s1, r)
67  if (nearest(x, -r) .ne. s1) STOP 4
68  x = nearest(s1, -r)
69  if (nearest(x, r) .ne. s1) STOP 5
70
71  s1 = -s1
72  x = nearest(s1, r)
73  if (nearest(x, -r) .ne. s1) STOP 6
74  x = nearest(s1, -r)
75  if (nearest(x, r) .ne. s1) STOP 7
76end
77