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