C Copyright © Oracle Corporation 1995.  All Rights Reserved.
	SUBROUTINE callable_error_handler(STATUS)



C-------------------------------------------------------
C This subroutine is an error handler to handle run-time
C errors that occur during a call to RDB$INTERPRET.
C-------------------------------------------------------

	IMPLICIT NONE
C-------------------------------------------------------
C Declare variables, including symbolic error codes and
C system 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$_STREAM_EOF
	INTEGER*4 LIB$MATCH_COND,SYS$PUTMSG,error_match,Rdb$STATUS
	INTEGER*4 STATUS,RDB$INTERPRET,RDB$SIGNAL,Rdb$MESSAGE_VECTOR(20)
	COMMON /Rdb$MESSAGE_VECTOR/ Rdb$MESSAGE_VECTOR
	EXTERNAL RDB$_LOCK_CONFLICT,RDB$_DEADLOCK,RDB$_NO_DUP
	EXTERNAL RDB$_NOT_VALID,RDB$_INTEG_FAIL,RDB$_STREAM_EOF
	EXTERNAL LIB$MATCH_COND

	OPEN (UNIT=3, FILE='callable_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(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$_STREAM_EOF))

C------------------------------------------------------
C The GO TO statement directs program to appropriate
C statements to execute depending on which error was
C 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(Rdb$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)
	RETURN

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

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

C	End of stream 
50	WRITE (5,500)
	WRITE (3,500)
	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 (' ',' There are no collges that match that code'/)

	END