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