libgfortran/ieee/ieee_arithmetic.F90

   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
  31 module IEEE_ARITHMETIC
  32
  33   use IEEE_EXCEPTIONS
  34   implicit none
  35   private
  36
  37   ! Every public symbol from IEEE_EXCEPTIONS must be made public here
  38   public :: IEEE_FLAG_TYPE, IEEE_INVALID, IEEE_OVERFLOW, &
  39     IEEE_DIVIDE_BY_ZERO, IEEE_UNDERFLOW, IEEE_INEXACT, IEEE_USUAL, &
  40     IEEE_ALL, IEEE_STATUS_TYPE, IEEE_GET_FLAG, IEEE_GET_HALTING_MODE, &
  41     IEEE_GET_STATUS, IEEE_SET_FLAG, IEEE_SET_HALTING_MODE, &
  42     IEEE_SET_STATUS, IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING
  43
  44   ! Derived types and named constants
  45
  46   type, public :: IEEE_CLASS_TYPE
  47     private
  48     integer :: hidden
  49   end type
  50
  51   type(IEEE_CLASS_TYPE), parameter, public :: &
  52     IEEE_OTHER_VALUE       = IEEE_CLASS_TYPE(0), &
  53     IEEE_SIGNALING_NAN     = IEEE_CLASS_TYPE(1), &
  54     IEEE_QUIET_NAN         = IEEE_CLASS_TYPE(2), &
  55     IEEE_NEGATIVE_INF      = IEEE_CLASS_TYPE(3), &
  56     IEEE_NEGATIVE_NORMAL   = IEEE_CLASS_TYPE(4), &
  57     IEEE_NEGATIVE_DENORMAL = IEEE_CLASS_TYPE(5), &
  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
 235 COPYSIGN_MACRO(16,16)
 236 #ifdef HAVE_GFC_REAL_10
 237 COPYSIGN_MACRO(16,10)
 238 COPYSIGN_MACRO(10,16)
 239 #endif
 240 COPYSIGN_MACRO(16,8)
 241 COPYSIGN_MACRO(16,4)
 242 COPYSIGN_MACRO(8,16)
 243 COPYSIGN_MACRO(4,16)
 244 #endif
 245 #ifdef HAVE_GFC_REAL_10
 246 COPYSIGN_MACRO(10,10)
 247 COPYSIGN_MACRO(10,8)
 248 COPYSIGN_MACRO(10,4)
 249 COPYSIGN_MACRO(8,10)
 250 COPYSIGN_MACRO(4,10)
 251 #endif
 252 COPYSIGN_MACRO(8,8)
 253 COPYSIGN_MACRO(8,4)
 254 COPYSIGN_MACRO(4,8)
 255 COPYSIGN_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
 296 UNORDERED_MACRO(16,16)
 297 #ifdef HAVE_GFC_REAL_10
 298 UNORDERED_MACRO(16,10)
 299 UNORDERED_MACRO(10,16)
 300 #endif
 301 UNORDERED_MACRO(16,8)
 302 UNORDERED_MACRO(16,4)
 303 UNORDERED_MACRO(8,16)
 304 UNORDERED_MACRO(4,16)
 305 #endif
 306 #ifdef HAVE_GFC_REAL_10
 307 UNORDERED_MACRO(10,10)
 308 UNORDERED_MACRO(10,8)
 309 UNORDERED_MACRO(10,4)
 310 UNORDERED_MACRO(8,10)
 311 UNORDERED_MACRO(4,10)
 312 #endif
 313 UNORDERED_MACRO(8,8)
 314 UNORDERED_MACRO(8,4)
 315 UNORDERED_MACRO(4,8)
 316 UNORDERED_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
 391 NEXT_AFTER_MACRO(16,16)
 392 #ifdef HAVE_GFC_REAL_10
 393 NEXT_AFTER_MACRO(16,10)
 394 NEXT_AFTER_MACRO(10,16)
 395 #endif
 396 NEXT_AFTER_MACRO(16,8)
 397 NEXT_AFTER_MACRO(16,4)
 398 NEXT_AFTER_MACRO(8,16)
 399 NEXT_AFTER_MACRO(4,16)
 400 #endif
 401 #ifdef HAVE_GFC_REAL_10
 402 NEXT_AFTER_MACRO(10,10)
 403 NEXT_AFTER_MACRO(10,8)
 404 NEXT_AFTER_MACRO(10,4)
 405 NEXT_AFTER_MACRO(8,10)
 406 NEXT_AFTER_MACRO(4,10)
 407 #endif
 408 NEXT_AFTER_MACRO(8,8)
 409 NEXT_AFTER_MACRO(8,4)
 410 NEXT_AFTER_MACRO(4,8)
 411 NEXT_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
 452 REM_MACRO(16,16,16)
 453 #ifdef HAVE_GFC_REAL_10
 454 REM_MACRO(16,16,10)
 455 REM_MACRO(16,10,16)
 456 #endif
 457 REM_MACRO(16,16,8)
 458 REM_MACRO(16,16,4)
 459 REM_MACRO(16,8,16)
 460 REM_MACRO(16,4,16)
 461 #endif
 462 #ifdef HAVE_GFC_REAL_10
 463 REM_MACRO(10,10,10)
 464 REM_MACRO(10,10,8)
 465 REM_MACRO(10,10,4)
 466 REM_MACRO(10,8,10)
 467 REM_MACRO(10,4,10)
 468 #endif
 469 REM_MACRO(8,8,8)
 470 REM_MACRO(8,8,4)
 471 REM_MACRO(8,4,8)
 472 REM_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
 799 SUPPORTGENERIC(IEEE_SUPPORT_DATATYPE)
 800 SUPPORTGENERIC(IEEE_SUPPORT_DENORMAL)
 801 SUPPORTGENERIC(IEEE_SUPPORT_SUBNORMAL)
 802 SUPPORTGENERIC(IEEE_SUPPORT_DIVIDE)
 803 SUPPORTGENERIC(IEEE_SUPPORT_INF)
 804 SUPPORTGENERIC(IEEE_SUPPORT_IO)
 805 SUPPORTGENERIC(IEEE_SUPPORT_NAN)
 806 SUPPORTGENERIC(IEEE_SUPPORT_SQRT)
 807 SUPPORTGENERIC(IEEE_SUPPORT_STANDARD)
 808
 809 contains
 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
1356 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,4,.true.)
1357 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,8,.true.)
1358 #ifdef HAVE_GFC_REAL_10
1359 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,10,.true.)
1360 #endif
1361 #ifdef HAVE_GFC_REAL_16
1362 SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,16,.true.)
1363 #endif
1364 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.true.)
1365
1366 ! IEEE_SUPPORT_DENORMAL and IEEE_SUPPORT_SUBNORMAL
1367
1368 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,4,.true.)
1369 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,8,.true.)
1370 #ifdef HAVE_GFC_REAL_10
1371 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,10,.true.)
1372 #endif
1373 #ifdef HAVE_GFC_REAL_16
1374 SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,16,.true.)
1375 #endif
1376 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.true.)
1377
1378 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,4,.true.)
1379 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,8,.true.)
1380 #ifdef HAVE_GFC_REAL_10
1381 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,10,.true.)
1382 #endif
1383 #ifdef HAVE_GFC_REAL_16
1384 SUPPORTMACRO(IEEE_SUPPORT_SUBNORMAL,16,.true.)
1385 #endif
1386 SUPPORTMACRO_NOARG(IEEE_SUPPORT_SUBNORMAL,.true.)
1387
1388 ! IEEE_SUPPORT_DIVIDE
1389
1390 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,4,.true.)
1391 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,8,.true.)
1392 #ifdef HAVE_GFC_REAL_10
1393 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,10,.true.)
1394 #endif
1395 #ifdef HAVE_GFC_REAL_16
1396 SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,16,.true.)
1397 #endif
1398 SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.true.)
1399
1400 ! IEEE_SUPPORT_INF
1401
1402 SUPPORTMACRO(IEEE_SUPPORT_INF,4,.true.)
1403 SUPPORTMACRO(IEEE_SUPPORT_INF,8,.true.)
1404 #ifdef HAVE_GFC_REAL_10
1405 SUPPORTMACRO(IEEE_SUPPORT_INF,10,.true.)
1406 #endif
1407 #ifdef HAVE_GFC_REAL_16
1408 SUPPORTMACRO(IEEE_SUPPORT_INF,16,.true.)
1409 #endif
1410 SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.true.)
1411
1412 ! IEEE_SUPPORT_IO
1413
1414 SUPPORTMACRO(IEEE_SUPPORT_IO,4,.true.)
1415 SUPPORTMACRO(IEEE_SUPPORT_IO,8,.true.)
1416 #ifdef HAVE_GFC_REAL_10
1417 SUPPORTMACRO(IEEE_SUPPORT_IO,10,.true.)
1418 #endif
1419 #ifdef HAVE_GFC_REAL_16
1420 SUPPORTMACRO(IEEE_SUPPORT_IO,16,.true.)
1421 #endif
1422 SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.true.)
1423
1424 ! IEEE_SUPPORT_NAN
1425
1426 SUPPORTMACRO(IEEE_SUPPORT_NAN,4,.true.)
1427 SUPPORTMACRO(IEEE_SUPPORT_NAN,8,.true.)
1428 #ifdef HAVE_GFC_REAL_10
1429 SUPPORTMACRO(IEEE_SUPPORT_NAN,10,.true.)
1430 #endif
1431 #ifdef HAVE_GFC_REAL_16
1432 SUPPORTMACRO(IEEE_SUPPORT_NAN,16,.true.)
1433 #endif
1434 SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.true.)
1435
1436 ! IEEE_SUPPORT_SQRT
1437
1438 SUPPORTMACRO(IEEE_SUPPORT_SQRT,4,.true.)
1439 SUPPORTMACRO(IEEE_SUPPORT_SQRT,8,.true.)
1440 #ifdef HAVE_GFC_REAL_10
1441 SUPPORTMACRO(IEEE_SUPPORT_SQRT,10,.true.)
1442 #endif
1443 #ifdef HAVE_GFC_REAL_16
1444 SUPPORTMACRO(IEEE_SUPPORT_SQRT,16,.true.)
1445 #endif
1446 SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.true.)
1447
1448 ! IEEE_SUPPORT_STANDARD
1449
1450 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,4,.true.)
1451 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,8,.true.)
1452 #ifdef HAVE_GFC_REAL_10
1453 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,10,.true.)
1454 #endif
1455 #ifdef HAVE_GFC_REAL_16
1456 SUPPORTMACRO(IEEE_SUPPORT_STANDARD,16,.true.)
1457 #endif
1458 SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.true.)
1459
1460 end module IEEE_ARITHMETIC