C+ C Title: READ C Author: T. R. Wyant C Date: 07-Oct-1987 C Modified: C Remarks: C READ reads an indexed file, and returns the desired C record in an extended logical name. The purpose of this C is to provide an indirect command file with a way to C read an indexed file by key. It can be invoked as an MCR C command, or interactively. The command syntax is C , where: C C is the name of the file to read; C is a list of zero or more keywords from C the following list: C C /KEYEQ=key Specifies the key. An exact match C is required. C C /KEYGE=key Specifies the key. An exact match C is not required. C C /KEYGT=key Specifies the key. The first record C whose key is GREATER THAN the given C key is returned. C C /SEQ Specifies the file be read in sequential C order, from the last key of reference. C C /NAME=logical Specifies that the data be stored in C the given logical name. The default C is READ$RECORD. C C /LOCAL Specifies that the data is stored in C a local symbol. C C /GROUP Specifies that the data is stored in C a group symbol. C C /SYSTEM Specifies that the data is stored in C a system-wide symbol. C C /KEYLEN=n Pads the key to "n" bytes, with spaces. C C /RECLEN=n Truncates the returned record to "n" C bytes. C C /RECLOC=n Specifies that the record be loaded into C the symbol starting with byte "n". The C default is the first byte ("n" = 1). C C /KEYID=n Specifies the key of reference for the C read. The default is key 0 (the primary C key). C C Keywords may not be abbreviated. C C If run interactively, switches are appended to the file C name. If no key is available, the user is prompted for C one. The record is displayed. C- PARAMETER LUNTI = 5 PARAMETER LUNTO = 5 PARAMETER LUNDBG = 4 PARAMETER LUNDSK = 1 PARAMETER FERLOW = 29 PARAMETER FERHI = 49 CHARACTER*40 FERTXT (FERLOW:FERHI) ! Error text. INTEGER*2 ERRLEN ! Error length. CHARACTER*60 ERRTXT ! Error text. INTEGER*2 EXSTAT ! Exit status. CHARACTER*80 FILNAM ! Name of file. INTEGER*2 FILSPD ! .TRUE. if file specified. INTEGER*2 FILOPN ! .TRUE. if file open. INTEGER*2 IDSW ! Directive status. INTEGER*2 INTERA ! .TRUE. if interactive. INTEGER*2 KEYLEN ! Length of key. INTEGER*2 KEYNO ! Key number. CHARACTER*80 KEYTXT ! Test of key. INTEGER*2 MATCRI ! Key match criterion. INTEGER*2 MCREND ! End of MCR command line. CHARACTER*80 MCRLIN ! MCR command line. INTEGER*2 MCRLOC ! Location in MCR command line. CHARACTER*255 RECBUF ! File record buffer. INTEGER*2 RECEND ! End of record. INTEGER*2 RECLEN ! File record to pass. INTEGER*2 RECLOC ! Location in record. INTEGER*2 RECSIZ ! File record size. INTEGER*2 SYMLEN ! Length of storage symbol. CHARACTER*80 SYMNAM ! Storage symbol. INTEGER*2 SYNEND ! End of syntax element. INTEGER*2 TBLNUM ! Table number for symbol. INTEGER*2 WRDEND ! End of keyword. DATA FERTXT / * 'No such file\', * 'Open failure\', * 'Mixed file access modes\', * 'Invalid logical unit number\', * 'ENDFILE error\', * 'Unit already open\', * 'Segmented record format error\', * 'Attempt to access non-existent record\', * 'Inconsistent record length\', * 'Error during write\', * 'Error during read\', * 'Recursive I/O operation\', * 'No buffer room\', * 'No such device\', * 'File name specification error\', * 'Inconsistent record type\', * 'Keyword value error in OPEN statement\', * 'Inconsistent OPEN/CLOSE parameters\', * 'Write to read-only file\', * 'Unsupported I/O operation\', * 'Invalid key specification\'/ OPEN (UNIT=LUNTO, TYPE='NEW', RECORDSIZE=255) SYMNAM = 'READ$RECORD' SYMLEN = INDEX(SYMNAM, ' ') - 1 IF (SYMLEN .LT. 0) SYMLEN = LEN (SYMNAM) FILOPN = .FALSE. ! File not open. KEYNO = 0 ! Assume primary key. INTERA = .TRUE. ! Assume interactive. RECLEN = LEN(RECBUF) ! Assume pass whole rec. RECLOC = 1 ! Start at beginning. TBLNUM = 4 ! Local symbol. EXSTAT = 1 ! Assume success. CALL ERRSET (29, , .FALSE., , .FALSE.) ! File not found. CALL ERRSET (30, , .FALSE., , .FALSE.) ! Open error. CALL ERRSET (36, , .FALSE., , .FALSE.) ! Record not found. CALL ERRSET (43, , .FALSE., , .FALSE.) ! File name spec error. CALL ERRSET (49, , .FALSE., , .FALSE.) ! Invalid key spec. CALL GETMCR (MCRLIN, MCREND) IF (MCREND .GT. 0) THEN MCRLOC = INDEX (MCRLIN(:MCREND), ' ') IF (MCRLOC .GT. 0) THEN MCRLOC = MCRLOC + 1 INTERA = .FALSE. GO TO 2000 END IF END IF 1000 WRITE (LUNTO, 1010) ' ' 1010 FORMAT (16A) WRITE (LUNTO, 1010) '$Enter file to read: ' READ (LUNTI, 1020, END=9990) MCREND, MCRLIN 1020 FORMAT (Q, A) 1030 FORMAT (I) MCRLOC = 1 2000 SYNEND = INDEX (MCRLIN(MCRLOC:MCREND), '/') IF (SYNEND .GT. 0) THEN SYNEND = SYNEND + MCRLOC - 2 ELSE SYNEND = MCREND END IF FILSPD = (SYNEND .GE. MCRLOC) IF (FILSPD) THEN CALL UPCASE (SYNEND-MCRLOC+1, MCRLIN(MCRLOC:SYNEND)) FILNAM = MCRLIN(MCRLOC:SYNEND) WRITE (LUNDBG, 2010) 'Command line', MCRLIN(MCRLOC:MCREND), 1 'File name part', MCRLIN(MCRLOC:SYNEND), 2 'Extracted file name', FILNAM 2010 FORMAT (' READ -- Debug --', (X, T19, A, :, ' = "', A, '"')) END IF MCRLOC = SYNEND + 1 KEYLEN = 0 ! We have no key. MATCRI = 1 ! Assume want exact match. IF (MCRLOC .LE. MCREND) THEN 2200 MCRLOC = MCRLOC + 1 SYNEND = INDEX (MCRLIN(MCRLOC:MCREND), '/') IF (SYNEND .GT. 0) THEN SYNEND = SYNEND + MCRLOC - 2 ELSE SYNEND = MCREND END IF WRDEND = INDEX (MCRLIN(MCRLOC:SYNEND), ':') IF (WRDEND .LE. 0) THEN WRDEND = INDEX (MCRLIN(MCRLOC:SYNEND), '=') END IF IF (WRDEND .GT. 0) THEN WRDEND = WRDEND + MCRLOC - 2 ELSE WRDEND = SYNEND END IF CALL UPCASE (WRDEND-MCRLOC+1, MCRLIN(MCRLOC:WRDEND)) IF (MCRLIN(MCRLOC:WRDEND) .EQ. 'KEYEQ') THEN KEYTXT = MCRLIN(WRDEND+2:SYNEND) KEYLEN = LEN (MCRLIN(WRDEND+2:SYNEND)) MATCRI = 1 ELSE IF (MCRLIN(MCRLOC:WRDEND) .EQ. 'KEYGE') THEN KEYTXT = MCRLIN(WRDEND+2:SYNEND) KEYLEN = LEN (MCRLIN(WRDEND+2:SYNEND)) MATCRI = 2 ELSE IF (MCRLIN(MCRLOC:WRDEND) .EQ. 'KEYGT') THEN KEYTXT = MCRLIN(WRDEND+2:SYNEND) KEYLEN = LEN (MCRLIN(WRDEND+2:SYNEND)) MATCRI = 3 ELSE IF (MCRLIN(MCRLOC:WRDEND) .EQ. 'SEQ') THEN MATCRI = 0 ELSE IF (MCRLIN(MCRLOC:WRDEND) .EQ. 'NAME') THEN SYMNAM = MCRLIN(WRDEND+2:SYNEND) SYMLEN = LEN (MCRLIN(WRDEND+2:SYNEND)) ELSE IF (MCRLIN(MCRLOC:WRDEND) .EQ. 'LOCAL') THEN TBLNUM = 4 ELSE IF (MCRLIN(MCRLOC:WRDEND) .EQ. 'GROUP') THEN TBLNUM = 1 ELSE IF (MCRLIN(MCRLOC:WRDEND) .EQ. 'SYSTEM') THEN TBLNUM = 0 ELSE IF (MCRLIN(MCRLOC:WRDEND) .EQ. 'KEYLEN') THEN READ (MCRLIN(WRDEND+2:SYNEND), 1030) KEYLEN ELSE IF (MCRLIN(MCRLOC:WRDEND) .EQ. 'RECLEN') THEN READ (MCRLIN(WRDEND+2:SYNEND), 1030) RECLEN ELSE IF (MCRLIN(MCRLOC:WRDEND) .EQ. 'RECLOC') THEN READ (MCRLIN(WRDEND+2:SYNEND), 1030) RECLOC ELSE IF (MCRLIN(MCRLOC:WRDEND) .EQ. 'KEYID') THEN READ (MCRLIN(WRDEND+2:SYNEND), 1030) KEYNO ELSE WRITE (ERRTXT, 1010) 'Switch "', 1 MCRLIN(MCRLOC-1:SYNEND), 2 '" is undefined\' GO TO 9000 END IF MCRLOC = SYNEND + 1 IF (MCRLOC .LE. MCREND) GO TO 2200 END IF IF (INTERA .AND. KEYLEN .LE. 0 .AND. MATCRI .GT. 0) THEN WRITE (LUNTO, 1010) '$Enter key text: ' READ (LUNTI, 1020, END=9990) KEYLEN, KEYTXT IF (MATCRI .LE. 0) MATCRI = 1 END IF CALL DELLON (1, TBLNUM, SYMNAM, SYMLEN, IDSW) IF (IDSW .LT. 0 .AND. IDSW .NE. -21) THEN ERRTXT = 'Failed to delete logical\' GO TO 9000 END IF IF (FILSPD) THEN IF (FILOPN) CLOSE (UNIT=LUNDSK) OPEN (UNIT=LUNDSK, NAME=FILNAM, TYPE='OLD', FORM='FORMATTED', 1 ORGANIZATION='INDEXED', ACCESS='KEYED', READONLY, 2 SHARED, ERR=8000) FILOPN = .TRUE. END IF IF (.NOT. FILOPN) THEN ERRTXT = 'File name not specified\' GO TO 9000 END IF IF (KEYLEN .LE. 0) MATCRI = 0 IF (MATCRI .EQ. 0) THEN READ (LUNDSK, 1020, ERR=8000) RECEND, RECBUF ELSE IF (MATCRI .EQ. 1) THEN READ (LUNDSK, 1020, KEYID=KEYNO, KEYEQ=KEYTXT(:KEYLEN), 1 ERR=8000) RECEND, RECBUF ELSE IF (MATCRI .EQ. 2) THEN READ (LUNDSK, 1020, KEYID=KEYNO, KEYGE=KEYTXT(:KEYLEN), 1 ERR=8000) RECEND, RECBUF ELSE IF (MATCRI .EQ. 3) THEN READ (LUNDSK, 1020, KEYID=KEYNO, KEYGT=KEYTXT(:KEYLEN), 1 ERR=8000) RECEND, RECBUF END IF IF (.NOT. INTERA) THEN CLOSE (UNIT=LUNDSK) FILOPN = .FALSE. END IF RECSIZ = MIN (RECEND-RECLOC+1, RECLEN) CALL CRELON (1, TBLNUM, SYMNAM, SYMLEN, RECBUF(RECLOC:), 1 RECSIZ, IDSW) IF (IDSW .LT. 0) THEN ERRTXT = 'Failed to store data in logical\' GO TO 9000 END IF IF (INTERA) THEN WRITE (LUNTO, 1010) ' Record text: "', 1 RECBUF(RECLOC:RECSIZ+RECLOC-1), '".' END IF GO TO 9900 8000 CALL ERRSNS (IDSW) IF (IDSW .GE. FERLOW .AND. IDSW .LE. FERHI) THEN ERRTXT = FERTXT (IDSW) IDSW = 0 ELSE ERRTXT = 'FORTRAN error\' END IF GO TO 9000 9000 CLOSE (UNIT=LUNDSK) FILOPN = .FALSE. ERRLEN = INDEX(ERRTXT,'\') - 1 IF (IDSW .NE. 0) THEN WRITE (LUNTO, 9010) ERRTXT(:ERRLEN), IDSW ELSE WRITE (LUNTO, 9010) ERRTXT(:ERRLEN) END IF EXSTAT = 2 9010 FORMAT ('0READ -- Error -- ', A, '.', :, /, 1 X, 17X, 'Error code =', I6) GO TO 9900 9900 IF (INTERA) GO TO 1000 9990 CALL EXIT (EXSTAT) END