flang/module/ieee_arithmetic.f90

   1 !===-- module/ieee_arithmetic.f90 ------------------------------------------===!
   2 !
   3 ! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
   4 ! See https://llvm.org/LICENSE.txt for license information.
   5 ! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
   6 !
   7 !===------------------------------------------------------------------------===!
   8
   9 ! Fortran 2018 Clause 17
  10
  11 ! ieee_class_type and ieee_round_type values
  12 include '../include/flang/Runtime/ieee_arithmetic.h'
  13
  14 module ieee_arithmetic
  15   ! 17.1: "The module IEEE_ARITHMETIC behaves as if it contained a
  16   ! USE statement for IEEE_EXCEPTIONS; everything that is public in
  17   ! IEEE_EXCEPTIONS is public in IEEE_ARITHMETIC."
  18   use __Fortran_ieee_exceptions
  19
  20   use __Fortran_builtins, only: &
  21     ieee_fma => __builtin_fma, &
  22     ieee_is_nan => __builtin_ieee_is_nan, &
  23     ieee_is_negative => __builtin_ieee_is_negative, &
  24     ieee_is_normal => __builtin_ieee_is_normal, &
  25     ieee_next_after => __builtin_ieee_next_after, &
  26     ieee_next_down => __builtin_ieee_next_down, &
  27     ieee_next_up => __builtin_ieee_next_up, &
  28     ieee_scalb => scale, &
  29     ieee_selected_real_kind => __builtin_ieee_selected_real_kind, &
  30     ieee_support_datatype => __builtin_ieee_support_datatype, &
  31     ieee_support_denormal => __builtin_ieee_support_denormal, &
  32     ieee_support_divide => __builtin_ieee_support_divide, &
  33     ieee_support_inf => __builtin_ieee_support_inf, &
  34     ieee_support_io => __builtin_ieee_support_io, &
  35     ieee_support_nan => __builtin_ieee_support_nan, &
  36     ieee_support_sqrt => __builtin_ieee_support_sqrt, &
  37     ieee_support_standard => __builtin_ieee_support_standard, &
  38     ieee_support_subnormal => __builtin_ieee_support_subnormal, &
  39     ieee_support_underflow_control => __builtin_ieee_support_underflow_control
  40
  41   implicit none
  42
  43   type :: ieee_class_type
  44     private
  45     integer(kind=1) :: which = 0
  46   end type ieee_class_type
  47
  48   type(ieee_class_type), parameter :: &
  49     ieee_signaling_nan = ieee_class_type(_FORTRAN_RUNTIME_IEEE_SIGNALING_NAN), &
  50     ieee_quiet_nan = ieee_class_type(_FORTRAN_RUNTIME_IEEE_QUIET_NAN), &
  51     ieee_negative_inf = ieee_class_type(_FORTRAN_RUNTIME_IEEE_NEGATIVE_INF), &
  52     ieee_negative_normal = ieee_class_type(_FORTRAN_RUNTIME_IEEE_NEGATIVE_NORMAL), &
  53     ieee_negative_subnormal = ieee_class_type(_FORTRAN_RUNTIME_IEEE_NEGATIVE_SUBNORMAL), &
  54     ieee_negative_zero = ieee_class_type(_FORTRAN_RUNTIME_IEEE_NEGATIVE_ZERO), &
  55     ieee_positive_zero = ieee_class_type(_FORTRAN_RUNTIME_IEEE_POSITIVE_ZERO), &
  56     ieee_positive_subnormal = ieee_class_type(_FORTRAN_RUNTIME_IEEE_POSITIVE_SUBNORMAL), &
  57     ieee_positive_normal = ieee_class_type(_FORTRAN_RUNTIME_IEEE_POSITIVE_NORMAL), &
  58     ieee_positive_inf = ieee_class_type(_FORTRAN_RUNTIME_IEEE_POSITIVE_INF), &
  59     ieee_other_value = ieee_class_type(_FORTRAN_RUNTIME_IEEE_OTHER_VALUE)
  60
  61   type(ieee_class_type), parameter :: &
  62     ieee_negative_denormal = ieee_negative_subnormal, &
  63     ieee_positive_denormal = ieee_positive_subnormal
  64
  65   type :: ieee_round_type
  66     private
  67     integer(kind=1) :: mode = 0
  68   end type ieee_round_type
  69
  70   type(ieee_round_type), parameter :: &
  71     ieee_to_zero = ieee_round_type(_FORTRAN_RUNTIME_IEEE_TO_ZERO), &
  72     ieee_nearest = ieee_round_type(_FORTRAN_RUNTIME_IEEE_NEAREST), &
  73     ieee_up = ieee_round_type(_FORTRAN_RUNTIME_IEEE_UP), &
  74     ieee_down = ieee_round_type(_FORTRAN_RUNTIME_IEEE_DOWN), &
  75     ieee_away = ieee_round_type(_FORTRAN_RUNTIME_IEEE_AWAY), &
  76     ieee_other = ieee_round_type(_FORTRAN_RUNTIME_IEEE_OTHER)
  77
  78   interface operator(==)
  79     elemental logical function ieee_class_eq(x, y)
  80       import ieee_class_type
  81       type(ieee_class_type), intent(in) :: x, y
  82     end function ieee_class_eq
  83     elemental logical function ieee_round_eq(x, y)
  84       import ieee_round_type
  85       type(ieee_round_type), intent(in) :: x, y
  86     end function ieee_round_eq
  87   end interface operator(==)
  88   interface operator(/=)
  89     elemental logical function ieee_class_ne(x, y)
  90       import ieee_class_type
  91       type(ieee_class_type), intent(in) :: x, y
  92     end function ieee_class_ne
  93     elemental logical function ieee_round_ne(x, y)
  94       import ieee_round_type
  95       type(ieee_round_type), intent(in) :: x, y
  96     end function ieee_round_ne
  97   end interface operator(/=)
  98   private :: ieee_class_eq, ieee_round_eq, ieee_class_ne, ieee_round_ne
  99
 100 ! Define specifics with 1 or 2 INTEGER, LOGICAL, or REAL arguments for
 101 ! generic G.
 102 #define SPECIFICS_I(G) \
 103   G(1) G(2) G(4) G(8) G(16)
 104 #define SPECIFICS_L(G) \
 105   G(1) G(2) G(4) G(8)
 106 #if __x86_64__
 107 #define SPECIFICS_R(G) \
 108   G(2) G(3) G(4) G(8) G(10) G(16)
 109 #else
 110 #define SPECIFICS_R(G) \
 111   G(2) G(3) G(4) G(8) G(16)
 112 #endif
 113 #define SPECIFICS_II(G) \
 114   G(1,1) G(1,2) G(1,4) G(1,8) G(1,16) \
 115   G(2,1) G(2,2) G(2,4) G(2,8) G(2,16) \
 116   G(4,1) G(4,2) G(4,4) G(4,8) G(4,16) \
 117   G(8,1) G(8,2) G(8,4) G(8,8) G(8,16) \
 118   G(16,1) G(16,2) G(16,4) G(16,8) G(16,16)
 119 #if __x86_64__
 120 #define SPECIFICS_RI(G) \
 121   G(2,1) G(2,2) G(2,4) G(2,8) G(2,16) \
 122   G(3,1) G(3,2) G(3,4) G(3,8) G(3,16) \
 123   G(4,1) G(4,2) G(4,4) G(4,8) G(4,16) \
 124   G(8,1) G(8,2) G(8,4) G(8,8) G(8,16) \
 125   G(10,1) G(10,2) G(10,4) G(10,8) G(10,16) \
 126   G(16,1) G(16,2) G(16,4) G(16,8) G(16,16)
 127 #else
 128 #define SPECIFICS_RI(G) \
 129   G(2,1) G(2,2) G(2,4) G(2,8) G(2,16) \
 130   G(3,1) G(3,2) G(3,4) G(3,8) G(3,16) \
 131   G(4,1) G(4,2) G(4,4) G(4,8) G(4,16) \
 132   G(8,1) G(8,2) G(8,4) G(8,8) G(8,16) \
 133   G(16,1) G(16,2) G(16,4) G(16,8) G(16,16)
 134 #endif
 135
 136 #if __x86_64__
 137 #define SPECIFICS_RR(G) \
 138   G(2,2) G(2,3) G(2,4) G(2,8) G(2,10) G(2,16) \
 139   G(3,2) G(3,3) G(3,4) G(3,8) G(3,10) G(3,16) \
 140   G(4,2) G(4,3) G(4,4) G(4,8) G(4,10) G(4,16) \
 141   G(8,2) G(8,3) G(8,4) G(8,8) G(8,10) G(8,16) \
 142   G(10,2) G(10,3) G(10,4) G(10,8) G(10,10) G(10,16) \
 143   G(16,2) G(16,3) G(16,4) G(16,8) G(16,10) G(16,16)
 144 #else
 145 #define SPECIFICS_RR(G) \
 146   G(2,2) G(2,3) G(2,4) G(2,8) G(2,16) \
 147   G(3,2) G(3,3) G(3,4) G(3,8) G(3,16) \
 148   G(4,2) G(4,3) G(4,4) G(4,8) G(4,16) \
 149   G(8,2) G(8,3) G(8,4) G(8,8) G(8,16) \
 150   G(16,2) G(16,3) G(16,4) G(16,8) G(16,16)
 151 #endif
 152
 153 ! Set PRIVATE accessibility for specifics with 1 or 2 INTEGER, LOGICAL, or REAL
 154 ! arguments for generic G.
 155 #define PRIVATE_I(G) private :: \
 156   G##_i1, G##_i2, G##_i4, G##_i8, G##_i16
 157 #define PRIVATE_L(G) private :: \
 158   G##_l1, G##_l2, G##_l4, G##_l8
 159 #if __x86_64__
 160 #define PRIVATE_R(G) private :: \
 161   G##_a2, G##_a3, G##_a4, G##_a8, G##_a10, G##_a16
 162 #else
 163 #define PRIVATE_R(G) private :: \
 164   G##_a2, G##_a3, G##_a4, G##_a8, G##_a16
 165 #endif
 166 #define PRIVATE_II(G) private :: \
 167   G##_i1_i1, G##_i1_i2, G##_i1_i4, G##_i1_i8, G##_i1_i16, \
 168   G##_i2_i1, G##_i2_i2, G##_i2_i4, G##_i2_i8, G##_i2_i16, \
 169   G##_i4_i1, G##_i4_i2, G##_i4_i4, G##_i4_i8, G##_i4_i16, \
 170   G##_i8_i1, G##_i8_i2, G##_i8_i4, G##_i8_i8, G##_i8_i16, \
 171   G##_i16_i1, G##_i16_i2, G##_i16_i4, G##_i16_i8, G##_i16_i16
 172 #if __x86_64__
 173 #define PRIVATE_RI(G) private :: \
 174   G##_a2_i1, G##_a2_i2, G##_a2_i4, G##_a2_i8, G##_a2_i16, \
 175   G##_a3_i1, G##_a3_i2, G##_a3_i4, G##_a3_i8, G##_a3_i16, \
 176   G##_a4_i1, G##_a4_i2, G##_a4_i4, G##_a4_i8, G##_a4_i16, \
 177   G##_a8_i1, G##_a8_i2, G##_a8_i4, G##_a8_i8, G##_a8_i16, \
 178   G##_a10_i1, G##_a10_i2, G##_a10_i4, G##_a10_i8, G##_a10_i16, \
 179   G##_a16_i1, G##_a16_i2, G##_a16_i4, G##_a16_i8, G##_a16_i16
 180 #else
 181 #define PRIVATE_RI(G) private :: \
 182   G##_a2_i1, G##_a2_i2, G##_a2_i4, G##_a2_i8, G##_a2_i16, \
 183   G##_a3_i1, G##_a3_i2, G##_a3_i4, G##_a3_i8, G##_a3_i16, \
 184   G##_a4_i1, G##_a4_i2, G##_a4_i4, G##_a4_i8, G##_a4_i16, \
 185   G##_a8_i1, G##_a8_i2, G##_a8_i4, G##_a8_i8, G##_a8_i16, \
 186   G##_a16_i1, G##_a16_i2, G##_a16_i4, G##_a16_i8, G##_a16_i16
 187 #endif
 188 #if __x86_64__
 189 #define PRIVATE_RR(G) private :: \
 190   G##_a2_a2, G##_a2_a3, G##_a2_a4, G##_a2_a8, G##_a2_a10, G##_a2_a16, \
 191   G##_a3_a2, G##_a3_a3, G##_a3_a4, G##_a3_a8, G##_a3_a10, G##_a3_a16, \
 192   G##_a4_a2, G##_a4_a3, G##_a4_a4, G##_a4_a8, G##_a4_a10, G##_a4_a16, \
 193   G##_a8_a2, G##_a8_a3, G##_a8_a4, G##_a8_a8, G##_a8_a10, G##_a8_a16, \
 194   G##_a10_a2, G##_a10_a3, G##_a10_a4, G##_a10_a8, G##_a10_a10, G##_a10_a16, \
 195   G##_a16_a2, G##_a16_a3, G##_a16_a4, G##_a16_a8, G##_a16_a10, G##_a16_a16
 196 #else
 197 #define PRIVATE_RR(G) private :: \
 198   G##_a2_a2, G##_a2_a3, G##_a2_a4, G##_a2_a8, G##_a2_a16, \
 199   G##_a3_a2, G##_a3_a3, G##_a3_a4, G##_a3_a8, G##_a3_a16, \
 200   G##_a4_a2, G##_a4_a3, G##_a4_a4, G##_a4_a8, G##_a4_a16, \
 201   G##_a8_a2, G##_a8_a3, G##_a8_a4, G##_a8_a8, G##_a8_a16, \
 202   G##_a16_a2, G##_a16_a3, G##_a16_a4, G##_a16_a8, G##_a16_a16
 203 #endif
 204
 205 #define IEEE_CLASS_R(XKIND) \
 206   elemental type(ieee_class_type) function ieee_class_a##XKIND(x); \
 207     import ieee_class_type; \
 208     real(XKIND), intent(in) :: x; \
 209   end function ieee_class_a##XKIND;
 210   interface ieee_class
 211     SPECIFICS_R(IEEE_CLASS_R)
 212   end interface ieee_class
 213   PRIVATE_R(IEEE_CLASS)
 214 #undef IEEE_CLASS_R
 215
 216 #define IEEE_COPY_SIGN_RR(XKIND, YKIND) \
 217   elemental real(XKIND) function ieee_copy_sign_a##XKIND##_a##YKIND(x, y); \
 218     real(XKIND), intent(in) :: x; \
 219     real(YKIND), intent(in) :: y; \
 220   end function ieee_copy_sign_a##XKIND##_a##YKIND;
 221   interface ieee_copy_sign
 222     SPECIFICS_RR(IEEE_COPY_SIGN_RR)
 223   end interface ieee_copy_sign
 224   PRIVATE_RR(IEEE_COPY_SIGN)
 225 #undef IEEE_COPY_SIGN_RR
 226
 227 #define IEEE_GET_ROUNDING_MODE_I(RKIND) \
 228   subroutine ieee_get_rounding_mode_i##RKIND(round_value, radix); \
 229     import ieee_round_type; \
 230     type(ieee_round_type), intent(out) :: round_value; \
 231     integer(RKIND), intent(in) :: radix; \
 232   end subroutine ieee_get_rounding_mode_i##RKIND;
 233   interface ieee_get_rounding_mode
 234     subroutine ieee_get_rounding_mode_0(round_value)
 235       import ieee_round_type
 236       type(ieee_round_type), intent(out) :: round_value
 237     end subroutine ieee_get_rounding_mode_0
 238     SPECIFICS_I(IEEE_GET_ROUNDING_MODE_I)
 239   end interface ieee_get_rounding_mode
 240   PRIVATE_I(IEEE_GET_ROUNDING_MODE)
 241 #undef IEEE_GET_ROUNDING_MODE_I
 242
 243 #define IEEE_GET_UNDERFLOW_MODE_L(GKIND) \
 244   subroutine ieee_get_underflow_mode_l##GKIND(gradual); \
 245     logical(GKIND), intent(out) :: gradual; \
 246   end subroutine ieee_get_underflow_mode_l##GKIND;
 247   interface ieee_get_underflow_mode
 248     SPECIFICS_L(IEEE_GET_UNDERFLOW_MODE_L)
 249   end interface ieee_get_underflow_mode
 250   PRIVATE_L(IEEE_GET_UNDERFLOW_MODE)
 251 #undef IEEE_GET_UNDERFLOW_MODE_L
 252
 253 ! When kind argument is present, kind(result) is value(kind), not kind(kind).
 254 ! That is not known here, so return integer(16).
 255 #define IEEE_INT_R(AKIND) \
 256   elemental integer function ieee_int_a##AKIND(a, round); \
 257     import ieee_round_type; \
 258     real(AKIND), intent(in) :: a; \
 259     type(ieee_round_type), intent(in) :: round; \
 260   end function ieee_int_a##AKIND;
 261 #define IEEE_INT_RI(AKIND, KKIND) \
 262   elemental integer(16) function ieee_int_a##AKIND##_i##KKIND(a, round, kind); \
 263     import ieee_round_type; \
 264     real(AKIND), intent(in) :: a; \
 265     type(ieee_round_type), intent(in) :: round; \
 266     integer(KKIND), intent(in) :: kind; \
 267   end function ieee_int_a##AKIND##_i##KKIND;
 268   interface ieee_int
 269     SPECIFICS_R(IEEE_INT_R)
 270     SPECIFICS_RI(IEEE_INT_RI)
 271   end interface ieee_int
 272   PRIVATE_R(IEEE_INT)
 273   PRIVATE_RI(IEEE_INT)
 274 #undef IEEE_INT_R
 275 #undef IEEE_INT_RI
 276
 277 #define IEEE_IS_FINITE_R(XKIND) \
 278   elemental logical function ieee_is_finite_a##XKIND(x); \
 279     real(XKIND), intent(in) :: x; \
 280   end function ieee_is_finite_a##XKIND;
 281   interface ieee_is_finite
 282     SPECIFICS_R(IEEE_IS_FINITE_R)
 283   end interface ieee_is_finite
 284   PRIVATE_R(IEEE_IS_FINITE)
 285 #undef IEEE_IS_FINITE_R
 286
 287 #define IEEE_LOGB_R(XKIND) \
 288   elemental real(XKIND) function ieee_logb_a##XKIND(x); \
 289     real(XKIND), intent(in) :: x; \
 290   end function ieee_logb_a##XKIND;
 291   interface ieee_logb
 292     SPECIFICS_R(IEEE_LOGB_R)
 293   end interface ieee_logb
 294   PRIVATE_R(IEEE_LOGB)
 295 #undef IEEE_LOGB_R
 296
 297 #define IEEE_MAX_NUM_R(XKIND) \
 298   elemental real(XKIND) function ieee_max_num_a##XKIND(x, y); \
 299     real(XKIND), intent(in) :: x, y; \
 300   end function ieee_max_num_a##XKIND;
 301   interface ieee_max_num
 302     SPECIFICS_R(IEEE_MAX_NUM_R)
 303   end interface ieee_max_num
 304   PRIVATE_R(IEEE_MAX_NUM)
 305 #undef IEEE_MAX_NUM_R
 306
 307 #define IEEE_MAX_NUM_MAG_R(XKIND) \
 308   elemental real(XKIND) function ieee_max_num_mag_a##XKIND(x, y); \
 309     real(XKIND), intent(in) :: x, y; \
 310   end function ieee_max_num_mag_a##XKIND;
 311   interface ieee_max_num_mag
 312     SPECIFICS_R(IEEE_MAX_NUM_MAG_R)
 313   end interface ieee_max_num_mag
 314   PRIVATE_R(IEEE_MAX_NUM_MAG)
 315 #undef IEEE_MAX_NUM_MAG_R
 316
 317 #define IEEE_MIN_NUM_R(XKIND) \
 318   elemental real(XKIND) function ieee_min_num_a##XKIND(x, y); \
 319     real(XKIND), intent(in) :: x, y; \
 320   end function ieee_min_num_a##XKIND;
 321   interface ieee_min_num
 322     SPECIFICS_R(IEEE_MIN_NUM_R)
 323   end interface ieee_min_num
 324   PRIVATE_R(IEEE_MIN_NUM)
 325 #undef IEEE_MIN_NUM_R
 326
 327 #define IEEE_MIN_NUM_MAG_R(XKIND) \
 328   elemental real(XKIND) function ieee_min_num_mag_a##XKIND(x, y); \
 329     real(XKIND), intent(in) :: x, y; \
 330   end function ieee_min_num_mag_a##XKIND;
 331   interface ieee_min_num_mag
 332     SPECIFICS_R(IEEE_MIN_NUM_MAG_R)
 333   end interface ieee_min_num_mag
 334   PRIVATE_R(IEEE_MIN_NUM_MAG)
 335 #undef IEEE_MIN_NUM_MAG_R
 336
 337 #define IEEE_QUIET_EQ_R(AKIND) \
 338   elemental logical function ieee_quiet_eq_a##AKIND(a, b); \
 339     real(AKIND), intent(in) :: a, b; \
 340   end function ieee_quiet_eq_a##AKIND;
 341   interface ieee_quiet_eq
 342     SPECIFICS_R(IEEE_QUIET_EQ_R)
 343   end interface ieee_quiet_eq
 344   PRIVATE_R(IEEE_QUIET_EQ)
 345 #undef IEEE_QUIET_EQ_R
 346
 347 #define IEEE_QUIET_GE_R(AKIND) \
 348   elemental logical function ieee_quiet_ge_a##AKIND(a, b); \
 349     real(AKIND), intent(in) :: a, b; \
 350   end function ieee_quiet_ge_a##AKIND;
 351   interface ieee_quiet_ge
 352     SPECIFICS_R(IEEE_QUIET_GE_R)
 353   end interface ieee_quiet_ge
 354   PRIVATE_R(IEEE_QUIET_GE)
 355 #undef IEEE_QUIET_GE_R
 356
 357 #define IEEE_QUIET_GT_R(AKIND) \
 358   elemental logical function ieee_quiet_gt_a##AKIND(a, b); \
 359     real(AKIND), intent(in) :: a, b; \
 360   end function ieee_quiet_gt_a##AKIND;
 361   interface ieee_quiet_gt
 362     SPECIFICS_R(IEEE_QUIET_GT_R)
 363   end interface ieee_quiet_gt
 364   PRIVATE_R(IEEE_QUIET_GT)
 365 #undef IEEE_QUIET_GT_R
 366
 367 #define IEEE_QUIET_LE_R(AKIND) \
 368   elemental logical function ieee_quiet_le_a##AKIND(a, b); \
 369     real(AKIND), intent(in) :: a, b; \
 370   end function ieee_quiet_le_a##AKIND;
 371   interface ieee_quiet_le
 372     SPECIFICS_R(IEEE_QUIET_LE_R)
 373   end interface ieee_quiet_le
 374   PRIVATE_R(IEEE_QUIET_LE)
 375 #undef IEEE_QUIET_LE_R
 376
 377 #define IEEE_QUIET_LT_R(AKIND) \
 378   elemental logical function ieee_quiet_lt_a##AKIND(a, b); \
 379     real(AKIND), intent(in) :: a, b; \
 380   end function ieee_quiet_lt_a##AKIND;
 381   interface ieee_quiet_lt
 382     SPECIFICS_R(IEEE_QUIET_LT_R)
 383   end interface ieee_quiet_lt
 384   PRIVATE_R(IEEE_QUIET_LT)
 385 #undef IEEE_QUIET_LT_R
 386
 387 #define IEEE_QUIET_NE_R(AKIND) \
 388   elemental logical function ieee_quiet_ne_a##AKIND(a, b); \
 389     real(AKIND), intent(in) :: a, b; \
 390   end function ieee_quiet_ne_a##AKIND;
 391   interface ieee_quiet_ne
 392     SPECIFICS_R(IEEE_QUIET_NE_R)
 393   end interface ieee_quiet_ne
 394   PRIVATE_R(IEEE_QUIET_NE)
 395 #undef IEEE_QUIET_NE_R
 396
 397 ! When kind argument is present, kind(result) is value(kind), not kind(kind).
 398 ! That is not known here, so return real(16).
 399 #define IEEE_REAL_I(AKIND) \
 400   elemental real function ieee_real_i##AKIND(a); \
 401     integer(AKIND), intent(in) :: a; \
 402   end function ieee_real_i##AKIND;
 403 #define IEEE_REAL_R(AKIND) \
 404   elemental real function ieee_real_a##AKIND(a); \
 405     real(AKIND), intent(in) :: a; \
 406   end function ieee_real_a##AKIND;
 407 #define IEEE_REAL_II(AKIND, KKIND) \
 408   elemental real(16) function ieee_real_i##AKIND##_i##KKIND(a, kind); \
 409     integer(AKIND), intent(in) :: a; \
 410     integer(KKIND), intent(in) :: kind; \
 411   end function ieee_real_i##AKIND##_i##KKIND;
 412 #define IEEE_REAL_RI(AKIND, KKIND) \
 413   elemental real(16) function ieee_real_a##AKIND##_i##KKIND(a, kind); \
 414     real(AKIND), intent(in) :: a; \
 415     integer(KKIND), intent(in) :: kind; \
 416   end function ieee_real_a##AKIND##_i##KKIND;
 417   interface ieee_real
 418     SPECIFICS_I(IEEE_REAL_I)
 419     SPECIFICS_R(IEEE_REAL_R)
 420     SPECIFICS_II(IEEE_REAL_II)
 421     SPECIFICS_RI(IEEE_REAL_RI)
 422   end interface ieee_real
 423   PRIVATE_I(IEEE_REAL)
 424   PRIVATE_R(IEEE_REAL)
 425   PRIVATE_II(IEEE_REAL)
 426   PRIVATE_RI(IEEE_REAL)
 427 #undef IEEE_REAL_I
 428 #undef IEEE_REAL_R
 429 #undef IEEE_REAL_II
 430 #undef IEEE_REAL_RI
 431
 432 #define IEEE_REM_RR(XKIND, YKIND) \
 433   elemental real(XKIND) function ieee_rem_a##XKIND##_a##YKIND(x, y); \
 434     real(XKIND), intent(in) :: x; \
 435     real(YKIND), intent(in) :: y; \
 436   end function ieee_rem_a##XKIND##_a##YKIND;
 437   interface ieee_rem
 438     SPECIFICS_RR(IEEE_REM_RR)
 439   end interface ieee_rem
 440   PRIVATE_RR(IEEE_REM)
 441 #undef IEEE_REM_RR
 442
 443 #define IEEE_RINT_R(XKIND) \
 444   elemental real(XKIND) function ieee_rint_a##XKIND(x, round); \
 445     import ieee_round_type; \
 446     real(XKIND), intent(in) :: x; \
 447     type(ieee_round_type), optional, intent(in) :: round; \
 448   end function ieee_rint_a##XKIND;
 449   interface ieee_rint
 450     SPECIFICS_R(IEEE_RINT_R)
 451   end interface ieee_rint
 452   PRIVATE_R(IEEE_RINT)
 453 #undef IEEE_RINT_R
 454
 455 #define IEEE_SET_ROUNDING_MODE_I(RKIND) \
 456   subroutine ieee_set_rounding_mode_i##RKIND(round_value, radix); \
 457     import ieee_round_type; \
 458     type(ieee_round_type), intent(in) :: round_value; \
 459     integer(RKIND), intent(in) :: radix; \
 460   end subroutine ieee_set_rounding_mode_i##RKIND;
 461   interface ieee_set_rounding_mode
 462     subroutine ieee_set_rounding_mode_0(round_value)
 463       import ieee_round_type
 464       type(ieee_round_type), intent(in) :: round_value
 465     end subroutine ieee_set_rounding_mode_0
 466     SPECIFICS_I(IEEE_SET_ROUNDING_MODE_I)
 467   end interface ieee_set_rounding_mode
 468   PRIVATE_I(IEEE_SET_ROUNDING_MODE)
 469 #undef IEEE_SET_ROUNDING_MODE_I
 470
 471 #define IEEE_SET_UNDERFLOW_MODE_L(GKIND) \
 472   subroutine ieee_set_underflow_mode_l##GKIND(gradual); \
 473     logical(GKIND), intent(in) :: gradual; \
 474   end subroutine ieee_set_underflow_mode_l##GKIND;
 475   interface ieee_set_underflow_mode
 476     SPECIFICS_L(IEEE_SET_UNDERFLOW_MODE_L)
 477   end interface ieee_set_underflow_mode
 478   PRIVATE_L(IEEE_SET_UNDERFLOW_MODE)
 479 #undef IEEE_SET_UNDERFLOW_MODE_L
 480
 481 #define IEEE_SIGNALING_EQ_R(AKIND) \
 482   elemental logical function ieee_signaling_eq_a##AKIND(a, b); \
 483     real(AKIND), intent(in) :: a, b; \
 484   end function ieee_signaling_eq_a##AKIND;
 485   interface ieee_signaling_eq
 486     SPECIFICS_R(IEEE_SIGNALING_EQ_R)
 487   end interface ieee_signaling_eq
 488   PRIVATE_R(IEEE_SIGNALING_EQ)
 489 #undef IEEE_SIGNALING_EQ_R
 490
 491 #define IEEE_SIGNALING_GE_R(AKIND) \
 492   elemental logical function ieee_signaling_ge_a##AKIND(a, b); \
 493     real(AKIND), intent(in) :: a, b; \
 494   end function ieee_signaling_ge_a##AKIND;
 495   interface ieee_signaling_ge
 496     SPECIFICS_R(IEEE_SIGNALING_GE_R)
 497   end interface ieee_signaling_ge
 498   PRIVATE_R(IEEE_SIGNALING_GE)
 499 #undef IEEE_SIGNALING_GE_R
 500
 501 #define IEEE_SIGNALING_GT_R(AKIND) \
 502   elemental logical function ieee_signaling_gt_a##AKIND(a, b); \
 503     real(AKIND), intent(in) :: a, b; \
 504   end function ieee_signaling_gt_a##AKIND;
 505   interface ieee_signaling_gt
 506     SPECIFICS_R(IEEE_SIGNALING_GT_R)
 507   end interface ieee_signaling_gt
 508   PRIVATE_R(IEEE_SIGNALING_GT)
 509 #undef IEEE_SIGNALING_GT_R
 510
 511 #define IEEE_SIGNALING_LE_R(AKIND) \
 512   elemental logical function ieee_signaling_le_a##AKIND(a, b); \
 513     real(AKIND), intent(in) :: a, b; \
 514   end function ieee_signaling_le_a##AKIND;
 515   interface ieee_signaling_le
 516     SPECIFICS_R(IEEE_SIGNALING_LE_R)
 517   end interface ieee_signaling_le
 518   PRIVATE_R(IEEE_SIGNALING_LE)
 519 #undef IEEE_SIGNALING_LE_R
 520
 521 #define IEEE_SIGNALING_LT_R(AKIND) \
 522   elemental logical function ieee_signaling_lt_a##AKIND(a, b); \
 523     real(AKIND), intent(in) :: a, b; \
 524   end function ieee_signaling_lt_a##AKIND;
 525   interface ieee_signaling_lt
 526     SPECIFICS_R(IEEE_SIGNALING_LT_R)
 527   end interface ieee_signaling_lt
 528   PRIVATE_R(IEEE_SIGNALING_LT)
 529 #undef IEEE_SIGNALING_LT_R
 530
 531 #define IEEE_SIGNALING_NE_R(AKIND) \
 532   elemental logical function ieee_signaling_ne_a##AKIND(a, b); \
 533     real(AKIND), intent(in) :: a, b; \
 534   end function ieee_signaling_ne_a##AKIND;
 535   interface ieee_signaling_ne
 536     SPECIFICS_R(IEEE_SIGNALING_NE_R)
 537   end interface ieee_signaling_ne
 538   PRIVATE_R(IEEE_SIGNALING_NE)
 539 #undef IEEE_SIGNALING_NE_R
 540
 541 #define IEEE_SIGNBIT_R(XKIND) \
 542   elemental logical function ieee_signbit_a##XKIND(x); \
 543     real(XKIND), intent(in) :: x; \
 544   end function ieee_signbit_a##XKIND;
 545   interface ieee_signbit
 546     SPECIFICS_R(IEEE_SIGNBIT_R)
 547   end interface ieee_signbit
 548   PRIVATE_R(IEEE_SIGNBIT)
 549 #undef IEEE_SIGNBIT_R
 550
 551 #define IEEE_SUPPORT_ROUNDING_R(XKIND) \
 552   pure logical function ieee_support_rounding_a##XKIND(round_value, x); \
 553     import ieee_round_type; \
 554     type(ieee_round_type), intent(in) :: round_value; \
 555     real(XKIND), intent(in) :: x(..); \
 556   end function ieee_support_rounding_a##XKIND;
 557   interface ieee_support_rounding
 558     pure logical function ieee_support_rounding_0(round_value)
 559       import ieee_round_type
 560       type(ieee_round_type), intent(in) :: round_value
 561     end function ieee_support_rounding_0
 562     SPECIFICS_R(IEEE_SUPPORT_ROUNDING_R)
 563   end interface ieee_support_rounding
 564   PRIVATE_R(IEEE_SUPPORT_ROUNDING)
 565 #undef IEEE_SUPPORT_ROUNDING_R
 566
 567 #define IEEE_UNORDERED_RR(XKIND, YKIND) \
 568  elemental logical function ieee_unordered_a##XKIND##_a##YKIND(x, y); \
 569     real(XKIND), intent(in) :: x; \
 570     real(YKIND), intent(in) :: y; \
 571   end function ieee_unordered_a##XKIND##_a##YKIND;
 572   interface ieee_unordered
 573     SPECIFICS_RR(IEEE_UNORDERED_RR)
 574   end interface ieee_unordered
 575   PRIVATE_RR(IEEE_UNORDERED)
 576 #undef IEEE_UNORDERED_RR
 577
 578 #define IEEE_VALUE_R(XKIND) \
 579   elemental real(XKIND) function ieee_value_a##XKIND(x, class); \
 580     import ieee_class_type; \
 581     real(XKIND), intent(in) :: x; \
 582     type(ieee_class_type), intent(in) :: class; \
 583   end function ieee_value_a##XKIND;
 584   interface ieee_value
 585     SPECIFICS_R(IEEE_VALUE_R)
 586   end interface ieee_value
 587   PRIVATE_R(IEEE_VALUE)
 588 #undef IEEE_VALUE_R
 589
 590 end module ieee_arithmetic