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

   1 !Program to test EXPONENT and FRACTION intrinsic function.
   2
   3 program test_exponent_fraction
   4   real x
   5   integer*4 i
   6   real*8 y
   7   integer*8 j
   8   equivalence (x, i), (y, j)
   9
  10   x = 3.
  11   call test_4(x)
  12
  13   x = 0.
  14   call test_4(x)
  15
  16   i = o'00000000001'
  17   call test_4(x)
  18
  19   i = o'00010000000'
  20   call test_4(x)
  21
  22   i = o'17700000000'
  23   call test_4(x)
  24
  25   i = o'00004000001'
  26   call test_4(x)
  27
  28   i = o'17737777777'
  29   call test_4(x)
  30
  31   i = o'10000000000'
  32   call test_4(x)
  33
  34   i = o'0000010000'
  35   call test_4(x)
  36
  37   y = 0.5
  38   call test_8(y)
  39
  40   y = 0.
  41   call test_8(y)
  42
  43   j = o'00000000001'
  44   call test_8(y)
  45
  46   y = 0.2938735877D-38
  47   call test_8(y)
  48
  49   y = -1.469369D-39
  50   call test_8(y)
  51
  52   y = z'7fe00000'
  53   call test_8(y)
  54
  55   y = -5.739719D+42
  56   call test_8(y)
  57 end
  58
  59 subroutine test_4(x)
  60 real*4 x,y
  61 integer z
  62 y = fraction (x)
  63 z = exponent(x)
  64 if (z .gt. 0) then
  65   y = (y * 2.) * (2. ** (z - 1))
  66 else
  67   y = (y / 2.) * (2. ** (z + 1))
  68 end if
  69 if (abs (x - y) .gt. abs(x * 1e-6)) call abort()
  70 end
  71
  72 subroutine test_8(x)
  73 real*8 x, y
  74 integer z
  75 y = fraction (x)
  76 z = exponent(x)
  77 if (z .gt. 0) then
  78   y = (y * 2._8) * (2._8 ** (z - 1))
  79 else
  80   y = (y / 2._8) * (2._8 ** (z + 1))
  81 end if
  82 if (abs (x - y) .gt. abs(x * 1e-6)) call abort()
  83 end
  84