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