! *
! **********************************************************************************
! * INTEL CORPORATION                                                              *
! * Copyright 2006-2012 Intel Corporation All Rights Reserved.                     *
! *                                                                                *
! * The source code contained or described herein and all documents related to     *
! * the source code ("Material") are owned by Intel Corporation or its suppliers   *
! * or licensors. Title to the Material remains with Intel Corporation or its      *
! * suppliers and licensors. The Material contains trade secrets and proprietary   *
! * and confidential information of Intel or its suppliers and licensors. The      *
! * Material is protected by worldwide copyright and trade secret laws and         *
! * treaty provisions. No part of the Material may be used, copied, reproduced,    *
! * modified, published, uploaded, posted, transmitted, distributed, or            *
! * disclosed in any way without Intel's prior express written permission.         *
! *                                                                                *
! * No license under any patent, copyright, trade secret or other intellectual     *
! * property right is granted to or conferred upon you by disclosure or delivery   *
! * of the Materials, either expressly, by implication, inducement, estoppel or    *
! * otherwise. Any license under such intellectual property rights must be         *
! * express and approved by Intel in writing.                                      *
! **********************************************************************************
! *

! **************************** Edit History ****************************************
!
! Jan-27-2008  Created 
! Apr-30-2008  Implemented needed changes of IEEE 2003 for the 11.0 beta update.
! Jun-19-2008  IEEE_LOGB has incorrect behavior.
! Sep-29-2008  Fix C_ASSOCIATED(C_NULL_PTR) returns true in mixed-language. This 
!              .obj file is moved from libifcore builds to a new ifmodintr.lib library.
! Jan-15-2009  Added BIND(C) attribute to global constant definition for portability.
! Jan-17-2009  Removed BIND(C) attribute from global constant definition.
! Mar-30-2010  Added DEFAULT attribute to global constant definition for portability.
! Feb-15-2012  Removed use of ISNAN in some classification functions to be closer to
!              the definitions of those functions in the Fortran 2008 standard.
! Aug-13-2012  Use FOR_GET_FPE to find the status of denormal support.
! **********************************************************************************

MODULE IEEE_ARITHMETIC

!DEC$ IF DEFINED(_WIN32) .OR. DEFINED(_WIN64)
!DEC$ OBJCOMMENT LIB:"ifmodintr.lib"
!DEC$ ENDIF

    USE IEEE_EXCEPTIONS
    
    IMPLICIT NONE

    PRIVATE
    PUBLIC :: &
! Derived types and constants
        IEEE_CLASS_TYPE, &
        IEEE_SIGNALING_NAN, IEEE_QUIET_NAN, IEEE_NEGATIVE_INF, &
        IEEE_NEGATIVE_NORMAL, IEEE_NEGATIVE_DENORMAL, &
        IEEE_NEGATIVE_ZERO, IEEE_POSITIVE_ZERO, &
        IEEE_POSITIVE_DENORMAL, IEEE_POSITIVE_NORMAL, &
        IEEE_POSITIVE_INF, IEEE_OTHER_VALUE, &

        IEEE_ROUND_TYPE, &
        IEEE_NEAREST, IEEE_TO_ZERO, IEEE_UP, IEEE_DOWN, IEEE_OTHER, &

! Elemental operators
        OPERATOR (==), OPERATOR (/=), &

! Inquiry functions
        IEEE_SUPPORT_DATATYPE, IEEE_SUPPORT_DENORMAL, IEEE_SUPPORT_DIVIDE, &
        IEEE_SUPPORT_INF, IEEE_SUPPORT_IO, IEEE_SUPPORT_NAN, &
        IEEE_SUPPORT_ROUNDING, IEEE_SUPPORT_SQRT, IEEE_SUPPORT_STANDARD, &
        IEEE_SUPPORT_UNDERFLOW_CONTROL, &

! Elemental functions
        IEEE_CLASS, IEEE_COPY_SIGN, IEEE_IS_FINITE, IEEE_IS_NAN, &
        IEEE_IS_NORMAL, IEEE_IS_NEGATIVE, IEEE_LOGB, IEEE_NEXT_AFTER, &
        IEEE_REM, IEEE_RINT, IEEE_SCALB, IEEE_UNORDERED, IEEE_VALUE, &

! Kind function
        IEEE_SELECTED_REAL_KIND, &

! Nonelemental subroutines
        IEEE_GET_ROUNDING_MODE, IEEE_GET_UNDERFLOW_MODE, &
        IEEE_SET_ROUNDING_MODE, IEEE_SET_UNDERFLOW_MODE
    
    INTEGER (KIND=4), PARAMETER, PUBLIC :: IEEE_ARITHMETIC_VERSION = 100

! Everything that is public in IEEE_EXCEPTIONS is public in IEEE_ARITHMETIC
    PUBLIC :: &
! Derived types and constants
        IEEE_FLAG_TYPE, &
        IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, &
        IEEE_UNDERFLOW, IEEE_INEXACT, IEEE_USUAL, IEEE_ALL, &

        IEEE_STATUS_TYPE, &

! Inquiry functions
        IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING, &

! Elemental subroutines
        IEEE_GET_FLAG, IEEE_GET_HALTING_MODE, &

! Nonelemental subroutines
        IEEE_GET_STATUS, IEEE_SET_FLAG, IEEE_SET_HALTING_MODE, IEEE_SET_STATUS

    INCLUDE 'fordef.for' 

! -----------------------------------------------------------------------------
! IEEE Arithmetic derived types
! -----------------------------------------------------------------------------    
    
! Derived type for specification of a particular rounding mode.
! The IEEE_ROUND_TYPE contains elemental operators ‘==’ and ‘/=’ which
! allows comparing two values of that type.
    TYPE IEEE_ROUND_TYPE
      PRIVATE
      SEQUENCE        
      INTEGER(4) :: IEEE_ROUND 
    END TYPE IEEE_ROUND_TYPE

! Derived type for specification of a class of floating-point values.
! The IEEE_CLASS_TYPE contains elemental operators ‘==’ and ‘/=’ which
! allows comparing two values of that type.

    TYPE IEEE_CLASS_TYPE
      PRIVATE
      SEQUENCE        
      INTEGER(4) :: IEEE_CLASS 
    END TYPE IEEE_CLASS_TYPE

! -----------------------------------------------------------------------------
! IEEE Arithmetic constants
! -----------------------------------------------------------------------------

! The following named constants specifying rounding modes in the module are
! the only possible values of the IEEE_ROUND_TYPE type:

!DEC$ OPTIONS /NOALIGN
! Rounds the exact result to the next representable value.
    TYPE(IEEE_ROUND_TYPE), PARAMETER :: IEEE_NEAREST = IEEE_ROUND_TYPE(FOR_FP_ROUND_NEAR)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_NEAREST
! Rounds the exact result towards zero to the next representable value.    
    TYPE(IEEE_ROUND_TYPE), PARAMETER :: IEEE_TO_ZERO = IEEE_ROUND_TYPE(FOR_FP_ROUND_CHOP)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_TO_ZERO
! Rounds the exact result towards +infinity to the next representable value.    
    TYPE(IEEE_ROUND_TYPE), PARAMETER :: IEEE_UP = IEEE_ROUND_TYPE(FOR_FP_ROUND_UP)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_UP
! Rounds the exact result towards -infinity to the next representable value.    
    TYPE(IEEE_ROUND_TYPE), PARAMETER :: IEEE_DOWN = IEEE_ROUND_TYPE(FOR_FP_ROUND_DOWN)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_DOWN
! Other roundings.    
    TYPE(IEEE_ROUND_TYPE), PARAMETER :: IEEE_OTHER = IEEE_ROUND_TYPE(FOR_FP_ROUND_OTHER)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_OTHER
!DEC$ END OPTIONS

! The following named constants specifying class of floating-point values in 
! the module are the only possible values of the IEEE_CLASS_TYPE type:

!DEC$ OPTIONS /NOALIGN
! Signaling non-number value.
    TYPE(IEEE_CLASS_TYPE), PARAMETER :: IEEE_SIGNALING_NAN = IEEE_CLASS_TYPE(FOR_K_FP_SNAN)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_SIGNALING_NAN
! Quiet non-number value.    
    TYPE(IEEE_CLASS_TYPE), PARAMETER :: IEEE_QUIET_NAN = IEEE_CLASS_TYPE(FOR_K_FP_QNAN)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_QUIET_NAN
! Negative infinity value.    
    TYPE(IEEE_CLASS_TYPE), PARAMETER :: IEEE_NEGATIVE_INF = IEEE_CLASS_TYPE(FOR_K_FP_NEG_INF)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_NEGATIVE_INF
! Negative normal value.    
    TYPE(IEEE_CLASS_TYPE), PARAMETER :: IEEE_NEGATIVE_NORMAL = IEEE_CLASS_TYPE(FOR_K_FP_NEG_NORM)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_NEGATIVE_NORMAL
! Negative denormalized value.    
    TYPE(IEEE_CLASS_TYPE), PARAMETER :: IEEE_NEGATIVE_DENORMAL = IEEE_CLASS_TYPE(FOR_K_FP_NEG_DENORM)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_NEGATIVE_DENORMAL
! Negative zero value.    
    TYPE(IEEE_CLASS_TYPE), PARAMETER :: IEEE_NEGATIVE_ZERO = IEEE_CLASS_TYPE(FOR_K_FP_NEG_ZERO)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_NEGATIVE_ZERO
! Positive zero value.    
    TYPE(IEEE_CLASS_TYPE), PARAMETER :: IEEE_POSITIVE_ZERO = IEEE_CLASS_TYPE(FOR_K_FP_POS_ZERO)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_POSITIVE_ZERO
! Positive denormalized value.    
    TYPE(IEEE_CLASS_TYPE), PARAMETER :: IEEE_POSITIVE_DENORMAL = IEEE_CLASS_TYPE(FOR_K_FP_POS_DENORM)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_POSITIVE_DENORMAL
! Positive normal value.    
    TYPE(IEEE_CLASS_TYPE), PARAMETER :: IEEE_POSITIVE_NORMAL = IEEE_CLASS_TYPE(FOR_K_FP_POS_NORM)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_POSITIVE_NORMAL
! Positive infinity value.    
    TYPE(IEEE_CLASS_TYPE), PARAMETER :: IEEE_POSITIVE_INF = IEEE_CLASS_TYPE(FOR_K_FP_POS_INF)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_POSITIVE_INF
! Other value.    
    TYPE(IEEE_CLASS_TYPE), PARAMETER :: IEEE_OTHER_VALUE = IEEE_CLASS_TYPE(FOR_K_FP_OTHER_VALUE)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_OTHER_VALUE
!DEC$ END OPTIONS

! -------------------------------------------------------------------------
! IEEE Arithmetic procedure interfaces
! -------------------------------------------------------------------------

    INTERFACE IEEE_CLASS
    
      MODULE PROCEDURE FOR_IEEE_CLASS_K4
      MODULE PROCEDURE FOR_IEEE_CLASS_K8
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      MODULE PROCEDURE FOR_IEEE_CLASS_K16
!DEC$ ENDIF
    END INTERFACE IEEE_CLASS
    
    INTERFACE IEEE_COPY_SIGN
    
      MODULE PROCEDURE FOR_IEEE_COPY_SIGN_K4
      MODULE PROCEDURE FOR_IEEE_COPY_SIGN_K8
      MODULE PROCEDURE FOR_IEEE_COPY_SIGN_K48
      MODULE PROCEDURE FOR_IEEE_COPY_SIGN_K84
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      MODULE PROCEDURE FOR_IEEE_COPY_SIGN_K16
      MODULE PROCEDURE FOR_IEEE_COPY_SIGN_K416
      MODULE PROCEDURE FOR_IEEE_COPY_SIGN_K816
      MODULE PROCEDURE FOR_IEEE_COPY_SIGN_K164
      MODULE PROCEDURE FOR_IEEE_COPY_SIGN_K168
!DEC$ ENDIF

    END INTERFACE IEEE_COPY_SIGN    

    INTERFACE IEEE_IS_FINITE

      MODULE PROCEDURE FOR_IEEE_IS_FINITE_K4
      MODULE PROCEDURE FOR_IEEE_IS_FINITE_K8
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      MODULE PROCEDURE FOR_IEEE_IS_FINITE_K16
!DEC$ ENDIF
    END INTERFACE IEEE_IS_FINITE

    INTERFACE IEEE_IS_NAN

      MODULE PROCEDURE FOR_IEEE_IS_NAN_K4
      MODULE PROCEDURE FOR_IEEE_IS_NAN_K8
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      MODULE PROCEDURE FOR_IEEE_IS_NAN_K16
!DEC$ ENDIF

    END INTERFACE IEEE_IS_NAN

    INTERFACE IEEE_IS_NEGATIVE

      MODULE PROCEDURE FOR_IEEE_IS_NEGATIVE_K4
      MODULE PROCEDURE FOR_IEEE_IS_NEGATIVE_K8
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      MODULE PROCEDURE FOR_IEEE_IS_NEGATIVE_K16
!DEC$ ENDIF
      
    END INTERFACE IEEE_IS_NEGATIVE

    INTERFACE IEEE_IS_NORMAL

      MODULE PROCEDURE FOR_IEEE_IS_NORMAL_K4
      MODULE PROCEDURE FOR_IEEE_IS_NORMAL_K8
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      MODULE PROCEDURE FOR_IEEE_IS_NORMAL_K16
!DEC$ ENDIF
      
    END INTERFACE IEEE_IS_NORMAL
                    
    INTERFACE IEEE_GET_ROUNDING_MODE
    
      SUBROUTINE IEEE_GET_ROUNDING_MODE_PRIV (ROUND_VALUE)
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_get_rounding_mode_' :: IEEE_GET_ROUNDING_MODE_PRIV
        IMPORT IEEE_ROUND_TYPE
        IMPLICIT NONE
        TYPE(IEEE_ROUND_TYPE), INTENT(OUT) :: ROUND_VALUE
      END SUBROUTINE 

    END INTERFACE IEEE_GET_ROUNDING_MODE

    INTERFACE IEEE_SET_ROUNDING_MODE

      SUBROUTINE IEEE_SET_ROUNDING_MODE_PRIV (ROUND_VALUE)
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_set_rounding_mode_' :: IEEE_SET_ROUNDING_MODE_PRIV
        IMPORT IEEE_ROUND_TYPE
        IMPLICIT NONE
        TYPE(IEEE_ROUND_TYPE), INTENT(IN) :: ROUND_VALUE
      END SUBROUTINE

    END INTERFACE IEEE_SET_ROUNDING_MODE
    
    INTERFACE IEEE_GET_UNDERFLOW_MODE
    
      MODULE PROCEDURE FOR_IEEE_GET_UNDERFLOW_MODE_K1
      MODULE PROCEDURE FOR_IEEE_GET_UNDERFLOW_MODE_K2
      MODULE PROCEDURE FOR_IEEE_GET_UNDERFLOW_MODE_K4
      MODULE PROCEDURE FOR_IEEE_GET_UNDERFLOW_MODE_K8
    
    END INTERFACE IEEE_GET_UNDERFLOW_MODE
    
    INTERFACE IEEE_SET_UNDERFLOW_MODE
    
      MODULE PROCEDURE FOR_IEEE_SET_UNDERFLOW_MODE_K1
      MODULE PROCEDURE FOR_IEEE_SET_UNDERFLOW_MODE_K2
      MODULE PROCEDURE FOR_IEEE_SET_UNDERFLOW_MODE_K4
      MODULE PROCEDURE FOR_IEEE_SET_UNDERFLOW_MODE_K8
    
    END INTERFACE IEEE_SET_UNDERFLOW_MODE
    
    INTERFACE IEEE_LOGB   

      MODULE PROCEDURE FOR_IEEE_LOGB_K4
      MODULE PROCEDURE FOR_IEEE_LOGB_K8
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      MODULE PROCEDURE FOR_IEEE_LOGB_K16
!DEC$ ENDIF
      
    END INTERFACE IEEE_LOGB

    INTERFACE IEEE_NEXT_AFTER

      ELEMENTAL REAL(4) FUNCTION IEEE_NEXT_AFTER_K4 (X, Y)      
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_next_after_k4_' :: IEEE_NEXT_AFTER_K4
        REAL(4), INTENT(IN) :: X
        REAL(4), INTENT(IN) :: Y        
      END FUNCTION
      
      ELEMENTAL REAL(8) FUNCTION IEEE_NEXT_AFTER_K8 (X, Y)      
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_next_after_k8_' :: IEEE_NEXT_AFTER_K8
        REAL(8), INTENT(IN) :: X
        REAL(8), INTENT(IN) :: Y         
      END FUNCTION
      
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      ELEMENTAL REAL(16) FUNCTION IEEE_NEXT_AFTER_K16 (X, Y)         
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_next_after_k16_' :: IEEE_NEXT_AFTER_K16
        REAL(16), INTENT(IN) :: X
        REAL(16), INTENT(IN) :: Y         
      END FUNCTION      
!DEC$ ENDIF

      MODULE PROCEDURE FOR_IEEE_NEXT_AFTER_K48
      MODULE PROCEDURE FOR_IEEE_NEXT_AFTER_K84
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      MODULE PROCEDURE FOR_IEEE_NEXT_AFTER_K416
      MODULE PROCEDURE FOR_IEEE_NEXT_AFTER_K816
      MODULE PROCEDURE FOR_IEEE_NEXT_AFTER_K164
      MODULE PROCEDURE FOR_IEEE_NEXT_AFTER_K168
!DEC$ ENDIF
      
    END INTERFACE IEEE_NEXT_AFTER
    
    INTERFACE IEEE_REM

      ELEMENTAL REAL(4) FUNCTION IEEE_REM_K4 (X, Y)      
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_rem_k4_' :: IEEE_REM_K4
        REAL(4), INTENT(IN) :: X
        REAL(4), INTENT(IN) :: Y        
      END FUNCTION
      
      ELEMENTAL REAL(8) FUNCTION IEEE_REM_K8 (X, Y)      
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_rem_k8_' :: IEEE_REM_K8
        REAL(8), INTENT(IN) :: X
        REAL(8), INTENT(IN) :: Y         
      END FUNCTION
      
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      ELEMENTAL REAL(16) FUNCTION IEEE_REM_K16 (X, Y)         
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_rem_k16_' :: IEEE_REM_K16
        REAL(16), INTENT(IN) :: X
        REAL(16), INTENT(IN) :: Y         
      END FUNCTION      
!DEC$ ENDIF

      MODULE PROCEDURE FOR_IEEE_REM_K48
      MODULE PROCEDURE FOR_IEEE_REM_K84
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      MODULE PROCEDURE FOR_IEEE_REM_K416
      MODULE PROCEDURE FOR_IEEE_REM_K816
      MODULE PROCEDURE FOR_IEEE_REM_K164
      MODULE PROCEDURE FOR_IEEE_REM_K168
!DEC$ ENDIF
      
    END INTERFACE IEEE_REM
    
    INTERFACE IEEE_RINT

      ELEMENTAL REAL(4) FUNCTION IEEE_RINT_K4 (X)      
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_rint_k4_' :: IEEE_RINT_K4
        REAL(4), INTENT(IN) :: X
      END FUNCTION    

      ELEMENTAL REAL(8) FUNCTION IEEE_RINT_K8 (X)      
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_rint_k8_' :: IEEE_RINT_K8
        REAL(8), INTENT(IN) :: X
      END FUNCTION
      
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      ELEMENTAL REAL(16) FUNCTION IEEE_RINT_K16 (X)         
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_rint_k16_' :: IEEE_RINT_K16
        REAL(16), INTENT(IN) :: X
      END FUNCTION
!DEC$ ENDIF

    END INTERFACE IEEE_RINT    

    INTERFACE IEEE_SCALB
    
      ELEMENTAL REAL(4) FUNCTION IEEE_SCALB_K44 (X, I)      
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_scalb_k44_' :: IEEE_SCALB_K44
        REAL(4), INTENT(IN) :: X
        INTEGER(4), INTENT(IN) :: I        
      END FUNCTION
      
      ELEMENTAL REAL(8) FUNCTION IEEE_SCALB_K84 (X, I)      
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_scalb_k84_' :: IEEE_SCALB_K84
        REAL(8), INTENT(IN) :: X
        INTEGER(4), INTENT(IN) :: I
      END FUNCTION
      
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      ELEMENTAL REAL(16) FUNCTION IEEE_SCALB_K164 (X, I)         
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_scalb_k164_' :: IEEE_SCALB_K164
        REAL(16), INTENT(IN) :: X
        INTEGER(4), INTENT(IN) :: I         
      END FUNCTION
!DEC$ ENDIF

      MODULE PROCEDURE FOR_IEEE_SCALB_K41 
      MODULE PROCEDURE FOR_IEEE_SCALB_K42
      MODULE PROCEDURE FOR_IEEE_SCALB_K48
      MODULE PROCEDURE FOR_IEEE_SCALB_K81
      MODULE PROCEDURE FOR_IEEE_SCALB_K82
      MODULE PROCEDURE FOR_IEEE_SCALB_K88
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      MODULE PROCEDURE FOR_IEEE_SCALB_K161
      MODULE PROCEDURE FOR_IEEE_SCALB_K162
      MODULE PROCEDURE FOR_IEEE_SCALB_K168
!DEC$ ENDIF
      
    END INTERFACE IEEE_SCALB

    INTERFACE IEEE_SELECTED_REAL_KIND

      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K11
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K12
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K14
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K18
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K21
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K22
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K24
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K28
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K41
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K42
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K44
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K48
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K81
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K82
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K84
      MODULE PROCEDURE FOR_IEEE_SELECTED_REAL_KIND_K88

    END INTERFACE IEEE_SELECTED_REAL_KIND

    INTERFACE IEEE_SUPPORT_DATATYPE   

      MODULE PROCEDURE FOR_IEEE_SUPPORT_DATATYPE
      MODULE PROCEDURE FOR_IEEE_SUPPORT_DATATYPE_ALL

    END INTERFACE IEEE_SUPPORT_DATATYPE    

    INTERFACE IEEE_SUPPORT_DENORMAL   

      MODULE PROCEDURE FOR_IEEE_SUPPORT_DENORMAL
      MODULE PROCEDURE FOR_IEEE_SUPPORT_DENORMAL_ALL

    END INTERFACE IEEE_SUPPORT_DENORMAL
    
    INTERFACE IEEE_SUPPORT_DIVIDE   

      MODULE PROCEDURE FOR_IEEE_SUPPORT_DIVIDE
      MODULE PROCEDURE FOR_IEEE_SUPPORT_DIVIDE_ALL

    END INTERFACE IEEE_SUPPORT_DIVIDE
    
    INTERFACE IEEE_SUPPORT_INF   

      MODULE PROCEDURE FOR_IEEE_SUPPORT_INF
      MODULE PROCEDURE FOR_IEEE_SUPPORT_INF_ALL

    END INTERFACE IEEE_SUPPORT_INF
    
    INTERFACE IEEE_SUPPORT_IO   

      MODULE PROCEDURE FOR_IEEE_SUPPORT_IO
      MODULE PROCEDURE FOR_IEEE_SUPPORT_IO_ALL

    END INTERFACE IEEE_SUPPORT_IO
    
    INTERFACE IEEE_SUPPORT_NAN  

      MODULE PROCEDURE FOR_IEEE_SUPPORT_NAN
      MODULE PROCEDURE FOR_IEEE_SUPPORT_NAN_ALL

    END INTERFACE IEEE_SUPPORT_NAN

    INTERFACE IEEE_SUPPORT_ROUNDING   

      MODULE PROCEDURE FOR_IEEE_SUPPORT_ROUNDING
      MODULE PROCEDURE FOR_IEEE_SUPPORT_ROUNDING_ALL

    END INTERFACE IEEE_SUPPORT_ROUNDING
    
    INTERFACE IEEE_SUPPORT_SQRT   

      MODULE PROCEDURE FOR_IEEE_SUPPORT_SQRT
      MODULE PROCEDURE FOR_IEEE_SUPPORT_SQRT_ALL

    END INTERFACE IEEE_SUPPORT_SQRT
    
    INTERFACE IEEE_SUPPORT_STANDARD   

      MODULE PROCEDURE FOR_IEEE_SUPPORT_STANDARD
      MODULE PROCEDURE FOR_IEEE_SUPPORT_STANDARD_ALL

    END INTERFACE IEEE_SUPPORT_STANDARD    

    INTERFACE IEEE_SUPPORT_UNDERFLOW_CONTROL   

      MODULE PROCEDURE FOR_IEEE_SUPPORT_UNDERFLOW_CONTROL
      MODULE PROCEDURE FOR_IEEE_SUPPORT_UNDERFLOW_CONTROL_ALL
  
    END INTERFACE IEEE_SUPPORT_UNDERFLOW_CONTROL

    INTERFACE IEEE_UNORDERED

      MODULE PROCEDURE FOR_IEEE_UNORDERED_K4
      MODULE PROCEDURE FOR_IEEE_UNORDERED_K48
      MODULE PROCEDURE FOR_IEEE_UNORDERED_K84
      MODULE PROCEDURE FOR_IEEE_UNORDERED_K8
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      MODULE PROCEDURE FOR_IEEE_UNORDERED_K416
      MODULE PROCEDURE FOR_IEEE_UNORDERED_K816
      MODULE PROCEDURE FOR_IEEE_UNORDERED_K164
      MODULE PROCEDURE FOR_IEEE_UNORDERED_K168
      MODULE PROCEDURE FOR_IEEE_UNORDERED_K16
!DEC$ ENDIF
      
    END INTERFACE IEEE_UNORDERED
    
    INTERFACE IEEE_VALUE   

      MODULE PROCEDURE FOR_IEEE_VALUE_K4
      MODULE PROCEDURE FOR_IEEE_VALUE_K8
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
      MODULE PROCEDURE FOR_IEEE_VALUE_K16
!DEC$ ENDIF

    END INTERFACE IEEE_VALUE    

    INTERFACE OPERATOR (==)
      MODULE PROCEDURE FOR_IEEE_ROUND_EQ
      MODULE PROCEDURE FOR_IEEE_CLASS_EQ
    END INTERFACE OPERATOR (==)
    
    INTERFACE OPERATOR (/=)
      MODULE PROCEDURE FOR_IEEE_ROUND_NEQ
      MODULE PROCEDURE FOR_IEEE_CLASS_NEQ
    END INTERFACE OPERATOR (/=)

! -----------------------------------------------------------------------------
! PROCEDURES
! -----------------------------------------------------------------------------
    CONTAINS

!------------------------------------------------------------------------------
! Description: The elemental operator == for two values of the IEEE_ROUND_TYPE 
!   type return true if the values are the same and false otherwise.     
!
! Arguments:
! LP - IEEE_ROUND_TYPE type value or IEEE_ROUND_TYPE type array.
! RP - IEEE_ROUND_TYPE type value or IEEE_ROUND_TYPE type array.
!------------------------------------------------------------------------------
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_ROUND_EQ (LP, RP)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_ROUND_EQ    
      TYPE(IEEE_ROUND_TYPE), INTENT(IN) :: LP, RP
      
      IF ( LP%IEEE_ROUND == RP%IEEE_ROUND) THEN
        FOR_IEEE_ROUND_EQ = .TRUE.
      ELSE
        FOR_IEEE_ROUND_EQ = .FALSE.
      END IF
    END FUNCTION FOR_IEEE_ROUND_EQ

!------------------------------------------------------------------------------
! Description: The elemental operator /= for two values of the IEEE_ROUND_TYPE 
!   type return true if the values differ and false otherwise.     
!
! Arguments:
! LP - IEEE_ROUND_TYPE type value or IEEE_ROUND_TYPE type array.
! RP - IEEE_ROUND_TYPE type value or IEEE_ROUND_TYPE type array.
!------------------------------------------------------------------------------
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_ROUND_NEQ (LP, RP)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_ROUND_NEQ    
      TYPE(IEEE_ROUND_TYPE), INTENT(IN) :: LP, RP
      
      IF ( LP%IEEE_ROUND /= RP%IEEE_ROUND) THEN
        FOR_IEEE_ROUND_NEQ = .TRUE.
      ELSE
        FOR_IEEE_ROUND_NEQ = .FALSE.
      END IF
    END FUNCTION FOR_IEEE_ROUND_NEQ
    
!------------------------------------------------------------------------------
! Description: The elemental operator == for two values of the IEEE_CLASS_TYPE 
!   type return true if the values are the same and false otherwise.     
!
! Arguments:
! LP - IEEE_CLASS_TYPE type value or IEEE_CLASS_TYPE type array.
! RP - IEEE_CLASS_TYPE type value or IEEE_CLASS_TYPE type array.
!------------------------------------------------------------------------------
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_CLASS_EQ (LP, RP)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_CLASS_EQ    
      TYPE(IEEE_CLASS_TYPE), INTENT(IN) :: LP, RP
      
      IF ( LP%IEEE_CLASS == RP%IEEE_CLASS) THEN
        FOR_IEEE_CLASS_EQ = .TRUE.
      ELSE
        FOR_IEEE_CLASS_EQ = .FALSE.
      END IF
    END FUNCTION FOR_IEEE_CLASS_EQ

!------------------------------------------------------------------------------
! Description: The elemental operator /= for two values of the IEEE_CLASS_TYPE 
!   type return true if the values differ and false otherwise.     
!
! Arguments:
! LP - IEEE_CLASS_TYPE type value or IEEE_CLASS_TYPE type array.
! RP - IEEE_CLASS_TYPE type value or IEEE_CLASS_TYPE type array.
!------------------------------------------------------------------------------
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_CLASS_NEQ (LP, RP)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_CLASS_NEQ    
      TYPE(IEEE_CLASS_TYPE), INTENT(IN) :: LP, RP
      
      IF ( LP%IEEE_CLASS /= RP%IEEE_CLASS) THEN
        FOR_IEEE_CLASS_NEQ = .TRUE.
      ELSE
        FOR_IEEE_CLASS_NEQ = .FALSE.
      END IF
    END FUNCTION FOR_IEEE_CLASS_NEQ

!-------------------------------------------------------------------------------
! Description: IEEE_CLASS function.
!
! Argument:
! X - real value or real array.
!
! Result Value: The result value will be IEEE_SIGNALING_NAN or IEEE_QUIET_NAN if 
!   the value of X is a signaling or quiet NaN, respectively. The result value 
!   will be IEEE_NEGATIVE_INF or IEEE_POSITIVE_INF if the value of X is negative 
!   or positive infinity, respectively. The result value will be 
!   IEEE_NEGATIVE_DENORMAL or IEEE_POSITIVE_DENORMAL if the value of X is a 
!   negative or positive denormalized value, respectively. The result value will 
!   be IEEE_NEGATIVE_NORMAL, IEEE_NEGATIVE_ZERO, IEEE_POSITIVE_ZERO, or 
!   IEEE_POSITIVE_NORMAL if value of X is negative normal, negative zero, 
!   positive zero, or positive normal, respectively.
!-------------------------------------------------------------------------------
    ELEMENTAL TYPE(IEEE_CLASS_TYPE) FUNCTION FOR_IEEE_CLASS_K4 (X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_CLASS_K4    
      IMPLICIT NONE
      REAL(4), INTENT(IN) :: X
      
      FOR_IEEE_CLASS_K4 = IEEE_OTHER_VALUE
      SELECT CASE (FP_CLASS(X))
      CASE (FOR_K_FP_SNAN)
        FOR_IEEE_CLASS_K4 = IEEE_SIGNALING_NAN
      CASE (FOR_K_FP_QNAN)
        FOR_IEEE_CLASS_K4 = IEEE_QUIET_NAN
      CASE (FOR_K_FP_POS_INF)
        FOR_IEEE_CLASS_K4 = IEEE_POSITIVE_INF
      CASE (FOR_K_FP_NEG_INF)
        FOR_IEEE_CLASS_K4 = IEEE_NEGATIVE_INF
      CASE (FOR_K_FP_POS_NORM)
        FOR_IEEE_CLASS_K4 = IEEE_POSITIVE_NORMAL
      CASE (FOR_K_FP_NEG_NORM)
        FOR_IEEE_CLASS_K4 = IEEE_NEGATIVE_NORMAL
      CASE (FOR_K_FP_POS_DENORM)
        FOR_IEEE_CLASS_K4 = IEEE_POSITIVE_DENORMAL
      CASE (FOR_K_FP_NEG_DENORM)
        FOR_IEEE_CLASS_K4 = IEEE_NEGATIVE_DENORMAL
      CASE (FOR_K_FP_POS_ZERO)
        FOR_IEEE_CLASS_K4 = IEEE_POSITIVE_ZERO
      CASE (FOR_K_FP_NEG_ZERO)
        FOR_IEEE_CLASS_K4 = IEEE_NEGATIVE_ZERO
      END SELECT                
    END FUNCTION

    ELEMENTAL TYPE(IEEE_CLASS_TYPE) FUNCTION FOR_IEEE_CLASS_K8 (X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_CLASS_K8    
      IMPLICIT NONE
      REAL(8), INTENT(IN) :: X
      
      FOR_IEEE_CLASS_K8 = IEEE_OTHER_VALUE
      SELECT CASE (FP_CLASS(X))
      CASE (FOR_K_FP_SNAN)
        FOR_IEEE_CLASS_K8 = IEEE_SIGNALING_NAN
      CASE (FOR_K_FP_QNAN)
        FOR_IEEE_CLASS_K8 = IEEE_QUIET_NAN
      CASE (FOR_K_FP_POS_INF)
        FOR_IEEE_CLASS_K8 = IEEE_POSITIVE_INF
      CASE (FOR_K_FP_NEG_INF)
        FOR_IEEE_CLASS_K8 = IEEE_NEGATIVE_INF
      CASE (FOR_K_FP_POS_NORM)
        FOR_IEEE_CLASS_K8 = IEEE_POSITIVE_NORMAL
      CASE (FOR_K_FP_NEG_NORM)
        FOR_IEEE_CLASS_K8 = IEEE_NEGATIVE_NORMAL
      CASE (FOR_K_FP_POS_DENORM)
        FOR_IEEE_CLASS_K8 = IEEE_POSITIVE_DENORMAL
      CASE (FOR_K_FP_NEG_DENORM)
        FOR_IEEE_CLASS_K8 = IEEE_NEGATIVE_DENORMAL
      CASE (FOR_K_FP_POS_ZERO)
        FOR_IEEE_CLASS_K8 = IEEE_POSITIVE_ZERO
      CASE (FOR_K_FP_NEG_ZERO)
        FOR_IEEE_CLASS_K8 = IEEE_NEGATIVE_ZERO
      END SELECT                      
    END FUNCTION

!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL TYPE(IEEE_CLASS_TYPE) FUNCTION FOR_IEEE_CLASS_K16 (X)         
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_CLASS_K16
      IMPLICIT NONE
      REAL(16), INTENT(IN) :: X

      FOR_IEEE_CLASS_K16 = IEEE_OTHER_VALUE     
      SELECT CASE (FP_CLASS(X))
      CASE (FOR_K_FP_SNAN)
        FOR_IEEE_CLASS_K16 = IEEE_SIGNALING_NAN
      CASE (FOR_K_FP_QNAN)
        FOR_IEEE_CLASS_K16 = IEEE_QUIET_NAN
      CASE (FOR_K_FP_POS_INF)
        FOR_IEEE_CLASS_K16 = IEEE_POSITIVE_INF
      CASE (FOR_K_FP_NEG_INF)
        FOR_IEEE_CLASS_K16 = IEEE_NEGATIVE_INF
      CASE (FOR_K_FP_POS_NORM)
        FOR_IEEE_CLASS_K16 = IEEE_POSITIVE_NORMAL
      CASE (FOR_K_FP_NEG_NORM)
        FOR_IEEE_CLASS_K16 = IEEE_NEGATIVE_NORMAL
      CASE (FOR_K_FP_POS_DENORM)
        FOR_IEEE_CLASS_K16 = IEEE_POSITIVE_DENORMAL
      CASE (FOR_K_FP_NEG_DENORM)
        FOR_IEEE_CLASS_K16 = IEEE_NEGATIVE_DENORMAL
      CASE (FOR_K_FP_POS_ZERO)
        FOR_IEEE_CLASS_K16 = IEEE_POSITIVE_ZERO
      CASE (FOR_K_FP_NEG_ZERO)
        FOR_IEEE_CLASS_K16 = IEEE_NEGATIVE_ZERO
      END SELECT                      
    END FUNCTION
!DEC$ ENDIF    
!-------------------------------------------------------------------------------
! Description: IEEE copysign function.
!
! Arguments:
! X - real value or real array.
! Y - real value or real array.
!
! Result Value: The result has the value of X with the sign of Y. This is true 
!   even for IEEE special values, such as a NaN or an infinity.
!-------------------------------------------------------------------------------
    ELEMENTAL REAL(4) FUNCTION FOR_IEEE_COPY_SIGN_K4 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_COPY_SIGN_K4
      REAL(4), INTENT(IN) :: X
      REAL(4), INTENT(IN) :: Y
      REAL(4)  R1,R2
      INTEGER(4), DIMENSION(1) :: EI1,EI2

      EQUIVALENCE (R1, EI1)
      EQUIVALENCE (R2, EI2)

! Sign position.       

      INTEGER(4), PARAMETER :: SIGN_POS = BIT_SIZE(SIGN_POS)-1

! Quiet NAN, single precision.      

      REAL(4), PARAMETER :: FOR_S_QNAN         = TRANSFER((/ Z'7FC00000' /),1.0_4)      

      R1 = X
      R2 = Y

      IF (ISNAN(X) .OR. ISNAN(Y)) THEN
        FOR_IEEE_COPY_SIGN_K4 = FOR_S_QNAN
        CALL IEEE_SET_FLAG(IEEE_INVALID, .TRUE.)

      ELSE            
        IF (BTEST(EI2(1), SIGN_POS)) THEN
          EI1(1) = IBSET(EI1(1), SIGN_POS)
        ELSE
          EI1(1) = IBCLR(EI1(1), SIGN_POS)
        ENDIF

        FOR_IEEE_COPY_SIGN_K4 = R1
      ENDIF
      
    END FUNCTION
      
    ELEMENTAL REAL(8) FUNCTION FOR_IEEE_COPY_SIGN_K8 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_COPY_SIGN_K8
      REAL(8), INTENT(IN) :: X
      REAL(8), INTENT(IN) :: Y
      REAL(8)  R1,R2
      INTEGER(8), DIMENSION(1) :: EI1,EI2

      EQUIVALENCE (R1, EI1)
      EQUIVALENCE (R2, EI2)

! Sign position.       

      INTEGER(8), PARAMETER :: SIGN_POS = BIT_SIZE(SIGN_POS)-1

! Quiet NAN, double precision.

      REAL(8), PARAMETER :: FOR_D_QNAN = &
      TRANSFER((/ Z'00000000', Z'7FF80000' /),1.0_8)      

      R1 = X
      R2 = Y

      IF (ISNAN(X) .OR. ISNAN(Y)) THEN
        FOR_IEEE_COPY_SIGN_K8 = FOR_D_QNAN
        CALL IEEE_SET_FLAG(IEEE_INVALID, .TRUE.)
      ELSE       
        IF (BTEST(EI2(1), SIGN_POS)) THEN
          EI1(1) = IBSET(EI1(1), SIGN_POS)
        ELSE
          EI1(1) = IBCLR(EI1(1), SIGN_POS)
        ENDIF

        FOR_IEEE_COPY_SIGN_K8 = R1        
      ENDIF
      
    END FUNCTION
      
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL REAL(16) FUNCTION FOR_IEEE_COPY_SIGN_K16 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_COPY_SIGN_K16
      REAL(16), INTENT(IN) :: X
      REAL(16), INTENT(IN) :: Y
      REAL(16)  R1,R2

      INTEGER(8), DIMENSION(2) :: EI1,EI2
      EQUIVALENCE (R1, EI1)
      EQUIVALENCE (R2, EI2)

! Sign position.       

      INTEGER(8), PARAMETER :: SIGN_POS = BIT_SIZE(SIGN_POS)-1

! Quiet NAN, extended double precision.        

      REAL(16), PARAMETER :: FOR_Q_QNAN = &

      TRANSFER((/ Z'00000000', Z'00000000', Z'00000000', Z'7FFF8000' /),1.0_16)      

      R1 = X
      R2 = Y

      IF (ISNAN(X) .OR. ISNAN(Y)) THEN
        FOR_IEEE_COPY_SIGN_K16 = FOR_Q_QNAN
        CALL IEEE_SET_FLAG(IEEE_INVALID, .TRUE.)
      ELSE       
        IF (BTEST(EI2(2), SIGN_POS)) THEN
          EI1(2) = IBSET(EI1(2), SIGN_POS)
        ELSE
          EI1(2) = IBCLR(EI1(2), SIGN_POS)
        ENDIF

        FOR_IEEE_COPY_SIGN_K16 = R1
      ENDIF
            
    END FUNCTION
!DEC$ ENDIF
      
    ELEMENTAL REAL(4) FUNCTION FOR_IEEE_COPY_SIGN_K48 (X, Y)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_COPY_SIGN_K48
      REAL(4), INTENT(IN) :: X
      REAL(8), INTENT(IN) :: Y
      
      FOR_IEEE_COPY_SIGN_K48 = FOR_IEEE_COPY_SIGN_K4(X, REAL(Y, 4))
    END FUNCTION

!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL REAL(4) FUNCTION FOR_IEEE_COPY_SIGN_K416 (X, Y)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_COPY_SIGN_K416
      REAL(4), INTENT(IN) :: X
      REAL(16), INTENT(IN) :: Y
      
      FOR_IEEE_COPY_SIGN_K416 = FOR_IEEE_COPY_SIGN_K4(X, REAL(Y, 4))
    END FUNCTION
!DEC$ ENDIF
            
    ELEMENTAL REAL(8) FUNCTION FOR_IEEE_COPY_SIGN_K84 (X, Y)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_COPY_SIGN_K84
      REAL(8), INTENT(IN) :: X
      REAL(4), INTENT(IN) :: Y
      
      FOR_IEEE_COPY_SIGN_K84 = FOR_IEEE_COPY_SIGN_K8(X, REAL(Y, 8))
    END FUNCTION
      
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL REAL(8) FUNCTION FOR_IEEE_COPY_SIGN_K816 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_COPY_SIGN_K816
      REAL(8), INTENT(IN) :: X
      REAL(16), INTENT(IN) :: Y
      
      FOR_IEEE_COPY_SIGN_K816 = FOR_IEEE_COPY_SIGN_K8(X, REAL(Y, 8))      
    END FUNCTION
      
    ELEMENTAL REAL(16) FUNCTION FOR_IEEE_COPY_SIGN_K164 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_COPY_SIGN_K164
      REAL(16), INTENT(IN) :: X
      REAL(4), INTENT(IN) :: Y
     
      FOR_IEEE_COPY_SIGN_K164 = FOR_IEEE_COPY_SIGN_K16(X, REAL(Y, 16))      
    END FUNCTION
      
    ELEMENTAL REAL(16) FUNCTION FOR_IEEE_COPY_SIGN_K168 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_COPY_SIGN_K168
      REAL(16), INTENT(IN) :: X
      REAL(8), INTENT(IN) :: Y
      
      FOR_IEEE_COPY_SIGN_K168 = FOR_IEEE_COPY_SIGN_K16(X, REAL(Y, 16))
    END FUNCTION
!DEC$ ENDIF

!-------------------------------------------------------------------------------
! Description: Get the current underflow mode.
!
! Argument:
! GRADUAL - value is true if the current underflow mode is “gradual
!   underflow", and false if the current underflow mode is “abrupt underflow”.
!-------------------------------------------------------------------------------
    SUBROUTINE FOR_IEEE_GET_UNDERFLOW_MODE_K1 (GRADUAL)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_GET_UNDERFLOW_MODE_K1
      USE IFCORE
      IMPLICIT NONE    
      LOGICAL(1), INTENT(OUT) :: GRADUAL
      
      IF (IAND(FOR_GET_FPE(), FPE_M_ABRUPT_UND) == 0) THEN
        GRADUAL = .TRUE.
      ELSE
        GRADUAL = .FALSE.
      ENDIF
    END SUBROUTINE
    
    SUBROUTINE FOR_IEEE_GET_UNDERFLOW_MODE_K2 (GRADUAL)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_GET_UNDERFLOW_MODE_K2
      USE IFCORE
      IMPLICIT NONE    
      LOGICAL(2), INTENT(OUT) :: GRADUAL
      
      IF (IAND(FOR_GET_FPE(), FPE_M_ABRUPT_UND) == 0) THEN
        GRADUAL = .TRUE.
      ELSE
        GRADUAL = .FALSE.
      ENDIF
    END SUBROUTINE
    
    SUBROUTINE FOR_IEEE_GET_UNDERFLOW_MODE_K4 (GRADUAL)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_GET_UNDERFLOW_MODE_K4
      USE IFCORE
      IMPLICIT NONE    
      LOGICAL(4), INTENT(OUT) :: GRADUAL
      
      IF (IAND(FOR_GET_FPE(), FPE_M_ABRUPT_UND) == 0) THEN
        GRADUAL = .TRUE.
      ELSE
        GRADUAL = .FALSE.
      ENDIF
    END SUBROUTINE
    
    SUBROUTINE FOR_IEEE_GET_UNDERFLOW_MODE_K8 (GRADUAL)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_GET_UNDERFLOW_MODE_K8
      USE IFCORE
      IMPLICIT NONE    
      LOGICAL(8), INTENT(OUT) :: GRADUAL
      
      IF (IAND(FOR_GET_FPE(), FPE_M_ABRUPT_UND) == 0) THEN
        GRADUAL = .TRUE.
      ELSE
        GRADUAL = .FALSE.
      ENDIF
    END SUBROUTINE

!-------------------------------------------------------------------------------
! Description: Determine if a value is finite.
!
! Argument:
! X - real value or real array.
!
! Result Value: The result has the value true if the value of X is finite, that 
!   is, IEEE_CLASS(X) has one of the values IEEE_NEGATIVE_NORMAL, 
!   IEEE_NEGATIVE_DENORMAL, IEEE_NEGATIVE_ZERO, IEEE_POSITIVE_ZERO, 
!   IEEE_POSITIVE_DENORMAL, or IEEE_POSITIVE_NORMAL; otherwise, the result has 
!   the value false.
!-------------------------------------------------------------------------------

    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_IS_FINITE_K4 (X)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_IS_FINITE_K4
      REAL(4), INTENT(IN) :: X
      INTEGER(4) CL
      
      CL = FP_CLASS(X)
      IF (CL == FOR_K_FP_NEG_NORM   .OR. &
          CL == FOR_K_FP_NEG_DENORM .OR. &
          CL == FOR_K_FP_NEG_ZERO   .OR. &
          CL == FOR_K_FP_POS_ZERO   .OR. &
          CL == FOR_K_FP_POS_DENORM .OR. &
          CL == FOR_K_FP_POS_NORM ) THEN
        FOR_IEEE_IS_FINITE_K4 = .TRUE.
      ELSE
        FOR_IEEE_IS_FINITE_K4 = .FALSE.
      ENDIF
      
    END FUNCTION    

    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_IS_FINITE_K8 (X)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_IS_FINITE_K8
      REAL(8), INTENT(IN) :: X
      INTEGER(4) CL
      
      CL = FP_CLASS(X)
      IF (CL == FOR_K_FP_NEG_NORM   .OR. &
          CL == FOR_K_FP_NEG_DENORM .OR. &
          CL == FOR_K_FP_NEG_ZERO   .OR. &
          CL == FOR_K_FP_POS_ZERO   .OR. &
          CL == FOR_K_FP_POS_DENORM .OR. &
          CL == FOR_K_FP_POS_NORM ) THEN
        FOR_IEEE_IS_FINITE_K8 = .TRUE.
      ELSE
        FOR_IEEE_IS_FINITE_K8 = .FALSE.
      ENDIF
            
    END FUNCTION
      
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_IS_FINITE_K16 (X)         
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_IS_FINITE_K16
      REAL(16), INTENT(IN) :: X
      INTEGER(4) CL
      
      CL = FP_CLASS(X)
      IF (CL == FOR_K_FP_NEG_NORM   .OR. &
          CL == FOR_K_FP_NEG_DENORM .OR. &
          CL == FOR_K_FP_NEG_ZERO   .OR. &
          CL == FOR_K_FP_POS_ZERO   .OR. &
          CL == FOR_K_FP_POS_DENORM .OR. &
          CL == FOR_K_FP_POS_NORM ) THEN
        FOR_IEEE_IS_FINITE_K16 = .TRUE.
      ELSE
        FOR_IEEE_IS_FINITE_K16 = .FALSE.
      ENDIF
            
    END FUNCTION
!DEC$ ENDIF
!-------------------------------------------------------------------------------
! Description: Determine if a value is IEEE Not-a-Number.
!
! Argument:
! X - real value or real array.
!
! Result Value: The result has the value true if the value of X is an IEEE NaN; 
!    otherwise, it has the value false.
!-------------------------------------------------------------------------------
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_IS_NAN_K4 (X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_IS_NAN_K4
      REAL(4), INTENT(IN) :: X
      INTEGER(4) CL

      CL = FP_CLASS(X)
      IF (CL == FOR_K_FP_SNAN .OR. &
          CL == FOR_K_FP_QNAN) THEN
        FOR_IEEE_IS_NAN_K4 = .TRUE.
      ELSE
        FOR_IEEE_IS_NAN_K4 = .FALSE.
      ENDIF

    END FUNCTION
    
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_IS_NAN_K8 (X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_IS_NAN_K8    
      REAL(8), INTENT(IN) :: X
      INTEGER(4) CL
      
      CL = FP_CLASS(X)
      IF (CL == FOR_K_FP_SNAN .OR. &
          CL == FOR_K_FP_QNAN) THEN
        FOR_IEEE_IS_NAN_K8 = .TRUE.
      ELSE
        FOR_IEEE_IS_NAN_K8 = .FALSE.
      ENDIF

    END FUNCTION
      
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_IS_NAN_K16 (X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_IS_NAN_K16    
      REAL(16), INTENT(IN) :: X
      INTEGER(4) CL
      
      CL = FP_CLASS(X)
      IF (CL == FOR_K_FP_SNAN .OR. &
          CL == FOR_K_FP_QNAN) THEN
        FOR_IEEE_IS_NAN_K16 = .TRUE.
      ELSE
        FOR_IEEE_IS_NAN_K16 = .FALSE.
      ENDIF

    END FUNCTION
!DEC$ ENDIF

!-------------------------------------------------------------------------------
! Description: Determine if a value is negative.
!
! Argument:
! X - real value or real array.
!
! Result Value: The result has the value true if IEEE_CLASS(X) has one of 
!   the values IEEE_NEGATIVE_NORMAL, IEEE_NEGATIVE_DENORMAL, IEEE_NEGATIVE_ZERO 
!   or IEEE_NEGATIVE_INF; otherwise, the result has the value false.
!-------------------------------------------------------------------------------    
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_IS_NEGATIVE_K4 (X)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_IS_NEGATIVE_K4
      REAL(4), INTENT(IN) :: X
      INTEGER(4) CL

      CL = FP_CLASS(X)
      IF (CL == FOR_K_FP_NEG_NORM   .OR. &
          CL == FOR_K_FP_NEG_DENORM .OR. &
          CL == FOR_K_FP_NEG_ZERO   .OR. &
          CL == FOR_K_FP_NEG_INF) THEN
        FOR_IEEE_IS_NEGATIVE_K4 = .TRUE.
      ELSE
        FOR_IEEE_IS_NEGATIVE_K4 = .FALSE.
      ENDIF
   
    END FUNCTION    

    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_IS_NEGATIVE_K8 (X)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_IS_NEGATIVE_K8
      REAL(8), INTENT(IN) :: X
      INTEGER(4) CL

      CL = FP_CLASS(X)
      IF (CL == FOR_K_FP_NEG_NORM   .OR. &
          CL == FOR_K_FP_NEG_DENORM .OR. &
          CL == FOR_K_FP_NEG_ZERO   .OR. &
          CL == FOR_K_FP_NEG_INF) THEN
        FOR_IEEE_IS_NEGATIVE_K8 = .TRUE.
      ELSE
        FOR_IEEE_IS_NEGATIVE_K8 = .FALSE.
      ENDIF
            
    END FUNCTION
      
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_IS_NEGATIVE_K16 (X)         
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_IS_NEGATIVE_K16
      REAL(16), INTENT(IN) :: X
      INTEGER(4) CL

      CL = FP_CLASS(X)
      IF (CL == FOR_K_FP_NEG_NORM   .OR. &
          CL == FOR_K_FP_NEG_DENORM .OR. &
          CL == FOR_K_FP_NEG_ZERO   .OR. &
          CL == FOR_K_FP_NEG_INF) THEN
        FOR_IEEE_IS_NEGATIVE_K16 = .TRUE.
      ELSE
        FOR_IEEE_IS_NEGATIVE_K16 = .FALSE.
      ENDIF

    END FUNCTION

!DEC$ ENDIF
    
!-------------------------------------------------------------------------------
! Description: Determine if a value is normal, that is, neither an infinity, 
!   a NaN, nor denormalized.
!
! Argument:
! X - real value or real array.
!
! Result Value: The result has the value true if IEEE_CLASS(X) has one of 
!   the values IEEE_NEGATIVE_NORMAL, IEEE_NEGATIVE_ZERO, IEEE_POSITIVE_ZERO or 
!   IEEE_POSITIVE_NORMAL; otherwise, the result has the value false.
!-------------------------------------------------------------------------------    
    
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_IS_NORMAL_K4 (X)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_IS_NORMAL_K4
      REAL(4), INTENT(IN) :: X
      INTEGER(4) CL
      
      CL = FP_CLASS(X)
      IF (CL == FOR_K_FP_POS_NORM .OR. &
          CL == FOR_K_FP_NEG_NORM .OR. &
          CL == FOR_K_FP_POS_ZERO .OR. &
          CL == FOR_K_FP_NEG_ZERO) THEN
        FOR_IEEE_IS_NORMAL_K4 = .TRUE.
      ELSE
        FOR_IEEE_IS_NORMAL_K4 = .FALSE.
      ENDIF
            
    END FUNCTION    

    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_IS_NORMAL_K8 (X)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_IS_NORMAL_K8
      REAL(8), INTENT(IN) :: X
      INTEGER(4) CL
      
      CL = FP_CLASS(X)
      IF (CL == FOR_K_FP_POS_NORM .OR. &
          CL == FOR_K_FP_NEG_NORM .OR. &
          CL == FOR_K_FP_POS_ZERO .OR. &
          CL == FOR_K_FP_NEG_ZERO) THEN
        FOR_IEEE_IS_NORMAL_K8 = .TRUE.
      ELSE
        FOR_IEEE_IS_NORMAL_K8 = .FALSE.
      ENDIF
          
    END FUNCTION
      
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_IS_NORMAL_K16 (X)         
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_IS_NORMAL_K16
      REAL(16), INTENT(IN) :: X
      INTEGER(4) CL
      
      CL = FP_CLASS(X)
      IF (CL == FOR_K_FP_POS_NORM .OR. &
          CL == FOR_K_FP_NEG_NORM .OR. &
          CL == FOR_K_FP_POS_ZERO .OR. &
          CL == FOR_K_FP_NEG_ZERO) THEN
        FOR_IEEE_IS_NORMAL_K16 = .TRUE.
      ELSE
        FOR_IEEE_IS_NORMAL_K16 = .FALSE.
      ENDIF
          
    END FUNCTION
!DEC$ ENDIF

!-------------------------------------------------------------------------------
! Description: Unbiased exponent in the IEEE floating point format.
!
! Arguments:
! X - real value or real array.
!
! Result Value:
!   Case (1): If X is a NaN (SNaN or QNaN), the result is that NaN, ie, X.
!   Case (2): If X==0, the result is -Infinity and IEEE_DIVIDE_BY_ZERO signals.
!   Case (3): If the value of X is finite (neither zero, Infinity, nor NaN), the
!     result has the value of the unbiased exponent of X. Note: this value is
!     equal to EXPONENT(X)-1.
!   Case (4): Otherwise, X is +Infinity or -Infinity and the result is +Infinity.
!-------------------------------------------------------------------------------    
    ELEMENTAL REAL(4) FUNCTION FOR_IEEE_LOGB_K4 (X)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_LOGB_K4
      REAL(4), INTENT(IN) :: X
      
      IF (IEEE_IS_NAN (X)) THEN
        FOR_IEEE_LOGB_K4 = X
      ELSEIF (X == 0) THEN
        FOR_IEEE_LOGB_K4 = IEEE_VALUE(X, IEEE_NEGATIVE_INF)
        CALL IEEE_SET_FLAG(IEEE_DIVIDE_BY_ZERO, .TRUE.)
      ELSEIF (IEEE_IS_FINITE(X)) THEN
        FOR_IEEE_LOGB_K4 = EXPONENT(X)-1
      ELSE
        FOR_IEEE_LOGB_K4 = IEEE_VALUE(X, IEEE_POSITIVE_INF)
      ENDIF              
      
    END FUNCTION    

    ELEMENTAL REAL(8) FUNCTION FOR_IEEE_LOGB_K8 (X)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_LOGB_K8
      REAL(8), INTENT(IN) :: X
      
      IF (IEEE_IS_NAN (X)) THEN
        FOR_IEEE_LOGB_K8 = X
      ELSEIF (X == 0) THEN
        FOR_IEEE_LOGB_K8 = IEEE_VALUE(X, IEEE_NEGATIVE_INF)
        CALL IEEE_SET_FLAG(IEEE_DIVIDE_BY_ZERO, .TRUE.)
      ELSEIF (IEEE_IS_FINITE(X)) THEN
        FOR_IEEE_LOGB_K8 = EXPONENT(X)-1
      ELSE
        FOR_IEEE_LOGB_K8 = IEEE_VALUE(X, IEEE_POSITIVE_INF)
      ENDIF
      
    END FUNCTION

!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL REAL(16) FUNCTION FOR_IEEE_LOGB_K16 (X)         
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_LOGB_K16
      REAL(16), INTENT(IN) :: X
      
      IF (IEEE_IS_NAN (X)) THEN
        FOR_IEEE_LOGB_K16 = X
      ELSEIF (X == 0) THEN
        FOR_IEEE_LOGB_K16 = IEEE_VALUE(X, IEEE_NEGATIVE_INF)
        CALL IEEE_SET_FLAG(IEEE_DIVIDE_BY_ZERO, .TRUE.)
      ELSEIF (IEEE_IS_FINITE(X)) THEN
        FOR_IEEE_LOGB_K16 = EXPONENT(X)-1
      ELSE
        FOR_IEEE_LOGB_K16 = IEEE_VALUE(X, IEEE_POSITIVE_INF)
      ENDIF 
      
    END FUNCTION
!DEC$ ENDIF

!-------------------------------------------------------------------------------
! Description: Returns the next representable neighbor of X in the direction 
!   toward Y.
!
! Arguments:
! X - real value or real array.
! Y - real value or real array.
!
! Result Value: 
!   Case (i): If X == X, the result is X and no exception is signaled.
!   Case (ii): If X /= Y, the result has the value of the next representable 
!   neighbor of X in the direction of Y. The neighbors of zero (of either 
!   sign) are both nonzero. IEEE_OVERFLOW is signaled when X is finite but 
!   IEEE_NEXT_AFTER(X,Y) is infinite; IEEE_UNDERFLOW is signaled when 
!   IEEE_NEXT_AFTER(X,Y) is denormalized; in both cases, IEEE_INEXACT signals.
!-------------------------------------------------------------------------------    
    ELEMENTAL REAL(4) FUNCTION FOR_IEEE_NEXT_AFTER_K48 (X, Y)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_NEXT_AFTER_K48
      REAL(4), INTENT(IN) :: X
      REAL(8), INTENT(IN) :: Y
      
      FOR_IEEE_NEXT_AFTER_K48 = IEEE_NEXT_AFTER_K4 (X, REAL(Y, 4))
    END FUNCTION   

!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL REAL(4) FUNCTION FOR_IEEE_NEXT_AFTER_K416 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_NEXT_AFTER_K416
      REAL(4), INTENT(IN) :: X
      REAL(16), INTENT(IN) :: Y
      
      FOR_IEEE_NEXT_AFTER_K416 = IEEE_NEXT_AFTER_K4 (X, REAL(Y, 4))      
    END FUNCTION   
!DEC$ ENDIF

    ELEMENTAL REAL(8) FUNCTION FOR_IEEE_NEXT_AFTER_K84 (X, Y)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_NEXT_AFTER_K84
      REAL(8), INTENT(IN) :: X
      REAL(4), INTENT(IN) :: Y
      
      FOR_IEEE_NEXT_AFTER_K84 = IEEE_NEXT_AFTER_K8 (X, REAL(Y, 8))
    END FUNCTION

!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL REAL(8) FUNCTION FOR_IEEE_NEXT_AFTER_K816 (X, Y)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_NEXT_AFTER_K816
      REAL(8), INTENT(IN) :: X
      REAL(16), INTENT(IN) :: Y
      
      FOR_IEEE_NEXT_AFTER_K816 = IEEE_NEXT_AFTER_K8 (X, REAL(Y, 8))      
    END FUNCTION
      
    ELEMENTAL REAL(16) FUNCTION FOR_IEEE_NEXT_AFTER_K164 (X, Y)         
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_NEXT_AFTER_K164
      REAL(16), INTENT(IN) :: X
      REAL(4), INTENT(IN) :: Y
      
      FOR_IEEE_NEXT_AFTER_K164 = IEEE_NEXT_AFTER_K16 (X, REAL(Y, 16))
    END FUNCTION

    ELEMENTAL REAL(16) FUNCTION FOR_IEEE_NEXT_AFTER_K168 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_NEXT_AFTER_K168
      REAL(16), INTENT(IN) :: X
      REAL(8), INTENT(IN) :: Y
      
      FOR_IEEE_NEXT_AFTER_K168 = IEEE_NEXT_AFTER_K16 (X, REAL(Y, 16))      
    END FUNCTION
!DEC$ ENDIF
    
!-------------------------------------------------------------------------------
! Description: IEEE_REM function.
!
! Arguments:
! X - real value or real array.
! Y - real value or real array.
!
! Result Value: The result value, regardless of the rounding mode, shall be exactly 
!   X - Y*N, where N is the integer nearest to the exact value X/Y; 
!   whenever |N - X/Y| = 1/2, N shall be even. If the result value is zero, 
!   the sign shall be that of X.
!-------------------------------------------------------------------------------
    ELEMENTAL REAL(8) FUNCTION FOR_IEEE_REM_K48 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_REM_K48
      REAL(4), INTENT(IN) :: X
      REAL(8), INTENT(IN) :: Y
      
      FOR_IEEE_REM_K48 = IEEE_REM_K8 (REAL(X, 8), Y)
    END FUNCTION  

!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL REAL(16) FUNCTION FOR_IEEE_REM_K416 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_REM_K416
      REAL(4), INTENT(IN) :: X
      REAL(16), INTENT(IN) :: Y
      
      FOR_IEEE_REM_K416 = IEEE_REM_K16 (REAL(X, 16), Y)      
    END FUNCTION  
!DEC$ ENDIF
      
    ELEMENTAL REAL(8) FUNCTION FOR_IEEE_REM_K84 (X, Y)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_REM_K84
      REAL(8), INTENT(IN) :: X
      REAL(4), INTENT(IN) :: Y
      
      FOR_IEEE_REM_K84 = IEEE_REM_K8 (X, REAL(Y, 8))      
    END FUNCTION
     
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL REAL(16) FUNCTION FOR_IEEE_REM_K816 (X, Y)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_REM_K816
      REAL(8), INTENT(IN) :: X
      REAL(16), INTENT(IN) :: Y
      
      FOR_IEEE_REM_K816 = IEEE_REM_K16 (REAL(X, 16), Y)      
    END FUNCTION
      
    ELEMENTAL REAL(16) FUNCTION FOR_IEEE_REM_K164 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_REM_K164
      REAL(16), INTENT(IN) :: X
      REAL(4), INTENT(IN) :: Y
      
      FOR_IEEE_REM_K164 = IEEE_REM_K16 (X, REAL(Y, 16))
    END FUNCTION

    ELEMENTAL REAL(16) FUNCTION FOR_IEEE_REM_K168 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_REM_K168
      REAL(16), INTENT(IN) :: X
      REAL(8), INTENT(IN) :: Y
      
      FOR_IEEE_REM_K168 = IEEE_REM_K16 (X, REAL(Y, 16))      
    END FUNCTION
!DEC$ ENDIF
    
!-------------------------------------------------------------------------------
! Description: Returns X * 2**I.
!
! Arguments:
! X - real value or real array.
! I - integer power.
!
! Result Value: 
!   Case (i): If X * 2**I is representable as a normal number, the result 
!   has this value.
!   Case (ii): If X is finite and X * 2**I is too large, the 
!   IEEE_OVERFLOW exception shall occur. The result value is infinity with the 
!   sign of X; otherwise, the result value is SIGN(HUGE(X),X).
!   Case (iii): If X * 2**I is too small and there is loss of accuracy, 
!   the IEEE_UNDERFLOW exception shall occur. The result is the representable 
!   number having a magnitude nearest to |2**I| and the same sign as X.
!   Case (iv): If X is infinite, the result is the same as X; no exception 
!   signals.
!-------------------------------------------------------------------------------    
    ELEMENTAL REAL(4) FUNCTION FOR_IEEE_SCALB_K41 (X, I)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SCALB_K41
      REAL(4), INTENT(IN) :: X
      INTEGER(1), INTENT(IN) :: I
      
      FOR_IEEE_SCALB_K41 = IEEE_SCALB_K44(X, INT(I, 4)) 
    END FUNCTION   

    ELEMENTAL REAL(4) FUNCTION FOR_IEEE_SCALB_K42 (X, I)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SCALB_K42
      REAL(4), INTENT(IN) :: X
      INTEGER(2), INTENT(IN) :: I
      
      FOR_IEEE_SCALB_K42 = IEEE_SCALB_K44(X, INT(I, 4))      
    END FUNCTION    

    ELEMENTAL REAL(4) FUNCTION FOR_IEEE_SCALB_K48 (X, I)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SCALB_K48
      REAL(4), INTENT(IN) :: X
      INTEGER(8), INTENT(IN) :: I
      
      FOR_IEEE_SCALB_K48 = IEEE_SCALB_K44(X, INT(I, 4))      
    END FUNCTION 

    ELEMENTAL REAL(8) FUNCTION FOR_IEEE_SCALB_K81 (X, I)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SCALB_K81
      REAL(8), INTENT(IN) :: X
      INTEGER(1), INTENT(IN) :: I
      
      FOR_IEEE_SCALB_K81 = IEEE_SCALB_K84(X, INT(I, 4))      
    END FUNCTION
            
    ELEMENTAL REAL(8) FUNCTION FOR_IEEE_SCALB_K82 (X, I)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SCALB_K82
      REAL(8), INTENT(IN) :: X
      INTEGER(2), INTENT(IN) :: I
      
      FOR_IEEE_SCALB_K82 = IEEE_SCALB_K84(X, INT(I, 4))      
    END FUNCTION
      
    ELEMENTAL REAL(8) FUNCTION FOR_IEEE_SCALB_K88 (X, I)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SCALB_K88
      REAL(8), INTENT(IN) :: X
      INTEGER(8), INTENT(IN) :: I
      
      FOR_IEEE_SCALB_K88 = IEEE_SCALB_K84(X, INT(I, 4))      
    END FUNCTION            
      
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL REAL(16) FUNCTION FOR_IEEE_SCALB_K161 (X, I)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SCALB_K161
      REAL(16), INTENT(IN) :: X
      INTEGER(1), INTENT(IN) :: I
      
      FOR_IEEE_SCALB_K161 = IEEE_SCALB_K164(X, INT(I, 4))      
    END FUNCTION
      
    ELEMENTAL REAL(16) FUNCTION FOR_IEEE_SCALB_K162 (X, I)         
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SCALB_K162
      REAL(16), INTENT(IN) :: X
      INTEGER(2), INTENT(IN) :: I
      
      FOR_IEEE_SCALB_K162 = IEEE_SCALB_K164(X, INT(I, 4))      
    END FUNCTION

    ELEMENTAL REAL(16) FUNCTION FOR_IEEE_SCALB_K168 (X, I) 
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SCALB_K168
      REAL(16), INTENT(IN) :: X
      INTEGER(8), INTENT(IN) :: I
      
      FOR_IEEE_SCALB_K168 = IEEE_SCALB_K164(X, INT(I, 4))      
    END FUNCTION    
!DEC$ ENDIF
    
!-------------------------------------------------------------------------------
! Description: Returns a value of the kind type parameter of an IEEE real data 
!   type with decimal precision of at least P digits and a decimal exponent 
!   range of at least R.
!
! Argument:
! P - decimal precision.
! R - decimal exponent range.
!
! Result Value: The result has a value equal to a value of the kind type 
!   parameter of an IEEE real type with decimal precision, as returned by the 
!   function PRECISION, of at least P digits and a decimal exponent range, as 
!   returned by the function RANGE, of at least R, or if no such kind type 
!   parameter is available on the processor, the result is -1 if the precision 
!   is not available, -2 if the exponent range is not available, and -3 if 
!   neither is available. If more than one kind type parameter value meets the 
!   criteria, the value returned is the one with the smallest decimal precision, 
!   unless there are several such values, in which case the smallest of these 
!   kind values is returned.
!-------------------------------------------------------------------------------
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K11 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K11
      INTEGER(1), OPTIONAL, INTENT(IN) :: P
      INTEGER(1), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K11 = SELECTED_REAL_KIND(P,R)
    END FUNCTION      
      
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K12 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K12
      INTEGER(1), OPTIONAL, INTENT(IN) :: P
      INTEGER(2), OPTIONAL, INTENT(IN) :: R
      
      FOR_IEEE_SELECTED_REAL_KIND_K12 = SELECTED_REAL_KIND(P,R)
    END FUNCTION
    
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K14 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K14
      INTEGER(1), OPTIONAL, INTENT(IN) :: P
      INTEGER(4), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K14 = SELECTED_REAL_KIND(P,R)
    END FUNCTION
          
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K18 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K18
      INTEGER(1), OPTIONAL, INTENT(IN) :: P
      INTEGER(8), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K18 = SELECTED_REAL_KIND(P,R)
    END FUNCTION
          
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K21 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K21
      INTEGER(2), OPTIONAL, INTENT(IN) :: P
      INTEGER(1), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K21 = SELECTED_REAL_KIND(P,R)
    END FUNCTION
    
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K22 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K22
      INTEGER(2), OPTIONAL, INTENT(IN) :: P
      INTEGER(2), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K22 = SELECTED_REAL_KIND(P,R)
    END FUNCTION
    
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K24 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K24
      INTEGER(2), OPTIONAL, INTENT(IN) :: P
      INTEGER(4), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K24 = SELECTED_REAL_KIND(P,R)
    END FUNCTION
    
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K28 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K28
      INTEGER(2), OPTIONAL, INTENT(IN) :: P
      INTEGER(8), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K28 = SELECTED_REAL_KIND(P,R)
    END FUNCTION
    
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K41 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K41
      INTEGER(4), OPTIONAL, INTENT(IN) :: P
      INTEGER(1), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K41 = SELECTED_REAL_KIND(P,R)
    END FUNCTION

    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K42 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K42
      INTEGER(4), OPTIONAL, INTENT(IN) :: P
      INTEGER(2), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K42  = SELECTED_REAL_KIND(P,R)
    END FUNCTION
    
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K44 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K44
      INTEGER(4), OPTIONAL, INTENT(IN) :: P
      INTEGER(4), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K44 = SELECTED_REAL_KIND(P,R)
    END FUNCTION
    
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K48 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K48
      INTEGER(4), OPTIONAL, INTENT(IN) :: P
      INTEGER(8), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K48 = SELECTED_REAL_KIND(P,R)
    END FUNCTION
    
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K81 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K81
      INTEGER(8), OPTIONAL, INTENT(IN) :: P
      INTEGER(1), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K81 = SELECTED_REAL_KIND(P,R)
    END FUNCTION    
    
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K82 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K82
      INTEGER(8), OPTIONAL, INTENT(IN) :: P
      INTEGER(2), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K82 = SELECTED_REAL_KIND(P,R)
    END FUNCTION
    
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K84 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K84
      INTEGER(8), OPTIONAL, INTENT(IN) :: P
      INTEGER(4), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K84 = SELECTED_REAL_KIND(P,R)
    END FUNCTION
    
    INTEGER(4) FUNCTION FOR_IEEE_SELECTED_REAL_KIND_K88 (P, R)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SELECTED_REAL_KIND_K88
      INTEGER(8), OPTIONAL, INTENT(IN) :: P
      INTEGER(8), OPTIONAL, INTENT(IN) :: R

      FOR_IEEE_SELECTED_REAL_KIND_K88 = SELECTED_REAL_KIND(P,R)
    END FUNCTION                            
    
!-------------------------------------------------------------------------------
! Description: Set the current underflow mode.
!
! Argument:
! GRADUAL - if GRADUAL is true, the current underflow mode is set to “gradual 
!   underflow". If it is false, the current underflow mode is set to “abrupt 
!   underflow”.
!-------------------------------------------------------------------------------
    SUBROUTINE FOR_IEEE_SET_UNDERFLOW_MODE_K1 (GRADUAL)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SET_UNDERFLOW_MODE_K1
      USE IFCORE
      IMPLICIT NONE      
      LOGICAL(1), INTENT(IN) :: GRADUAL
      INTEGER(4) CW, CW1
      
!     Get current control word 
      CW = FOR_GET_FPE()
!     Add underflow mode value      
      IF (GRADUAL) THEN
        CW = IAND(CW, NOT(FPE_M_ABRUPT_UND))
      ELSE
        CW = IOR(CW, FPE_M_ABRUPT_UND) 
      ENDIF
!     Set new control word
      CW1 = FOR_SET_FPE(CW)
    END SUBROUTINE
    
    SUBROUTINE FOR_IEEE_SET_UNDERFLOW_MODE_K2 (GRADUAL)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SET_UNDERFLOW_MODE_K2
      USE IFCORE
      IMPLICIT NONE      
      LOGICAL(2), INTENT(IN) :: GRADUAL
      INTEGER(4) CW, CW1
      
!     Get current control word 
      CW = FOR_GET_FPE()
!     Add underflow mode value      
      IF (GRADUAL) THEN
        CW = IAND(CW, NOT(FPE_M_ABRUPT_UND))
      ELSE
        CW = IOR(CW, FPE_M_ABRUPT_UND) 
      ENDIF
!     Set new control word
      CW1 = FOR_SET_FPE(CW)
    END SUBROUTINE
    
    SUBROUTINE FOR_IEEE_SET_UNDERFLOW_MODE_K4 (GRADUAL)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SET_UNDERFLOW_MODE_K4
      USE IFCORE
      IMPLICIT NONE      
      LOGICAL(4), INTENT(IN) :: GRADUAL
      INTEGER(4) CW, CW1
      
!     Get current control word 
      CW = FOR_GET_FPE()
!     Add underflow mode value      
      IF (GRADUAL) THEN
        CW = IAND(CW, NOT(FPE_M_ABRUPT_UND))
      ELSE
        CW = IOR(CW, FPE_M_ABRUPT_UND) 
      ENDIF
!     Set new control word
      CW1 = FOR_SET_FPE(CW)
    END SUBROUTINE 
    
    SUBROUTINE FOR_IEEE_SET_UNDERFLOW_MODE_K8 (GRADUAL)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SET_UNDERFLOW_MODE_K8
      USE IFCORE
      IMPLICIT NONE      
      LOGICAL(8), INTENT(IN) :: GRADUAL
      INTEGER(4) CW, CW1
      
!     Get current control word 
      CW = FOR_GET_FPE()
!     Add underflow mode value      
      IF (GRADUAL) THEN
        CW = IAND(CW, NOT(FPE_M_ABRUPT_UND))
      ELSE
        CW = IOR(CW, FPE_M_ABRUPT_UND) 
      ENDIF
!     Set new control word
      CW1 = FOR_SET_FPE(CW)
    END SUBROUTINE         
                            
!-------------------------------------------------------------------------------
! Description: Inquire whether the processor supports IEEE arithmetic.
!
! Argument:
! X - real value or an array.
!
! Result Value: The result has the value true if the processor supports IEEE 
!   arithmetic for all reals (X absent) or for real variables of the same 
!   kind type parameter as X; otherwise, it has the value false. 
!-------------------------------------------------------------------------------
    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_DATATYPE (X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_DATATYPE
      !DEC$ ATTRIBUTES NO_ARG_CHECK :: X       
      REAL(4), INTENT(IN) :: X
      
      FOR_IEEE_SUPPORT_DATATYPE = .TRUE.
    END FUNCTION    

    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_DATATYPE_ALL ()
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_DATATYPE_ALL    
    
      FOR_IEEE_SUPPORT_DATATYPE_ALL = .TRUE.    
    END FUNCTION

!-------------------------------------------------------------------------------
! Description: Inquire whether the processor supports IEEE denormalized numbers.
!
! Argument:
! X - real value or real array.
!
! Result Value:
!   Case (i): FOR_IEEE_SUPPORT_DENORMAL_KK(X) has the value true if 
!   the processor supports arithmetic operations and assignments with 
!   denormalized numbers (biased exponent e = 0 and fraction f != 0 for real 
!   variables of the same kind (kind == K) type parameter as X; otherwise, it 
!   has the value false.
!   Case (ii): FOR_IEEE_SUPPORT_DENORMAL_ALL() has the value true if and only 
!   if the processor supports arithmetic operations and assignments with 
!   denormalized numbers for all kinds K.
!-------------------------------------------------------------------------------
    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_DENORMAL (X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_DENORMAL
      !DEC$ ATTRIBUTES NO_ARG_CHECK :: X
      USE IFCORE
      REAL(4), INTENT(IN) :: X

      INTEGER(4) FTZ_FLAGS, FOR_FLAGS

      FTZ_FLAGS = FPE_M_ABRUPT_UND + FPE_M_ABRUPT_DMZ + FPE_M_MSG_UND
      FOR_FLAGS = FOR_GET_FPE()

      IF (IAND(FOR_FLAGS, FTZ_FLAGS) == 0) THEN
          IF (IAND(FOR_FLAGS, FPE_M_TRAP_UND) == 0) THEN
              FOR_IEEE_SUPPORT_DENORMAL = .TRUE.
          ELSE
              FOR_IEEE_SUPPORT_DENORMAL = .FALSE.
          END IF
      ELSE
          FOR_IEEE_SUPPORT_DENORMAL = .FALSE.
      END IF
    END FUNCTION    

    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_DENORMAL_ALL ()
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_DENORMAL_ALL
      USE IFCORE
      INTEGER(4) FTZ_FLAGS, FOR_FLAGS

      FTZ_FLAGS = FPE_M_ABRUPT_UND + FPE_M_ABRUPT_DMZ + FPE_M_MSG_UND
      FOR_FLAGS = FOR_GET_FPE()

      IF (IAND(FOR_FLAGS, FTZ_FLAGS) == 0) THEN
          IF (IAND(FOR_FLAGS, FPE_M_TRAP_UND) == 0) THEN
              FOR_IEEE_SUPPORT_DENORMAL_ALL = .TRUE.
          ELSE
              FOR_IEEE_SUPPORT_DENORMAL_ALL = .FALSE.
          END IF
      ELSE
         FOR_IEEE_SUPPORT_DENORMAL_ALL = .FALSE.
      END IF
    END FUNCTION
      
!-------------------------------------------------------------------------------
! Description: Inquire whether the processor supports divide with the accuracy 
!   specified by the IEEE International Standard.
!
! Argument:
! X - real value or real array.
!
! Result Value:
!   Case (i): FOR_IEEE_SUPPORT_DIVIDE_KK(X) has the value true if the 
!   processor supports divide with the accuracy specified by the IEEE 
!   International Standard for real variables of the same kind (kind == K) 
!   type parameter as X; otherwise, it has the value false.
!   Case (ii): FOR_IEEE_SUPPORT_DIVIDE_ALL() has the value true if and only 
!   if the processor supports divide with the accuracy specified by the IEEE 
!   International Standard for all kinds K.
!-------------------------------------------------------------------------------
    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_DIVIDE (X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_DIVIDE
      !DEC$ ATTRIBUTES NO_ARG_CHECK :: X        
      REAL(4), INTENT(IN) :: X
      
      FOR_IEEE_SUPPORT_DIVIDE = .TRUE.
    END FUNCTION    

    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_DIVIDE_ALL ()
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_DIVIDE_ALL    

      FOR_IEEE_SUPPORT_DIVIDE_ALL = .TRUE.
    END FUNCTION

!-------------------------------------------------------------------------------
! Description: Inquire whether the processor supports the IEEE infinity facility.
!
! Argument:
! X - real value or real array.
!
! Result Value.
!   Case (i): FOR_IEEE_SUPPORT_INF_K4(X) has the value true if the processor 
!   supports IEEE infinities (positive and negative) for real variables of the 
!   same kind (kind == K) type parameter as X; otherwise, it has the value 
!   false.
!   Case (ii): FOR_IEEE_SUPPORT_INF_ALL() has the value true if and only if 
!   the processor supports IEEE infinities (positive and negative) for all real 
!   kinds K.
!-------------------------------------------------------------------------------
    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_INF (X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_INF
      !DEC$ ATTRIBUTES NO_ARG_CHECK :: X        
      REAL(4), INTENT(IN) :: X
        
      FOR_IEEE_SUPPORT_INF = .TRUE.
    END FUNCTION    

    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_INF_ALL ()
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_INF_ALL    

      FOR_IEEE_SUPPORT_INF_ALL = .TRUE.
    END FUNCTION

!-------------------------------------------------------------------------------
! Description: Inquire whether the processor supports IEEE base conversion 
!   rounding during formatted input/output.
!
! Argument:
! X - real value or real array.
!
! Result Value:
!   Case (i): FOR_IEEE_SUPPORT_IO_K4(X) has the value true if the processor 
!   supports IEEE base conversion during formatted input/output as described in 
!   the IEEE International Standard for the modes UP, DOWN, ZERO, and NEAREST 
!   for real variables of the same kind (kind == K) type parameter as X; 
!   otherwise, it has the value false.
!   Case (ii): FOR_IEEE_SUPPORT_IO_ALL() has the value true if and only if 
!   the processor supports IEEE base conversion during formatted input/output 
!   for all kinds K.
!-------------------------------------------------------------------------------
    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_IO (X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_IO
      !DEC$ ATTRIBUTES NO_ARG_CHECK :: X        
      REAL(4), INTENT(IN) :: X
       
      FOR_IEEE_SUPPORT_IO = .TRUE.
    END FUNCTION    

    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_IO_ALL ()
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_IO_ALL    
    
      FOR_IEEE_SUPPORT_IO_ALL = .TRUE.
    END FUNCTION
  
!-------------------------------------------------------------------------------
! Description: Inquire whether the processor supports the IEEE Not-a-Number 
!   facility.
!
! Argument:
! X - real value or real array.
!
! Result Value:
!   Case (i): FOR_IEEE_SUPPORT_NAN_K4(X) has the value true if the processor 
!   supports IEEE NaNs for real variables of the same kind (kind == K) type 
!   parameter as X; otherwise, it has the value false.
!   Case (ii): FOR_IEEE_SUPPORT_NAN_ALL() has the value true if and only if 
!   the processor supports IEEE NaNs for real variables for all kinds K.
!-------------------------------------------------------------------------------
    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_NAN (X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_NAN
      !DEC$ ATTRIBUTES NO_ARG_CHECK :: X        
      REAL(4), INTENT(IN) :: X
        
      FOR_IEEE_SUPPORT_NAN = .TRUE.
    END FUNCTION    

    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_NAN_ALL ()
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_NAN_ALL    
    
      FOR_IEEE_SUPPORT_NAN_ALL = .TRUE.
    END FUNCTION

!-------------------------------------------------------------------------------
! Description: Inquire whether the processor supports a particular IEEE rounding 
!   mode.
!
! Arguments:
! ROUND_VALUE – value which shall be one of the - IEEE_NEAREST, 
!   IEEE_TO_ZERO, IEEE_UP, or IEEE_DOWN.
!
! X – real value or real array.
!
! Result Value.
!   Case (i): IEEE_SUPPORT_ROUNDING (ROUND_VALUE, X) has the value true if the 
!   processor supports the rounding mode defined by ROUND_VALUE for real 
!   variables of the same kind type parameter as X; otherwise, it has the value 
!   false. Support includes the ability to change the mode by CALL 
!   IEEE_SET_ROUNDING_MODE (ROUND_VALUE).
!   Case (ii): IEEE_SUPPORT_ROUNDING (ROUND_VALUE) has the value true if the 
!   processor supports the rounding mode defined by ROUND_VALUE for all real X.
!-------------------------------------------------------------------------------
    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_ROUNDING (ROUND_VALUE, X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_ROUNDING
      TYPE(IEEE_ROUND_TYPE), INTENT(IN) :: ROUND_VALUE
      !DEC$ ATTRIBUTES NO_ARG_CHECK :: X       
      REAL(4), INTENT(IN) :: X
      
      FOR_IEEE_SUPPORT_ROUNDING = .TRUE.
    END FUNCTION
    
    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_ROUNDING_ALL (ROUND_VALUE)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_ROUNDING_ALL
      TYPE(IEEE_ROUND_TYPE), INTENT(IN) :: ROUND_VALUE
      
      FOR_IEEE_SUPPORT_ROUNDING_ALL = .TRUE.      
    END FUNCTION    

!-------------------------------------------------------------------------------
! Description: Inquire whether the processor implements SQRT in accord with the 
!   IEEE International Standard.
!
! Argument.
! X - real value or real array.
!
! Result Value:
!   Case (i): FOR_IEEE_SUPPORT_SQRT_K4(X) has the value true if the processor 
!   implements SQRT in accord with the IEEE International Standard for real 
!   variables of the same kind (kind == K) type parameter as *px; otherwise, 
!   it has the value false.
!   Case (ii): FOR_IEEE_SUPPORT_SQRT_ALL() has the value true if and only if 
!   the processor implements SQRT in accord with the IEEE International Standard 
!   for all kinds K.
!-------------------------------------------------------------------------------
    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_SQRT (X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_SQRT
      !DEC$ ATTRIBUTES NO_ARG_CHECK :: X        
      REAL(4), INTENT(IN) :: X
        
      FOR_IEEE_SUPPORT_SQRT = .TRUE.
    END FUNCTION    

    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_SQRT_ALL ()
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_SQRT_ALL    

      FOR_IEEE_SUPPORT_SQRT_ALL = .TRUE.
    END FUNCTION
    

!-------------------------------------------------------------------------------
! Description: Inquire whether the processor supports all the IEEE facilities 
!   defined in this standard.
!
! Argument:
! X - real value or real array.
!
! Result Value:
!   Case (i): FOR_IEEE_SUPPORT_STANDARD (X) has the value true if the 
!   results of all the functions FOR_IEEE_SUPPORT_DATATYPE(X), 
!   FOR_IEEE_SUPPORT_DENORMAL(X), FOR_IEEE_SUPPORT_DIVIDE(X), 
!   FOR_IEEE_SUPPORT_FLAG(FLAG, X) for valid FLAG, 
!   FOR_IEEE_SUPPORT_HALTING(FLAG) for valid FLAG, 
!   FOR_IEEE_SUPPORT_INF(X), FOR_IEEE_SUPPORT_NAN(X), 
!   FOR_IEEE_SUPPORT_ROUNDING(ROUND_VALUE, X) for valid ROUND_VALUE, 
!   and FOR_IEEE_SUPPORT_SQRT(X) are all true; otherwise, the result has 
!   the value false.
!   Case (ii): FOR_IEEE_SUPPORT_STANDARD () has the value true if and only 
!   if FOR_IEEE_SUPPORT_STANDARD (X) has the value true for all kinds K.
!-------------------------------------------------------------------------------    
    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_STANDARD (X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_STANDARD
      !DEC$ ATTRIBUTES NO_ARG_CHECK :: X       
      REAL(4), INTENT(IN) :: X
      
      FOR_IEEE_SUPPORT_STANDARD = .TRUE.
    END FUNCTION
    
    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_STANDARD_ALL ()
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_STANDARD_ALL
      
      FOR_IEEE_SUPPORT_STANDARD_ALL = .TRUE.      
    END FUNCTION    
    
!-------------------------------------------------------------------------------
! Description: Inquire whether the procedure supports the ability to control the 
!   underflow mode during program execution.
!
! Argument:
! X - real value or real array.
!
! Result Value:
!   Case (i): IEEE_SUPPORT_UNDERFLOW_CONTROL_K4(X) has the value true 
!   if the processor supports control of the underflow mode for floating-point 
!   calculations with the same kind (kind == K) type as *px, and false 
!   otherwise.
!   Case (ii): IEEE_SUPPORT_UNDERFLOW_CONTROL_ALL() has the value true 
!   if the processor supports control of the underflow mode for all 
!   floating-point calculations, and false otherwise.
!-------------------------------------------------------------------------------
    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_UNDERFLOW_CONTROL (X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_UNDERFLOW_CONTROL
      !DEC$ ATTRIBUTES NO_ARG_CHECK :: X      
      REAL(4), INTENT(IN) :: X
        
      FOR_IEEE_SUPPORT_UNDERFLOW_CONTROL = .TRUE.
    END FUNCTION    

    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_UNDERFLOW_CONTROL_ALL ()
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_UNDERFLOW_CONTROL_ALL    

      FOR_IEEE_SUPPORT_UNDERFLOW_CONTROL_ALL = .TRUE.
    END FUNCTION    

!-------------------------------------------------------------------------------
! Description: Generate an IEEE value.
!
! Arguments:
! X - real value or real array.
! CLASS - the value is permitted to be: IEEE_SIGNALING_NAN or IEEE_QUIET_NAN if 
!   IEEE_SUPPORT_NAN(X) has the value true, IEEE_NEGATIVE_INF or 
!   IEEE_POSITIVE_INF if IEEE_SUPPORT_INF(X) has the value true, 
!   IEEE_NEGATIVE_DENORMAL or IEEE_POSITIVE_DENORMAL if 
!   IEEE_SUPPORT_DENORMAL(X) has the value true, IEEE_NEGATIVE_NORMAL, 
!   IEEE_NEGATIVE_ZERO, IEEE_POSITIVE_ZERO or IEEE_POSITIVE_NORMAL.
!
! Result Value: The result value is an IEEE value as specified by CLASS.
!-------------------------------------------------------------------------------
    ELEMENTAL REAL(4) FUNCTION FOR_IEEE_VALUE_K4 (X, CLASS)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_VALUE_K4
      REAL(4), INTENT(IN) :: X
      TYPE(IEEE_CLASS_TYPE) , INTENT(IN) :: CLASS
!------------------------------------------------------------------------------
! Single precision special constants.
!------------------------------------------------------------------------------
! Signaling NAN, single precision.      
      REAL(4), PARAMETER :: FOR_S_SNAN         = TRANSFER((/ Z'7FA00000' /),1.0_4)

! Quiet NAN, single precision.      

      REAL(4), PARAMETER :: FOR_S_QNAN         = TRANSFER((/ Z'7FC00000' /),1.0_4)

! Positive infinite, single precision.       

      REAL(4), PARAMETER :: FOR_S_POS_INF      = TRANSFER((/ Z'7F800000' /),1.0_4)

! Negative infinite, single precision.       

      REAL(4), PARAMETER :: FOR_S_NEG_INF      = TRANSFER((/ Z'FF800000' /),1.0_4)

! Positive normal (+1.0), single precision.      

      REAL(4), PARAMETER :: FOR_S_POS_ONE      = TRANSFER((/ Z'3F800000' /),1.0_4)

! Negative normal (-1.0), single precision.       

      REAL(4), PARAMETER :: FOR_S_NEG_ONE      = TRANSFER((/ Z'BF800000' /),1.0_4)

! Positive huge denormal (+1.1754942E-38), single precision.       

      REAL(4), PARAMETER :: FOR_S_POS_DENORMAL = TRANSFER((/ Z'007FFFFF' /),1.0_4)

! Negative huge denormal (-1.1754942E-38), single precision.      

      REAL(4), PARAMETER :: FOR_S_NEG_DENORMAL = TRANSFER((/ Z'807FFFFF' /),1.0_4)

! Positive zero (+0.0), single precision.       

      REAL(4), PARAMETER :: FOR_S_POS_ZERO     = TRANSFER((/ Z'00000000' /),1.0_4)

! Negative zero (-0.0), single precision.      

      REAL(4), PARAMETER :: FOR_S_NEG_ZERO     = TRANSFER((/ Z'80000000' /),1.0_4)      
      
      IF (CLASS == IEEE_SIGNALING_NAN)          THEN
        FOR_IEEE_VALUE_K4 = FOR_S_SNAN
      ELSE IF (CLASS == IEEE_QUIET_NAN)         THEN
        FOR_IEEE_VALUE_K4 = FOR_S_QNAN
      ELSE IF (CLASS == IEEE_POSITIVE_INF)      THEN
        FOR_IEEE_VALUE_K4 = FOR_S_POS_INF
      ELSE IF (CLASS == IEEE_NEGATIVE_INF)      THEN
        FOR_IEEE_VALUE_K4 = FOR_S_NEG_INF
      ELSE IF (CLASS == IEEE_POSITIVE_NORMAL)   THEN
        FOR_IEEE_VALUE_K4 = FOR_S_POS_ONE
      ELSE IF (CLASS == IEEE_NEGATIVE_NORMAL)   THEN
        FOR_IEEE_VALUE_K4 = FOR_S_NEG_ONE
      ELSE IF (CLASS == IEEE_POSITIVE_DENORMAL) THEN
        FOR_IEEE_VALUE_K4 = FOR_S_POS_DENORMAL
      ELSE IF (CLASS == IEEE_NEGATIVE_DENORMAL) THEN
        FOR_IEEE_VALUE_K4 = FOR_S_NEG_DENORMAL
      ELSE IF (CLASS == IEEE_POSITIVE_ZERO)     THEN
        FOR_IEEE_VALUE_K4 = FOR_S_POS_ZERO
      ELSE IF (CLASS == IEEE_NEGATIVE_ZERO)     THEN
        FOR_IEEE_VALUE_K4 = FOR_S_NEG_ZERO
      ENDIF
      
    END FUNCTION    

    ELEMENTAL REAL(8) FUNCTION FOR_IEEE_VALUE_K8 (X, CLASS)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_VALUE_K8
      REAL(8), INTENT(IN) :: X
      TYPE(IEEE_CLASS_TYPE) , INTENT(IN) :: CLASS
!------------------------------------------------------------------------------
! Double precision special constants.
!------------------------------------------------------------------------------      
! Signaling NAN, double precision.
      REAL(8), PARAMETER :: FOR_D_SNAN = &

        TRANSFER((/ Z'00000000', Z'7FF40000' /),1.0_8)

! Quiet NAN, double precision.

      REAL(8), PARAMETER :: FOR_D_QNAN = &

        TRANSFER((/ Z'00000000', Z'7FF80000' /),1.0_8)

! Positive infinite, double precision.        

      REAL(8), PARAMETER :: FOR_D_POS_INF = &

        TRANSFER((/ Z'00000000', Z'7FF00000' /),1.0_8)

! Negative infinite, double precision.        

      REAL(8), PARAMETER :: FOR_D_NEG_INF = &

        TRANSFER((/ Z'00000000', Z'FFF00000' /),1.0_8)

! Positive normal (+1.0), double precision.        

      REAL(8), PARAMETER :: FOR_D_POS_ONE = &

        TRANSFER((/ Z'00000000', Z'3FF00000' /),1.0_8)

! Negative normal (-1.0), double precision.        

      REAL(8), PARAMETER :: FOR_D_NEG_ONE = &

        TRANSFER((/ Z'00000000', Z'BFF00000' /),1.0_8)

! Positive huge denormal (+2.225073858507201E-308), double precision.        

      REAL(8), PARAMETER :: FOR_D_POS_DENORMAL = &

        TRANSFER((/ Z'FFFFFFFF', Z'000FFFFF' /),1.0_8)

! Negative huge denormal (-2.225073858507201E-308), double precision.

      REAL(8), PARAMETER :: FOR_D_NEG_DENORMAL = &

        TRANSFER((/ Z'FFFFFFFF', Z'800FFFFF' /),1.0_8)

! Positive zero (+0.0), double precision.        

      REAL(8), PARAMETER :: FOR_D_POS_ZERO = &

        TRANSFER((/ Z'00000000', Z'00000000' /),1.0_8)

! Negative zero (-0.0), double precision.        

      REAL(8), PARAMETER :: FOR_D_NEG_ZERO = &

        TRANSFER((/ Z'00000000', Z'80000000' /),1.0_8)      
      
      IF (CLASS == IEEE_SIGNALING_NAN)          THEN
        FOR_IEEE_VALUE_K8 = FOR_D_SNAN
      ELSE IF (CLASS == IEEE_QUIET_NAN)         THEN
        FOR_IEEE_VALUE_K8 = FOR_D_QNAN
      ELSE IF (CLASS == IEEE_POSITIVE_INF)      THEN
        FOR_IEEE_VALUE_K8 = FOR_D_POS_INF
      ELSE IF (CLASS == IEEE_NEGATIVE_INF)      THEN
        FOR_IEEE_VALUE_K8 = FOR_D_NEG_INF
      ELSE IF (CLASS == IEEE_POSITIVE_NORMAL)   THEN
        FOR_IEEE_VALUE_K8 = FOR_D_POS_ONE
      ELSE IF (CLASS == IEEE_NEGATIVE_NORMAL)   THEN
        FOR_IEEE_VALUE_K8 = FOR_D_NEG_ONE
      ELSE IF (CLASS == IEEE_POSITIVE_DENORMAL) THEN
        FOR_IEEE_VALUE_K8 = FOR_D_POS_DENORMAL
      ELSE IF (CLASS == IEEE_NEGATIVE_DENORMAL) THEN
        FOR_IEEE_VALUE_K8 = FOR_D_NEG_DENORMAL
      ELSE IF (CLASS == IEEE_POSITIVE_ZERO)     THEN
        FOR_IEEE_VALUE_K8 = FOR_D_POS_ZERO
      ELSE IF (CLASS == IEEE_NEGATIVE_ZERO)     THEN
        FOR_IEEE_VALUE_K8 = FOR_D_NEG_ZERO
      ENDIF
      
    END FUNCTION
      
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL REAL(16) FUNCTION FOR_IEEE_VALUE_K16 (X, CLASS)         
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_VALUE_K16
      REAL(16), INTENT(IN) :: X
      TYPE(IEEE_CLASS_TYPE) , INTENT(IN) :: CLASS
!------------------------------------------------------------------------------
! Extended double precision special constants.
!------------------------------------------------------------------------------
! Signaling NAN, extended double precision.      
      REAL(16), PARAMETER :: FOR_Q_SNAN = &

        TRANSFER((/ Z'00000000', Z'00000000', Z'00000000', Z'7FFF4000' /),1.0_16)

! Quiet NAN, extended double precision.        

      REAL(16), PARAMETER :: FOR_Q_QNAN = &

        TRANSFER((/ Z'00000000', Z'00000000', Z'00000000', Z'7FFF8000' /),1.0_16)

! Positive infinite, extended double precision.         

      REAL(16), PARAMETER :: FOR_Q_POS_INF = &

        TRANSFER((/ Z'00000000', Z'00000000', Z'00000000', Z'7FFF0000' /),1.0_16)

! Negative infinite, extended double precision.         

      REAL(16), PARAMETER :: FOR_Q_NEG_INF = &

        TRANSFER((/ Z'00000000', Z'00000000', Z'00000000', Z'FFFF0000' /),1.0_16)

! Positive normal (+1.0), extended double precision.          

      REAL(16), PARAMETER :: FOR_Q_POS_ONE = &

        TRANSFER((/ Z'00000000', Z'00000000', Z'00000000', Z'3FFF0000' /),1.0_16)

! Negative normal (-1.0), extended double precision.         

      REAL(16), PARAMETER :: FOR_Q_NEG_ONE = &

        TRANSFER((/ Z'00000000', Z'00000000', Z'00000000', Z'BFFF0000' /),1.0_16)

! Positive huge denormal (+3.362103143112093506262677817321752E-4932), 

! extended double precision.          

      REAL(16), PARAMETER :: FOR_Q_POS_DENORMAL = &

        TRANSFER((/ Z'FFFFFFFF', Z'FFFFFFFF', Z'FFFFFFFF', Z'0000FFFF' /),1.0_16)

! Negative huge denormal (-3.362103143112093506262677817321752E-4932), 

! extended double precision.        

      REAL(16), PARAMETER :: FOR_Q_NEG_DENORMAL = &

        TRANSFER((/ Z'FFFFFFFF', Z'FFFFFFFF', Z'FFFFFFFF', Z'8000FFFF' /),1.0_16)

! Positive zero (+0.0), extended double precision.         

      REAL(16), PARAMETER :: FOR_Q_POS_ZERO = &

        TRANSFER((/ Z'00000000', Z'00000000', Z'00000000', Z'00000000' /),1.0_16)

! Negative zero (-0.0), extended double precision.        

      REAL(16), PARAMETER :: FOR_Q_NEG_ZERO = &

        TRANSFER((/ Z'00000000', Z'00000000', Z'00000000', Z'80000000' /),1.0_16)
        
      IF (CLASS == IEEE_SIGNALING_NAN)          THEN
        FOR_IEEE_VALUE_K16 = FOR_Q_SNAN
      ELSE IF (CLASS == IEEE_QUIET_NAN)         THEN
        FOR_IEEE_VALUE_K16 = FOR_Q_QNAN
      ELSE IF (CLASS == IEEE_POSITIVE_INF)      THEN
        FOR_IEEE_VALUE_K16 = FOR_Q_POS_INF
      ELSE IF (CLASS == IEEE_NEGATIVE_INF)      THEN
        FOR_IEEE_VALUE_K16 = FOR_Q_NEG_INF
      ELSE IF (CLASS == IEEE_POSITIVE_NORMAL)   THEN
        FOR_IEEE_VALUE_K16 = FOR_Q_POS_ONE
      ELSE IF (CLASS == IEEE_NEGATIVE_NORMAL)   THEN
        FOR_IEEE_VALUE_K16 = FOR_Q_NEG_ONE
      ELSE IF (CLASS == IEEE_POSITIVE_DENORMAL) THEN
        FOR_IEEE_VALUE_K16 = FOR_Q_POS_DENORMAL
      ELSE IF (CLASS == IEEE_NEGATIVE_DENORMAL) THEN
        FOR_IEEE_VALUE_K16 = FOR_Q_NEG_DENORMAL
      ELSE IF (CLASS == IEEE_POSITIVE_ZERO)     THEN
        FOR_IEEE_VALUE_K16 = FOR_Q_POS_ZERO
      ELSE IF (CLASS == IEEE_NEGATIVE_ZERO)     THEN
        FOR_IEEE_VALUE_K16 = FOR_Q_NEG_ZERO
      ENDIF
              
    END FUNCTION
!DEC$ ENDIF
    
!-------------------------------------------------------------------------------
! Description: IEEE unordered function. True if X or Y is a NaN, and false 
!   otherwise.
!
! Arguments:
! X - real value or real array.
! Y - real value or real array.
!
!Result Value: The result has the value true if X or Y is a NaN or both are 
!   NaNs; otherwise, it has the value false.
!-------------------------------------------------------------------------------    
    
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_UNORDERED_K4 (X, Y)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_UNORDERED_K4
      REAL(4), INTENT(IN) :: X
      REAL(4), INTENT(IN) :: Y
      
      IF (ISNAN(X) .OR. ISNAN(Y)) THEN
        FOR_IEEE_UNORDERED_K4 = .TRUE.
      ELSE
        FOR_IEEE_UNORDERED_K4 = .FALSE.
      ENDIF
      
    END FUNCTION
    
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_UNORDERED_K8 (X, Y)      
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_UNORDERED_K8
      REAL(8), INTENT(IN) :: X
      REAL(8), INTENT(IN) :: Y
      
      IF (ISNAN(X) .OR. ISNAN(Y)) THEN
        FOR_IEEE_UNORDERED_K8 = .TRUE.
      ELSE
        FOR_IEEE_UNORDERED_K8 = .FALSE.
      ENDIF
            
    END FUNCTION
    
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_UNORDERED_K16 (X, Y)         
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_UNORDERED_K16
      REAL(16), INTENT(IN) :: X
      REAL(16), INTENT(IN) :: Y
      
      IF (ISNAN(X) .OR. ISNAN(Y)) THEN
        FOR_IEEE_UNORDERED_K16 = .TRUE.
      ELSE
        FOR_IEEE_UNORDERED_K16 = .FALSE.
      ENDIF
            
    END FUNCTION
!DEC$ ENDIF

    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_UNORDERED_K48 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_UNORDERED_K48
      REAL(4), INTENT(IN) :: X
      REAL(8), INTENT(IN) :: Y
      
      IF (ISNAN(X) .OR. ISNAN(Y)) THEN
        FOR_IEEE_UNORDERED_K48 = .TRUE.
      ELSE
        FOR_IEEE_UNORDERED_K48 = .FALSE.
      ENDIF
            
    END FUNCTION  

!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_UNORDERED_K416 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_UNORDERED_K416
      REAL(4), INTENT(IN) :: X
      REAL(16), INTENT(IN) :: Y
      
      IF (ISNAN(X) .OR. ISNAN(Y)) THEN
        FOR_IEEE_UNORDERED_K416 = .TRUE.
      ELSE
        FOR_IEEE_UNORDERED_K416 = .FALSE.
      ENDIF
            
    END FUNCTION  
!DEC$ ENDIF

    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_UNORDERED_K84 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_UNORDERED_K84
      REAL(8), INTENT(IN) :: X
      REAL(4), INTENT(IN) :: Y
      
      IF (ISNAN(X) .OR. ISNAN(Y)) THEN
        FOR_IEEE_UNORDERED_K84 = .TRUE.
      ELSE
        FOR_IEEE_UNORDERED_K84 = .FALSE.
      ENDIF
            
    END FUNCTION
                  
!DEC$ IF .NOT. DEFINED(LONG_DOUBLE_SIZE64)
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_UNORDERED_K816 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_UNORDERED_K816
      REAL(8), INTENT(IN) :: X
      REAL(16), INTENT(IN) :: Y
      
      IF (ISNAN(X) .OR. ISNAN(Y)) THEN
        FOR_IEEE_UNORDERED_K816 = .TRUE.
      ELSE
        FOR_IEEE_UNORDERED_K816 = .FALSE.
      ENDIF
            
    END FUNCTION
      
    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_UNORDERED_K164 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_UNORDERED_K164
      REAL(16), INTENT(IN) :: X
      REAL(4), INTENT(IN) :: Y
      
      IF (ISNAN(X) .OR. ISNAN(Y)) THEN
        FOR_IEEE_UNORDERED_K164 = .TRUE.
      ELSE
        FOR_IEEE_UNORDERED_K164 = .FALSE.
      ENDIF
            
    END FUNCTION

    ELEMENTAL LOGICAL(4) FUNCTION FOR_IEEE_UNORDERED_K168 (X, Y)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_UNORDERED_K168
      REAL(16), INTENT(IN) :: X
      REAL(8), INTENT(IN) :: Y
      
      IF (ISNAN(X) .OR. ISNAN(Y)) THEN
        FOR_IEEE_UNORDERED_K168 = .TRUE.
      ELSE
        FOR_IEEE_UNORDERED_K168 = .FALSE.
      ENDIF
            
    END FUNCTION
!DEC$ ENDIF

END MODULE IEEE_ARITHMETIC
