C Copyright © Oracle Corporation 1995.  All Rights Reserved.
	SUBROUTINE error_handler(RDB$STATUS,success)

C------------------------------------------------------------
C This subroutine handles run-time errors trapped by
C the ON ERROR clause in the sample FORTRAN programs.
C------------------------------------------------------------


	IMPLICIT NONE
	LOGICAL success

C-----------------------------------------------------
C Declare variables and symbolic error codes and system
C service library routines.
C-----------------------------------------------------

	CHARACTER*80 msg_txt
	INTEGER*4 RDB$_LOCK_CONFLICT,RDB$_DEADLOCK,RDB$_NO_DUP
	INTEGER*4 RDB$_NOT_VALID,RDB$_INTEG_FAIL,RDB$_NO_RECORD
	INTEGER*4 RDB$STATUS,LIB$CALLG,SYS$GETMSG,LIB$SIGNAL
	INTEGER*4 LIB$MATCH_COND,SYS$PUTMSG,error_match
	EXTERNAL RDB$_LOCK_CONFLICT,RDB$_DEADLOCK,RDB$_NO_DUP
	EXTERNAL RDB$_NOT_VALID,RDB$_INTEG_FAIL,RDB$_NO_RECORD
	EXTERNAL LIB$MATCH_COND

&RDB&	DATABASE EXTERNAL pers = FILENAME 'MF_PERSONNEL' 
&RDB&	DBKEY SCOPE IS FINISH

	OPEN (UNIT=3, FILE='error_file.log', STATUS='new')

C-----------------------------------------------------
C Use LIB$MATCH_COND to determine which of a series
C of errors might have occurred.
C-----------------------------------------------------

	error_match = LIB$MATCH_COND(%REF(RDB$STATUS),
	1		%LOC(RDB$_LOCK_CONFLICT),
	1		%LOC(RDB$_DEADLOCK),
	1		%LOC(RDB$_NO_DUP),
	1		%LOC(RDB$_NOT_VALID),
	1		%LOC(RDB$_INTEG_FAIL),
	1		%LOC(RDB$_NO_RECORD))

C----------------------------------------------------
C The GO TO statement directs program to appropriate
C statements to execute depending on the error
C that was trapped.
C----------------------------------------------------

	GO TO (10,10,20,30,40,50) error_match

C	Unexpected Error
	WRITE (5,90)
	WRITE (3,90)
	CALL SYS$GETMSG(%VAL(Rdb$STATUS),,%DESCR(msg_txt))
	WRITE (5,95) msg_txt
	WRITE (3,95) msg_txt
	CALL LIB$CALLG(%REF(Rdb$MESSAGE_VECTOR),
	1		%VAL(LIB$SIGNAL))
	RETURN

C	Lock Conflict and Deadlock
10	CALL SYS$PUTMSG(%REF(Rdb$MESSAGE_VECTOR))
	WRITE (5,100)
	WRITE (3,100)
	RETURN

C	No duplicates allowed
20	CALL SYS$PUTMSG(%REF(Rdb$MESSAGE_VECTOR))
	WRITE (5,200)
	WRITE (3,200)
	success = .TRUE.
	RETURN

C	Invalid data
30	CALL SYS$PUTMSG(%REF(Rdb$MESSAGE_VECTOR))
	WRITE (5,300)
	WRITE (3,300)
	success = .TRUE.
	RETURN

C	Integrity failure
40	CALL SYS$PUTMSG(%REF(Rdb$MESSAGE_VECTOR))
	WRITE (5,400)
	WRITE (3,400)
	success = .TRUE.
	RETURN

C	Record deleted
50	WRITE (5,500)
	WRITE (3,500)
	success = .TRUE.
	RETURN

90	FORMAT (' ',' Unexpected error - terminating program'/)

95	FORMAT (' ',A80)

100	FORMAT (' ',' Another user is accessing data you 
	1attempted to access',/,' Please choose a new value 
	1and try again'/) 

200	FORMAT (' ',' You attempted to insert a record with a 
	1value already on file'/)

300	FORMAT (' ',' In the data you entered, you specified
	1 an invalid value',/,' Please correct the error and 
	1try again')

400	FORMAT (' ',' In the data you entered, you violated
	1a constraint',/,' Please correct the error and try
	1again'/)

500	FORMAT (' ',' Record entered has already been deleted'/)

	END