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