1! Implementation of the IEEE_ARITHMETIC standard intrinsic module 2! Copyright (C) 2013-2019 Free Software Foundation, Inc. 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 31module 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), & 58 IEEE_NEGATIVE_SUBNORMAL= IEEE_CLASS_TYPE(5), & 59 IEEE_NEGATIVE_ZERO = IEEE_CLASS_TYPE(6), & 60 IEEE_POSITIVE_ZERO = IEEE_CLASS_TYPE(7), & 61 IEEE_POSITIVE_DENORMAL = IEEE_CLASS_TYPE(8), & 62 IEEE_POSITIVE_SUBNORMAL= IEEE_CLASS_TYPE(8), & 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 233#ifdef HAVE_GFC_REAL_16 234COPYSIGN_MACRO(16,16) 235#ifdef HAVE_GFC_REAL_10 236COPYSIGN_MACRO(16,10) 237COPYSIGN_MACRO(10,16) 238#endif 239COPYSIGN_MACRO(16,8) 240COPYSIGN_MACRO(16,4) 241COPYSIGN_MACRO(8,16) 242COPYSIGN_MACRO(4,16) 243#endif 244#ifdef HAVE_GFC_REAL_10 245COPYSIGN_MACRO(10,10) 246COPYSIGN_MACRO(10,8) 247COPYSIGN_MACRO(10,4) 248COPYSIGN_MACRO(8,10) 249COPYSIGN_MACRO(4,10) 250#endif 251COPYSIGN_MACRO(8,8) 252COPYSIGN_MACRO(8,4) 253COPYSIGN_MACRO(4,8) 254COPYSIGN_MACRO(4,4) 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, & 263 _gfortran_ieee_copy_sign_10_16, & 264#endif 265 _gfortran_ieee_copy_sign_16_8, & 266 _gfortran_ieee_copy_sign_16_4, & 267 _gfortran_ieee_copy_sign_8_16, & 268 _gfortran_ieee_copy_sign_4_16, & 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, & 275 _gfortran_ieee_copy_sign_4_10, & 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 294#ifdef HAVE_GFC_REAL_16 295UNORDERED_MACRO(16,16) 296#ifdef HAVE_GFC_REAL_10 297UNORDERED_MACRO(16,10) 298UNORDERED_MACRO(10,16) 299#endif 300UNORDERED_MACRO(16,8) 301UNORDERED_MACRO(16,4) 302UNORDERED_MACRO(8,16) 303UNORDERED_MACRO(4,16) 304#endif 305#ifdef HAVE_GFC_REAL_10 306UNORDERED_MACRO(10,10) 307UNORDERED_MACRO(10,8) 308UNORDERED_MACRO(10,4) 309UNORDERED_MACRO(8,10) 310UNORDERED_MACRO(4,10) 311#endif 312UNORDERED_MACRO(8,8) 313UNORDERED_MACRO(8,4) 314UNORDERED_MACRO(4,8) 315UNORDERED_MACRO(4,4) 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, & 324 _gfortran_ieee_unordered_10_16, & 325#endif 326 _gfortran_ieee_unordered_16_8, & 327 _gfortran_ieee_unordered_16_4, & 328 _gfortran_ieee_unordered_8_16, & 329 _gfortran_ieee_unordered_4_16, & 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, & 336 _gfortran_ieee_unordered_4_10, & 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 389#ifdef HAVE_GFC_REAL_16 390NEXT_AFTER_MACRO(16,16) 391#ifdef HAVE_GFC_REAL_10 392NEXT_AFTER_MACRO(16,10) 393NEXT_AFTER_MACRO(10,16) 394#endif 395NEXT_AFTER_MACRO(16,8) 396NEXT_AFTER_MACRO(16,4) 397NEXT_AFTER_MACRO(8,16) 398NEXT_AFTER_MACRO(4,16) 399#endif 400#ifdef HAVE_GFC_REAL_10 401NEXT_AFTER_MACRO(10,10) 402NEXT_AFTER_MACRO(10,8) 403NEXT_AFTER_MACRO(10,4) 404NEXT_AFTER_MACRO(8,10) 405NEXT_AFTER_MACRO(4,10) 406#endif 407NEXT_AFTER_MACRO(8,8) 408NEXT_AFTER_MACRO(8,4) 409NEXT_AFTER_MACRO(4,8) 410NEXT_AFTER_MACRO(4,4) 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, & 419 _gfortran_ieee_next_after_10_16, & 420#endif 421 _gfortran_ieee_next_after_16_8, & 422 _gfortran_ieee_next_after_16_4, & 423 _gfortran_ieee_next_after_8_16, & 424 _gfortran_ieee_next_after_4_16, & 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, & 431 _gfortran_ieee_next_after_4_10, & 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 450#ifdef HAVE_GFC_REAL_16 451REM_MACRO(16,16,16) 452#ifdef HAVE_GFC_REAL_10 453REM_MACRO(16,16,10) 454REM_MACRO(16,10,16) 455#endif 456REM_MACRO(16,16,8) 457REM_MACRO(16,16,4) 458REM_MACRO(16,8,16) 459REM_MACRO(16,4,16) 460#endif 461#ifdef HAVE_GFC_REAL_10 462REM_MACRO(10,10,10) 463REM_MACRO(10,10,8) 464REM_MACRO(10,10,4) 465REM_MACRO(10,8,10) 466REM_MACRO(10,4,10) 467#endif 468REM_MACRO(8,8,8) 469REM_MACRO(8,8,4) 470REM_MACRO(8,4,8) 471REM_MACRO(4,4,4) 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, & 480 _gfortran_ieee_rem_10_16, & 481#endif 482 _gfortran_ieee_rem_16_8, & 483 _gfortran_ieee_rem_16_4, & 484 _gfortran_ieee_rem_8_16, & 485 _gfortran_ieee_rem_4_16, & 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, & 492 _gfortran_ieee_rem_4_10, & 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 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) 578 real(kind=4), intent(in) :: X 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 632 integer, intent(in) :: I 633 end function 634#endif 635#ifdef HAVE_GFC_REAL_10 636 elemental real(kind=10) function _gfortran_ieee_scalb_10_4 (X, I) 637 real(kind=10), intent(in) :: X 638 integer, intent(in) :: I 639 end function 640#endif 641 elemental real(kind=8) function _gfortran_ieee_scalb_8_4 (X, I) 642 real(kind=8), intent(in) :: X 643 integer, intent(in) :: I 644 end function 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 649 end interface 650 651 interface IEEE_SCALB 652 procedure & 653#ifdef HAVE_GFC_INTEGER_16 654#ifdef HAVE_GFC_REAL_16 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, & 666#endif 667#ifdef HAVE_GFC_REAL_10 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, & 682#endif 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 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 798SUPPORTGENERIC(IEEE_SUPPORT_DATATYPE) 799SUPPORTGENERIC(IEEE_SUPPORT_DENORMAL) 800SUPPORTGENERIC(IEEE_SUPPORT_SUBNORMAL) 801SUPPORTGENERIC(IEEE_SUPPORT_DIVIDE) 802SUPPORTGENERIC(IEEE_SUPPORT_INF) 803SUPPORTGENERIC(IEEE_SUPPORT_IO) 804SUPPORTGENERIC(IEEE_SUPPORT_NAN) 805SUPPORTGENERIC(IEEE_SUPPORT_SQRT) 806SUPPORTGENERIC(IEEE_SUPPORT_STANDARD) 807 808contains 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 920 logical flag 921 922 select case (CLASS%hidden) 923 case (1) ! IEEE_SIGNALING_NAN 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 928 res = -1 929 res = sqrt(res) 930 if (ieee_support_halting(ieee_invalid)) then 931 call ieee_set_halting_mode(ieee_invalid, flag) 932 end if 933 case (2) ! IEEE_QUIET_NAN 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 938 res = -1 939 res = sqrt(res) 940 if (ieee_support_halting(ieee_invalid)) then 941 call ieee_set_halting_mode(ieee_invalid, flag) 942 end if 943 case (3) ! IEEE_NEGATIVE_INF 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 948 res = huge(res) 949 res = (-res) * res 950 if (ieee_support_halting(ieee_overflow)) then 951 call ieee_set_halting_mode(ieee_overflow, flag) 952 end if 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 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 973 res = huge(res) 974 res = res * res 975 if (ieee_support_halting(ieee_overflow)) then 976 call ieee_set_halting_mode(ieee_overflow, flag) 977 end if 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 987 logical flag 988 989 select case (CLASS%hidden) 990 case (1) ! IEEE_SIGNALING_NAN 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 995 res = -1 996 res = sqrt(res) 997 if (ieee_support_halting(ieee_invalid)) then 998 call ieee_set_halting_mode(ieee_invalid, flag) 999 end if 1000 case (2) ! IEEE_QUIET_NAN 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 1005 res = -1 1006 res = sqrt(res) 1007 if (ieee_support_halting(ieee_invalid)) then 1008 call ieee_set_halting_mode(ieee_invalid, flag) 1009 end if 1010 case (3) ! IEEE_NEGATIVE_INF 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 1015 res = huge(res) 1016 res = (-res) * res 1017 if (ieee_support_halting(ieee_overflow)) then 1018 call ieee_set_halting_mode(ieee_overflow, flag) 1019 end if 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 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 1040 res = huge(res) 1041 res = res * res 1042 if (ieee_support_halting(ieee_overflow)) then 1043 call ieee_set_halting_mode(ieee_overflow, flag) 1044 end if 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 1055 logical flag 1056 1057 select case (CLASS%hidden) 1058 case (1) ! IEEE_SIGNALING_NAN 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 1063 res = -1 1064 res = sqrt(res) 1065 if (ieee_support_halting(ieee_invalid)) then 1066 call ieee_set_halting_mode(ieee_invalid, flag) 1067 end if 1068 case (2) ! IEEE_QUIET_NAN 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 1073 res = -1 1074 res = sqrt(res) 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 1083 res = huge(res) 1084 res = (-res) * res 1085 if (ieee_support_halting(ieee_overflow)) then 1086 call ieee_set_halting_mode(ieee_overflow, flag) 1087 end if 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 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 1108 res = huge(res) 1109 res = res * res 1110 if (ieee_support_halting(ieee_overflow)) then 1111 call ieee_set_halting_mode(ieee_overflow, flag) 1112 end if 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 1125 logical flag 1126 1127 select case (CLASS%hidden) 1128 case (1) ! IEEE_SIGNALING_NAN 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 1133 res = -1 1134 res = sqrt(res) 1135 if (ieee_support_halting(ieee_invalid)) then 1136 call ieee_set_halting_mode(ieee_invalid, flag) 1137 end if 1138 case (2) ! IEEE_QUIET_NAN 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 1143 res = -1 1144 res = sqrt(res) 1145 if (ieee_support_halting(ieee_invalid)) then 1146 call ieee_set_halting_mode(ieee_invalid, flag) 1147 end if 1148 case (3) ! IEEE_NEGATIVE_INF 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 1153 res = huge(res) 1154 res = (-res) * res 1155 if (ieee_support_halting(ieee_overflow)) then 1156 call ieee_set_halting_mode(ieee_overflow, flag) 1157 end if 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 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 1178 res = huge(res) 1179 res = res * res 1180 if (ieee_support_halting(ieee_overflow)) then 1181 call ieee_set_halting_mode(ieee_overflow, flag) 1182 end if 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 1355SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,4,.true.) 1356SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,8,.true.) 1357#ifdef HAVE_GFC_REAL_10 1358SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,10,.true.) 1359#endif 1360#ifdef HAVE_GFC_REAL_16 1361SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,16,.true.) 1362#endif 1363SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.true.) 1364 1365! IEEE_SUPPORT_DENORMAL and IEEE_SUPPORT_SUBNORMAL 1366 1367SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,4,.true.) 1368SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,8,.true.) 1369#ifdef HAVE_GFC_REAL_10 1370SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,10,.true.) 1371#endif 1372#ifdef HAVE_GFC_REAL_16 1373SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,16,.true.) 1374#endif 1375SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.true.) 1376 1377SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,4,.true.) 1378SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,8,.true.) 1379#ifdef HAVE_GFC_REAL_10 1380SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,10,.true.) 1381#endif 1382#ifdef HAVE_GFC_REAL_16 1383SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,16,.true.) 1384#endif 1385SUPPORTMACRO_NOARG(IEEE_SUPPORT_SUBNORMAL,.true.) 1386 1387! IEEE_SUPPORT_DIVIDE 1388 1389SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,4,.true.) 1390SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,8,.true.) 1391#ifdef HAVE_GFC_REAL_10 1392SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,10,.true.) 1393#endif 1394#ifdef HAVE_GFC_REAL_16 1395SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,16,.true.) 1396#endif 1397SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.true.) 1398 1399! IEEE_SUPPORT_INF 1400 1401SUPPORTMACRO(IEEE_SUPPORT_INF,4,.true.) 1402SUPPORTMACRO(IEEE_SUPPORT_INF,8,.true.) 1403#ifdef HAVE_GFC_REAL_10 1404SUPPORTMACRO(IEEE_SUPPORT_INF,10,.true.) 1405#endif 1406#ifdef HAVE_GFC_REAL_16 1407SUPPORTMACRO(IEEE_SUPPORT_INF,16,.true.) 1408#endif 1409SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.true.) 1410 1411! IEEE_SUPPORT_IO 1412 1413SUPPORTMACRO(IEEE_SUPPORT_IO,4,.true.) 1414SUPPORTMACRO(IEEE_SUPPORT_IO,8,.true.) 1415#ifdef HAVE_GFC_REAL_10 1416SUPPORTMACRO(IEEE_SUPPORT_IO,10,.true.) 1417#endif 1418#ifdef HAVE_GFC_REAL_16 1419SUPPORTMACRO(IEEE_SUPPORT_IO,16,.true.) 1420#endif 1421SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.true.) 1422 1423! IEEE_SUPPORT_NAN 1424 1425SUPPORTMACRO(IEEE_SUPPORT_NAN,4,.true.) 1426SUPPORTMACRO(IEEE_SUPPORT_NAN,8,.true.) 1427#ifdef HAVE_GFC_REAL_10 1428SUPPORTMACRO(IEEE_SUPPORT_NAN,10,.true.) 1429#endif 1430#ifdef HAVE_GFC_REAL_16 1431SUPPORTMACRO(IEEE_SUPPORT_NAN,16,.true.) 1432#endif 1433SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.true.) 1434 1435! IEEE_SUPPORT_SQRT 1436 1437SUPPORTMACRO(IEEE_SUPPORT_SQRT,4,.true.) 1438SUPPORTMACRO(IEEE_SUPPORT_SQRT,8,.true.) 1439#ifdef HAVE_GFC_REAL_10 1440SUPPORTMACRO(IEEE_SUPPORT_SQRT,10,.true.) 1441#endif 1442#ifdef HAVE_GFC_REAL_16 1443SUPPORTMACRO(IEEE_SUPPORT_SQRT,16,.true.) 1444#endif 1445SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.true.) 1446 1447! IEEE_SUPPORT_STANDARD 1448 1449SUPPORTMACRO(IEEE_SUPPORT_STANDARD,4,.true.) 1450SUPPORTMACRO(IEEE_SUPPORT_STANDARD,8,.true.) 1451#ifdef HAVE_GFC_REAL_10 1452SUPPORTMACRO(IEEE_SUPPORT_STANDARD,10,.true.) 1453#endif 1454#ifdef HAVE_GFC_REAL_16 1455SUPPORTMACRO(IEEE_SUPPORT_STANDARD,16,.true.) 1456#endif 1457SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.true.) 1458 1459end module IEEE_ARITHMETIC 1460