gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_nearest.f90

   1 !Program to test NEAREST intrinsic function.
   2
   3 program 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)
  48 end
  49
  50 subroutine test_up(s, e)
  51   real s, e, x
  52
  53   x = nearest(s, 1.0)
  54   if (x .ne. e) call abort()
  55 end
  56
  57 subroutine test_down(s, e)
  58   real s, e, x
  59
  60   x = nearest(s, -1.0)
  61   if (x .ne. e) call abort()
  62 end
  63
  64 subroutine 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()
  77 end