! { dg-do run } ! { dg-additional-options "-mfp-rounding-mode=d" { target alpha*-*-* } } use, intrinsic :: ieee_features use, intrinsic :: ieee_arithmetic implicit none ! k1 and k2 will be large real kinds, if supported, and single/double ! otherwise integer, parameter :: k1 = & max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) integer, parameter :: k2 = & max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) interface check_equal procedure check_equal1, check_equal2 end interface interface check_not_equal procedure check_not_equal1, check_not_equal2 end interface interface divide procedure divide1, divide2 end interface real(kind=k1) :: x1, x2, x3 real(kind=k2) :: y1, y2, y3 type(ieee_round_type) :: mode if (ieee_support_rounding(ieee_up, x1) .and. & ieee_support_rounding(ieee_down, x1) .and. & ieee_support_rounding(ieee_nearest, x1) .and. & ieee_support_rounding(ieee_to_zero, x1)) then x1 = 1 x2 = 3 x1 = divide(x1, x2, ieee_up) x3 = 1 x2 = 3 x3 = divide(x3, x2, ieee_down) call check_not_equal(x1, x3) call check_equal(x3, nearest(x1, -1._k1)) call check_equal(x1, nearest(x3, 1._k1)) call check_equal(1._k1/3._k1, divide(1._k1, 3._k1, ieee_nearest)) call check_equal(-1._k1/3._k1, divide(-1._k1, 3._k1, ieee_nearest)) call check_equal(divide(3._k1, 7._k1, ieee_to_zero), & divide(3._k1, 7._k1, ieee_down)) call check_equal(divide(-3._k1, 7._k1, ieee_to_zero), & divide(-3._k1, 7._k1, ieee_up)) end if if (ieee_support_rounding(ieee_up, y1) .and. & ieee_support_rounding(ieee_down, y1) .and. & ieee_support_rounding(ieee_nearest, y1) .and. & ieee_support_rounding(ieee_to_zero, y1)) then y1 = 1 y2 = 3 y1 = divide(y1, y2, ieee_up) y3 = 1 y2 = 3 y3 = divide(y3, y2, ieee_down) call check_not_equal(y1, y3) call check_equal(y3, nearest(y1, -1._k2)) call check_equal(y1, nearest(y3, 1._k2)) call check_equal(1._k2/3._k2, divide(1._k2, 3._k2, ieee_nearest)) call check_equal(-1._k2/3._k2, divide(-1._k2, 3._k2, ieee_nearest)) call check_equal(divide(3._k2, 7._k2, ieee_to_zero), & divide(3._k2, 7._k2, ieee_down)) call check_equal(divide(-3._k2, 7._k2, ieee_to_zero), & divide(-3._k2, 7._k2, ieee_up)) end if contains real(kind=k1) function divide1 (x, y, rounding) result(res) use, intrinsic :: ieee_arithmetic real(kind=k1), intent(in) :: x, y type(ieee_round_type), intent(in) :: rounding type(ieee_round_type) :: old call ieee_get_rounding_mode (old) call ieee_set_rounding_mode (rounding) res = x / y call ieee_set_rounding_mode (old) end function real(kind=k2) function divide2 (x, y, rounding) result(res) use, intrinsic :: ieee_arithmetic real(kind=k2), intent(in) :: x, y type(ieee_round_type), intent(in) :: rounding type(ieee_round_type) :: old call ieee_get_rounding_mode (old) call ieee_set_rounding_mode (rounding) res = x / y call ieee_set_rounding_mode (old) end function subroutine check_equal1 (x, y) real(kind=k1), intent(in) :: x, y if (x /= y) then print *, x, y STOP 1 end if end subroutine subroutine check_equal2 (x, y) real(kind=k2), intent(in) :: x, y if (x /= y) then print *, x, y STOP 2 end if end subroutine subroutine check_not_equal1 (x, y) real(kind=k1), intent(in) :: x, y if (x == y) then print *, x, y STOP 3 end if end subroutine subroutine check_not_equal2 (x, y) real(kind=k2), intent(in) :: x, y if (x == y) then print *, x, y STOP 4 end if end subroutine end