home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
prime.tar.gz
/
prime.tar
/
primet.ftn
< prev
next >
Wrap
Text File
|
1988-08-16
|
9KB
|
274 lines
C VTAPEIN - READ LABELED TAPES WITH VERIABLE RECORD LENGTHS
C
C R. COUCH PRIME MARKETING SUPPORT N.Y.C. 03/28/85
C
C *** Reads tapes created by:
C *** VAX with Unix using ANSITAR utility
C *** VAX with VMS using the COPY utility
C *** DECSYSTEM-20 using the WRITEL program
C
C *** These will come from VAX/VMSM, RSX-11 or RSTS/E sites
C
C *** This routine is written to read tapes written as follows:
C
C *** 9 Track, 1600 BPI
C
C *** ANSI labels (each label is an 80-byte ASCII record)
C *** Each label begins with a 4-char identifier, like VOL1,HDR1,EOF.,EOV1
C *** Volume name is in columns 5-10 (Vol labels only at beginning of tape)
C *** HDR1 - file name is in columns 5-21
C *** HDR2 - column 5 is record format (F, D, or S) (I only work with D)
C *** 6-10 block length (I use what they tell me from keyboard)
C *** 1-15 record length (this program defaults to 300
C *** it doesn't matter anyway because
C *** this is a max record size)
C *** There may be an EOF1 and EOF2 they are skipped
C *** At the end of the tape there is supposed to be an EOV1 and EOV2
C *** followed by a double tape mark.
C
C *** Record Format "D":
C *** Variable length records with a 4-digit ASCII length field at
C *** the beginning of each record (the length includes the length field)
C *** Line terminators are stripped, and there is no record crossing
C *** a block boundry . The record may be padded at the end with 1, 2,
C *** or 3 circumflex characters, which are not included in the field
C *** length. (this programer did not know what the heck a circumflex
C *** character was and did not take them into account. This routine
C *** did however, work on the tape I had to test with.)
C *** My spec called for block sizes of 2048, 4096, and 8192 characters
C *** only, so this program only allows that selection. If there were
C *** other block sizes to wory about simply allow that size to be entered.
C
C
LOGICAL
* OPEN$A,YSNO$A,CSTR$A,LSTR$A
C
C
INTEGER
* IUNIT,HRSIZE,READRC,STATUS(6),CODE,HAT,PUNIT,GCHR$A,
* ZERO,GSTAT,TSTAT(6),TCODE,IBUF(4200),TCHAR,RLEN,MAXCHR,
* I,J,K,L,OCTAL,TEXT,LSIZ(2),LBUF(150),EARY(152),FIXODD,
* ESIZ,BUFPNT,RSIZ, DATASZ,FSTCHR,LSTCHR,FNAM(8),EOF,
* NUNAM(9),NLEN,NLEN$A,RWIND,XCODE,GTPMRK,WDATSZ,JOBNO,
* TSTNAM(8),TSTLEN,CKLEN,SKPREC
C
C
INTEGER*4
* BIGZRO
C
C
EQUIVALENCE
* (EARY(1),LSIZ(1)),
* (EARY(3),LBUF(1)),
* (IBUF(2),NUNAM(1)),
* (IBUF(3),FNAM(1))
C
C
$INSERT SYSCOM>A$KEYS
$INSERT SYSCOM>ERRD.INS.FTN
C
C
HRSIZE = 40 /* HEADER RECORD SIZE
READRC = :042600 /* READ A RECORD (BLOCK)
RWIND = :000040 /* REWIND TAPE
GSTAT = :100000 /* GET TAPE STATUS (CAUSES A WAIT ON SEMIPHORE)
GTPMRK = :022200 /* GET TAPE MARK
SKPREC = :062200
ZERO = 0
BIGZRO = 0
OCTAL = 7777
TEXT = 0000
HAT = '^ '
EOF = 0
C
5 CONTINUE
CALL TONL
CALL TNOUA ('ENTER TAPE DRIVE #: ',20)
READ (1,10,ERR=5) IUNIT
10 FORMAT (I2)
15 CONTINUE
CALL TNOUA ('BLOCK SIZE (2048,4096 OR 8192 ONLY): ',37)
READ (1,20,ERR=15) DATASZ
20 FORMAT (I4)
WDATSZ = DATASZ / 2
IF (DATASZ.NE.2048 .AND.
* DATASZ.NE.4096 .AND.
* DATASZ.NE.8192) GOTO 15
C
C *** REWIND TO BEGINNING OF TAPE
C *** READ THE VOLUME LABEL
C
CALL T$MT (IUNIT,BIGZRO,ZERO,RWIND,TSTAT,TCODE)
C
C *** DURING REWIND LET'S SEE WHAT HE WANT'S TO DO
C
70 CONTINUE
JOBNO = 0 /* READ ALL FILES
IF (YSNO$A('READ FULL TAPE ',15,A$NDEF)) GO TO 90
JOBNO = 1 /* READ A SINGLE FILE
IF (YSNO$A('READ A SINGLE FILE ',19,A$NDEF)) GOTO 80
JOBNO = 2 /* READ ALL FILES CONTAINING STRING
IF (YSNO$A('READ ALL FILES CONTAINING STRING ',33,A$NDEF))
* GOTO 80
GOTO 70
80 CONTINUE
CALL TNOUA ('ENTER FULL NAME OR STRING (16 CHAR MAX): ',41)
READ (1,85) TSTNAM
85 FORMAT (8A2)
TSTLEN = NLEN$A (TSTNAM,16)
IF (TSTLEN.EQ.0) GOTO 80
90 CONTINUE
CALL T$MT (IUNIT,BIGZRO,ZERO,GSTAT,TSTAT,XCODE)
IF (TCODE.NE.0) GOTO 9020
CALL T$MT (IUNIT,LOC(IBUF),HRSIZE,READRC,STATUS,CODE) /* VOLUME HEADER
CALL T$MT (IUNIT,BIGZRO,ZERO,GSTAT,TSTAT,TCODE)
C
C *** READ THE HDR1 RECORD , TURN ON THE :200 BIT IN EACH CHARACTER
C *** GET THE FILE NAME OUT OF COLUMNS 5-21, AND OPEN A SAM FILE OF
C *** THAT NAME FOR WRITTING. (ON THE TAPE THAT I HAD SOME OF THE FILE
C *** NAMES BEGAN WITH DIGITS, SO I INSERTED 'V.' IN FRONT OF THE NAME)
C
100 CONTINUE
CALL T$MT (IUNIT,LOC(IBUF),HRSIZE,READRC,STATUS,CODE) /* HEADER
CALL T$MT (IUNIT,BIGZRO,ZERO,GSTAT,TSTAT,TCODE)
IF (AND(STATUS(2),:400).NE.0) GOTO 9500 /* MUST BE END OF VOLUME
DO 1055 I = 1,50
IBUF(I) = OR(IBUF(I),:100200)
1055 CONTINUE
NUNAM(1) = 'V.'
NLEN = NLEN$A(NUNAM,18)
CKLEN = NLEN - 2
CALL TNOU (FNAM,CKLEN)
IF (JOBNO.EQ.0) GOTO 104 /* READ ALL FILES
IF (JOBNO.NE.1) GOTO 103
IF (CSTR$A(TSTNAM,TSTLEN,FNAM,CKLEN)) GOTO 104
GOTO 375
103 CONTINUE
IF (LSTR$A(TSTNAM,TSTLEN,FNAM,CKLEN,FSTCHR,LSTCHR))
* GOTO 104
GO TO 375
104 CONTINUE
CALL TNOUA ('OPENING ',8)
CALL TNOU (NUNAM,NLEN)
IF (OPEN$A(A$WRIT+A$SAMF+A$GETU,NUNAM,NLEN,PUNIT)) GOTO 105
CALL TNOUA ('CAN''T OPEN ',11)
GOTO 9000
105 CONTINUE
C
C *** DON'T CARE ABOUT BALANCE OF HEADER STUFF, SO SKIP TO NEXT TAPE
C *** THIS IS THE ACTUAL DATA STUFF
C
110 CONTINUE
CALL T$MT (IUNIT,BIGZRO,ZERO,GTPMRK,TSTAT,XCODE)
C
C *** READ A BLOCK OF THE ACTUAL TAPE DATA, TURN ON THE :200 BIT
C *** IN EACH CHARACTER
C
200 CONTINUE
CALL T$MT (IUNIT,LOC(IBUF),WDATSZ,READRC,STATUS,CODE)
CALL T$MT (IUNIT,BIGZRO,ZERO,GSTAT,TSTAT,TCODE)
IF (STATUS(3).EQ.0) GOTO 300
MAXCHR = STATUS(3) * 2 - 1
DO 205 I = 1,WDATSZ
IBUF(I) = OR(IBUF(I),:100200)
205 CONTINUE
BUFPNT = 0
FSTCHR = 1
LSTCHR = 4
C
C *** FIRST 4 CHAR OF EACH DATA RECORD AR THE RECORD LENGTH
C *** IN CHARACTERS (THIS INCLUDES THE 4 CHAR).
C *** MOVE THE RECORD OUT OF THE TAPE BUFFER INTO A LINE BUFFER
C *** STUFF A SPACE AT THE END TO TAKE CARE OF ODD CHAR LENGTH RECORDS
C *** WRITE IT TO THE DISK FILE, BUMP THE TAPE BUFFER POINTERS
C *** IF LAST CHARA POINTER IS POINTING BEYOND NUMBER OF WORDS
C *** READ IN THIS BLOCK WE ARE READY TO GET THE NEXT BLOCK
C
210 CONTINUE
CALL MSUB$A (IBUF,DATASZ,FSTCHR,LSTCHR,LSIZ,4,1,4)
DECODE (4,225,LSIZ,ERR=400) ESIZ
225 FORMAT (I4)
IF (ESIZ.GT.304) GOTO 5000 /* LINE IS OUT OF RANGE
LSTCHR = FSTCHR + ESIZ - 1
CALL MSUB$A (IBUF,DATASZ,FSTCHR,LSTCHR,EARY,304,1,ESIZ)
RSIZ = ESIZ - 4
RLEN = (RSIZ + 1) / 2
FIXODD = RSIZ + 1
CALL MCHR$A (LBUF,FIXODD,' ',1)
CALL WTLIN$ (PUNIT,LBUF,RLEN,CODE)
IF (CODE.NE.0) GOTO 9010
FSTCHR = FSTCHR + ESIZ
LSTCHR = FSTCHR + 3
IF (LSTCHR.GE.MAXCHR) GOTO 300
GOTO 210
C *** THE TAPE BUFFER IS NOW EMPTY, IF WE HAVEN'T READ A TAPE MARK
C *** GO GET THE NEXT DATA BLOCK.
C *** IF WE HAVE READ A TAPE MARK IT'S END OF FILE, SKIP THE END
C *** FILE LABEL AND GO GET THE NEXT FILE
C
300 CONTINUE
IF (AND(STATUS(2),:400).EQ.0) GOTO 200
325 CONTINUE
CALL CLOS$A (PUNIT)
IF (JOBNO.EQ.1) GOTO 9510
C
C *** WE GO FORWARD ONE TAPE MARK HERE.
C *** FRANKLY, I DON'T KNOW IF I'M SKIPPING THE TAPE MARK I READ
C *** WHEN I TRIED TO GET THE NEXT DATA BLOCK OR IF I'M SKIPPING THE
C *** THE 'EOF' RECORD, BUT IT SEEMS TO WORK.
C
350 CONTINUE /* COME DIRECTLY HERE TO SKIP AN EOF RECORD
CALL T$MT (IUNIT,BIGZRO,ZERO,GTPMRK,STATUS,CODE)
CALL T$MT (IUNIT,BIGZRO,ZERO,GSTAT,TSTAT,XCODE)
GOTO 100
375 CONTINUE /* COME DIRECTLY HERE TO SKIP A FILE
C *** SKIP HEADER TAPE MARK
CALL T$MT (IUNIT,BIGZRO,ZERO,GTPMRK,STATUS,CODE) /* HEADER
CALL T$MT (IUNIT,BIGZRO,ZERO,GSTAT,TSTAT,XCODE)
CALL T$MT (IUNIT,BIGZRO,ZERO,GTPMRK,STATUS,CODE) /* DATA FILE
CALL T$MT (IUNIT,BIGZRO,ZERO,GSTAT,TSTAT,XCODE)
GOTO 350 /* GO SKIP THE TRAILER LABEL
C
400 CONTINUE
WRITE (1,405) FSTCHR,MAXCHR
405 FORMAT ('POINTING AT CHAR#',I5,' READ',I5,' CHARS',/,
* 'IF TAPE MARK GET NEXT FILE ELSE NEXT BLOCK')
IF (AND(STATUS(2),:400).NE.0) GOTO 325
GOTO 200
C
C
5000 CONTINUE
WRITE (1,5005) ESIZ
5005 FORMAT ('THAT''S STUPID RECORD SIZE CAN''T BE ',I5)
STOP 200
C
C
9000 CONTINUE
CALL EXIT
C
9010 CONTINUE
WRITE (1,9015) CODE
9015 FORMAT ('ERROR',I6,' WRITTING DATA FILE')
GOTO 9000
9020 CONTINUE
IF (TCODE.NE.E$NASS) GOTO 9030
CALL TNOU ('** TAPE NOT ASSIGNED **',23)
CALL EXIT
9030 CONTINUE
IF (TCODE.NE.E$BNWD) GOTO 9040
CALL TNOU ('** BAD BLOCK SIZE **',20)
CALL EXIT
9040 CONTINUE
WRITE (1,9045) TCODE
9045 FORMAT ('TAPE ERROR -',I5)
CALL EXIT
9500 CONTINUE
CALL CLOS$A (PUNIT)
CALL TONL
CALL TNOU (' *** END OF TAPE ***',25)
CALL EXIT
9510 CONTINUE
CALL TNOU ('FILE COMPLETE',13)
CALL EXIT
END