llvm-project

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
include '../include/flang/Runtime/magic-numbers.h'
12

13
module ieee_arithmetic
14
  ! F18 Clause 17.1p1:
15
  ! The module IEEE_ARITHMETIC behaves as if it contained a USE statement for
16
  ! IEEE_EXCEPTIONS; everything that is public in IEEE_EXCEPTIONS is public in
17
  ! IEEE_ARITHMETIC.
18
  use __fortran_ieee_exceptions
19

20
  use __fortran_builtins, only: &
21
    ieee_away => __builtin_ieee_away, &
22
    ieee_down => __builtin_ieee_down, &
23
    ieee_fma => __builtin_fma, &
24
    ieee_is_nan => __builtin_ieee_is_nan, &
25
    ieee_is_negative => __builtin_ieee_is_negative, &
26
    ieee_is_normal => __builtin_ieee_is_normal, &
27
    ieee_nearest => __builtin_ieee_nearest, &
28
    ieee_next_after => __builtin_ieee_next_after, &
29
    ieee_next_down => __builtin_ieee_next_down, &
30
    ieee_next_up => __builtin_ieee_next_up, &
31
    ieee_other => __builtin_ieee_other, &
32
    ieee_round_type => __builtin_ieee_round_type, &
33
    ieee_scalb => scale, &
34
    ieee_selected_real_kind => __builtin_ieee_selected_real_kind, &
35
    ieee_support_datatype => __builtin_ieee_support_datatype, &
36
    ieee_support_denormal => __builtin_ieee_support_denormal, &
37
    ieee_support_divide => __builtin_ieee_support_divide, &
38
    ieee_support_inf => __builtin_ieee_support_inf, &
39
    ieee_support_io => __builtin_ieee_support_io, &
40
    ieee_support_nan => __builtin_ieee_support_nan, &
41
    ieee_support_rounding => __builtin_ieee_support_rounding, &
42
    ieee_support_sqrt => __builtin_ieee_support_sqrt, &
43
    ieee_support_standard => __builtin_ieee_support_standard, &
44
    ieee_support_subnormal => __builtin_ieee_support_subnormal, &
45
    ieee_support_underflow_control => __builtin_ieee_support_underflow_control, &
46
    ieee_to_zero => __builtin_ieee_to_zero, &
47
    ieee_up => __builtin_ieee_up
48

49

50
  implicit none
51

52
  ! Set PRIVATE by default to explicitly only export what is meant
53
  ! to be exported by this MODULE.
54
  private
55

56
  ! Explicitly export the symbols from __fortran_builtins
57
  public :: ieee_away
58
  public :: ieee_down
59
  public :: ieee_fma
60
  public :: ieee_is_nan
61
  public :: ieee_is_negative
62
  public :: ieee_is_normal
63
  public :: ieee_nearest
64
  public :: ieee_other
65
  public :: ieee_next_after
66
  public :: ieee_next_down
67
  public :: ieee_next_up
68
  public :: ieee_round_type
69
  public :: ieee_scalb
70
  public :: ieee_selected_real_kind
71
  public :: ieee_support_datatype
72
  public :: ieee_support_denormal
73
  public :: ieee_support_divide
74
  public :: ieee_support_inf
75
  public :: ieee_support_io
76
  public :: ieee_support_nan
77
  public :: ieee_support_rounding
78
  public :: ieee_support_sqrt
79
  public :: ieee_support_standard
80
  public :: ieee_support_subnormal
81
  public :: ieee_support_underflow_control
82
  public :: ieee_to_zero
83
  public :: ieee_up
84

85
  ! Explicitly export the symbols from __fortran_ieee_exceptions
86
  public :: ieee_flag_type
87
  public :: ieee_invalid
88
  public :: ieee_overflow
89
  public :: ieee_divide_by_zero
90
  public :: ieee_underflow
91
  public :: ieee_inexact
92
  public :: ieee_denorm
93
  public :: ieee_usual
94
  public :: ieee_all
95
  public :: ieee_modes_type
96
  public :: ieee_status_type
97
  public :: ieee_get_flag
98
  public :: ieee_get_halting_mode
99
  public :: ieee_get_modes
100
  public :: ieee_get_status
101
  public :: ieee_set_flag
102
  public :: ieee_set_halting_mode
103
  public :: ieee_set_modes
104
  public :: ieee_set_status
105
  public :: ieee_support_flag
106
  public :: ieee_support_halting
107

108
  type, public :: ieee_class_type
109
    private
110
    integer(kind=1) :: which = 0
111
  end type ieee_class_type
112

113
  type(ieee_class_type), parameter, public :: &
114
    ieee_signaling_nan = ieee_class_type(_FORTRAN_RUNTIME_IEEE_SIGNALING_NAN), &
115
    ieee_quiet_nan = ieee_class_type(_FORTRAN_RUNTIME_IEEE_QUIET_NAN), &
116
    ieee_negative_inf = ieee_class_type(_FORTRAN_RUNTIME_IEEE_NEGATIVE_INF), &
117
    ieee_negative_normal = &
118
        ieee_class_type(_FORTRAN_RUNTIME_IEEE_NEGATIVE_NORMAL), &
119
    ieee_negative_subnormal = &
120
        ieee_class_type(_FORTRAN_RUNTIME_IEEE_NEGATIVE_SUBNORMAL), &
121
    ieee_negative_zero = ieee_class_type(_FORTRAN_RUNTIME_IEEE_NEGATIVE_ZERO), &
122
    ieee_positive_zero = ieee_class_type(_FORTRAN_RUNTIME_IEEE_POSITIVE_ZERO), &
123
    ieee_positive_subnormal = &
124
         ieee_class_type(_FORTRAN_RUNTIME_IEEE_POSITIVE_SUBNORMAL), &
125
    ieee_positive_normal = &
126
        ieee_class_type(_FORTRAN_RUNTIME_IEEE_POSITIVE_NORMAL), &
127
    ieee_positive_inf = ieee_class_type(_FORTRAN_RUNTIME_IEEE_POSITIVE_INF), &
128
    ieee_other_value = ieee_class_type(_FORTRAN_RUNTIME_IEEE_OTHER_VALUE)
129

130
  type(ieee_class_type), parameter, public :: &
131
    ieee_negative_denormal = ieee_negative_subnormal, &
132
    ieee_positive_denormal = ieee_positive_subnormal
133

134
  interface operator(==)
135
    elemental logical function ieee_class_eq(x, y)
136
      import ieee_class_type
137
      type(ieee_class_type), intent(in) :: x, y
138
    end function ieee_class_eq
139
    elemental logical function ieee_round_eq(x, y)
140
      import ieee_round_type
141
      type(ieee_round_type), intent(in) :: x, y
142
    end function ieee_round_eq
143
  end interface operator(==)
144
  public :: operator(==)
145

146
  interface operator(/=)
147
    elemental logical function ieee_class_ne(x, y)
148
      import ieee_class_type
149
      type(ieee_class_type), intent(in) :: x, y
150
    end function ieee_class_ne
151
    elemental logical function ieee_round_ne(x, y)
152
      import ieee_round_type
153
      type(ieee_round_type), intent(in) :: x, y
154
    end function ieee_round_ne
155
  end interface operator(/=)
156
  public :: operator(/=)
157

158
! Define specifics with 1 or 2 INTEGER, LOGICAL, or REAL arguments for
159
! generic G.
160
#define SPECIFICS_I(G) \
161
  G(1) G(2) G(4) G(8) G(16)
162
#define SPECIFICS_L(G) \
163
  G(1) G(2) G(4) G(8)
164
#if __x86_64__
165
#define SPECIFICS_R(G) \
166
  G(2) G(3) G(4) G(8) G(10) G(16)
167
#else
168
#define SPECIFICS_R(G) \
169
  G(2) G(3) G(4) G(8) G(16)
170
#endif
171
#define SPECIFICS_II(G) \
172
  G(1,1) G(1,2) G(1,4) G(1,8) G(1,16) \
173
  G(2,1) G(2,2) G(2,4) G(2,8) G(2,16) \
174
  G(4,1) G(4,2) G(4,4) G(4,8) G(4,16) \
175
  G(8,1) G(8,2) G(8,4) G(8,8) G(8,16) \
176
  G(16,1) G(16,2) G(16,4) G(16,8) G(16,16)
177
#if __x86_64__
178
#define SPECIFICS_RI(G) \
179
  G(2,1) G(2,2) G(2,4) G(2,8) G(2,16) \
180
  G(3,1) G(3,2) G(3,4) G(3,8) G(3,16) \
181
  G(4,1) G(4,2) G(4,4) G(4,8) G(4,16) \
182
  G(8,1) G(8,2) G(8,4) G(8,8) G(8,16) \
183
  G(10,1) G(10,2) G(10,4) G(10,8) G(10,16) \
184
  G(16,1) G(16,2) G(16,4) G(16,8) G(16,16)
185
#else
186
#define SPECIFICS_RI(G) \
187
  G(2,1) G(2,2) G(2,4) G(2,8) G(2,16) \
188
  G(3,1) G(3,2) G(3,4) G(3,8) G(3,16) \
189
  G(4,1) G(4,2) G(4,4) G(4,8) G(4,16) \
190
  G(8,1) G(8,2) G(8,4) G(8,8) G(8,16) \
191
  G(16,1) G(16,2) G(16,4) G(16,8) G(16,16)
192
#endif
193

194
#if __x86_64__
195
#define SPECIFICS_RR(G) \
196
  G(2,2) G(2,3) G(2,4) G(2,8) G(2,10) G(2,16) \
197
  G(3,2) G(3,3) G(3,4) G(3,8) G(3,10) G(3,16) \
198
  G(4,2) G(4,3) G(4,4) G(4,8) G(4,10) G(4,16) \
199
  G(8,2) G(8,3) G(8,4) G(8,8) G(8,10) G(8,16) \
200
  G(10,2) G(10,3) G(10,4) G(10,8) G(10,10) G(10,16) \
201
  G(16,2) G(16,3) G(16,4) G(16,8) G(16,10) G(16,16)
202
#else
203
#define SPECIFICS_RR(G) \
204
  G(2,2) G(2,3) G(2,4) G(2,8) G(2,16) \
205
  G(3,2) G(3,3) G(3,4) G(3,8) G(3,16) \
206
  G(4,2) G(4,3) G(4,4) G(4,8) G(4,16) \
207
  G(8,2) G(8,3) G(8,4) G(8,8) G(8,16) \
208
  G(16,2) G(16,3) G(16,4) G(16,8) G(16,16)
209
#endif
210

211
#define IEEE_CLASS_R(XKIND) \
212
  elemental type(ieee_class_type) function ieee_class_a##XKIND(x); \
213
    import ieee_class_type; \
214
    real(XKIND), intent(in) :: x; \
215
  end function ieee_class_a##XKIND;
216
  interface ieee_class
217
    SPECIFICS_R(IEEE_CLASS_R)
218
  end interface ieee_class
219
  public :: ieee_class
220
#undef IEEE_CLASS_R
221

222
#define IEEE_COPY_SIGN_RR(XKIND, YKIND) \
223
  elemental real(XKIND) function ieee_copy_sign_a##XKIND##_a##YKIND(x, y); \
224
    real(XKIND), intent(in) :: x; \
225
    real(YKIND), intent(in) :: y; \
226
  end function ieee_copy_sign_a##XKIND##_a##YKIND;
227
  interface ieee_copy_sign
228
    SPECIFICS_RR(IEEE_COPY_SIGN_RR)
229
  end interface ieee_copy_sign
230
  public :: ieee_copy_sign
231
#undef IEEE_COPY_SIGN_RR
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
  public :: 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
  public ::  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
  public :: ieee_int
279
#undef IEEE_INT_R
280
#undef IEEE_INT_RI
281

282
#define IEEE_IS_FINITE_R(XKIND) \
283
  elemental logical function ieee_is_finite_a##XKIND(x); \
284
    real(XKIND), intent(in) :: x; \
285
  end function ieee_is_finite_a##XKIND;
286
  interface ieee_is_finite
287
    SPECIFICS_R(IEEE_IS_FINITE_R)
288
  end interface ieee_is_finite
289
  public :: ieee_is_finite
290
#undef IEEE_IS_FINITE_R
291

292
#define IEEE_LOGB_R(XKIND) \
293
  elemental real(XKIND) function ieee_logb_a##XKIND(x); \
294
    real(XKIND), intent(in) :: x; \
295
  end function ieee_logb_a##XKIND;
296
  interface ieee_logb
297
    SPECIFICS_R(IEEE_LOGB_R)
298
  end interface ieee_logb
299
  public :: ieee_logb
300
#undef IEEE_LOGB_R
301

302
#define IEEE_MAX_R(XKIND) \
303
  elemental real(XKIND) function ieee_max_a##XKIND(x, y); \
304
    real(XKIND), intent(in) :: x, y; \
305
  end function ieee_max_a##XKIND;
306
  interface ieee_max
307
    SPECIFICS_R(IEEE_MAX_R)
308
  end interface ieee_max
309
  public :: ieee_max
310
#undef IEEE_MAX_R
311

312
#define IEEE_MAX_MAG_R(XKIND) \
313
  elemental real(XKIND) function ieee_max_mag_a##XKIND(x, y); \
314
    real(XKIND), intent(in) :: x, y; \
315
  end function ieee_max_mag_a##XKIND;
316
  interface ieee_max_mag
317
    SPECIFICS_R(IEEE_MAX_MAG_R)
318
  end interface ieee_max_mag
319
  public :: ieee_max_mag
320
#undef IEEE_MAX_MAG_R
321

322
#define IEEE_MAX_NUM_R(XKIND) \
323
  elemental real(XKIND) function ieee_max_num_a##XKIND(x, y); \
324
    real(XKIND), intent(in) :: x, y; \
325
  end function ieee_max_num_a##XKIND;
326
  interface ieee_max_num
327
    SPECIFICS_R(IEEE_MAX_NUM_R)
328
  end interface ieee_max_num
329
  public :: ieee_max_num
330
#undef IEEE_MAX_NUM_R
331

332
#define IEEE_MAX_NUM_MAG_R(XKIND) \
333
  elemental real(XKIND) function ieee_max_num_mag_a##XKIND(x, y); \
334
    real(XKIND), intent(in) :: x, y; \
335
  end function ieee_max_num_mag_a##XKIND;
336
  interface ieee_max_num_mag
337
    SPECIFICS_R(IEEE_MAX_NUM_MAG_R)
338
  end interface ieee_max_num_mag
339
  public :: ieee_max_num_mag
340
#undef IEEE_MAX_NUM_MAG_R
341

342
#define IEEE_MIN_R(XKIND) \
343
  elemental real(XKIND) function ieee_min_a##XKIND(x, y); \
344
    real(XKIND), intent(in) :: x, y; \
345
  end function ieee_min_a##XKIND;
346
  interface ieee_min
347
    SPECIFICS_R(IEEE_MIN_R)
348
  end interface ieee_min
349
  public :: ieee_min
350
#undef IEEE_MIN_R
351

352
#define IEEE_MIN_MAG_R(XKIND) \
353
  elemental real(XKIND) function ieee_min_mag_a##XKIND(x, y); \
354
    real(XKIND), intent(in) :: x, y; \
355
  end function ieee_min_mag_a##XKIND;
356
  interface ieee_min_mag
357
    SPECIFICS_R(IEEE_MIN_MAG_R)
358
  end interface ieee_min_mag
359
  public :: ieee_min_mag
360
#undef IEEE_MIN_MAG_R
361

362
#define IEEE_MIN_NUM_R(XKIND) \
363
  elemental real(XKIND) function ieee_min_num_a##XKIND(x, y); \
364
    real(XKIND), intent(in) :: x, y; \
365
  end function ieee_min_num_a##XKIND;
366
  interface ieee_min_num
367
    SPECIFICS_R(IEEE_MIN_NUM_R)
368
  end interface ieee_min_num
369
  public :: ieee_min_num
370
#undef IEEE_MIN_NUM_R
371

372
#define IEEE_MIN_NUM_MAG_R(XKIND) \
373
  elemental real(XKIND) function ieee_min_num_mag_a##XKIND(x, y); \
374
    real(XKIND), intent(in) :: x, y; \
375
  end function ieee_min_num_mag_a##XKIND;
376
  interface ieee_min_num_mag
377
    SPECIFICS_R(IEEE_MIN_NUM_MAG_R)
378
  end interface ieee_min_num_mag
379
  public ::ieee_min_num_mag
380
#undef IEEE_MIN_NUM_MAG_R
381

382
#define IEEE_QUIET_EQ_R(AKIND) \
383
  elemental logical function ieee_quiet_eq_a##AKIND(a, b); \
384
    real(AKIND), intent(in) :: a, b; \
385
  end function ieee_quiet_eq_a##AKIND;
386
  interface ieee_quiet_eq
387
    SPECIFICS_R(IEEE_QUIET_EQ_R)
388
  end interface ieee_quiet_eq
389
  public :: ieee_quiet_eq
390
#undef IEEE_QUIET_EQ_R
391

392
#define IEEE_QUIET_GE_R(AKIND) \
393
  elemental logical function ieee_quiet_ge_a##AKIND(a, b); \
394
    real(AKIND), intent(in) :: a, b; \
395
  end function ieee_quiet_ge_a##AKIND;
396
  interface ieee_quiet_ge
397
    SPECIFICS_R(IEEE_QUIET_GE_R)
398
  end interface ieee_quiet_ge
399
  public :: ieee_quiet_ge
400
#undef IEEE_QUIET_GE_R
401

402
#define IEEE_QUIET_GT_R(AKIND) \
403
  elemental logical function ieee_quiet_gt_a##AKIND(a, b); \
404
    real(AKIND), intent(in) :: a, b; \
405
  end function ieee_quiet_gt_a##AKIND;
406
  interface ieee_quiet_gt
407
    SPECIFICS_R(IEEE_QUIET_GT_R)
408
  end interface ieee_quiet_gt
409
  public :: ieee_quiet_gt
410
#undef IEEE_QUIET_GT_R
411

412
#define IEEE_QUIET_LE_R(AKIND) \
413
  elemental logical function ieee_quiet_le_a##AKIND(a, b); \
414
    real(AKIND), intent(in) :: a, b; \
415
  end function ieee_quiet_le_a##AKIND;
416
  interface ieee_quiet_le
417
    SPECIFICS_R(IEEE_QUIET_LE_R)
418
  end interface ieee_quiet_le
419
  public :: ieee_quiet_le
420
#undef IEEE_QUIET_LE_R
421

422
#define IEEE_QUIET_LT_R(AKIND) \
423
  elemental logical function ieee_quiet_lt_a##AKIND(a, b); \
424
    real(AKIND), intent(in) :: a, b; \
425
  end function ieee_quiet_lt_a##AKIND;
426
  interface ieee_quiet_lt
427
    SPECIFICS_R(IEEE_QUIET_LT_R)
428
  end interface ieee_quiet_lt
429
  public :: ieee_quiet_lt
430
#undef IEEE_QUIET_LT_R
431

432
#define IEEE_QUIET_NE_R(AKIND) \
433
  elemental logical function ieee_quiet_ne_a##AKIND(a, b); \
434
    real(AKIND), intent(in) :: a, b; \
435
  end function ieee_quiet_ne_a##AKIND;
436
  interface ieee_quiet_ne
437
    SPECIFICS_R(IEEE_QUIET_NE_R)
438
  end interface ieee_quiet_ne
439
  public :: ieee_quiet_ne
440
#undef IEEE_QUIET_NE_R
441

442
! When kind argument is present, kind(result) is value(kind), not kind(kind).
443
! That is not known here, so return real(16).
444
#define IEEE_REAL_I(AKIND) \
445
  elemental real function ieee_real_i##AKIND(a); \
446
    integer(AKIND), intent(in) :: a; \
447
  end function ieee_real_i##AKIND;
448
#define IEEE_REAL_R(AKIND) \
449
  elemental real function ieee_real_a##AKIND(a); \
450
    real(AKIND), intent(in) :: a; \
451
  end function ieee_real_a##AKIND;
452
#define IEEE_REAL_II(AKIND, KKIND) \
453
  elemental real(16) function ieee_real_i##AKIND##_i##KKIND(a, kind); \
454
    integer(AKIND), intent(in) :: a; \
455
    integer(KKIND), intent(in) :: kind; \
456
  end function ieee_real_i##AKIND##_i##KKIND;
457
#define IEEE_REAL_RI(AKIND, KKIND) \
458
  elemental real(16) function ieee_real_a##AKIND##_i##KKIND(a, kind); \
459
    real(AKIND), intent(in) :: a; \
460
    integer(KKIND), intent(in) :: kind; \
461
  end function ieee_real_a##AKIND##_i##KKIND;
462
  interface ieee_real
463
    SPECIFICS_I(IEEE_REAL_I)
464
    SPECIFICS_R(IEEE_REAL_R)
465
    SPECIFICS_II(IEEE_REAL_II)
466
    SPECIFICS_RI(IEEE_REAL_RI)
467
  end interface ieee_real
468
  public :: ieee_real
469
#undef IEEE_REAL_I
470
#undef IEEE_REAL_R
471
#undef IEEE_REAL_II
472
#undef IEEE_REAL_RI
473

474
#define IEEE_REM_RR(XKIND, YKIND) \
475
  elemental real(XKIND) function ieee_rem_a##XKIND##_a##YKIND(x, y); \
476
    real(XKIND), intent(in) :: x; \
477
    real(YKIND), intent(in) :: y; \
478
  end function ieee_rem_a##XKIND##_a##YKIND;
479
  interface ieee_rem
480
    SPECIFICS_RR(IEEE_REM_RR)
481
  end interface ieee_rem
482
  public :: ieee_rem
483
#undef IEEE_REM_RR
484

485
#define IEEE_RINT_R(XKIND) \
486
  elemental real(XKIND) function ieee_rint_a##XKIND(x, round); \
487
    import ieee_round_type; \
488
    real(XKIND), intent(in) :: x; \
489
    type(ieee_round_type), optional, intent(in) :: round; \
490
  end function ieee_rint_a##XKIND;
491
  interface ieee_rint
492
    SPECIFICS_R(IEEE_RINT_R)
493
  end interface ieee_rint
494
  public :: ieee_rint
495
#undef IEEE_RINT_R
496

497
#define IEEE_SET_ROUNDING_MODE_I(RKIND) \
498
  subroutine ieee_set_rounding_mode_i##RKIND(round_value, radix); \
499
    import ieee_round_type; \
500
    type(ieee_round_type), intent(in) :: round_value; \
501
    integer(RKIND), intent(in) :: radix; \
502
  end subroutine ieee_set_rounding_mode_i##RKIND;
503
  interface ieee_set_rounding_mode
504
    subroutine ieee_set_rounding_mode_0(round_value)
505
      import ieee_round_type
506
      type(ieee_round_type), intent(in) :: round_value
507
    end subroutine ieee_set_rounding_mode_0
508
    SPECIFICS_I(IEEE_SET_ROUNDING_MODE_I)
509
  end interface ieee_set_rounding_mode
510
  public :: ieee_set_rounding_mode
511
#undef IEEE_SET_ROUNDING_MODE_I
512

513
#define IEEE_SET_UNDERFLOW_MODE_L(GKIND) \
514
  subroutine ieee_set_underflow_mode_l##GKIND(gradual); \
515
    logical(GKIND), intent(in) :: gradual; \
516
  end subroutine ieee_set_underflow_mode_l##GKIND;
517
  interface ieee_set_underflow_mode
518
    SPECIFICS_L(IEEE_SET_UNDERFLOW_MODE_L)
519
  end interface ieee_set_underflow_mode
520
  public :: ieee_set_underflow_mode
521
#undef IEEE_SET_UNDERFLOW_MODE_L
522

523
#define IEEE_SIGNALING_EQ_R(AKIND) \
524
  elemental logical function ieee_signaling_eq_a##AKIND(a, b); \
525
    real(AKIND), intent(in) :: a, b; \
526
  end function ieee_signaling_eq_a##AKIND;
527
  interface ieee_signaling_eq
528
    SPECIFICS_R(IEEE_SIGNALING_EQ_R)
529
  end interface ieee_signaling_eq
530
  public :: ieee_signaling_eq
531
#undef IEEE_SIGNALING_EQ_R
532

533
#define IEEE_SIGNALING_GE_R(AKIND) \
534
  elemental logical function ieee_signaling_ge_a##AKIND(a, b); \
535
    real(AKIND), intent(in) :: a, b; \
536
  end function ieee_signaling_ge_a##AKIND;
537
  interface ieee_signaling_ge
538
    SPECIFICS_R(IEEE_SIGNALING_GE_R)
539
  end interface ieee_signaling_ge
540
  public :: ieee_signaling_ge
541
#undef IEEE_SIGNALING_GE_R
542

543
#define IEEE_SIGNALING_GT_R(AKIND) \
544
  elemental logical function ieee_signaling_gt_a##AKIND(a, b); \
545
    real(AKIND), intent(in) :: a, b; \
546
  end function ieee_signaling_gt_a##AKIND;
547
  interface ieee_signaling_gt
548
    SPECIFICS_R(IEEE_SIGNALING_GT_R)
549
  end interface ieee_signaling_gt
550
  public :: ieee_signaling_gt
551
#undef IEEE_SIGNALING_GT_R
552

553
#define IEEE_SIGNALING_LE_R(AKIND) \
554
  elemental logical function ieee_signaling_le_a##AKIND(a, b); \
555
    real(AKIND), intent(in) :: a, b; \
556
  end function ieee_signaling_le_a##AKIND;
557
  interface ieee_signaling_le
558
    SPECIFICS_R(IEEE_SIGNALING_LE_R)
559
  end interface ieee_signaling_le
560
  public :: ieee_signaling_le
561
#undef IEEE_SIGNALING_LE_R
562

563
#define IEEE_SIGNALING_LT_R(AKIND) \
564
  elemental logical function ieee_signaling_lt_a##AKIND(a, b); \
565
    real(AKIND), intent(in) :: a, b; \
566
  end function ieee_signaling_lt_a##AKIND;
567
  interface ieee_signaling_lt
568
    SPECIFICS_R(IEEE_SIGNALING_LT_R)
569
  end interface ieee_signaling_lt
570
  public :: ieee_signaling_lt
571
#undef IEEE_SIGNALING_LT_R
572

573
#define IEEE_SIGNALING_NE_R(AKIND) \
574
  elemental logical function ieee_signaling_ne_a##AKIND(a, b); \
575
    real(AKIND), intent(in) :: a, b; \
576
  end function ieee_signaling_ne_a##AKIND;
577
  interface ieee_signaling_ne
578
    SPECIFICS_R(IEEE_SIGNALING_NE_R)
579
  end interface ieee_signaling_ne
580
  public :: ieee_signaling_ne
581
#undef IEEE_SIGNALING_NE_R
582

583
#define IEEE_SIGNBIT_R(XKIND) \
584
  elemental logical function ieee_signbit_a##XKIND(x); \
585
    real(XKIND), intent(in) :: x; \
586
  end function ieee_signbit_a##XKIND;
587
  interface ieee_signbit
588
    SPECIFICS_R(IEEE_SIGNBIT_R)
589
  end interface ieee_signbit
590
  public :: ieee_signbit
591
#undef IEEE_SIGNBIT_R
592

593
#define IEEE_UNORDERED_RR(XKIND, YKIND) \
594
  elemental logical function ieee_unordered_a##XKIND##_a##YKIND(x, y); \
595
    real(XKIND), intent(in) :: x; \
596
    real(YKIND), intent(in) :: y; \
597
  end function ieee_unordered_a##XKIND##_a##YKIND;
598
  interface ieee_unordered
599
    SPECIFICS_RR(IEEE_UNORDERED_RR)
600
  end interface ieee_unordered
601
  public :: ieee_unordered
602
#undef IEEE_UNORDERED_RR
603

604
#define IEEE_VALUE_R(XKIND) \
605
  elemental real(XKIND) function ieee_value_a##XKIND(x, class); \
606
    import ieee_class_type; \
607
    real(XKIND), intent(in) :: x; \
608
    type(ieee_class_type), intent(in) :: class; \
609
  end function ieee_value_a##XKIND;
610
  interface ieee_value
611
    SPECIFICS_R(IEEE_VALUE_R)
612
  end interface ieee_value
613
  public :: ieee_value
614
#undef IEEE_VALUE_R
615

616
end module ieee_arithmetic
617