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