|
111
|
1 ! Implementation of the IEEE_ARITHMETIC standard intrinsic module
|
|
145
|
2 ! Copyright (C) 2013-2020 Free Software Foundation, Inc.
|
|
111
|
3 ! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
|
|
4 !
|
|
|
5 ! This file is part of the GNU Fortran runtime library (libgfortran).
|
|
|
6 !
|
|
|
7 ! Libgfortran is free software; you can redistribute it and/or
|
|
|
8 ! modify it under the terms of the GNU General Public
|
|
|
9 ! License as published by the Free Software Foundation; either
|
|
|
10 ! version 3 of the License, or (at your option) any later version.
|
|
|
11 !
|
|
|
12 ! Libgfortran is distributed in the hope that it will be useful,
|
|
|
13 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
14 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
15 ! GNU General Public License for more details.
|
|
|
16 !
|
|
|
17 ! Under Section 7 of GPL version 3, you are granted additional
|
|
|
18 ! permissions described in the GCC Runtime Library Exception, version
|
|
|
19 ! 3.1, as published by the Free Software Foundation.
|
|
|
20 !
|
|
|
21 ! You should have received a copy of the GNU General Public License and
|
|
|
22 ! a copy of the GCC Runtime Library Exception along with this program;
|
|
|
23 ! see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|
|
24 ! <http://www.gnu.org/licenses/>. */
|
|
|
25
|
|
|
26 #include "config.h"
|
|
|
27 #include "kinds.inc"
|
|
|
28 #include "c99_protos.inc"
|
|
|
29 #include "fpu-target.inc"
|
|
|
30
|
|
|
31 module IEEE_ARITHMETIC
|
|
|
32
|
|
|
33 use IEEE_EXCEPTIONS
|
|
|
34 implicit none
|
|
|
35 private
|
|
|
36
|
|
|
37 ! Every public symbol from IEEE_EXCEPTIONS must be made public here
|
|
|
38 public :: IEEE_FLAG_TYPE, IEEE_INVALID, IEEE_OVERFLOW, &
|
|
|
39 IEEE_DIVIDE_BY_ZERO, IEEE_UNDERFLOW, IEEE_INEXACT, IEEE_USUAL, &
|
|
|
40 IEEE_ALL, IEEE_STATUS_TYPE, IEEE_GET_FLAG, IEEE_GET_HALTING_MODE, &
|
|
|
41 IEEE_GET_STATUS, IEEE_SET_FLAG, IEEE_SET_HALTING_MODE, &
|
|
|
42 IEEE_SET_STATUS, IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING
|
|
|
43
|
|
|
44 ! Derived types and named constants
|
|
|
45
|
|
|
46 type, public :: IEEE_CLASS_TYPE
|
|
|
47 private
|
|
|
48 integer :: hidden
|
|
|
49 end type
|
|
|
50
|
|
|
51 type(IEEE_CLASS_TYPE), parameter, public :: &
|
|
|
52 IEEE_OTHER_VALUE = IEEE_CLASS_TYPE(0), &
|
|
|
53 IEEE_SIGNALING_NAN = IEEE_CLASS_TYPE(1), &
|
|
|
54 IEEE_QUIET_NAN = IEEE_CLASS_TYPE(2), &
|
|
|
55 IEEE_NEGATIVE_INF = IEEE_CLASS_TYPE(3), &
|
|
|
56 IEEE_NEGATIVE_NORMAL = IEEE_CLASS_TYPE(4), &
|
|
|
57 IEEE_NEGATIVE_DENORMAL = IEEE_CLASS_TYPE(5), &
|
|
145
|
58 IEEE_NEGATIVE_SUBNORMAL= IEEE_CLASS_TYPE(5), &
|
|
111
|
59 IEEE_NEGATIVE_ZERO = IEEE_CLASS_TYPE(6), &
|
|
|
60 IEEE_POSITIVE_ZERO = IEEE_CLASS_TYPE(7), &
|
|
|
61 IEEE_POSITIVE_DENORMAL = IEEE_CLASS_TYPE(8), &
|
|
145
|
62 IEEE_POSITIVE_SUBNORMAL= IEEE_CLASS_TYPE(8), &
|
|
111
|
63 IEEE_POSITIVE_NORMAL = IEEE_CLASS_TYPE(9), &
|
|
|
64 IEEE_POSITIVE_INF = IEEE_CLASS_TYPE(10)
|
|
|
65
|
|
|
66 type, public :: IEEE_ROUND_TYPE
|
|
|
67 private
|
|
|
68 integer :: hidden
|
|
|
69 end type
|
|
|
70
|
|
|
71 type(IEEE_ROUND_TYPE), parameter, public :: &
|
|
|
72 IEEE_NEAREST = IEEE_ROUND_TYPE(GFC_FPE_TONEAREST), &
|
|
|
73 IEEE_TO_ZERO = IEEE_ROUND_TYPE(GFC_FPE_TOWARDZERO), &
|
|
|
74 IEEE_UP = IEEE_ROUND_TYPE(GFC_FPE_UPWARD), &
|
|
|
75 IEEE_DOWN = IEEE_ROUND_TYPE(GFC_FPE_DOWNWARD), &
|
|
|
76 IEEE_OTHER = IEEE_ROUND_TYPE(0)
|
|
|
77
|
|
|
78
|
|
|
79 ! Equality operators on the derived types
|
|
|
80 interface operator (==)
|
|
|
81 module procedure IEEE_CLASS_TYPE_EQ, IEEE_ROUND_TYPE_EQ
|
|
|
82 end interface
|
|
|
83 public :: operator(==)
|
|
|
84
|
|
|
85 interface operator (/=)
|
|
|
86 module procedure IEEE_CLASS_TYPE_NE, IEEE_ROUND_TYPE_NE
|
|
|
87 end interface
|
|
|
88 public :: operator (/=)
|
|
|
89
|
|
|
90
|
|
|
91 ! IEEE_IS_FINITE
|
|
|
92
|
|
|
93 interface
|
|
|
94 elemental logical function _gfortran_ieee_is_finite_4(X)
|
|
|
95 real(kind=4), intent(in) :: X
|
|
|
96 end function
|
|
|
97 elemental logical function _gfortran_ieee_is_finite_8(X)
|
|
|
98 real(kind=8), intent(in) :: X
|
|
|
99 end function
|
|
|
100 #ifdef HAVE_GFC_REAL_10
|
|
|
101 elemental logical function _gfortran_ieee_is_finite_10(X)
|
|
|
102 real(kind=10), intent(in) :: X
|
|
|
103 end function
|
|
|
104 #endif
|
|
|
105 #ifdef HAVE_GFC_REAL_16
|
|
|
106 elemental logical function _gfortran_ieee_is_finite_16(X)
|
|
|
107 real(kind=16), intent(in) :: X
|
|
|
108 end function
|
|
|
109 #endif
|
|
|
110 end interface
|
|
|
111
|
|
|
112 interface IEEE_IS_FINITE
|
|
|
113 procedure &
|
|
|
114 #ifdef HAVE_GFC_REAL_16
|
|
|
115 _gfortran_ieee_is_finite_16, &
|
|
|
116 #endif
|
|
|
117 #ifdef HAVE_GFC_REAL_10
|
|
|
118 _gfortran_ieee_is_finite_10, &
|
|
|
119 #endif
|
|
|
120 _gfortran_ieee_is_finite_8, _gfortran_ieee_is_finite_4
|
|
|
121 end interface
|
|
|
122 public :: IEEE_IS_FINITE
|
|
|
123
|
|
|
124 ! IEEE_IS_NAN
|
|
|
125
|
|
|
126 interface
|
|
|
127 elemental logical function _gfortran_ieee_is_nan_4(X)
|
|
|
128 real(kind=4), intent(in) :: X
|
|
|
129 end function
|
|
|
130 elemental logical function _gfortran_ieee_is_nan_8(X)
|
|
|
131 real(kind=8), intent(in) :: X
|
|
|
132 end function
|
|
|
133 #ifdef HAVE_GFC_REAL_10
|
|
|
134 elemental logical function _gfortran_ieee_is_nan_10(X)
|
|
|
135 real(kind=10), intent(in) :: X
|
|
|
136 end function
|
|
|
137 #endif
|
|
|
138 #ifdef HAVE_GFC_REAL_16
|
|
|
139 elemental logical function _gfortran_ieee_is_nan_16(X)
|
|
|
140 real(kind=16), intent(in) :: X
|
|
|
141 end function
|
|
|
142 #endif
|
|
|
143 end interface
|
|
|
144
|
|
|
145 interface IEEE_IS_NAN
|
|
|
146 procedure &
|
|
|
147 #ifdef HAVE_GFC_REAL_16
|
|
|
148 _gfortran_ieee_is_nan_16, &
|
|
|
149 #endif
|
|
|
150 #ifdef HAVE_GFC_REAL_10
|
|
|
151 _gfortran_ieee_is_nan_10, &
|
|
|
152 #endif
|
|
|
153 _gfortran_ieee_is_nan_8, _gfortran_ieee_is_nan_4
|
|
|
154 end interface
|
|
|
155 public :: IEEE_IS_NAN
|
|
|
156
|
|
|
157 ! IEEE_IS_NEGATIVE
|
|
|
158
|
|
|
159 interface
|
|
|
160 elemental logical function _gfortran_ieee_is_negative_4(X)
|
|
|
161 real(kind=4), intent(in) :: X
|
|
|
162 end function
|
|
|
163 elemental logical function _gfortran_ieee_is_negative_8(X)
|
|
|
164 real(kind=8), intent(in) :: X
|
|
|
165 end function
|
|
|
166 #ifdef HAVE_GFC_REAL_10
|
|
|
167 elemental logical function _gfortran_ieee_is_negative_10(X)
|
|
|
168 real(kind=10), intent(in) :: X
|
|
|
169 end function
|
|
|
170 #endif
|
|
|
171 #ifdef HAVE_GFC_REAL_16
|
|
|
172 elemental logical function _gfortran_ieee_is_negative_16(X)
|
|
|
173 real(kind=16), intent(in) :: X
|
|
|
174 end function
|
|
|
175 #endif
|
|
|
176 end interface
|
|
|
177
|
|
|
178 interface IEEE_IS_NEGATIVE
|
|
|
179 procedure &
|
|
|
180 #ifdef HAVE_GFC_REAL_16
|
|
|
181 _gfortran_ieee_is_negative_16, &
|
|
|
182 #endif
|
|
|
183 #ifdef HAVE_GFC_REAL_10
|
|
|
184 _gfortran_ieee_is_negative_10, &
|
|
|
185 #endif
|
|
|
186 _gfortran_ieee_is_negative_8, _gfortran_ieee_is_negative_4
|
|
|
187 end interface
|
|
|
188 public :: IEEE_IS_NEGATIVE
|
|
|
189
|
|
|
190 ! IEEE_IS_NORMAL
|
|
|
191
|
|
|
192 interface
|
|
|
193 elemental logical function _gfortran_ieee_is_normal_4(X)
|
|
|
194 real(kind=4), intent(in) :: X
|
|
|
195 end function
|
|
|
196 elemental logical function _gfortran_ieee_is_normal_8(X)
|
|
|
197 real(kind=8), intent(in) :: X
|
|
|
198 end function
|
|
|
199 #ifdef HAVE_GFC_REAL_10
|
|
|
200 elemental logical function _gfortran_ieee_is_normal_10(X)
|
|
|
201 real(kind=10), intent(in) :: X
|
|
|
202 end function
|
|
|
203 #endif
|
|
|
204 #ifdef HAVE_GFC_REAL_16
|
|
|
205 elemental logical function _gfortran_ieee_is_normal_16(X)
|
|
|
206 real(kind=16), intent(in) :: X
|
|
|
207 end function
|
|
|
208 #endif
|
|
|
209 end interface
|
|
|
210
|
|
|
211 interface IEEE_IS_NORMAL
|
|
|
212 procedure &
|
|
|
213 #ifdef HAVE_GFC_REAL_16
|
|
|
214 _gfortran_ieee_is_normal_16, &
|
|
|
215 #endif
|
|
|
216 #ifdef HAVE_GFC_REAL_10
|
|
|
217 _gfortran_ieee_is_normal_10, &
|
|
|
218 #endif
|
|
|
219 _gfortran_ieee_is_normal_8, _gfortran_ieee_is_normal_4
|
|
|
220 end interface
|
|
|
221 public :: IEEE_IS_NORMAL
|
|
|
222
|
|
|
223 ! IEEE_COPY_SIGN
|
|
|
224
|
|
|
225 #define COPYSIGN_MACRO(A,B) \
|
|
|
226 elemental real(kind = A) function \
|
|
|
227 _gfortran_ieee_copy_sign_/**/A/**/_/**/B (X,Y) ; \
|
|
|
228 real(kind = A), intent(in) :: X ; \
|
|
|
229 real(kind = B), intent(in) :: Y ; \
|
|
|
230 end function
|
|
|
231
|
|
|
232 interface
|
|
145
|
233 #ifdef HAVE_GFC_REAL_16
|
|
|
234 COPYSIGN_MACRO(16,16)
|
|
111
|
235 #ifdef HAVE_GFC_REAL_10
|
|
145
|
236 COPYSIGN_MACRO(16,10)
|
|
|
237 COPYSIGN_MACRO(10,16)
|
|
111
|
238 #endif
|
|
145
|
239 COPYSIGN_MACRO(16,8)
|
|
|
240 COPYSIGN_MACRO(16,4)
|
|
|
241 COPYSIGN_MACRO(8,16)
|
|
111
|
242 COPYSIGN_MACRO(4,16)
|
|
|
243 #endif
|
|
|
244 #ifdef HAVE_GFC_REAL_10
|
|
|
245 COPYSIGN_MACRO(10,10)
|
|
145
|
246 COPYSIGN_MACRO(10,8)
|
|
|
247 COPYSIGN_MACRO(10,4)
|
|
|
248 COPYSIGN_MACRO(8,10)
|
|
|
249 COPYSIGN_MACRO(4,10)
|
|
111
|
250 #endif
|
|
145
|
251 COPYSIGN_MACRO(8,8)
|
|
|
252 COPYSIGN_MACRO(8,4)
|
|
|
253 COPYSIGN_MACRO(4,8)
|
|
|
254 COPYSIGN_MACRO(4,4)
|
|
111
|
255 end interface
|
|
|
256
|
|
|
257 interface IEEE_COPY_SIGN
|
|
|
258 procedure &
|
|
|
259 #ifdef HAVE_GFC_REAL_16
|
|
|
260 _gfortran_ieee_copy_sign_16_16, &
|
|
|
261 #ifdef HAVE_GFC_REAL_10
|
|
|
262 _gfortran_ieee_copy_sign_16_10, &
|
|
145
|
263 _gfortran_ieee_copy_sign_10_16, &
|
|
111
|
264 #endif
|
|
|
265 _gfortran_ieee_copy_sign_16_8, &
|
|
|
266 _gfortran_ieee_copy_sign_16_4, &
|
|
145
|
267 _gfortran_ieee_copy_sign_8_16, &
|
|
|
268 _gfortran_ieee_copy_sign_4_16, &
|
|
111
|
269 #endif
|
|
|
270 #ifdef HAVE_GFC_REAL_10
|
|
|
271 _gfortran_ieee_copy_sign_10_10, &
|
|
|
272 _gfortran_ieee_copy_sign_10_8, &
|
|
|
273 _gfortran_ieee_copy_sign_10_4, &
|
|
|
274 _gfortran_ieee_copy_sign_8_10, &
|
|
145
|
275 _gfortran_ieee_copy_sign_4_10, &
|
|
111
|
276 #endif
|
|
|
277 _gfortran_ieee_copy_sign_8_8, &
|
|
|
278 _gfortran_ieee_copy_sign_8_4, &
|
|
|
279 _gfortran_ieee_copy_sign_4_8, &
|
|
|
280 _gfortran_ieee_copy_sign_4_4
|
|
|
281 end interface
|
|
|
282 public :: IEEE_COPY_SIGN
|
|
|
283
|
|
|
284 ! IEEE_UNORDERED
|
|
|
285
|
|
|
286 #define UNORDERED_MACRO(A,B) \
|
|
|
287 elemental logical function \
|
|
|
288 _gfortran_ieee_unordered_/**/A/**/_/**/B (X,Y) ; \
|
|
|
289 real(kind = A), intent(in) :: X ; \
|
|
|
290 real(kind = B), intent(in) :: Y ; \
|
|
|
291 end function
|
|
|
292
|
|
|
293 interface
|
|
145
|
294 #ifdef HAVE_GFC_REAL_16
|
|
|
295 UNORDERED_MACRO(16,16)
|
|
111
|
296 #ifdef HAVE_GFC_REAL_10
|
|
145
|
297 UNORDERED_MACRO(16,10)
|
|
|
298 UNORDERED_MACRO(10,16)
|
|
111
|
299 #endif
|
|
145
|
300 UNORDERED_MACRO(16,8)
|
|
|
301 UNORDERED_MACRO(16,4)
|
|
|
302 UNORDERED_MACRO(8,16)
|
|
111
|
303 UNORDERED_MACRO(4,16)
|
|
|
304 #endif
|
|
|
305 #ifdef HAVE_GFC_REAL_10
|
|
|
306 UNORDERED_MACRO(10,10)
|
|
145
|
307 UNORDERED_MACRO(10,8)
|
|
|
308 UNORDERED_MACRO(10,4)
|
|
|
309 UNORDERED_MACRO(8,10)
|
|
|
310 UNORDERED_MACRO(4,10)
|
|
111
|
311 #endif
|
|
145
|
312 UNORDERED_MACRO(8,8)
|
|
|
313 UNORDERED_MACRO(8,4)
|
|
|
314 UNORDERED_MACRO(4,8)
|
|
|
315 UNORDERED_MACRO(4,4)
|
|
111
|
316 end interface
|
|
|
317
|
|
|
318 interface IEEE_UNORDERED
|
|
|
319 procedure &
|
|
|
320 #ifdef HAVE_GFC_REAL_16
|
|
|
321 _gfortran_ieee_unordered_16_16, &
|
|
|
322 #ifdef HAVE_GFC_REAL_10
|
|
|
323 _gfortran_ieee_unordered_16_10, &
|
|
145
|
324 _gfortran_ieee_unordered_10_16, &
|
|
111
|
325 #endif
|
|
|
326 _gfortran_ieee_unordered_16_8, &
|
|
|
327 _gfortran_ieee_unordered_16_4, &
|
|
145
|
328 _gfortran_ieee_unordered_8_16, &
|
|
|
329 _gfortran_ieee_unordered_4_16, &
|
|
111
|
330 #endif
|
|
|
331 #ifdef HAVE_GFC_REAL_10
|
|
|
332 _gfortran_ieee_unordered_10_10, &
|
|
|
333 _gfortran_ieee_unordered_10_8, &
|
|
|
334 _gfortran_ieee_unordered_10_4, &
|
|
|
335 _gfortran_ieee_unordered_8_10, &
|
|
145
|
336 _gfortran_ieee_unordered_4_10, &
|
|
111
|
337 #endif
|
|
|
338 _gfortran_ieee_unordered_8_8, &
|
|
|
339 _gfortran_ieee_unordered_8_4, &
|
|
|
340 _gfortran_ieee_unordered_4_8, &
|
|
|
341 _gfortran_ieee_unordered_4_4
|
|
|
342 end interface
|
|
|
343 public :: IEEE_UNORDERED
|
|
|
344
|
|
|
345 ! IEEE_LOGB
|
|
|
346
|
|
|
347 interface
|
|
|
348 elemental real(kind=4) function _gfortran_ieee_logb_4 (X)
|
|
|
349 real(kind=4), intent(in) :: X
|
|
|
350 end function
|
|
|
351 elemental real(kind=8) function _gfortran_ieee_logb_8 (X)
|
|
|
352 real(kind=8), intent(in) :: X
|
|
|
353 end function
|
|
|
354 #ifdef HAVE_GFC_REAL_10
|
|
|
355 elemental real(kind=10) function _gfortran_ieee_logb_10 (X)
|
|
|
356 real(kind=10), intent(in) :: X
|
|
|
357 end function
|
|
|
358 #endif
|
|
|
359 #ifdef HAVE_GFC_REAL_16
|
|
|
360 elemental real(kind=16) function _gfortran_ieee_logb_16 (X)
|
|
|
361 real(kind=16), intent(in) :: X
|
|
|
362 end function
|
|
|
363 #endif
|
|
|
364 end interface
|
|
|
365
|
|
|
366 interface IEEE_LOGB
|
|
|
367 procedure &
|
|
|
368 #ifdef HAVE_GFC_REAL_16
|
|
|
369 _gfortran_ieee_logb_16, &
|
|
|
370 #endif
|
|
|
371 #ifdef HAVE_GFC_REAL_10
|
|
|
372 _gfortran_ieee_logb_10, &
|
|
|
373 #endif
|
|
|
374 _gfortran_ieee_logb_8, &
|
|
|
375 _gfortran_ieee_logb_4
|
|
|
376 end interface
|
|
|
377 public :: IEEE_LOGB
|
|
|
378
|
|
|
379 ! IEEE_NEXT_AFTER
|
|
|
380
|
|
|
381 #define NEXT_AFTER_MACRO(A,B) \
|
|
|
382 elemental real(kind = A) function \
|
|
|
383 _gfortran_ieee_next_after_/**/A/**/_/**/B (X,Y) ; \
|
|
|
384 real(kind = A), intent(in) :: X ; \
|
|
|
385 real(kind = B), intent(in) :: Y ; \
|
|
|
386 end function
|
|
|
387
|
|
|
388 interface
|
|
145
|
389 #ifdef HAVE_GFC_REAL_16
|
|
|
390 NEXT_AFTER_MACRO(16,16)
|
|
111
|
391 #ifdef HAVE_GFC_REAL_10
|
|
145
|
392 NEXT_AFTER_MACRO(16,10)
|
|
|
393 NEXT_AFTER_MACRO(10,16)
|
|
111
|
394 #endif
|
|
145
|
395 NEXT_AFTER_MACRO(16,8)
|
|
|
396 NEXT_AFTER_MACRO(16,4)
|
|
|
397 NEXT_AFTER_MACRO(8,16)
|
|
111
|
398 NEXT_AFTER_MACRO(4,16)
|
|
|
399 #endif
|
|
|
400 #ifdef HAVE_GFC_REAL_10
|
|
|
401 NEXT_AFTER_MACRO(10,10)
|
|
145
|
402 NEXT_AFTER_MACRO(10,8)
|
|
|
403 NEXT_AFTER_MACRO(10,4)
|
|
|
404 NEXT_AFTER_MACRO(8,10)
|
|
|
405 NEXT_AFTER_MACRO(4,10)
|
|
111
|
406 #endif
|
|
145
|
407 NEXT_AFTER_MACRO(8,8)
|
|
|
408 NEXT_AFTER_MACRO(8,4)
|
|
|
409 NEXT_AFTER_MACRO(4,8)
|
|
|
410 NEXT_AFTER_MACRO(4,4)
|
|
111
|
411 end interface
|
|
|
412
|
|
|
413 interface IEEE_NEXT_AFTER
|
|
|
414 procedure &
|
|
|
415 #ifdef HAVE_GFC_REAL_16
|
|
|
416 _gfortran_ieee_next_after_16_16, &
|
|
|
417 #ifdef HAVE_GFC_REAL_10
|
|
|
418 _gfortran_ieee_next_after_16_10, &
|
|
145
|
419 _gfortran_ieee_next_after_10_16, &
|
|
111
|
420 #endif
|
|
|
421 _gfortran_ieee_next_after_16_8, &
|
|
|
422 _gfortran_ieee_next_after_16_4, &
|
|
145
|
423 _gfortran_ieee_next_after_8_16, &
|
|
|
424 _gfortran_ieee_next_after_4_16, &
|
|
111
|
425 #endif
|
|
|
426 #ifdef HAVE_GFC_REAL_10
|
|
|
427 _gfortran_ieee_next_after_10_10, &
|
|
|
428 _gfortran_ieee_next_after_10_8, &
|
|
|
429 _gfortran_ieee_next_after_10_4, &
|
|
|
430 _gfortran_ieee_next_after_8_10, &
|
|
145
|
431 _gfortran_ieee_next_after_4_10, &
|
|
111
|
432 #endif
|
|
|
433 _gfortran_ieee_next_after_8_8, &
|
|
|
434 _gfortran_ieee_next_after_8_4, &
|
|
|
435 _gfortran_ieee_next_after_4_8, &
|
|
|
436 _gfortran_ieee_next_after_4_4
|
|
|
437 end interface
|
|
|
438 public :: IEEE_NEXT_AFTER
|
|
|
439
|
|
|
440 ! IEEE_REM
|
|
|
441
|
|
|
442 #define REM_MACRO(RES,A,B) \
|
|
|
443 elemental real(kind = RES) function \
|
|
|
444 _gfortran_ieee_rem_/**/A/**/_/**/B (X,Y) ; \
|
|
|
445 real(kind = A), intent(in) :: X ; \
|
|
|
446 real(kind = B), intent(in) :: Y ; \
|
|
|
447 end function
|
|
|
448
|
|
|
449 interface
|
|
145
|
450 #ifdef HAVE_GFC_REAL_16
|
|
|
451 REM_MACRO(16,16,16)
|
|
111
|
452 #ifdef HAVE_GFC_REAL_10
|
|
145
|
453 REM_MACRO(16,16,10)
|
|
|
454 REM_MACRO(16,10,16)
|
|
111
|
455 #endif
|
|
145
|
456 REM_MACRO(16,16,8)
|
|
|
457 REM_MACRO(16,16,4)
|
|
|
458 REM_MACRO(16,8,16)
|
|
111
|
459 REM_MACRO(16,4,16)
|
|
|
460 #endif
|
|
|
461 #ifdef HAVE_GFC_REAL_10
|
|
|
462 REM_MACRO(10,10,10)
|
|
145
|
463 REM_MACRO(10,10,8)
|
|
|
464 REM_MACRO(10,10,4)
|
|
|
465 REM_MACRO(10,8,10)
|
|
|
466 REM_MACRO(10,4,10)
|
|
111
|
467 #endif
|
|
145
|
468 REM_MACRO(8,8,8)
|
|
|
469 REM_MACRO(8,8,4)
|
|
|
470 REM_MACRO(8,4,8)
|
|
|
471 REM_MACRO(4,4,4)
|
|
111
|
472 end interface
|
|
|
473
|
|
|
474 interface IEEE_REM
|
|
|
475 procedure &
|
|
|
476 #ifdef HAVE_GFC_REAL_16
|
|
|
477 _gfortran_ieee_rem_16_16, &
|
|
|
478 #ifdef HAVE_GFC_REAL_10
|
|
|
479 _gfortran_ieee_rem_16_10, &
|
|
145
|
480 _gfortran_ieee_rem_10_16, &
|
|
111
|
481 #endif
|
|
|
482 _gfortran_ieee_rem_16_8, &
|
|
|
483 _gfortran_ieee_rem_16_4, &
|
|
145
|
484 _gfortran_ieee_rem_8_16, &
|
|
|
485 _gfortran_ieee_rem_4_16, &
|
|
111
|
486 #endif
|
|
|
487 #ifdef HAVE_GFC_REAL_10
|
|
|
488 _gfortran_ieee_rem_10_10, &
|
|
|
489 _gfortran_ieee_rem_10_8, &
|
|
|
490 _gfortran_ieee_rem_10_4, &
|
|
|
491 _gfortran_ieee_rem_8_10, &
|
|
145
|
492 _gfortran_ieee_rem_4_10, &
|
|
111
|
493 #endif
|
|
|
494 _gfortran_ieee_rem_8_8, &
|
|
|
495 _gfortran_ieee_rem_8_4, &
|
|
|
496 _gfortran_ieee_rem_4_8, &
|
|
|
497 _gfortran_ieee_rem_4_4
|
|
|
498 end interface
|
|
|
499 public :: IEEE_REM
|
|
|
500
|
|
|
501 ! IEEE_RINT
|
|
|
502
|
|
|
503 interface
|
|
|
504 elemental real(kind=4) function _gfortran_ieee_rint_4 (X)
|
|
|
505 real(kind=4), intent(in) :: X
|
|
|
506 end function
|
|
|
507 elemental real(kind=8) function _gfortran_ieee_rint_8 (X)
|
|
|
508 real(kind=8), intent(in) :: X
|
|
|
509 end function
|
|
|
510 #ifdef HAVE_GFC_REAL_10
|
|
|
511 elemental real(kind=10) function _gfortran_ieee_rint_10 (X)
|
|
|
512 real(kind=10), intent(in) :: X
|
|
|
513 end function
|
|
|
514 #endif
|
|
|
515 #ifdef HAVE_GFC_REAL_16
|
|
|
516 elemental real(kind=16) function _gfortran_ieee_rint_16 (X)
|
|
|
517 real(kind=16), intent(in) :: X
|
|
|
518 end function
|
|
|
519 #endif
|
|
|
520 end interface
|
|
|
521
|
|
|
522 interface IEEE_RINT
|
|
|
523 procedure &
|
|
|
524 #ifdef HAVE_GFC_REAL_16
|
|
|
525 _gfortran_ieee_rint_16, &
|
|
|
526 #endif
|
|
|
527 #ifdef HAVE_GFC_REAL_10
|
|
|
528 _gfortran_ieee_rint_10, &
|
|
|
529 #endif
|
|
|
530 _gfortran_ieee_rint_8, _gfortran_ieee_rint_4
|
|
|
531 end interface
|
|
|
532 public :: IEEE_RINT
|
|
|
533
|
|
|
534 ! IEEE_SCALB
|
|
|
535
|
|
|
536 interface
|
|
145
|
537 #ifdef HAVE_GFC_INTEGER_16
|
|
|
538 #ifdef HAVE_GFC_REAL_16
|
|
|
539 elemental real(kind=16) function _gfortran_ieee_scalb_16_16 (X, I)
|
|
|
540 real(kind=16), intent(in) :: X
|
|
|
541 integer(kind=16), intent(in) :: I
|
|
|
542 end function
|
|
|
543 #endif
|
|
|
544 #ifdef HAVE_GFC_REAL_10
|
|
|
545 elemental real(kind=10) function _gfortran_ieee_scalb_10_16 (X, I)
|
|
|
546 real(kind=10), intent(in) :: X
|
|
|
547 integer(kind=16), intent(in) :: I
|
|
|
548 end function
|
|
|
549 #endif
|
|
|
550 elemental real(kind=8) function _gfortran_ieee_scalb_8_16 (X, I)
|
|
|
551 real(kind=8), intent(in) :: X
|
|
|
552 integer(kind=16), intent(in) :: I
|
|
|
553 end function
|
|
|
554 elemental real(kind=4) function _gfortran_ieee_scalb_4_16 (X, I)
|
|
|
555 real(kind=4), intent(in) :: X
|
|
|
556 integer(kind=16), intent(in) :: I
|
|
|
557 end function
|
|
|
558 #endif
|
|
|
559
|
|
|
560 #ifdef HAVE_GFC_INTEGER_8
|
|
|
561 #ifdef HAVE_GFC_REAL_16
|
|
|
562 elemental real(kind=16) function _gfortran_ieee_scalb_16_8 (X, I)
|
|
|
563 real(kind=16), intent(in) :: X
|
|
|
564 integer(kind=8), intent(in) :: I
|
|
|
565 end function
|
|
|
566 #endif
|
|
|
567 #ifdef HAVE_GFC_REAL_10
|
|
|
568 elemental real(kind=10) function _gfortran_ieee_scalb_10_8 (X, I)
|
|
|
569 real(kind=10), intent(in) :: X
|
|
|
570 integer(kind=8), intent(in) :: I
|
|
|
571 end function
|
|
|
572 #endif
|
|
|
573 elemental real(kind=8) function _gfortran_ieee_scalb_8_8 (X, I)
|
|
|
574 real(kind=8), intent(in) :: X
|
|
|
575 integer(kind=8), intent(in) :: I
|
|
|
576 end function
|
|
|
577 elemental real(kind=4) function _gfortran_ieee_scalb_4_8 (X, I)
|
|
111
|
578 real(kind=4), intent(in) :: X
|
|
145
|
579 integer(kind=8), intent(in) :: I
|
|
|
580 end function
|
|
|
581 #endif
|
|
|
582
|
|
|
583 #ifdef HAVE_GFC_INTEGER_2
|
|
|
584 #ifdef HAVE_GFC_REAL_16
|
|
|
585 elemental real(kind=16) function _gfortran_ieee_scalb_16_2 (X, I)
|
|
|
586 real(kind=16), intent(in) :: X
|
|
|
587 integer(kind=2), intent(in) :: I
|
|
|
588 end function
|
|
|
589 #endif
|
|
|
590 #ifdef HAVE_GFC_REAL_10
|
|
|
591 elemental real(kind=10) function _gfortran_ieee_scalb_10_2 (X, I)
|
|
|
592 real(kind=10), intent(in) :: X
|
|
|
593 integer(kind=2), intent(in) :: I
|
|
|
594 end function
|
|
|
595 #endif
|
|
|
596 elemental real(kind=8) function _gfortran_ieee_scalb_8_2 (X, I)
|
|
|
597 real(kind=8), intent(in) :: X
|
|
|
598 integer(kind=2), intent(in) :: I
|
|
|
599 end function
|
|
|
600 elemental real(kind=4) function _gfortran_ieee_scalb_4_2 (X, I)
|
|
|
601 real(kind=4), intent(in) :: X
|
|
|
602 integer(kind=2), intent(in) :: I
|
|
|
603 end function
|
|
|
604 #endif
|
|
|
605
|
|
|
606 #ifdef HAVE_GFC_INTEGER_1
|
|
|
607 #ifdef HAVE_GFC_REAL_16
|
|
|
608 elemental real(kind=16) function _gfortran_ieee_scalb_16_1 (X, I)
|
|
|
609 real(kind=16), intent(in) :: X
|
|
|
610 integer(kind=1), intent(in) :: I
|
|
|
611 end function
|
|
|
612 #endif
|
|
|
613 #ifdef HAVE_GFC_REAL_10
|
|
|
614 elemental real(kind=10) function _gfortran_ieee_scalb_10_1 (X, I)
|
|
|
615 real(kind=10), intent(in) :: X
|
|
|
616 integer(kind=1), intent(in) :: I
|
|
|
617 end function
|
|
|
618 #endif
|
|
|
619 elemental real(kind=8) function _gfortran_ieee_scalb_8_1 (X, I)
|
|
|
620 real(kind=8), intent(in) :: X
|
|
|
621 integer(kind=1), intent(in) :: I
|
|
|
622 end function
|
|
|
623 elemental real(kind=4) function _gfortran_ieee_scalb_4_1 (X, I)
|
|
|
624 real(kind=4), intent(in) :: X
|
|
|
625 integer(kind=1), intent(in) :: I
|
|
|
626 end function
|
|
|
627 #endif
|
|
|
628
|
|
|
629 #ifdef HAVE_GFC_REAL_16
|
|
|
630 elemental real(kind=16) function _gfortran_ieee_scalb_16_4 (X, I)
|
|
|
631 real(kind=16), intent(in) :: X
|
|
111
|
632 integer, intent(in) :: I
|
|
|
633 end function
|
|
145
|
634 #endif
|
|
111
|
635 #ifdef HAVE_GFC_REAL_10
|
|
145
|
636 elemental real(kind=10) function _gfortran_ieee_scalb_10_4 (X, I)
|
|
111
|
637 real(kind=10), intent(in) :: X
|
|
|
638 integer, intent(in) :: I
|
|
|
639 end function
|
|
|
640 #endif
|
|
145
|
641 elemental real(kind=8) function _gfortran_ieee_scalb_8_4 (X, I)
|
|
|
642 real(kind=8), intent(in) :: X
|
|
111
|
643 integer, intent(in) :: I
|
|
|
644 end function
|
|
145
|
645 elemental real(kind=4) function _gfortran_ieee_scalb_4_4 (X, I)
|
|
|
646 real(kind=4), intent(in) :: X
|
|
|
647 integer, intent(in) :: I
|
|
|
648 end function
|
|
111
|
649 end interface
|
|
|
650
|
|
|
651 interface IEEE_SCALB
|
|
|
652 procedure &
|
|
145
|
653 #ifdef HAVE_GFC_INTEGER_16
|
|
111
|
654 #ifdef HAVE_GFC_REAL_16
|
|
145
|
655 _gfortran_ieee_scalb_16_16, &
|
|
|
656 #endif
|
|
|
657 #ifdef HAVE_GFC_REAL_10
|
|
|
658 _gfortran_ieee_scalb_10_16, &
|
|
|
659 #endif
|
|
|
660 _gfortran_ieee_scalb_8_16, &
|
|
|
661 _gfortran_ieee_scalb_4_16, &
|
|
|
662 #endif
|
|
|
663 #ifdef HAVE_GFC_INTEGER_8
|
|
|
664 #ifdef HAVE_GFC_REAL_16
|
|
|
665 _gfortran_ieee_scalb_16_8, &
|
|
111
|
666 #endif
|
|
|
667 #ifdef HAVE_GFC_REAL_10
|
|
145
|
668 _gfortran_ieee_scalb_10_8, &
|
|
|
669 #endif
|
|
|
670 _gfortran_ieee_scalb_8_8, &
|
|
|
671 _gfortran_ieee_scalb_4_8, &
|
|
|
672 #endif
|
|
|
673 #ifdef HAVE_GFC_INTEGER_2
|
|
|
674 #ifdef HAVE_GFC_REAL_16
|
|
|
675 _gfortran_ieee_scalb_16_2, &
|
|
|
676 #endif
|
|
|
677 #ifdef HAVE_GFC_REAL_10
|
|
|
678 _gfortran_ieee_scalb_10_2, &
|
|
|
679 #endif
|
|
|
680 _gfortran_ieee_scalb_8_2, &
|
|
|
681 _gfortran_ieee_scalb_4_2, &
|
|
111
|
682 #endif
|
|
145
|
683 #ifdef HAVE_GFC_INTEGER_1
|
|
|
684 #ifdef HAVE_GFC_REAL_16
|
|
|
685 _gfortran_ieee_scalb_16_1, &
|
|
|
686 #endif
|
|
|
687 #ifdef HAVE_GFC_REAL_10
|
|
|
688 _gfortran_ieee_scalb_10_1, &
|
|
|
689 #endif
|
|
|
690 _gfortran_ieee_scalb_8_1, &
|
|
|
691 _gfortran_ieee_scalb_4_1, &
|
|
|
692 #endif
|
|
|
693 #ifdef HAVE_GFC_REAL_16
|
|
|
694 _gfortran_ieee_scalb_16_4, &
|
|
|
695 #endif
|
|
|
696 #ifdef HAVE_GFC_REAL_10
|
|
|
697 _gfortran_ieee_scalb_10_4, &
|
|
|
698 #endif
|
|
|
699 _gfortran_ieee_scalb_8_4, &
|
|
|
700 _gfortran_ieee_scalb_4_4
|
|
111
|
701 end interface
|
|
|
702 public :: IEEE_SCALB
|
|
|
703
|
|
|
704 ! IEEE_VALUE
|
|
|
705
|
|
|
706 interface IEEE_VALUE
|
|
|
707 module procedure &
|
|
|
708 #ifdef HAVE_GFC_REAL_16
|
|
|
709 IEEE_VALUE_16, &
|
|
|
710 #endif
|
|
|
711 #ifdef HAVE_GFC_REAL_10
|
|
|
712 IEEE_VALUE_10, &
|
|
|
713 #endif
|
|
|
714 IEEE_VALUE_8, IEEE_VALUE_4
|
|
|
715 end interface
|
|
|
716 public :: IEEE_VALUE
|
|
|
717
|
|
|
718 ! IEEE_CLASS
|
|
|
719
|
|
|
720 interface IEEE_CLASS
|
|
|
721 module procedure &
|
|
|
722 #ifdef HAVE_GFC_REAL_16
|
|
|
723 IEEE_CLASS_16, &
|
|
|
724 #endif
|
|
|
725 #ifdef HAVE_GFC_REAL_10
|
|
|
726 IEEE_CLASS_10, &
|
|
|
727 #endif
|
|
|
728 IEEE_CLASS_8, IEEE_CLASS_4
|
|
|
729 end interface
|
|
|
730 public :: IEEE_CLASS
|
|
|
731
|
|
|
732 ! Public declarations for contained procedures
|
|
|
733 public :: IEEE_GET_ROUNDING_MODE, IEEE_SET_ROUNDING_MODE
|
|
|
734 public :: IEEE_GET_UNDERFLOW_MODE, IEEE_SET_UNDERFLOW_MODE
|
|
|
735 public :: IEEE_SELECTED_REAL_KIND
|
|
|
736
|
|
|
737 ! IEEE_SUPPORT_ROUNDING
|
|
|
738
|
|
|
739 interface IEEE_SUPPORT_ROUNDING
|
|
|
740 module procedure IEEE_SUPPORT_ROUNDING_4, IEEE_SUPPORT_ROUNDING_8, &
|
|
|
741 #ifdef HAVE_GFC_REAL_10
|
|
|
742 IEEE_SUPPORT_ROUNDING_10, &
|
|
|
743 #endif
|
|
|
744 #ifdef HAVE_GFC_REAL_16
|
|
|
745 IEEE_SUPPORT_ROUNDING_16, &
|
|
|
746 #endif
|
|
|
747 IEEE_SUPPORT_ROUNDING_NOARG
|
|
|
748 end interface
|
|
|
749 public :: IEEE_SUPPORT_ROUNDING
|
|
|
750
|
|
|
751 ! Interface to the FPU-specific function
|
|
|
752 interface
|
|
|
753 pure integer function support_rounding_helper(flag) &
|
|
|
754 bind(c, name="_gfortrani_support_fpu_rounding_mode")
|
|
|
755 integer, intent(in), value :: flag
|
|
|
756 end function
|
|
|
757 end interface
|
|
|
758
|
|
|
759 ! IEEE_SUPPORT_UNDERFLOW_CONTROL
|
|
|
760
|
|
|
761 interface IEEE_SUPPORT_UNDERFLOW_CONTROL
|
|
|
762 module procedure IEEE_SUPPORT_UNDERFLOW_CONTROL_4, &
|
|
|
763 IEEE_SUPPORT_UNDERFLOW_CONTROL_8, &
|
|
|
764 #ifdef HAVE_GFC_REAL_10
|
|
|
765 IEEE_SUPPORT_UNDERFLOW_CONTROL_10, &
|
|
|
766 #endif
|
|
|
767 #ifdef HAVE_GFC_REAL_16
|
|
|
768 IEEE_SUPPORT_UNDERFLOW_CONTROL_16, &
|
|
|
769 #endif
|
|
|
770 IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG
|
|
|
771 end interface
|
|
|
772 public :: IEEE_SUPPORT_UNDERFLOW_CONTROL
|
|
|
773
|
|
|
774 ! Interface to the FPU-specific function
|
|
|
775 interface
|
|
|
776 pure integer function support_underflow_control_helper(kind) &
|
|
|
777 bind(c, name="_gfortrani_support_fpu_underflow_control")
|
|
|
778 integer, intent(in), value :: kind
|
|
|
779 end function
|
|
|
780 end interface
|
|
|
781
|
|
|
782 ! IEEE_SUPPORT_* generic functions
|
|
|
783
|
|
|
784 #if defined(HAVE_GFC_REAL_10) && defined(HAVE_GFC_REAL_16)
|
|
|
785 # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_10, NAME/**/_16, NAME/**/_NOARG
|
|
|
786 #elif defined(HAVE_GFC_REAL_10)
|
|
|
787 # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_10, NAME/**/_NOARG
|
|
|
788 #elif defined(HAVE_GFC_REAL_16)
|
|
|
789 # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_16, NAME/**/_NOARG
|
|
|
790 #else
|
|
|
791 # define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_NOARG
|
|
|
792 #endif
|
|
|
793
|
|
|
794 #define SUPPORTGENERIC(NAME) \
|
|
|
795 interface NAME ; module procedure MACRO1(NAME) ; end interface ; \
|
|
|
796 public :: NAME
|
|
|
797
|
|
|
798 SUPPORTGENERIC(IEEE_SUPPORT_DATATYPE)
|
|
|
799 SUPPORTGENERIC(IEEE_SUPPORT_DENORMAL)
|
|
145
|
800 SUPPORTGENERIC(IEEE_SUPPORT_SUBNORMAL)
|
|
111
|
801 SUPPORTGENERIC(IEEE_SUPPORT_DIVIDE)
|
|
|
802 SUPPORTGENERIC(IEEE_SUPPORT_INF)
|
|
|
803 SUPPORTGENERIC(IEEE_SUPPORT_IO)
|
|
|
804 SUPPORTGENERIC(IEEE_SUPPORT_NAN)
|
|
|
805 SUPPORTGENERIC(IEEE_SUPPORT_SQRT)
|
|
|
806 SUPPORTGENERIC(IEEE_SUPPORT_STANDARD)
|
|
|
807
|
|
|
808 contains
|
|
|
809
|
|
|
810 ! Equality operators for IEEE_CLASS_TYPE and IEEE_ROUNDING_MODE
|
|
|
811 elemental logical function IEEE_CLASS_TYPE_EQ (X, Y) result(res)
|
|
|
812 implicit none
|
|
|
813 type(IEEE_CLASS_TYPE), intent(in) :: X, Y
|
|
|
814 res = (X%hidden == Y%hidden)
|
|
|
815 end function
|
|
|
816
|
|
|
817 elemental logical function IEEE_CLASS_TYPE_NE (X, Y) result(res)
|
|
|
818 implicit none
|
|
|
819 type(IEEE_CLASS_TYPE), intent(in) :: X, Y
|
|
|
820 res = (X%hidden /= Y%hidden)
|
|
|
821 end function
|
|
|
822
|
|
|
823 elemental logical function IEEE_ROUND_TYPE_EQ (X, Y) result(res)
|
|
|
824 implicit none
|
|
|
825 type(IEEE_ROUND_TYPE), intent(in) :: X, Y
|
|
|
826 res = (X%hidden == Y%hidden)
|
|
|
827 end function
|
|
|
828
|
|
|
829 elemental logical function IEEE_ROUND_TYPE_NE (X, Y) result(res)
|
|
|
830 implicit none
|
|
|
831 type(IEEE_ROUND_TYPE), intent(in) :: X, Y
|
|
|
832 res = (X%hidden /= Y%hidden)
|
|
|
833 end function
|
|
|
834
|
|
|
835
|
|
|
836 ! IEEE_SELECTED_REAL_KIND
|
|
|
837
|
|
|
838 integer function IEEE_SELECTED_REAL_KIND (P, R, RADIX) result(res)
|
|
|
839 implicit none
|
|
|
840 integer, intent(in), optional :: P, R, RADIX
|
|
|
841
|
|
|
842 ! Currently, if IEEE is supported and this module is built, it means
|
|
|
843 ! all our floating-point types conform to IEEE. Hence, we simply call
|
|
|
844 ! SELECTED_REAL_KIND.
|
|
|
845
|
|
|
846 res = SELECTED_REAL_KIND (P, R, RADIX)
|
|
|
847
|
|
|
848 end function
|
|
|
849
|
|
|
850
|
|
|
851 ! IEEE_CLASS
|
|
|
852
|
|
|
853 elemental function IEEE_CLASS_4 (X) result(res)
|
|
|
854 implicit none
|
|
|
855 real(kind=4), intent(in) :: X
|
|
|
856 type(IEEE_CLASS_TYPE) :: res
|
|
|
857
|
|
|
858 interface
|
|
|
859 pure integer function _gfortrani_ieee_class_helper_4(val)
|
|
|
860 real(kind=4), intent(in) :: val
|
|
|
861 end function
|
|
|
862 end interface
|
|
|
863
|
|
|
864 res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_4(X))
|
|
|
865 end function
|
|
|
866
|
|
|
867 elemental function IEEE_CLASS_8 (X) result(res)
|
|
|
868 implicit none
|
|
|
869 real(kind=8), intent(in) :: X
|
|
|
870 type(IEEE_CLASS_TYPE) :: res
|
|
|
871
|
|
|
872 interface
|
|
|
873 pure integer function _gfortrani_ieee_class_helper_8(val)
|
|
|
874 real(kind=8), intent(in) :: val
|
|
|
875 end function
|
|
|
876 end interface
|
|
|
877
|
|
|
878 res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_8(X))
|
|
|
879 end function
|
|
|
880
|
|
|
881 #ifdef HAVE_GFC_REAL_10
|
|
|
882 elemental function IEEE_CLASS_10 (X) result(res)
|
|
|
883 implicit none
|
|
|
884 real(kind=10), intent(in) :: X
|
|
|
885 type(IEEE_CLASS_TYPE) :: res
|
|
|
886
|
|
|
887 interface
|
|
|
888 pure integer function _gfortrani_ieee_class_helper_10(val)
|
|
|
889 real(kind=10), intent(in) :: val
|
|
|
890 end function
|
|
|
891 end interface
|
|
|
892
|
|
|
893 res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_10(X))
|
|
|
894 end function
|
|
|
895 #endif
|
|
|
896
|
|
|
897 #ifdef HAVE_GFC_REAL_16
|
|
|
898 elemental function IEEE_CLASS_16 (X) result(res)
|
|
|
899 implicit none
|
|
|
900 real(kind=16), intent(in) :: X
|
|
|
901 type(IEEE_CLASS_TYPE) :: res
|
|
|
902
|
|
|
903 interface
|
|
|
904 pure integer function _gfortrani_ieee_class_helper_16(val)
|
|
|
905 real(kind=16), intent(in) :: val
|
|
|
906 end function
|
|
|
907 end interface
|
|
|
908
|
|
|
909 res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_16(X))
|
|
|
910 end function
|
|
|
911 #endif
|
|
|
912
|
|
|
913
|
|
|
914 ! IEEE_VALUE
|
|
|
915
|
|
|
916 elemental real(kind=4) function IEEE_VALUE_4(X, CLASS) result(res)
|
|
|
917
|
|
|
918 real(kind=4), intent(in) :: X
|
|
|
919 type(IEEE_CLASS_TYPE), intent(in) :: CLASS
|
|
145
|
920 logical flag
|
|
111
|
921
|
|
|
922 select case (CLASS%hidden)
|
|
|
923 case (1) ! IEEE_SIGNALING_NAN
|
|
145
|
924 if (ieee_support_halting(ieee_invalid)) then
|
|
|
925 call ieee_get_halting_mode(ieee_invalid, flag)
|
|
|
926 call ieee_set_halting_mode(ieee_invalid, .false.)
|
|
|
927 end if
|
|
111
|
928 res = -1
|
|
|
929 res = sqrt(res)
|
|
145
|
930 if (ieee_support_halting(ieee_invalid)) then
|
|
|
931 call ieee_set_halting_mode(ieee_invalid, flag)
|
|
|
932 end if
|
|
111
|
933 case (2) ! IEEE_QUIET_NAN
|
|
145
|
934 if (ieee_support_halting(ieee_invalid)) then
|
|
|
935 call ieee_get_halting_mode(ieee_invalid, flag)
|
|
|
936 call ieee_set_halting_mode(ieee_invalid, .false.)
|
|
|
937 end if
|
|
111
|
938 res = -1
|
|
|
939 res = sqrt(res)
|
|
145
|
940 if (ieee_support_halting(ieee_invalid)) then
|
|
|
941 call ieee_set_halting_mode(ieee_invalid, flag)
|
|
|
942 end if
|
|
111
|
943 case (3) ! IEEE_NEGATIVE_INF
|
|
145
|
944 if (ieee_support_halting(ieee_overflow)) then
|
|
|
945 call ieee_get_halting_mode(ieee_overflow, flag)
|
|
|
946 call ieee_set_halting_mode(ieee_overflow, .false.)
|
|
|
947 end if
|
|
111
|
948 res = huge(res)
|
|
|
949 res = (-res) * res
|
|
145
|
950 if (ieee_support_halting(ieee_overflow)) then
|
|
|
951 call ieee_set_halting_mode(ieee_overflow, flag)
|
|
|
952 end if
|
|
111
|
953 case (4) ! IEEE_NEGATIVE_NORMAL
|
|
|
954 res = -42
|
|
|
955 case (5) ! IEEE_NEGATIVE_DENORMAL
|
|
|
956 res = -tiny(res)
|
|
|
957 res = res / 2
|
|
|
958 case (6) ! IEEE_NEGATIVE_ZERO
|
|
|
959 res = 0
|
|
|
960 res = -res
|
|
|
961 case (7) ! IEEE_POSITIVE_ZERO
|
|
|
962 res = 0
|
|
|
963 case (8) ! IEEE_POSITIVE_DENORMAL
|
|
|
964 res = tiny(res)
|
|
|
965 res = res / 2
|
|
|
966 case (9) ! IEEE_POSITIVE_NORMAL
|
|
|
967 res = 42
|
|
|
968 case (10) ! IEEE_POSITIVE_INF
|
|
145
|
969 if (ieee_support_halting(ieee_overflow)) then
|
|
|
970 call ieee_get_halting_mode(ieee_overflow, flag)
|
|
|
971 call ieee_set_halting_mode(ieee_overflow, .false.)
|
|
|
972 end if
|
|
111
|
973 res = huge(res)
|
|
|
974 res = res * res
|
|
145
|
975 if (ieee_support_halting(ieee_overflow)) then
|
|
|
976 call ieee_set_halting_mode(ieee_overflow, flag)
|
|
|
977 end if
|
|
111
|
978 case default ! IEEE_OTHER_VALUE, should not happen
|
|
|
979 res = 0
|
|
|
980 end select
|
|
|
981 end function
|
|
|
982
|
|
|
983 elemental real(kind=8) function IEEE_VALUE_8(X, CLASS) result(res)
|
|
|
984
|
|
|
985 real(kind=8), intent(in) :: X
|
|
|
986 type(IEEE_CLASS_TYPE), intent(in) :: CLASS
|
|
145
|
987 logical flag
|
|
111
|
988
|
|
|
989 select case (CLASS%hidden)
|
|
|
990 case (1) ! IEEE_SIGNALING_NAN
|
|
145
|
991 if (ieee_support_halting(ieee_invalid)) then
|
|
|
992 call ieee_get_halting_mode(ieee_invalid, flag)
|
|
|
993 call ieee_set_halting_mode(ieee_invalid, .false.)
|
|
|
994 end if
|
|
111
|
995 res = -1
|
|
|
996 res = sqrt(res)
|
|
145
|
997 if (ieee_support_halting(ieee_invalid)) then
|
|
|
998 call ieee_set_halting_mode(ieee_invalid, flag)
|
|
|
999 end if
|
|
111
|
1000 case (2) ! IEEE_QUIET_NAN
|
|
145
|
1001 if (ieee_support_halting(ieee_invalid)) then
|
|
|
1002 call ieee_get_halting_mode(ieee_invalid, flag)
|
|
|
1003 call ieee_set_halting_mode(ieee_invalid, .false.)
|
|
|
1004 end if
|
|
111
|
1005 res = -1
|
|
|
1006 res = sqrt(res)
|
|
145
|
1007 if (ieee_support_halting(ieee_invalid)) then
|
|
|
1008 call ieee_set_halting_mode(ieee_invalid, flag)
|
|
|
1009 end if
|
|
111
|
1010 case (3) ! IEEE_NEGATIVE_INF
|
|
145
|
1011 if (ieee_support_halting(ieee_overflow)) then
|
|
|
1012 call ieee_get_halting_mode(ieee_overflow, flag)
|
|
|
1013 call ieee_set_halting_mode(ieee_overflow, .false.)
|
|
|
1014 end if
|
|
111
|
1015 res = huge(res)
|
|
|
1016 res = (-res) * res
|
|
145
|
1017 if (ieee_support_halting(ieee_overflow)) then
|
|
|
1018 call ieee_set_halting_mode(ieee_overflow, flag)
|
|
|
1019 end if
|
|
111
|
1020 case (4) ! IEEE_NEGATIVE_NORMAL
|
|
|
1021 res = -42
|
|
|
1022 case (5) ! IEEE_NEGATIVE_DENORMAL
|
|
|
1023 res = -tiny(res)
|
|
|
1024 res = res / 2
|
|
|
1025 case (6) ! IEEE_NEGATIVE_ZERO
|
|
|
1026 res = 0
|
|
|
1027 res = -res
|
|
|
1028 case (7) ! IEEE_POSITIVE_ZERO
|
|
|
1029 res = 0
|
|
|
1030 case (8) ! IEEE_POSITIVE_DENORMAL
|
|
|
1031 res = tiny(res)
|
|
|
1032 res = res / 2
|
|
|
1033 case (9) ! IEEE_POSITIVE_NORMAL
|
|
|
1034 res = 42
|
|
|
1035 case (10) ! IEEE_POSITIVE_INF
|
|
145
|
1036 if (ieee_support_halting(ieee_overflow)) then
|
|
|
1037 call ieee_get_halting_mode(ieee_overflow, flag)
|
|
|
1038 call ieee_set_halting_mode(ieee_overflow, .false.)
|
|
|
1039 end if
|
|
111
|
1040 res = huge(res)
|
|
|
1041 res = res * res
|
|
145
|
1042 if (ieee_support_halting(ieee_overflow)) then
|
|
|
1043 call ieee_set_halting_mode(ieee_overflow, flag)
|
|
|
1044 end if
|
|
111
|
1045 case default ! IEEE_OTHER_VALUE, should not happen
|
|
|
1046 res = 0
|
|
|
1047 end select
|
|
|
1048 end function
|
|
|
1049
|
|
|
1050 #ifdef HAVE_GFC_REAL_10
|
|
|
1051 elemental real(kind=10) function IEEE_VALUE_10(X, CLASS) result(res)
|
|
|
1052
|
|
|
1053 real(kind=10), intent(in) :: X
|
|
|
1054 type(IEEE_CLASS_TYPE), intent(in) :: CLASS
|
|
145
|
1055 logical flag
|
|
111
|
1056
|
|
|
1057 select case (CLASS%hidden)
|
|
|
1058 case (1) ! IEEE_SIGNALING_NAN
|
|
145
|
1059 if (ieee_support_halting(ieee_invalid)) then
|
|
|
1060 call ieee_get_halting_mode(ieee_invalid, flag)
|
|
|
1061 call ieee_set_halting_mode(ieee_invalid, .false.)
|
|
|
1062 end if
|
|
111
|
1063 res = -1
|
|
|
1064 res = sqrt(res)
|
|
145
|
1065 if (ieee_support_halting(ieee_invalid)) then
|
|
|
1066 call ieee_set_halting_mode(ieee_invalid, flag)
|
|
|
1067 end if
|
|
111
|
1068 case (2) ! IEEE_QUIET_NAN
|
|
145
|
1069 if (ieee_support_halting(ieee_invalid)) then
|
|
|
1070 call ieee_get_halting_mode(ieee_invalid, flag)
|
|
|
1071 call ieee_set_halting_mode(ieee_invalid, .false.)
|
|
|
1072 end if
|
|
111
|
1073 res = -1
|
|
|
1074 res = sqrt(res)
|
|
145
|
1075 if (ieee_support_halting(ieee_invalid)) then
|
|
|
1076 call ieee_set_halting_mode(ieee_invalid, flag)
|
|
|
1077 end if
|
|
|
1078 case (3) ! IEEE_NEGATIVE_INF
|
|
|
1079 if (ieee_support_halting(ieee_overflow)) then
|
|
|
1080 call ieee_get_halting_mode(ieee_overflow, flag)
|
|
|
1081 call ieee_set_halting_mode(ieee_overflow, .false.)
|
|
|
1082 end if
|
|
111
|
1083 res = huge(res)
|
|
|
1084 res = (-res) * res
|
|
145
|
1085 if (ieee_support_halting(ieee_overflow)) then
|
|
|
1086 call ieee_set_halting_mode(ieee_overflow, flag)
|
|
|
1087 end if
|
|
111
|
1088 case (4) ! IEEE_NEGATIVE_NORMAL
|
|
|
1089 res = -42
|
|
|
1090 case (5) ! IEEE_NEGATIVE_DENORMAL
|
|
|
1091 res = -tiny(res)
|
|
|
1092 res = res / 2
|
|
|
1093 case (6) ! IEEE_NEGATIVE_ZERO
|
|
|
1094 res = 0
|
|
|
1095 res = -res
|
|
|
1096 case (7) ! IEEE_POSITIVE_ZERO
|
|
|
1097 res = 0
|
|
|
1098 case (8) ! IEEE_POSITIVE_DENORMAL
|
|
|
1099 res = tiny(res)
|
|
|
1100 res = res / 2
|
|
|
1101 case (9) ! IEEE_POSITIVE_NORMAL
|
|
|
1102 res = 42
|
|
|
1103 case (10) ! IEEE_POSITIVE_INF
|
|
145
|
1104 if (ieee_support_halting(ieee_overflow)) then
|
|
|
1105 call ieee_get_halting_mode(ieee_overflow, flag)
|
|
|
1106 call ieee_set_halting_mode(ieee_overflow, .false.)
|
|
|
1107 end if
|
|
111
|
1108 res = huge(res)
|
|
|
1109 res = res * res
|
|
145
|
1110 if (ieee_support_halting(ieee_overflow)) then
|
|
|
1111 call ieee_set_halting_mode(ieee_overflow, flag)
|
|
|
1112 end if
|
|
111
|
1113 case default ! IEEE_OTHER_VALUE, should not happen
|
|
|
1114 res = 0
|
|
|
1115 end select
|
|
|
1116 end function
|
|
|
1117
|
|
|
1118 #endif
|
|
|
1119
|
|
|
1120 #ifdef HAVE_GFC_REAL_16
|
|
|
1121 elemental real(kind=16) function IEEE_VALUE_16(X, CLASS) result(res)
|
|
|
1122
|
|
|
1123 real(kind=16), intent(in) :: X
|
|
|
1124 type(IEEE_CLASS_TYPE), intent(in) :: CLASS
|
|
145
|
1125 logical flag
|
|
111
|
1126
|
|
|
1127 select case (CLASS%hidden)
|
|
|
1128 case (1) ! IEEE_SIGNALING_NAN
|
|
145
|
1129 if (ieee_support_halting(ieee_invalid)) then
|
|
|
1130 call ieee_get_halting_mode(ieee_invalid, flag)
|
|
|
1131 call ieee_set_halting_mode(ieee_invalid, .false.)
|
|
|
1132 end if
|
|
111
|
1133 res = -1
|
|
|
1134 res = sqrt(res)
|
|
145
|
1135 if (ieee_support_halting(ieee_invalid)) then
|
|
|
1136 call ieee_set_halting_mode(ieee_invalid, flag)
|
|
|
1137 end if
|
|
111
|
1138 case (2) ! IEEE_QUIET_NAN
|
|
145
|
1139 if (ieee_support_halting(ieee_invalid)) then
|
|
|
1140 call ieee_get_halting_mode(ieee_invalid, flag)
|
|
|
1141 call ieee_set_halting_mode(ieee_invalid, .false.)
|
|
|
1142 end if
|
|
111
|
1143 res = -1
|
|
|
1144 res = sqrt(res)
|
|
145
|
1145 if (ieee_support_halting(ieee_invalid)) then
|
|
|
1146 call ieee_set_halting_mode(ieee_invalid, flag)
|
|
|
1147 end if
|
|
111
|
1148 case (3) ! IEEE_NEGATIVE_INF
|
|
145
|
1149 if (ieee_support_halting(ieee_overflow)) then
|
|
|
1150 call ieee_get_halting_mode(ieee_overflow, flag)
|
|
|
1151 call ieee_set_halting_mode(ieee_overflow, .false.)
|
|
|
1152 end if
|
|
111
|
1153 res = huge(res)
|
|
|
1154 res = (-res) * res
|
|
145
|
1155 if (ieee_support_halting(ieee_overflow)) then
|
|
|
1156 call ieee_set_halting_mode(ieee_overflow, flag)
|
|
|
1157 end if
|
|
111
|
1158 case (4) ! IEEE_NEGATIVE_NORMAL
|
|
|
1159 res = -42
|
|
|
1160 case (5) ! IEEE_NEGATIVE_DENORMAL
|
|
|
1161 res = -tiny(res)
|
|
|
1162 res = res / 2
|
|
|
1163 case (6) ! IEEE_NEGATIVE_ZERO
|
|
|
1164 res = 0
|
|
|
1165 res = -res
|
|
|
1166 case (7) ! IEEE_POSITIVE_ZERO
|
|
|
1167 res = 0
|
|
|
1168 case (8) ! IEEE_POSITIVE_DENORMAL
|
|
|
1169 res = tiny(res)
|
|
|
1170 res = res / 2
|
|
|
1171 case (9) ! IEEE_POSITIVE_NORMAL
|
|
|
1172 res = 42
|
|
|
1173 case (10) ! IEEE_POSITIVE_INF
|
|
145
|
1174 if (ieee_support_halting(ieee_overflow)) then
|
|
|
1175 call ieee_get_halting_mode(ieee_overflow, flag)
|
|
|
1176 call ieee_set_halting_mode(ieee_overflow, .false.)
|
|
|
1177 end if
|
|
111
|
1178 res = huge(res)
|
|
|
1179 res = res * res
|
|
145
|
1180 if (ieee_support_halting(ieee_overflow)) then
|
|
|
1181 call ieee_set_halting_mode(ieee_overflow, flag)
|
|
|
1182 end if
|
|
111
|
1183 case default ! IEEE_OTHER_VALUE, should not happen
|
|
|
1184 res = 0
|
|
|
1185 end select
|
|
|
1186 end function
|
|
|
1187 #endif
|
|
|
1188
|
|
|
1189
|
|
|
1190 ! IEEE_GET_ROUNDING_MODE
|
|
|
1191
|
|
|
1192 subroutine IEEE_GET_ROUNDING_MODE (ROUND_VALUE)
|
|
|
1193 implicit none
|
|
|
1194 type(IEEE_ROUND_TYPE), intent(out) :: ROUND_VALUE
|
|
|
1195
|
|
|
1196 interface
|
|
|
1197 integer function helper() &
|
|
|
1198 bind(c, name="_gfortrani_get_fpu_rounding_mode")
|
|
|
1199 end function
|
|
|
1200 end interface
|
|
|
1201
|
|
|
1202 ROUND_VALUE = IEEE_ROUND_TYPE(helper())
|
|
|
1203 end subroutine
|
|
|
1204
|
|
|
1205
|
|
|
1206 ! IEEE_SET_ROUNDING_MODE
|
|
|
1207
|
|
|
1208 subroutine IEEE_SET_ROUNDING_MODE (ROUND_VALUE)
|
|
|
1209 implicit none
|
|
|
1210 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
|
|
|
1211
|
|
|
1212 interface
|
|
|
1213 subroutine helper(val) &
|
|
|
1214 bind(c, name="_gfortrani_set_fpu_rounding_mode")
|
|
|
1215 integer, value :: val
|
|
|
1216 end subroutine
|
|
|
1217 end interface
|
|
|
1218
|
|
|
1219 call helper(ROUND_VALUE%hidden)
|
|
|
1220 end subroutine
|
|
|
1221
|
|
|
1222
|
|
|
1223 ! IEEE_GET_UNDERFLOW_MODE
|
|
|
1224
|
|
|
1225 subroutine IEEE_GET_UNDERFLOW_MODE (GRADUAL)
|
|
|
1226 implicit none
|
|
|
1227 logical, intent(out) :: GRADUAL
|
|
|
1228
|
|
|
1229 interface
|
|
|
1230 integer function helper() &
|
|
|
1231 bind(c, name="_gfortrani_get_fpu_underflow_mode")
|
|
|
1232 end function
|
|
|
1233 end interface
|
|
|
1234
|
|
|
1235 GRADUAL = (helper() /= 0)
|
|
|
1236 end subroutine
|
|
|
1237
|
|
|
1238
|
|
|
1239 ! IEEE_SET_UNDERFLOW_MODE
|
|
|
1240
|
|
|
1241 subroutine IEEE_SET_UNDERFLOW_MODE (GRADUAL)
|
|
|
1242 implicit none
|
|
|
1243 logical, intent(in) :: GRADUAL
|
|
|
1244
|
|
|
1245 interface
|
|
|
1246 subroutine helper(val) &
|
|
|
1247 bind(c, name="_gfortrani_set_fpu_underflow_mode")
|
|
|
1248 integer, value :: val
|
|
|
1249 end subroutine
|
|
|
1250 end interface
|
|
|
1251
|
|
|
1252 call helper(merge(1, 0, GRADUAL))
|
|
|
1253 end subroutine
|
|
|
1254
|
|
|
1255 ! IEEE_SUPPORT_ROUNDING
|
|
|
1256
|
|
|
1257 pure logical function IEEE_SUPPORT_ROUNDING_4 (ROUND_VALUE, X) result(res)
|
|
|
1258 implicit none
|
|
|
1259 real(kind=4), intent(in) :: X
|
|
|
1260 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
|
|
|
1261 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
|
|
|
1262 end function
|
|
|
1263
|
|
|
1264 pure logical function IEEE_SUPPORT_ROUNDING_8 (ROUND_VALUE, X) result(res)
|
|
|
1265 implicit none
|
|
|
1266 real(kind=8), intent(in) :: X
|
|
|
1267 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
|
|
|
1268 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
|
|
|
1269 end function
|
|
|
1270
|
|
|
1271 #ifdef HAVE_GFC_REAL_10
|
|
|
1272 pure logical function IEEE_SUPPORT_ROUNDING_10 (ROUND_VALUE, X) result(res)
|
|
|
1273 implicit none
|
|
|
1274 real(kind=10), intent(in) :: X
|
|
|
1275 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
|
|
|
1276 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
|
|
|
1277 end function
|
|
|
1278 #endif
|
|
|
1279
|
|
|
1280 #ifdef HAVE_GFC_REAL_16
|
|
|
1281 pure logical function IEEE_SUPPORT_ROUNDING_16 (ROUND_VALUE, X) result(res)
|
|
|
1282 implicit none
|
|
|
1283 real(kind=16), intent(in) :: X
|
|
|
1284 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
|
|
|
1285 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
|
|
|
1286 end function
|
|
|
1287 #endif
|
|
|
1288
|
|
|
1289 pure logical function IEEE_SUPPORT_ROUNDING_NOARG (ROUND_VALUE) result(res)
|
|
|
1290 implicit none
|
|
|
1291 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
|
|
|
1292 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
|
|
|
1293 end function
|
|
|
1294
|
|
|
1295 ! IEEE_SUPPORT_UNDERFLOW_CONTROL
|
|
|
1296
|
|
|
1297 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_4 (X) result(res)
|
|
|
1298 implicit none
|
|
|
1299 real(kind=4), intent(in) :: X
|
|
|
1300 res = (support_underflow_control_helper(4) /= 0)
|
|
|
1301 end function
|
|
|
1302
|
|
|
1303 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_8 (X) result(res)
|
|
|
1304 implicit none
|
|
|
1305 real(kind=8), intent(in) :: X
|
|
|
1306 res = (support_underflow_control_helper(8) /= 0)
|
|
|
1307 end function
|
|
|
1308
|
|
|
1309 #ifdef HAVE_GFC_REAL_10
|
|
|
1310 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_10 (X) result(res)
|
|
|
1311 implicit none
|
|
|
1312 real(kind=10), intent(in) :: X
|
|
|
1313 res = (support_underflow_control_helper(10) /= 0)
|
|
|
1314 end function
|
|
|
1315 #endif
|
|
|
1316
|
|
|
1317 #ifdef HAVE_GFC_REAL_16
|
|
|
1318 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_16 (X) result(res)
|
|
|
1319 implicit none
|
|
|
1320 real(kind=16), intent(in) :: X
|
|
|
1321 res = (support_underflow_control_helper(16) /= 0)
|
|
|
1322 end function
|
|
|
1323 #endif
|
|
|
1324
|
|
|
1325 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG () result(res)
|
|
|
1326 implicit none
|
|
|
1327 res = (support_underflow_control_helper(4) /= 0 &
|
|
|
1328 .and. support_underflow_control_helper(8) /= 0 &
|
|
|
1329 #ifdef HAVE_GFC_REAL_10
|
|
|
1330 .and. support_underflow_control_helper(10) /= 0 &
|
|
|
1331 #endif
|
|
|
1332 #ifdef HAVE_GFC_REAL_16
|
|
|
1333 .and. support_underflow_control_helper(16) /= 0 &
|
|
|
1334 #endif
|
|
|
1335 )
|
|
|
1336 end function
|
|
|
1337
|
|
|
1338 ! IEEE_SUPPORT_* functions
|
|
|
1339
|
|
|
1340 #define SUPPORTMACRO(NAME, INTKIND, VALUE) \
|
|
|
1341 pure logical function NAME/**/_/**/INTKIND (X) result(res) ; \
|
|
|
1342 implicit none ; \
|
|
|
1343 real(INTKIND), intent(in) :: X(..) ; \
|
|
|
1344 res = VALUE ; \
|
|
|
1345 end function
|
|
|
1346
|
|
|
1347 #define SUPPORTMACRO_NOARG(NAME, VALUE) \
|
|
|
1348 pure logical function NAME/**/_NOARG () result(res) ; \
|
|
|
1349 implicit none ; \
|
|
|
1350 res = VALUE ; \
|
|
|
1351 end function
|
|
|
1352
|
|
|
1353 ! IEEE_SUPPORT_DATATYPE
|
|
|
1354
|
|
|
1355 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,4,.true.)
|
|
|
1356 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,8,.true.)
|
|
|
1357 #ifdef HAVE_GFC_REAL_10
|
|
|
1358 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,10,.true.)
|
|
|
1359 #endif
|
|
|
1360 #ifdef HAVE_GFC_REAL_16
|
|
|
1361 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,16,.true.)
|
|
|
1362 #endif
|
|
|
1363 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.true.)
|
|
|
1364
|
|
145
|
1365 ! IEEE_SUPPORT_DENORMAL and IEEE_SUPPORT_SUBNORMAL
|
|
111
|
1366
|
|
|
1367 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,4,.true.)
|
|
|
1368 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,8,.true.)
|
|
|
1369 #ifdef HAVE_GFC_REAL_10
|
|
|
1370 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,10,.true.)
|
|
|
1371 #endif
|
|
|
1372 #ifdef HAVE_GFC_REAL_16
|
|
|
1373 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,16,.true.)
|
|
|
1374 #endif
|
|
|
1375 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.true.)
|
|
|
1376
|
|
145
|
1377 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,4,.true.)
|
|
|
1378 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,8,.true.)
|
|
|
1379 #ifdef HAVE_GFC_REAL_10
|
|
|
1380 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,10,.true.)
|
|
|
1381 #endif
|
|
|
1382 #ifdef HAVE_GFC_REAL_16
|
|
|
1383 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,16,.true.)
|
|
|
1384 #endif
|
|
|
1385 SUPPORTMACRO_NOARG(IEEE_SUPPORT_SUBNORMAL,.true.)
|
|
|
1386
|
|
111
|
1387 ! IEEE_SUPPORT_DIVIDE
|
|
|
1388
|
|
|
1389 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,4,.true.)
|
|
|
1390 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,8,.true.)
|
|
|
1391 #ifdef HAVE_GFC_REAL_10
|
|
|
1392 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,10,.true.)
|
|
|
1393 #endif
|
|
|
1394 #ifdef HAVE_GFC_REAL_16
|
|
|
1395 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,16,.true.)
|
|
|
1396 #endif
|
|
|
1397 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.true.)
|
|
|
1398
|
|
|
1399 ! IEEE_SUPPORT_INF
|
|
|
1400
|
|
|
1401 SUPPORTMACRO(IEEE_SUPPORT_INF,4,.true.)
|
|
|
1402 SUPPORTMACRO(IEEE_SUPPORT_INF,8,.true.)
|
|
|
1403 #ifdef HAVE_GFC_REAL_10
|
|
|
1404 SUPPORTMACRO(IEEE_SUPPORT_INF,10,.true.)
|
|
|
1405 #endif
|
|
|
1406 #ifdef HAVE_GFC_REAL_16
|
|
|
1407 SUPPORTMACRO(IEEE_SUPPORT_INF,16,.true.)
|
|
|
1408 #endif
|
|
|
1409 SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.true.)
|
|
|
1410
|
|
|
1411 ! IEEE_SUPPORT_IO
|
|
|
1412
|
|
|
1413 SUPPORTMACRO(IEEE_SUPPORT_IO,4,.true.)
|
|
|
1414 SUPPORTMACRO(IEEE_SUPPORT_IO,8,.true.)
|
|
|
1415 #ifdef HAVE_GFC_REAL_10
|
|
|
1416 SUPPORTMACRO(IEEE_SUPPORT_IO,10,.true.)
|
|
|
1417 #endif
|
|
|
1418 #ifdef HAVE_GFC_REAL_16
|
|
|
1419 SUPPORTMACRO(IEEE_SUPPORT_IO,16,.true.)
|
|
|
1420 #endif
|
|
|
1421 SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.true.)
|
|
|
1422
|
|
|
1423 ! IEEE_SUPPORT_NAN
|
|
|
1424
|
|
|
1425 SUPPORTMACRO(IEEE_SUPPORT_NAN,4,.true.)
|
|
|
1426 SUPPORTMACRO(IEEE_SUPPORT_NAN,8,.true.)
|
|
|
1427 #ifdef HAVE_GFC_REAL_10
|
|
|
1428 SUPPORTMACRO(IEEE_SUPPORT_NAN,10,.true.)
|
|
|
1429 #endif
|
|
|
1430 #ifdef HAVE_GFC_REAL_16
|
|
|
1431 SUPPORTMACRO(IEEE_SUPPORT_NAN,16,.true.)
|
|
|
1432 #endif
|
|
|
1433 SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.true.)
|
|
|
1434
|
|
|
1435 ! IEEE_SUPPORT_SQRT
|
|
|
1436
|
|
|
1437 SUPPORTMACRO(IEEE_SUPPORT_SQRT,4,.true.)
|
|
|
1438 SUPPORTMACRO(IEEE_SUPPORT_SQRT,8,.true.)
|
|
|
1439 #ifdef HAVE_GFC_REAL_10
|
|
|
1440 SUPPORTMACRO(IEEE_SUPPORT_SQRT,10,.true.)
|
|
|
1441 #endif
|
|
|
1442 #ifdef HAVE_GFC_REAL_16
|
|
|
1443 SUPPORTMACRO(IEEE_SUPPORT_SQRT,16,.true.)
|
|
|
1444 #endif
|
|
|
1445 SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.true.)
|
|
|
1446
|
|
|
1447 ! IEEE_SUPPORT_STANDARD
|
|
|
1448
|
|
|
1449 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,4,.true.)
|
|
|
1450 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,8,.true.)
|
|
|
1451 #ifdef HAVE_GFC_REAL_10
|
|
|
1452 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,10,.true.)
|
|
|
1453 #endif
|
|
|
1454 #ifdef HAVE_GFC_REAL_16
|
|
|
1455 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,16,.true.)
|
|
|
1456 #endif
|
|
|
1457 SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.true.)
|
|
|
1458
|
|
|
1459 end module IEEE_ARITHMETIC
|
