C+ C Title: LBCERR C Author: T. R. Wyant C Date: 09-Sep-1987 C Modified: C Remarks: C Function LBCERR is the error output section of C program LBC. Error information is obtained from the C common area, and is displayed. If the error code is C worse than WARNING, it closes all files and returns C the value .FALSE. - otherwise, it returns the value C .TRUE. C- FUNCTION LBCERR INTEGER*2 LBCERR ! Continuation flag. INCLUDE 'LBCCOM.INC' INTEGER*2 ERREND ! End of error message. CHARACTER*1 NULL ! = ASCII . INTEGER*2 SEVEND ! End of severity text. CHARACTER*16 SEVTXT (0:4) ! Severity text. CHARACTER*132 TXTBUF ! Error text buffer. DATA NULL /0/ DATA SEVTXT /'Warning', 'Success', 1 'Error', 'Information', 'Fatal'/ C C Find end of error text. C ERREND = INDEX (ERRTXT(2:), ERRTXT(1:1)) C C Find end of severity text. C SEVEND = INDEX (SEVTXT (EXSTAT), ' ') C C Set up the error message for ERRORS. C WRITE (TXTBUF, 2010) '%0LBC -- ', SEVTXT (EXSTAT)(:SEVEND), 1 '-- ', ERRTXT(2:ERREND), NULL 2010 FORMAT (16A) C C Set up user arguments for ERRORS. C IF (ERRDEV .GT. 0) THEN ERRARG(1) = DEVSLN(ERRDEV) CALL GETADR (ERRARG(2), DEVSPC(ERRDEV), PARAMS(4)) ELSE ERRARG (1) = 0 ERRARG (2) = 0 END IF C C Call ERRORS to display the error text. C IF (STATYP .EQ. 0) THEN CALL ERRORS (LUNTO, TXTBUF, ERRARG) ELSE CALL ERRORS (LUNTO, TXTBUF, ERRARG, STATYP, STATUS) END IF C C IF (success or warning) THEN C RETURN to caller. C LBCERR = .TRUE. IF (FRCXIT .LT. 0) GO TO 9900 IF (FRCXIT .EQ. 0) THEN IF ((EXSTAT .AND. 1) .NE. 0) GO TO 9900 IF (EXSTAT .EQ. EXSWAR) GO TO 9900 IF (OUTNEW) CLOSE (UNIT=LUNOUT, DISPOSE='DELETE') END IF C C Close all files. C LBCERR = .FALSE. CLOSE (UNIT=LUNIN) CLOSE (UNIT=LUNOUT) CLOSE (UNIT=LUNTRC) IF (.NOT. INTERA) CALL EXIT C C Exit. C 9900 RETURN END