! Non-default compiler options:
!   Fortran Debug and Release:  fpe:0 on X86
!   Fortran Release:  Optimization:None, Runtime Array Bound Checking enabled, and Traceback
!   C Debug and Release:  Code Generation:Use Runtime Library:  Multithreaded DLL
! Linker output file: gen_errs.dll

            SUBROUTINE Fortran_FP_Trap_Enable ()
            ! Specify that the routine name is to be made 
            ! available to callers of the DLL and that the 
            ! external name should not have any prefix or suffix
            ! (directives separated for clarity)
            !DEC$ ATTRIBUTES DLLEXPORT :: Fortran_FP_Trap_Enable
            !DEC$ ATTRIBUTES ALIAS:'Fortran_FP_Trap_Enable' :: Fortran_FP_Trap_Enable
			USE DFLIB
			INTEGER(2) CTL,TRAP_ENABLES

			CALL CLEARSTATUSFPQQ()
			CALL GETCONTROLFPQQ(CTL)
			CTL = CTL .AND. (.NOT. FPCW$MCW_EM)
			TRAP_ENABLES = FPCW$MCW_EM .XOR. (FPCW$OVERFLOW .OR. FPCW$ZERODIVIDE .OR. FPCW$INVALID)
			CTL = CTL .OR. TRAP_ENABLES
			CALL SETCONTROLFPQQ(CTL)

			RETURN
            END SUBROUTINE

            SUBROUTINE Fortran_FP_Trap_Disable ()
            ! Specify that the routine name is to be made 
            ! available to callers of the DLL and that the 
            ! external name should not have any prefix or suffix
            ! (directives separated for clarity)
            !DEC$ ATTRIBUTES DLLEXPORT :: Fortran_FP_Trap_Disable
            !DEC$ ATTRIBUTES ALIAS:'Fortran_FP_Trap_Disable' :: Fortran_FP_Trap_Disable
			USE DFLIB
			INTEGER(2) CTL,TRAP_ENABLES

			CALL GETCONTROLFPQQ(CTL)
			CTL = CTL .AND. (.NOT. FPCW$MCW_EM)
			TRAP_ENABLES = FPCW$MCW_EM
			CTL = CTL .OR. TRAP_ENABLES
			CALL SETCONTROLFPQQ(CTL)

			RETURN
            END SUBROUTINE

            SUBROUTINE Fortran_IDivByZero ()
            ! Specify that the routine name is to be made 
            ! available to callers of the DLL and that the 
            ! external name should not have any prefix or suffix
            ! (directives separated for clarity)
            !DEC$ ATTRIBUTES DLLEXPORT :: Fortran_IDivByZero
            !DEC$ ATTRIBUTES ALIAS:'Fortran_IDivByZero' :: Fortran_IDivByZero
			INTEGER(4) I,J,K

			I = 3
			J = 0
			K = I/K

			RETURN
            END SUBROUTINE

            SUBROUTINE Fortran_FltOvf ()
            ! Specify that the routine name is to be made 
            ! available to callers of the DLL and that the 
            ! external name should not have any prefix or suffix
            ! (directives separated for clarity)
            !DEC$ ATTRIBUTES DLLEXPORT :: Fortran_FltOvf
            !DEC$ ATTRIBUTES ALIAS:'Fortran_FltOvf' :: Fortran_FltOvf
			REAL(8) A,B,C

			A = 3.0D200
			B = 2.0D-200
			C = A/B

			RETURN
            END SUBROUTINE

            INTEGER(4) FUNCTION Fortran_Test ( TEST_SELECT )
            ! Specify that the routine name is to be made 
            ! available to callers of the DLL and that the 
            ! external name should not have any prefix or suffix
            ! (directives separated for clarity)
            !DEC$ ATTRIBUTES DLLEXPORT :: Fortran_Test
			!DEC$ IF DEFINED(_X86_)
			!DEC$ATTRIBUTES C, ALIAS:'_Fortran_Test' :: Fortran_Test
			!DEC$ ELSE
			!DEC$ATTRIBUTES C, ALIAS:'Fortran_Test' :: Fortran_Test
			!DEC$ ENDIF
            INTEGER(4) TEST_SELECT
            INTERFACE
               INTEGER(4) FUNCTION BING ( TEST_SELECT )
               INTEGER(4) TEST_SELECT
               END FUNCTION
            END INTERFACE

			! Call down through a few routine levels just to make
			! the call stack a little more interesting in the
			! traceback output for the IO errors.

            Fortran_Test = BING( TEST_SELECT )
            RETURN
            END FUNCTION

            INTEGER(4) FUNCTION BING ( TEST_SELECT )
            INTEGER(4) TEST_SELECT
            INTERFACE
               INTEGER(4) FUNCTION BANG ( TEST_SELECT )
               INTEGER(4) TEST_SELECT
               END FUNCTION
            END INTERFACE

            BING = BANG( TEST_SELECT )
            RETURN
            END FUNCTION

            INTEGER(4) FUNCTION BANG ( TEST_SELECT )
            INTEGER(4) TEST_SELECT
            INTERFACE
               INTEGER(4) FUNCTION BONG ( TEST_SELECT )
               INTEGER(4) TEST_SELECT
               END FUNCTION
            END INTERFACE

            BANG = BONG( TEST_SELECT )
            RETURN
            END FUNCTION

            INTEGER(4) FUNCTION BONG ( TEST_SELECT )
			USE DFLIB
			INCLUDE 'IOSDEF.FOR'
			INTEGER(4) TEST_SELECT
			INTEGER(4) STS
			INTEGER(4) NUM
			INTEGER(4) I
			REAL(4) A(3)

			TYPE ITEM
				CHARACTER*80		:: STR
				INTEGER				:: VALUE
				TYPE(ITEM), POINTER :: NEXT_ITEM
			END TYPE ITEM
			TYPE (ITEM), POINTER :: LIST_PTR

			SELECT CASE (TEST_SELECT)
				CASE(0)
				! This should generate an access violation
					ALLOCATE(LIST_PTR)
					LIST_PTR => LIST_PTR%NEXT_ITEM
					LIST_PTR%VALUE = 4
				CASE(1)
				! This should generate a nonexistent file status
					OPEN(10,FILE='A_NONEXISTENT_FILE.DAT',STATUS='OLD',IOSTAT=STS)
					IF (STS .NE. FOR$IOS_SUCCESS) THEN
						CALL TRACEBACKQQ("Here's the OPEN error!",USER_EXIT_CODE=-1)
						BONG = STS
						RETURN
					ENDIF
					BONG = STS
					RETURN
				CASE(2)
				! The WRITE statement should gen an unformatted io to formatted file error status
				! It will show up as a mixed file access error.
					OPEN(10,FILE='XXXYYYZZZ.DAT',FORM='FORMATTED', STATUS='NEW',IOSTAT=STS)
					IF (STS .NE. FOR$IOS_SUCCESS) THEN
						BONG = STS
						RETURN
					ENDIF
					NUM = 2
					WRITE(10,IOSTAT=STS) NUM
					IF (STS .NE. FOR$IOS_SUCCESS) THEN
						CALL TRACEBACKQQ("Here's the WRITE error!",USER_EXIT_CODE=-1)
						CLOSE(10,DISP='DELETE')
						BONG = STS
						RETURN
					ENDIF
					CLOSE(10,DISP='DELETE')
					BONG = STS
					RETURN
				CASE(3)
				! This should generate an array bounds exceeded exception
					DO I=1,5
						A(I) = REAL(I)
					END DO
			END SELECT

			RETURN
            END FUNCTION

			INTEGER(4) FUNCTION CHECK_EXCEPTION_INFO ( ExceptionInfo )
            ! Specify that the routine name is to be made 
            ! available to callers of the DLL and that the 
            ! external name should not have any prefix or suffix
            ! (directives separated for clarity)
            !DEC$ ATTRIBUTES DLLEXPORT :: CHECK_EXCEPTION_INFO
			!DEC$ IF DEFINED(_X86_)
			!DEC$ATTRIBUTES C, ALIAS:'_CHECK_EXCEPTION_INFO' :: CHECK_EXCEPTION_INFO
			!DEC$ ELSE
			!DEC$ATTRIBUTES C, ALIAS:'CHECK_EXCEPTION_INFO' :: CHECK_EXCEPTION_INFO
			!DEC$ ENDIF
			USE DFLIB
			USE DFWINTY
			USE DFWIN
			!DEC$ ATTRIBUTES REFERENCE :: ExceptionInfo
			TYPE(T_EXCEPTION_POINTERS) ExceptionInfo

			TYPE(T_EXCEPTION_RECORD) ERECPTR
			TYPE(T_CONTEXT) CTXPTR

			POINTER(EPTR,ERECPTR)
			POINTER(CTXP,CTXPTR)

			EPTR = ExceptionInfo.ExceptionRecord
			CTXP = ExceptionInfo.ContextRecord

			IF ( ERECPTR.ExceptionCode .EQ. STATUS_ACCESS_VIOLATION ) THEN
				CALL TRACEBACKQQ(STRING='Here is the access violation exception.', &
							USER_EXIT_CODE=-1, &
							EPTR=%LOC(ExceptionInfo))
				CHECK_EXCEPTION_INFO = EXCEPTION_EXECUTE_HANDLER
			ELSEIF ( ERECPTR.ExceptionCode .EQ. STATUS_ARRAY_BOUNDS_EXCEEDED ) THEN
				CALL TRACEBACKQQ(STRING='Here is the array bounds exceeded exception.', &
							USER_EXIT_CODE=-1, &
							EPTR=%LOC(ExceptionInfo))
				CHECK_EXCEPTION_INFO = EXCEPTION_EXECUTE_HANDLER
			ELSE
				CALL TRACEBACKQQ(STRING='Saw an unexpected exception.', &
							USER_EXIT_CODE=-1, &
							EPTR=%LOC(ExceptionInfo))
				CHECK_EXCEPTION_INFO = EXCEPTION_EXECUTE_HANDLER
			END IF

			END

			INTEGER(4) FUNCTION TRANSLATE_TO_MY_APP_CODES ( CODE, TABLE_SEL )
			! Specify that the routine name is to be made 
			! available to callers of the DLL and that the 
			! external name should not have any prefix or suffix
			! (directives separated for clarity)
			!DEC$ ATTRIBUTES DLLEXPORT :: TRANSLATE_TO_MY_APP_CODES
			!DEC$ IF DEFINED(_X86_)
			!DEC$ATTRIBUTES C, ALIAS:'_TRANSLATE_TO_MY_APP_CODES' :: TRANSLATE_TO_MY_APP_CODES
			!DEC$ ELSE
			!DEC$ATTRIBUTES C, ALIAS:'TRANSLATE_TO_MY_APP_CODES' :: TRANSLATE_TO_MY_APP_CODES
			!DEC$ ENDIF
			USE DFWINTY

			INCLUDE 'IOSDEF.FOR'
			INTEGER, PARAMETER :: USE_FORTRAN_STATUS_TABLE   =  0
			INTEGER, PARAMETER :: USE_EXCEPTION_STATUS_TABLE =  1
			INTEGER, PARAMETER :: MY_APP_SUCCESS = 0
			INTEGER, PARAMETER :: MY_APP_NONEXISTENT_FILE = 1
			INTEGER, PARAMETER :: MY_APP_MIXFILACC = 2
			INTEGER, PARAMETER :: MY_APP_UNKNOWN_ERROR = -1
			INTEGER, PARAMETER :: MY_APP_ACCVIO = -2
			INTEGER, PARAMETER :: MY_APP_ARRAY_BOUNDS_EXCEPTION = -3

			TYPE MYAPP_MAP_TABLE
				SEQUENCE
				INTEGER(4) CODE
				INTEGER(4) MY_APP_CODE
			END TYPE MYAPP_MAP_TABLE

			INTEGER(4) CODE
			INTEGER(4) TABLE_SEL
			INTEGER(4) I
			TYPE (MYAPP_MAP_TABLE) EXCEPTIONS_TO_MY_APP_CODE_MAPPING(2)
			TYPE (MYAPP_MAP_TABLE) FORTRAN_TO_MY_APP_CODE_MAPPING(3)
			DATA EXCEPTIONS_TO_MY_APP_CODE_MAPPING / &
					MYAPP_MAP_TABLE(STATUS_ACCESS_VIOLATION, MY_APP_ACCVIO), &
					MYAPP_MAP_TABLE(STATUS_ARRAY_BOUNDS_EXCEEDED, MY_APP_ARRAY_BOUNDS_EXCEPTION)/
			DATA FORTRAN_TO_MY_APP_CODE_MAPPING/ &
					MYAPP_MAP_TABLE(FOR$IOS_SUCCESS, MY_APP_SUCCESS), &
					MYAPP_MAP_TABLE(FOR$IOS_FILNOTFOU, MY_APP_NONEXISTENT_FILE), &
					MYAPP_MAP_TABLE(FOR$IOS_MIXFILACC, MY_APP_MIXFILACC)/

			SELECT CASE (TABLE_SEL)
				CASE(USE_FORTRAN_STATUS_TABLE)
					DO I = 1, SIZE(FORTRAN_TO_MY_APP_CODE_MAPPING)
						IF (CODE .EQ. FORTRAN_TO_MY_APP_CODE_MAPPING(I).CODE) THEN
							TRANSLATE_TO_MY_APP_CODES = FORTRAN_TO_MY_APP_CODE_MAPPING(I).MY_APP_CODE
							RETURN
						END IF
					END DO
				CASE(USE_EXCEPTION_STATUS_TABLE)
					DO I = 1, SIZE(EXCEPTIONS_TO_MY_APP_CODE_MAPPING)
						IF (CODE .EQ. EXCEPTIONS_TO_MY_APP_CODE_MAPPING(I).CODE) THEN
							TRANSLATE_TO_MY_APP_CODES = EXCEPTIONS_TO_MY_APP_CODE_MAPPING(I).MY_APP_CODE
							RETURN
						END IF
					END DO
			END SELECT
			TRANSLATE_TO_MY_APP_CODES = MY_APP_UNKNOWN_ERROR
			RETURN

			END FUNCTION
