|
173
|
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
|
|
236
|
9 ! Fortran 2018 Clause 17
|
|
|
10
|
|
173
|
11 module ieee_arithmetic
|
|
236
|
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
|
|
173
|
16
|
|
221
|
17 use __Fortran_builtins, only: &
|
|
|
18 ieee_is_nan => __builtin_ieee_is_nan, &
|
|
236
|
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, &
|
|
221
|
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
|
|
173
|
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(==)
|
|
236
|
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
|
|
173
|
83 end interface operator(==)
|
|
|
84 interface operator(/=)
|
|
236
|
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
|
|
173
|
93 end interface operator(/=)
|
|
236
|
94 private :: ieee_class_eq, ieee_round_eq, ieee_class_ne, ieee_round_ne
|
|
173
|
95
|
|
236
|
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
|
|
173
|
131
|
|
236
|
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
|
|
221
|
148
|
|
236
|
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
|
|
173
|
200
|
|
236
|
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
|
|
173
|
222
|
|
236
|
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
|
|
173
|
232
|
|
236
|
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
|
|
173
|
258
|
|
236
|
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
|
|
173
|
332
|
|
236
|
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
|
|
173
|
392
|
|
236
|
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
|
|
173
|
402
|
|
236
|
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
|
|
221
|
460
|
|
236
|
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
|
|
221
|
526
|
|
236
|
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
|
|
221
|
595
|
|
173
|
596 end module ieee_arithmetic
|
