! *
! **********************************************************************************
! * INTEL CORPORATION                                                              *
! * Copyright 2006-2011 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-29-2008  Created
! Apr-30-2008  Implemented needed changes of IEEE 2003 for the 11.0 beta update.
! 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.
! **********************************************************************************

MODULE IEEE_EXCEPTIONS

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

    IMPLICIT NONE

    PRIVATE
    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
    
    INTEGER (KIND=4), PARAMETER, PUBLIC :: IEEE_EXCEPTIONS_VERSION = 100

    INCLUDE 'fordef.for' 
    
! -------------------------------------------------------------------------
! IEEE Exception derived types
! -------------------------------------------------------------------------    
    
! Derived type for specification of a particular exception flag.    
    TYPE IEEE_FLAG_TYPE
        PRIVATE
        INTEGER(4) :: IEEE_FLAG 
    END TYPE IEEE_FLAG_TYPE
    
! Derived type for specifying a variable for saving the current floating point status.     
    TYPE IEEE_STATUS_TYPE
        PRIVATE
        SEQUENCE
        INTEGER(4), DIMENSION(IEEE_STATUS_TYPE_SIZE) :: ST_VALUE
    END TYPE IEEE_STATUS_TYPE
    
! -------------------------------------------------------------------------
! IEEE Exception flags
! -------------------------------------------------------------------------

! The following named constants specifying exception flags in the module are the only possible 
! values of the IEEE_FLAG_TYPE type:

! Invalid exception flag
    TYPE(IEEE_FLAG_TYPE), PARAMETER :: IEEE_INVALID = IEEE_FLAG_TYPE(FPE_M_TRAP_INV)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_INVALID 
! Overflow exception flag
    TYPE(IEEE_FLAG_TYPE), PARAMETER :: IEEE_OVERFLOW = IEEE_FLAG_TYPE(FPE_M_TRAP_OVF)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_OVERFLOW 
! Division by zero exception flag
    TYPE(IEEE_FLAG_TYPE), PARAMETER :: IEEE_DIVIDE_BY_ZERO = IEEE_FLAG_TYPE(FPE_M_TRAP_DIV0)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_DIVIDE_BY_ZERO 
! Underflow exception flag         
    TYPE(IEEE_FLAG_TYPE), PARAMETER :: IEEE_UNDERFLOW = IEEE_FLAG_TYPE(FPE_M_TRAP_UND)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_UNDERFLOW 
! The inexact exception flag
    TYPE(IEEE_FLAG_TYPE), PARAMETER :: IEEE_INEXACT = IEEE_FLAG_TYPE(FPE_M_TRAP_INE)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_INEXACT
! Common exception flags
    TYPE(IEEE_FLAG_TYPE), PARAMETER, DIMENSION(3) :: IEEE_USUAL =  &
    (/IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, IEEE_INVALID/)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_USUAL
! All exception flags
    TYPE(IEEE_FLAG_TYPE), PARAMETER, DIMENSION(5) :: IEEE_ALL =  &
    (/IEEE_USUAL, IEEE_UNDERFLOW, IEEE_INEXACT/)
    !DEC$ ATTRIBUTES DEFAULT :: IEEE_ALL

! -------------------------------------------------------------------------
! IEEE exceptions procedure interfaces
! -------------------------------------------------------------------------

    INTERFACE IEEE_GET_FLAG
    
      ELEMENTAL SUBROUTINE IEEE_GET_FLAG_K4 (FLAG, FLAG_VALUE)
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_get_flag_' :: IEEE_GET_FLAG_K4
        IMPORT IEEE_FLAG_TYPE
        IMPLICIT NONE
        TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
        LOGICAL(4), INTENT(OUT) :: FLAG_VALUE
      END SUBROUTINE    

      MODULE PROCEDURE FOR_IEEE_GET_FLAG_K2
      MODULE PROCEDURE FOR_IEEE_GET_FLAG_K8
      
    END INTERFACE IEEE_GET_FLAG
    
    INTERFACE IEEE_GET_HALTING_MODE
    
      ELEMENTAL SUBROUTINE IEEE_GET_HALTING_MODE_K4 (FLAG, HALTING)
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_get_halting_mode_' ::  IEEE_GET_HALTING_MODE_K4
        IMPORT IEEE_FLAG_TYPE
        IMPLICIT NONE
        TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
        LOGICAL(4), INTENT(OUT) :: HALTING
      END SUBROUTINE    

      MODULE PROCEDURE FOR_IEEE_GET_HALTING_MODE_K2
      MODULE PROCEDURE FOR_IEEE_GET_HALTING_MODE_K8 
      
    END INTERFACE IEEE_GET_HALTING_MODE
      
    INTERFACE IEEE_GET_STATUS

      SUBROUTINE FOR_IEEE_GET_STATUS (STATUS_VALUE)
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_get_status_' :: FOR_IEEE_GET_STATUS
        IMPORT IEEE_STATUS_TYPE
        IMPLICIT NONE
        TYPE(IEEE_STATUS_TYPE), INTENT(OUT) :: STATUS_VALUE
      END SUBROUTINE

    END INTERFACE IEEE_GET_STATUS

    INTERFACE IEEE_SET_STATUS

      SUBROUTINE FOR_IEEE_SET_STATUS (STATUS_VALUE)
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_set_status_' :: FOR_IEEE_SET_STATUS
        IMPORT IEEE_STATUS_TYPE
        IMPLICIT NONE
        TYPE(IEEE_STATUS_TYPE), INTENT(IN) :: STATUS_VALUE
      END SUBROUTINE

    END INTERFACE IEEE_SET_STATUS

    INTERFACE IEEE_SET_FLAG
    
      ELEMENTAL SUBROUTINE IEEE_SET_FLAG_K4 (FLAG, FLAG_VALUE)
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_set_flag_' :: IEEE_SET_FLAG_K4
        IMPORT IEEE_FLAG_TYPE
        IMPLICIT NONE
        TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
        LOGICAL(4), INTENT(IN) :: FLAG_VALUE
      END SUBROUTINE    

      MODULE PROCEDURE FOR_IEEE_SET_FLAG_K2
      MODULE PROCEDURE FOR_IEEE_SET_FLAG_K8
      
    END INTERFACE IEEE_SET_FLAG
    
    INTERFACE IEEE_SET_HALTING_MODE
    
      ELEMENTAL SUBROUTINE IEEE_SET_HALTING_MODE_K4 (FLAG, HALTING)
        !DEC$ ATTRIBUTES DEFAULT,DECORATE,ALIAS:'__for_ieee_set_halting_mode_' ::  IEEE_SET_HALTING_MODE_K4
        IMPORT IEEE_FLAG_TYPE
        IMPLICIT NONE
        TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
        LOGICAL(4), INTENT(IN) :: HALTING
      END SUBROUTINE
    
      MODULE PROCEDURE FOR_IEEE_SET_HALTING_MODE_K2
      MODULE PROCEDURE FOR_IEEE_SET_HALTING_MODE_K8
      
    END INTERFACE IEEE_SET_HALTING_MODE
    
    INTERFACE IEEE_SUPPORT_FLAG   

      MODULE PROCEDURE FOR_IEEE_SUPPORT_FLAG
      MODULE PROCEDURE FOR_IEEE_SUPPORT_FLAG_ALL
      
    END INTERFACE IEEE_SUPPORT_FLAG    
        
    INTERFACE IEEE_SUPPORT_HALTING
    
      MODULE PROCEDURE FOR_IEEE_SUPPORT_HALTING

    END INTERFACE IEEE_SUPPORT_HALTING
    
! -----------------------------------------------------------------------------
! PROCEDURES
! -----------------------------------------------------------------------------
    CONTAINS
    
!-------------------------------------------------------------------------------
! Description. Get an exception flag state.
!
! Arguments:
! FLAG - specifies the IEEE flag to be obtained.
!
! FLAG_VALUE - if the value of FLAG is IEEE_INVALID, IEEE_OVERFLOW, 
!   IEEE_DIVIDE_BY_ZERO, IEEE_UNDERFLOW, or IEEE_INEXACT, the result 
!   value is true if the corresponding exception flag is signaling and 
!   is false otherwise. 
!-------------------------------------------------------------------------------    
    ELEMENTAL SUBROUTINE FOR_IEEE_GET_FLAG_K2 (FLAG, FLAG_VALUE)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_GET_FLAG_K2
      TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
      LOGICAL(2), INTENT(OUT) :: FLAG_VALUE
      LOGICAL(4) T_FLAG_VALUE      
      
      CALL IEEE_GET_FLAG_K4 (FLAG, T_FLAG_VALUE)
      FLAG_VALUE = LOGICAL(T_FLAG_VALUE, 2)
    END SUBROUTINE

    ELEMENTAL SUBROUTINE FOR_IEEE_GET_FLAG_K8 (FLAG, FLAG_VALUE)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_GET_FLAG_K8
      TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
      LOGICAL(8), INTENT(OUT) :: FLAG_VALUE
      LOGICAL(4) T_FLAG_VALUE      
      
      CALL IEEE_GET_FLAG_K4 (FLAG, T_FLAG_VALUE)
      FLAG_VALUE = LOGICAL(T_FLAG_VALUE, 8)      
    END SUBROUTINE
    
!-------------------------------------------------------------------------------
! Description. Get halting mode for an exception.
!
! Arguments:
! FLAG - specifies the IEEE flag. It shall have one of the values 
!   IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, IEEE_UNDERFLOW, or 
!   IEEE_INEXACT.
!
! HALTING - it is true if the exception specified by FLAG
!   will cause halting. Otherwise, the value is false.
!-------------------------------------------------------------------------------    
    ELEMENTAL SUBROUTINE FOR_IEEE_GET_HALTING_MODE_K2 (FLAG, HALTING)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_GET_HALTING_MODE_K2
      TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
      LOGICAL(2), INTENT(OUT) :: HALTING
      LOGICAL(4) T_HALTING      
      
      CALL IEEE_GET_HALTING_MODE_K4 (FLAG, T_HALTING)
      HALTING = LOGICAL(HALTING, 2)        
    END SUBROUTINE
      
    ELEMENTAL SUBROUTINE FOR_IEEE_GET_HALTING_MODE_K8 (FLAG, HALTING)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_GET_HALTING_MODE_K8
      TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
      LOGICAL(8), INTENT(OUT) :: HALTING
      LOGICAL(4) T_HALTING      
      
      CALL IEEE_GET_HALTING_MODE_K4 (FLAG, T_HALTING)
      HALTING = LOGICAL(HALTING, 8)       
    END SUBROUTINE
    
!-------------------------------------------------------------------------------
! Description. Assign a value to an exception flag.
!
! Arguments:
! FLAG - it is IEEE_INVALID, IEEE_OVERFLOW, 
!   IEEE_DIVIDE_BY_ZERO, IEEE_UNDERFLOW, or IEEE_INEXACT, the corresponding 
!   exception flag is assigned a value. FLAG argument can be an array. No 
!   two elements of FLAG shall have the same value.
!
! FLAG_VALUE - shall be conformable with FLAG. If an element 
!   has the value true, the corresponding flag is set to be signaling; 
!   otherwise, the flag is set to be quiet.
!-------------------------------------------------------------------------------    
    ELEMENTAL SUBROUTINE FOR_IEEE_SET_FLAG_K2 (FLAG, FLAG_VALUE)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SET_FLAG_K2
      TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
      LOGICAL(2), INTENT(IN) :: FLAG_VALUE
      
      CALL IEEE_SET_FLAG_K4 (FLAG, LOGICAL(FLAG_VALUE, 4))
    END SUBROUTINE

    ELEMENTAL SUBROUTINE FOR_IEEE_SET_FLAG_K8 (FLAG, FLAG_VALUE)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SET_FLAG_K8
      TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
      LOGICAL(8), INTENT(IN) :: FLAG_VALUE
      
      CALL IEEE_SET_FLAG_K4 (FLAG, LOGICAL(FLAG_VALUE, 4))
    END SUBROUTINE    

!-------------------------------------------------------------------------------
! Description. Controls continuation or halting after an exception.
!
! Arguments:
! FLAG - its value which shall have only the values IEEE_INVALID, 
!   IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, IEEE_UNDERFLOW, or IEEE_INEXACT. FLAG
!   argument can be an array. No two elements of FLAG shall have the same
!   value.
!
! HALTING - its value which shall be conformable with FLAG. If an element has 
!   the value true, the corresponding exception specified by FLAG will cause 
!   halting. Otherwise, execution will continue after this exception.
!-------------------------------------------------------------------------------
    ELEMENTAL SUBROUTINE FOR_IEEE_SET_HALTING_MODE_K2 (FLAG, HALTING)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SET_HALTING_MODE_K2
      TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
      LOGICAL(2), INTENT(IN) :: HALTING
      
      CALL IEEE_SET_HALTING_MODE_K4 (FLAG, LOGICAL(HALTING, 4))
    END SUBROUTINE
      
    ELEMENTAL SUBROUTINE FOR_IEEE_SET_HALTING_MODE_K8 (FLAG, HALTING)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SET_HALTING_MODE_K8
      TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
      LOGICAL(8), INTENT(IN) :: HALTING
      
      CALL IEEE_SET_HALTING_MODE_K4 (FLAG, LOGICAL(HALTING, 4))      
    END SUBROUTINE
      
!-------------------------------------------------------------------------------
! Description. Inquire whether the processor supports an exception.
!
! Arguments:
! FLAG - its value which shall be one of IEEE_INVALID, IEEE_OVERFLOW, 
!   IEEE_DIVIDE_BY_ZERO, IEEE_UNDERFLOW, or IEEE_INEXACT.
!
! X - pointer to real value or real array.
!
! Result Value.
!   Case (i): FOR_IEEE_SUPPORT_FLAG (FLAG, X) has the value true if the 
!   processor supports detection of the specified exception for real variables 
!   of the same kind type parameter as X; otherwise, it has the value false.
!   Case (ii): FOR_IEEE_SUPPORT_FLAG (FLAG) has the value true if and only 
!   if FOR_IEEE_SUPPORT_FLAG (FLAG, X) has the value true for all real X.
!-------------------------------------------------------------------------------
    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_FLAG (FLAG, X)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_FLAG
      TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
      !DEC$ ATTRIBUTES NO_ARG_CHECK :: X       
      REAL(4), INTENT(IN) :: X

      FOR_IEEE_SUPPORT_FLAG = .TRUE.
    END FUNCTION 

    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_FLAG_ALL (FLAG)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_FLAG_ALL
      TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
      
      FOR_IEEE_SUPPORT_FLAG_ALL = .TRUE.      
    END FUNCTION
            
!-------------------------------------------------------------------------------
! Description: Inquire whether the processor supports the ability to control
!   during program execution whether to abort or continue execution after an
!   exception.
!
! Argument:
! FLAG - its value which shall be one of IEEE_INVALID, IEEE_OVERFLOW,
!   IEEE_DIVIDE_BY_ZERO, IEEE_UNDERFLOW, or IEEE_INEXACT.
!
! Result: The result has the value true if the processor supports the
!   ability to control during program execution whether to abort or continue
!   execution after the exception specified by *pflag; otherwise, it has the
!   value false. Support includes the ability to change the mode by
!   IEEE_SET_HALTING_MODE (FLAG, HALTING).
!-------------------------------------------------------------------------------
    LOGICAL(4) FUNCTION FOR_IEEE_SUPPORT_HALTING (FLAG)
      !DEC$ ATTRIBUTES DEFAULT :: FOR_IEEE_SUPPORT_HALTING 
      TYPE(IEEE_FLAG_TYPE), INTENT(IN) :: FLAG
      
      FOR_IEEE_SUPPORT_HALTING = .TRUE.
    END FUNCTION 

END MODULE IEEE_EXCEPTIONS
