1! Implementation of the IEEE_ARITHMETIC standard intrinsic module 2! Copyright (C) 2013-2022 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 real(kind=4), intent(in) :: X 919 type(IEEE_CLASS_TYPE), intent(in) :: CLASS 920 921 interface 922 pure real(kind=4) function _gfortrani_ieee_value_helper_4(x) 923 use ISO_C_BINDING, only: C_INT 924 integer(kind=C_INT), value :: x 925 end function 926 end interface 927 928 res = _gfortrani_ieee_value_helper_4(CLASS%hidden) 929 end function 930 931 elemental real(kind=8) function IEEE_VALUE_8(X, CLASS) result(res) 932 real(kind=8), intent(in) :: X 933 type(IEEE_CLASS_TYPE), intent(in) :: CLASS 934 935 interface 936 pure real(kind=8) function _gfortrani_ieee_value_helper_8(x) 937 use ISO_C_BINDING, only: C_INT 938 integer(kind=C_INT), value :: x 939 end function 940 end interface 941 942 res = _gfortrani_ieee_value_helper_8(CLASS%hidden) 943 end function 944 945#ifdef HAVE_GFC_REAL_10 946 elemental real(kind=10) function IEEE_VALUE_10(X, CLASS) result(res) 947 real(kind=10), intent(in) :: X 948 type(IEEE_CLASS_TYPE), intent(in) :: CLASS 949 950 interface 951 pure real(kind=10) function _gfortrani_ieee_value_helper_10(x) 952 use ISO_C_BINDING, only: C_INT 953 integer(kind=C_INT), value :: x 954 end function 955 end interface 956 957 res = _gfortrani_ieee_value_helper_10(CLASS%hidden) 958 end function 959 960#endif 961 962#ifdef HAVE_GFC_REAL_16 963 elemental real(kind=16) function IEEE_VALUE_16(X, CLASS) result(res) 964 real(kind=16), intent(in) :: X 965 type(IEEE_CLASS_TYPE), intent(in) :: CLASS 966 967 interface 968 pure real(kind=16) function _gfortrani_ieee_value_helper_16(x) 969 use ISO_C_BINDING, only: C_INT 970 integer(kind=C_INT), value :: x 971 end function 972 end interface 973 974 res = _gfortrani_ieee_value_helper_16(CLASS%hidden) 975 end function 976#endif 977 978 979 ! IEEE_GET_ROUNDING_MODE 980 981 subroutine IEEE_GET_ROUNDING_MODE (ROUND_VALUE) 982 implicit none 983 type(IEEE_ROUND_TYPE), intent(out) :: ROUND_VALUE 984 985 interface 986 integer function helper() & 987 bind(c, name="_gfortrani_get_fpu_rounding_mode") 988 end function 989 end interface 990 991 ROUND_VALUE = IEEE_ROUND_TYPE(helper()) 992 end subroutine 993 994 995 ! IEEE_SET_ROUNDING_MODE 996 997 subroutine IEEE_SET_ROUNDING_MODE (ROUND_VALUE) 998 implicit none 999 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE 1000 1001 interface 1002 subroutine helper(val) & 1003 bind(c, name="_gfortrani_set_fpu_rounding_mode") 1004 integer, value :: val 1005 end subroutine 1006 end interface 1007 1008 call helper(ROUND_VALUE%hidden) 1009 end subroutine 1010 1011 1012 ! IEEE_GET_UNDERFLOW_MODE 1013 1014 subroutine IEEE_GET_UNDERFLOW_MODE (GRADUAL) 1015 implicit none 1016 logical, intent(out) :: GRADUAL 1017 1018 interface 1019 integer function helper() & 1020 bind(c, name="_gfortrani_get_fpu_underflow_mode") 1021 end function 1022 end interface 1023 1024 GRADUAL = (helper() /= 0) 1025 end subroutine 1026 1027 1028 ! IEEE_SET_UNDERFLOW_MODE 1029 1030 subroutine IEEE_SET_UNDERFLOW_MODE (GRADUAL) 1031 implicit none 1032 logical, intent(in) :: GRADUAL 1033 1034 interface 1035 subroutine helper(val) & 1036 bind(c, name="_gfortrani_set_fpu_underflow_mode") 1037 integer, value :: val 1038 end subroutine 1039 end interface 1040 1041 call helper(merge(1, 0, GRADUAL)) 1042 end subroutine 1043 1044! IEEE_SUPPORT_ROUNDING 1045 1046 pure logical function IEEE_SUPPORT_ROUNDING_4 (ROUND_VALUE, X) result(res) 1047 implicit none 1048 real(kind=4), intent(in) :: X 1049 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE 1050 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0) 1051 end function 1052 1053 pure logical function IEEE_SUPPORT_ROUNDING_8 (ROUND_VALUE, X) result(res) 1054 implicit none 1055 real(kind=8), intent(in) :: X 1056 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE 1057 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0) 1058 end function 1059 1060#ifdef HAVE_GFC_REAL_10 1061 pure logical function IEEE_SUPPORT_ROUNDING_10 (ROUND_VALUE, X) result(res) 1062 implicit none 1063 real(kind=10), intent(in) :: X 1064 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE 1065 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0) 1066 end function 1067#endif 1068 1069#ifdef HAVE_GFC_REAL_16 1070 pure logical function IEEE_SUPPORT_ROUNDING_16 (ROUND_VALUE, X) result(res) 1071 implicit none 1072 real(kind=16), intent(in) :: X 1073 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE 1074 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0) 1075 end function 1076#endif 1077 1078 pure logical function IEEE_SUPPORT_ROUNDING_NOARG (ROUND_VALUE) result(res) 1079 implicit none 1080 type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE 1081 res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0) 1082 end function 1083 1084! IEEE_SUPPORT_UNDERFLOW_CONTROL 1085 1086 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_4 (X) result(res) 1087 implicit none 1088 real(kind=4), intent(in) :: X 1089 res = (support_underflow_control_helper(4) /= 0) 1090 end function 1091 1092 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_8 (X) result(res) 1093 implicit none 1094 real(kind=8), intent(in) :: X 1095 res = (support_underflow_control_helper(8) /= 0) 1096 end function 1097 1098#ifdef HAVE_GFC_REAL_10 1099 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_10 (X) result(res) 1100 implicit none 1101 real(kind=10), intent(in) :: X 1102 res = (support_underflow_control_helper(10) /= 0) 1103 end function 1104#endif 1105 1106#ifdef HAVE_GFC_REAL_16 1107 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_16 (X) result(res) 1108 implicit none 1109 real(kind=16), intent(in) :: X 1110 res = (support_underflow_control_helper(16) /= 0) 1111 end function 1112#endif 1113 1114 pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG () result(res) 1115 implicit none 1116 res = (support_underflow_control_helper(4) /= 0 & 1117 .and. support_underflow_control_helper(8) /= 0 & 1118#ifdef HAVE_GFC_REAL_10 1119 .and. support_underflow_control_helper(10) /= 0 & 1120#endif 1121#ifdef HAVE_GFC_REAL_16 1122 .and. support_underflow_control_helper(16) /= 0 & 1123#endif 1124 ) 1125 end function 1126 1127! IEEE_SUPPORT_* functions 1128 1129#define SUPPORTMACRO(NAME, INTKIND, VALUE) \ 1130 pure logical function NAME/**/_/**/INTKIND (X) result(res) ; \ 1131 implicit none ; \ 1132 real(INTKIND), intent(in) :: X(..) ; \ 1133 res = VALUE ; \ 1134 end function 1135 1136#define SUPPORTMACRO_NOARG(NAME, VALUE) \ 1137 pure logical function NAME/**/_NOARG () result(res) ; \ 1138 implicit none ; \ 1139 res = VALUE ; \ 1140 end function 1141 1142! IEEE_SUPPORT_DATATYPE 1143 1144SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,4,.true.) 1145SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,8,.true.) 1146#ifdef HAVE_GFC_REAL_10 1147SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,10,.true.) 1148#endif 1149#ifdef HAVE_GFC_REAL_16 1150SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,16,.true.) 1151#endif 1152SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.true.) 1153 1154! IEEE_SUPPORT_DENORMAL and IEEE_SUPPORT_SUBNORMAL 1155 1156SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,4,.true.) 1157SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,8,.true.) 1158#ifdef HAVE_GFC_REAL_10 1159SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,10,.true.) 1160#endif 1161#ifdef HAVE_GFC_REAL_16 1162SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,16,.true.) 1163#endif 1164SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.true.) 1165 1166SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,4,.true.) 1167SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,8,.true.) 1168#ifdef HAVE_GFC_REAL_10 1169SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,10,.true.) 1170#endif 1171#ifdef HAVE_GFC_REAL_16 1172SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,16,.true.) 1173#endif 1174SUPPORTMACRO_NOARG(IEEE_SUPPORT_SUBNORMAL,.true.) 1175 1176! IEEE_SUPPORT_DIVIDE 1177 1178SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,4,.true.) 1179SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,8,.true.) 1180#ifdef HAVE_GFC_REAL_10 1181SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,10,.true.) 1182#endif 1183#ifdef HAVE_GFC_REAL_16 1184SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,16,.true.) 1185#endif 1186SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.true.) 1187 1188! IEEE_SUPPORT_INF 1189 1190SUPPORTMACRO(IEEE_SUPPORT_INF,4,.true.) 1191SUPPORTMACRO(IEEE_SUPPORT_INF,8,.true.) 1192#ifdef HAVE_GFC_REAL_10 1193SUPPORTMACRO(IEEE_SUPPORT_INF,10,.true.) 1194#endif 1195#ifdef HAVE_GFC_REAL_16 1196SUPPORTMACRO(IEEE_SUPPORT_INF,16,.true.) 1197#endif 1198SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.true.) 1199 1200! IEEE_SUPPORT_IO 1201 1202SUPPORTMACRO(IEEE_SUPPORT_IO,4,.true.) 1203SUPPORTMACRO(IEEE_SUPPORT_IO,8,.true.) 1204#ifdef HAVE_GFC_REAL_10 1205SUPPORTMACRO(IEEE_SUPPORT_IO,10,.true.) 1206#endif 1207#ifdef HAVE_GFC_REAL_16 1208SUPPORTMACRO(IEEE_SUPPORT_IO,16,.true.) 1209#endif 1210SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.true.) 1211 1212! IEEE_SUPPORT_NAN 1213 1214SUPPORTMACRO(IEEE_SUPPORT_NAN,4,.true.) 1215SUPPORTMACRO(IEEE_SUPPORT_NAN,8,.true.) 1216#ifdef HAVE_GFC_REAL_10 1217SUPPORTMACRO(IEEE_SUPPORT_NAN,10,.true.) 1218#endif 1219#ifdef HAVE_GFC_REAL_16 1220SUPPORTMACRO(IEEE_SUPPORT_NAN,16,.true.) 1221#endif 1222SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.true.) 1223 1224! IEEE_SUPPORT_SQRT 1225 1226SUPPORTMACRO(IEEE_SUPPORT_SQRT,4,.true.) 1227SUPPORTMACRO(IEEE_SUPPORT_SQRT,8,.true.) 1228#ifdef HAVE_GFC_REAL_10 1229SUPPORTMACRO(IEEE_SUPPORT_SQRT,10,.true.) 1230#endif 1231#ifdef HAVE_GFC_REAL_16 1232SUPPORTMACRO(IEEE_SUPPORT_SQRT,16,.true.) 1233#endif 1234SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.true.) 1235 1236! IEEE_SUPPORT_STANDARD 1237 1238SUPPORTMACRO(IEEE_SUPPORT_STANDARD,4,.true.) 1239SUPPORTMACRO(IEEE_SUPPORT_STANDARD,8,.true.) 1240#ifdef HAVE_GFC_REAL_10 1241SUPPORTMACRO(IEEE_SUPPORT_STANDARD,10,.true.) 1242#endif 1243#ifdef HAVE_GFC_REAL_16 1244SUPPORTMACRO(IEEE_SUPPORT_STANDARD,16,.true.) 1245#endif 1246SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.true.) 1247 1248end module IEEE_ARITHMETIC 1249