C************************************************************************ C* * C* FILE NAME: OPTCHECK_INPUT.FOR * C* * C* AUTHOR: H. SIEGEL, TRW, 24 MAY 1988 * C* * C* PURPOSE: INPUT FILE MANIPULATION ROUTINES FOR OPTCHECK TOOL * C* * C************************************************************************ C SUBROUTINE OPEN_INPUT_FILE(ERR_FLAG) C IMPLICIT NONE C INCLUDE '($FABDEF)' INCLUDE '($NAMDEF)' INCLUDE '($RABDEF)' INCLUDE '($RMSDEF)' INCLUDE '($XABFHCDEF)' C INCLUDE 'OPTCHECK_INPUT_RMS.INC' C INTEGER*4 SYS$OPEN INTEGER*4 SYS$CONNECT C LOGICAL*1 ERR_FLAG C INTEGER*4 STS C EXTERNAL OPTCHK__OPENIN C C--------------------------------------------------------------------------- C STS = SYS$OPEN(IN_FAB) IF (STS) STS = SYS$CONNECT(IN_RAB) IF (.NOT. STS) THEN CALL FILE_STATUS(OPTCHK__OPENIN, IN_FAB) ERR_FLAG = .TRUE. ELSE ERR_FLAG = .FALSE. ENDIF C RETURN END SUBROUTINE GET_LINE(BUFFER, OUTLEN, ERR_FLAG) C IMPLICIT NONE C INCLUDE '($FABDEF)' INCLUDE '($NAMDEF)' INCLUDE '($RABDEF)' INCLUDE '($RMSDEF)' INCLUDE '($XABFHCDEF)' C INCLUDE 'OPTCHECK_INPUT_RMS.INC' C INTEGER*4 LIB$GET_VM INTEGER*4 LIB$FREE_VM C CHARACTER*(*) BUFFER INTEGER*2 OUTLEN LOGICAL*1 ERR_FLAG C INTEGER*4 STS C C--------------------------------------------------------------------------- C IF (IN_FHC_XAB.XAB$W_LRL .GT. INBFR_DSCR(1)) THEN IF (INBFR_DSCR(2) .NE. 0) THEN STS = LIB$FREE_VM(INBFR_DSCR(1), INBFR_DSCR(2)) IF (.NOT. STS) CALL LIB$SIGNAL(%VAL(STS)) ENDIF INBFR_DSCR(1) = IN_FHC_XAB.XAB$W_LRL STS = LIB$GET_VM(INBFR_DSCR(1), INBFR_DSCR(2)) IF (.NOT. STS) CALL LIB$SIGNAL(%VAL(STS)) ENDIF C CALL READ_FILE(BUFFER, OUTLEN, ERR_FLAG, INBFR_DSCR) C RETURN END SUBROUTINE READ_FILE(BUFFER, OUTLEN, ERR_FLAG, WRKBFR) C IMPLICIT NONE C INCLUDE '($FABDEF)' INCLUDE '($NAMDEF)' INCLUDE '($RABDEF)' INCLUDE '($RMSDEF)' INCLUDE '($XABFHCDEF)' C INCLUDE 'OPTCHECK_INPUT_RMS.INC' C INTEGER*4 SYS$GET C CHARACTER*(*) BUFFER INTEGER*2 OUTLEN LOGICAL*1 ERR_FLAG CHARACTER*(*) WRKBFR C INTEGER*4 STS INTEGER*2 ESF_FLAGS, WRKLEN, BANG LOGICAL*1 MORE C EXTERNAL ESF_M_COLLAPSE EXTERNAL ESF_M_UPCASE EXTERNAL OPTCHK__READERR EXTERNAL OPTCHK__BFROVRFLW C C--------------------------------------------------------------------------- C ESF_FLAGS = %LOC(ESF_M_COLLAPSE) .OR. %LOC(ESF_M_UPCASE) C IN_RAB.RAB$W_USZ = LEN(WRKBFR) IN_RAB.RAB$L_UBF = %LOC(WRKBFR) C OUTLEN = 0 ERR_FLAG = .FALSE. MORE = .TRUE. DO WHILE (MORE .AND. (.NOT. ERR_FLAG)) STS = SYS$GET(IN_RAB) IF (.NOT. STS) THEN ERR_FLAG = .TRUE. IF (STS .NE. RMS$_EOF) CALL FILE_STATUS(OPTCHK__READERR, IN_FAB) ELSE WRKLEN = IN_RAB.RAB$W_RSZ CALL EDIT_STRING(ESF_FLAGS, WRKBFR(1:WRKLEN), WRKBFR, WRKLEN) BANG = INDEX(WRKBFR(1:WRKLEN),'!') IF (BANG .GT. 0) WRKLEN = BANG-1 IF (WRKLEN .GT. 0) THEN IF (WRKBFR(WRKLEN:WRKLEN) .EQ. '-') THEN WRKLEN = WRKLEN - 1 ELSE MORE = .FALSE. ENDIF IF ((OUTLEN+WRKLEN) .GT. LEN(BUFFER)) THEN CALL LIB$STOP(OPTCHK__BFROVRFLW) ENDIF BUFFER(OUTLEN+1:) = WRKBFR(1:WRKLEN) OUTLEN = OUTLEN + WRKLEN ENDIF ENDIF ENDDO C RETURN END SUBROUTINE CLOSE_INPUT_FILE(ERR_FLAG) C IMPLICIT NONE C INCLUDE '($FABDEF)' INCLUDE '($NAMDEF)' INCLUDE '($RABDEF)' INCLUDE '($RMSDEF)' INCLUDE '($XABFHCDEF)' C INCLUDE 'OPTCHECK_INPUT_RMS.INC' C INTEGER*4 SYS$CLOSE C LOGICAL*1 ERR_FLAG C INTEGER*4 STS C EXTERNAL OPTCHK__CLOSEIN C C--------------------------------------------------------------------------- C STS = SYS$CLOSE(IN_FAB) IF (.NOT. STS) THEN CALL FILE_STATUS(OPTCHK__CLOSEIN, IN_FAB) ERR_FLAG = .TRUE. ELSE ERR_FLAG = .FALSE. ENDIF C RETURN END