gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90

   1 ! { dg-do run }
   2
   3   use, intrinsic :: ieee_features, only : ieee_rounding
   4   use, intrinsic :: ieee_arithmetic
   5   implicit none
   6
   7   interface check_equal
   8     procedure check_equal_float, check_equal_double
   9   end interface
  10
  11   interface check_not_equal
  12     procedure check_not_equal_float, check_not_equal_double
  13   end interface
  14
  15   interface divide
  16     procedure divide_float, divide_double
  17   end interface
  18
  19   real :: sx1, sx2, sx3
  20   double precision :: dx1, dx2, dx3
  21   type(ieee_round_type) :: mode
  22
  23   ! We should support at least C float and C double types
  24   if (ieee_support_rounding(ieee_nearest)) then
  25     if (.not. ieee_support_rounding(ieee_nearest, 0.)) call abort
  26     if (.not. ieee_support_rounding(ieee_nearest, 0.d0)) call abort
  27   end if
  28
  29   ! The initial rounding mode should probably be NEAREST
  30   ! (at least on the platforms we currently support)
  31   if (ieee_support_rounding(ieee_nearest, 0.)) then
  32     call ieee_get_rounding_mode (mode)
  33     if (mode /= ieee_nearest) call abort
  34   end if
  35
  36
  37   if (ieee_support_rounding(ieee_up, sx1) .and. &
  38       ieee_support_rounding(ieee_down, sx1) .and. &
  39       ieee_support_rounding(ieee_nearest, sx1) .and. &
  40       ieee_support_rounding(ieee_to_zero, sx1)) then
  41
  42     sx1 = 1
  43     sx2 = 3
  44     sx1 = divide(sx1, sx2, ieee_up)
  45
  46     sx3 = 1
  47     sx2 = 3
  48     sx3 = divide(sx3, sx2, ieee_down)
  49     call check_not_equal(sx1, sx3)
  50     call check_equal(sx3, nearest(sx1, -1.))
  51     call check_equal(sx1, nearest(sx3,  1.))
  52
  53     call check_equal(1./3., divide(1., 3., ieee_nearest))
  54     call check_equal(-1./3., divide(-1., 3., ieee_nearest))
  55
  56     call check_equal(divide(3., 7., ieee_to_zero), &
  57                     divide(3., 7., ieee_down))
  58     call check_equal(divide(-3., 7., ieee_to_zero), &
  59                     divide(-3., 7., ieee_up))
  60
  61   end if
  62
  63   if (ieee_support_rounding(ieee_up, dx1) .and. &
  64       ieee_support_rounding(ieee_down, dx1) .and. &
  65       ieee_support_rounding(ieee_nearest, dx1) .and. &
  66       ieee_support_rounding(ieee_to_zero, dx1)) then
  67
  68     dx1 = 1
  69     dx2 = 3
  70     dx1 = divide(dx1, dx2, ieee_up)
  71
  72     dx3 = 1
  73     dx2 = 3
  74     dx3 = divide(dx3, dx2, ieee_down)
  75     call check_not_equal(dx1, dx3)
  76     call check_equal(dx3, nearest(dx1, -1.d0))
  77     call check_equal(dx1, nearest(dx3,  1.d0))
  78
  79     call check_equal(1.d0/3.d0, divide(1.d0, 3.d0, ieee_nearest))
  80     call check_equal(-1.d0/3.d0, divide(-1.d0, 3.d0, ieee_nearest))
  81
  82     call check_equal(divide(3.d0, 7.d0, ieee_to_zero), &
  83                     divide(3.d0, 7.d0, ieee_down))
  84     call check_equal(divide(-3.d0, 7.d0, ieee_to_zero), &
  85                     divide(-3.d0, 7.d0, ieee_up))
  86
  87   end if
  88
  89 contains
  90
  91   real function divide_float (x, y, rounding) result(res)
  92     use, intrinsic :: ieee_arithmetic
  93     real, intent(in) :: x, y
  94     type(ieee_round_type), intent(in) :: rounding
  95     type(ieee_round_type) :: old
  96
  97     call ieee_get_rounding_mode (old)
  98     call ieee_set_rounding_mode (rounding)
  99
 100     res = x / y
 101
 102     call ieee_set_rounding_mode (old)
 103   end function
 104
 105   double precision function divide_double (x, y, rounding) result(res)
 106     use, intrinsic :: ieee_arithmetic
 107     double precision, intent(in) :: x, y
 108     type(ieee_round_type), intent(in) :: rounding
 109     type(ieee_round_type) :: old
 110
 111     call ieee_get_rounding_mode (old)
 112     call ieee_set_rounding_mode (rounding)
 113
 114     res = x / y
 115
 116     call ieee_set_rounding_mode (old)
 117   end function
 118
 119   subroutine check_equal_float (x, y)
 120     real, intent(in) :: x, y
 121     if (x /= y) then
 122       print *, x, y
 123       call abort
 124     end if
 125   end subroutine
 126
 127   subroutine check_equal_double (x, y)
 128     double precision, intent(in) :: x, y
 129     if (x /= y) then
 130       print *, x, y
 131       call abort
 132     end if
 133   end subroutine
 134
 135   subroutine check_not_equal_float (x, y)
 136     real, intent(in) :: x, y
 137     if (x == y) then
 138       print *, x, y
 139       call abort
 140     end if
 141   end subroutine
 142
 143   subroutine check_not_equal_double (x, y)
 144     double precision, intent(in) :: x, y
 145     if (x == y) then
 146       print *, x, y
 147       call abort
 148     end if
 149   end subroutine
 150
 151 end