C Copyright © Oracle Corporation 1995.  All Rights Reserved.
	SUBROUTINE callable                         

C-------------------------------------------------------------
C This subroutine demonstrates how to embed Callable RDO 
C statements that perform data manipulation tasks in one of 
C the FORTRAN sample programs. Note that you should always
C use RDBPRE FORTRAN DML to perform data manipulation
C tasks, unless special circumstances require that you
C use Callable RDO.  Callable RDO uses more resources,
C and is slower than using RDBPRE.
C-------------------------------------------------------------

	IMPLICIT NONE
	LOGICAL success
	INTEGER retry_count
	INTEGER*4 STATUS,RDB$INTERPRET,db_handle
	CHARACTER rdb_invoke*50,rdb_start*100,college_name*25
	CHARACTER rdb_string*100,college_code*4,rdb_get*50,city*20

C-------------------------------------------------------------
C Invoke the database in Callable RDO.  The DATABASE   
C statement issued in the main program (using RDBPRE) is 
C unknown to Callable RDO.  If an error occurs during the invoke,
C call an error handler.
C-------------------------------------------------------------

	rdb_invoke = 'DATABASE !VAL = FILENAME MF_PERSONNEL'
	STATUS = RDB$INTERPRET (rdb_invoke, %DESCR(db_handle))
	IF ((STATUS .AND. 1) .NE. 0) THEN
		CALL callable_error_handler(STATUS)
		success = .FALSE.
	END IF

	WRITE (6,90)
90	FORMAT ('1',T15,'**** RETRIEVE COLLEGE INFO with CALLABLE 
	1RDO ****'///)

C--------------------------------------------------------------
C Prompt user for the college code of the COLLEGES record he
C or she wants to view.
C--------------------------------------------------------------

	TYPE 110
110	FORMAT ('$',' Please enter college code of the 
	1college or type exit: ')
	ACCEPT 120, college_code
120	FORMAT (A)
	
	DO WHILE ((college_code.NE.'EXIT ').AND.(college_code.NE.'exit '))

		success = .FALSE.                              
		retry_count = 0

	    DO WHILE ((retry_count .LT. 5) .AND. (.NOT. (success)))
		success = .TRUE.
C--------------------------------------------------------
C Place the RDO START_TRANSACTION statement in a FORTRAN 
C variable.  Pass this variable to RDB$INTERPRET.
C-------------------------------------------------------

	 	rdb_start = 'START_TRANSACTION READ_WRITE 
	1RESERVING COLLEGES FOR EXCLUSIVE WRITE NOWAIT'
		STATUS = RDB$INTERPRET(%DESCR(RDB_START))
	        IF ((STATUS .AND. 1) .NE. 0) THEN     
			success = .FALSE.
			retry_count = retry_count + 1
			CALL callable_error_handler(STATUS)
		END IF
	    END DO

		success = .FALSE.
		retry_count = 0               

C---------------------------------------------
C Start a stream of COLLEGES records.
C---------------------------------------------

	    DO WHILE ((retry_count .LT. 5) .AND. (.NOT. (success)))
		success = .TRUE.
		rdb_string = 'START_STREAM coll_info USING C IN 
	1COLLEGES WITH C.COLLEGE_CODE = !VAL'
		STATUS = RDB$INTERPRET(%DESCR(rdb_string),college_code)
	        IF ((STATUS .AND. 1) .NE. 0) THEN     
			success = .FALSE.
			retry_count = retry_count + 1
			CALL callable_error_handler(STATUS)
		END IF
	    END DO

	    IF (success) THEN
		STATUS = RDB$INTERPRET(%DESCR('FETCH coll_info'))
	        IF ((STATUS .AND. 1) .NE. 0) THEN     
			success = .FALSE.
			retry_count = retry_count + 1
			CALL callable_error_handler(STATUS)
		END IF

C------------------------------------------
C Retrieve the value of a COLLEGES record.
C------------------------------------------

		IF (success) THEN
			rdb_get = 'GET !VAL = c.college_name;'//
	1			  '!VAL = c.city END_GET'
			CALL RDB$INTERPRET(rdb_get,college_name,city)

C-----------------------------------------
C Display the record.
C-----------------------------------------

			TYPE 1000, college_name,city
1000			FORMAT ('   ',A,' ',A)
		END IF
		CALL RDB$INTERPRET(%DESCR('END_STREAM coll_info'))
	    END IF

C-------------------------------------------------------
C Commit the transaction if 'success' equals true;
C otherwise, roll back the transaction.
C-------------------------------------------------------

	    IF (success) THEN
			CALL RDB$INTERPRET(%DESCR('COMMIT'))
	    ELSE
			CALL RDB$INTERPRET(%DESCR('ROLLBACK'))
	    END IF

	    PRINT *, '  '
	    TYPE 110
	    ACCEPT 120, college_code

	END DO

	RETURN
	END