home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / prime / primet.ftn < prev    next >
Text File  |  2020-01-01  |  9KB  |  274 lines
  1. C      VTAPEIN - READ LABELED TAPES WITH VERIABLE RECORD LENGTHS
  2. C
  3. C      R. COUCH PRIME MARKETING SUPPORT N.Y.C.   03/28/85
  4. C
  5. C  *** Reads tapes created by:
  6. C  ***    VAX with Unix using ANSITAR utility
  7. C  ***    VAX with VMS  using the COPY utility
  8. C  ***    DECSYSTEM-20 using the WRITEL program
  9. C
  10. C  *** These will come from VAX/VMSM, RSX-11 or RSTS/E sites
  11. C
  12. C  *** This routine is written to read tapes written as follows:
  13. C
  14. C  *** 9 Track, 1600 BPI
  15. C
  16. C  *** ANSI labels (each label is an 80-byte ASCII record)
  17. C  *** Each label begins with a 4-char identifier, like VOL1,HDR1,EOF.,EOV1
  18. C  *** Volume name is in columns 5-10 (Vol labels only at beginning of tape)
  19. C  *** HDR1 - file name is in columns 5-21
  20. C  *** HDR2 - column 5 is record format (F, D, or S) (I only work with D)
  21. C  ***               6-10 block length (I use what they tell me from keyboard)
  22. C  ***               1-15 record length (this program defaults to 300
  23. C  ***                                   it doesn't matter anyway because
  24. C  ***                                   this is a max record size)
  25. C  *** There may be an EOF1 and EOF2 they are skipped
  26. C  *** At the end of the tape there is supposed to be an EOV1 and EOV2
  27. C  *** followed by a double tape mark.
  28. C
  29. C  *** Record Format "D":
  30. C  *** Variable length records with a 4-digit ASCII length field at
  31. C  *** the beginning of each record (the length includes the length field)
  32. C  *** Line terminators are stripped, and there is no record crossing
  33. C  *** a block boundry . The record may be padded at the end with 1, 2,
  34. C  *** or 3 circumflex characters, which are not included in the field
  35. C  *** length. (this programer did not know what the heck a circumflex
  36. C  *** character was and did not take them into account. This routine
  37. C  *** did however, work on the tape I had to test with.)
  38. C  *** My spec called for block sizes of 2048, 4096, and 8192 characters
  39. C  *** only, so this program only allows that selection. If there were
  40. C  *** other block sizes to wory about simply allow that size to be entered.
  41. C
  42. C
  43.          LOGICAL
  44.      * OPEN$A,YSNO$A,CSTR$A,LSTR$A
  45. C
  46. C
  47.          INTEGER
  48.      * IUNIT,HRSIZE,READRC,STATUS(6),CODE,HAT,PUNIT,GCHR$A,
  49.      * ZERO,GSTAT,TSTAT(6),TCODE,IBUF(4200),TCHAR,RLEN,MAXCHR,
  50.      * I,J,K,L,OCTAL,TEXT,LSIZ(2),LBUF(150),EARY(152),FIXODD,
  51.      * ESIZ,BUFPNT,RSIZ, DATASZ,FSTCHR,LSTCHR,FNAM(8),EOF,
  52.      * NUNAM(9),NLEN,NLEN$A,RWIND,XCODE,GTPMRK,WDATSZ,JOBNO,
  53.      * TSTNAM(8),TSTLEN,CKLEN,SKPREC
  54. C
  55. C
  56.          INTEGER*4
  57.      * BIGZRO
  58. C
  59. C
  60.        EQUIVALENCE
  61.      * (EARY(1),LSIZ(1)),
  62.      * (EARY(3),LBUF(1)),
  63.      * (IBUF(2),NUNAM(1)),
  64.      * (IBUF(3),FNAM(1))
  65. C
  66. C
  67. $INSERT SYSCOM>A$KEYS
  68. $INSERT SYSCOM>ERRD.INS.FTN
  69. C
  70. C
  71.        HRSIZE = 40   /* HEADER RECORD SIZE
  72.        READRC = :042600   /* READ A RECORD (BLOCK)
  73.        RWIND  = :000040   /* REWIND TAPE
  74.        GSTAT  = :100000   /* GET TAPE STATUS (CAUSES A WAIT ON SEMIPHORE)
  75.        GTPMRK = :022200   /* GET TAPE MARK
  76.        SKPREC = :062200
  77.        ZERO = 0
  78.        BIGZRO = 0
  79.        OCTAL = 7777
  80.        TEXT = 0000
  81.        HAT = '^ '
  82.        EOF = 0
  83. C
  84. 5      CONTINUE
  85.        CALL TONL
  86.        CALL TNOUA ('ENTER TAPE DRIVE #: ',20)
  87.        READ (1,10,ERR=5) IUNIT
  88. 10     FORMAT (I2)
  89. 15     CONTINUE
  90.        CALL TNOUA ('BLOCK SIZE (2048,4096 OR 8192 ONLY): ',37)
  91.        READ (1,20,ERR=15) DATASZ
  92. 20     FORMAT (I4)
  93.        WDATSZ = DATASZ / 2
  94.        IF (DATASZ.NE.2048 .AND.
  95.      *     DATASZ.NE.4096 .AND.
  96.      *     DATASZ.NE.8192) GOTO 15
  97. C
  98. C  ***  REWIND TO BEGINNING OF TAPE
  99. C  ***  READ THE VOLUME LABEL
  100. C
  101.        CALL T$MT (IUNIT,BIGZRO,ZERO,RWIND,TSTAT,TCODE)
  102. C
  103. C  *** DURING REWIND LET'S SEE WHAT HE WANT'S TO DO
  104. C
  105. 70     CONTINUE
  106.        JOBNO = 0  /* READ ALL FILES
  107.        IF (YSNO$A('READ FULL TAPE ',15,A$NDEF)) GO TO 90
  108.        JOBNO = 1  /* READ A SINGLE FILE
  109.        IF (YSNO$A('READ A SINGLE FILE ',19,A$NDEF)) GOTO 80
  110.        JOBNO = 2  /* READ ALL FILES CONTAINING STRING
  111.        IF (YSNO$A('READ ALL FILES CONTAINING STRING ',33,A$NDEF))
  112.      * GOTO 80
  113.        GOTO 70
  114. 80     CONTINUE
  115.        CALL TNOUA ('ENTER FULL NAME OR STRING (16 CHAR MAX): ',41)
  116.        READ (1,85) TSTNAM
  117. 85     FORMAT (8A2)
  118.        TSTLEN = NLEN$A (TSTNAM,16)
  119.        IF (TSTLEN.EQ.0) GOTO 80
  120. 90     CONTINUE
  121.        CALL T$MT (IUNIT,BIGZRO,ZERO,GSTAT,TSTAT,XCODE)
  122.        IF (TCODE.NE.0) GOTO 9020
  123.        CALL T$MT (IUNIT,LOC(IBUF),HRSIZE,READRC,STATUS,CODE) /* VOLUME HEADER
  124.        CALL T$MT (IUNIT,BIGZRO,ZERO,GSTAT,TSTAT,TCODE)
  125. C
  126. C  *** READ THE HDR1 RECORD , TURN ON THE :200 BIT IN EACH CHARACTER
  127. C  *** GET THE FILE NAME OUT OF COLUMNS 5-21, AND OPEN A SAM FILE OF
  128. C  *** THAT NAME FOR WRITTING. (ON THE TAPE THAT I HAD SOME OF THE FILE
  129. C  *** NAMES BEGAN WITH DIGITS, SO I INSERTED 'V.' IN FRONT OF THE NAME)
  130. C
  131. 100    CONTINUE
  132.        CALL T$MT (IUNIT,LOC(IBUF),HRSIZE,READRC,STATUS,CODE) /* HEADER
  133.        CALL T$MT (IUNIT,BIGZRO,ZERO,GSTAT,TSTAT,TCODE)
  134.        IF (AND(STATUS(2),:400).NE.0) GOTO 9500   /* MUST BE END OF VOLUME
  135.        DO 1055 I = 1,50
  136.        IBUF(I) = OR(IBUF(I),:100200)
  137. 1055    CONTINUE
  138.        NUNAM(1) = 'V.'
  139.        NLEN = NLEN$A(NUNAM,18)
  140.        CKLEN = NLEN - 2
  141.        CALL TNOU (FNAM,CKLEN)
  142.        IF (JOBNO.EQ.0) GOTO 104  /* READ ALL FILES
  143.        IF (JOBNO.NE.1) GOTO 103
  144.        IF (CSTR$A(TSTNAM,TSTLEN,FNAM,CKLEN)) GOTO 104
  145.        GOTO 375
  146. 103    CONTINUE
  147.        IF (LSTR$A(TSTNAM,TSTLEN,FNAM,CKLEN,FSTCHR,LSTCHR))
  148.      * GOTO 104
  149.        GO TO 375
  150. 104    CONTINUE
  151.        CALL TNOUA ('OPENING ',8)
  152.        CALL TNOU (NUNAM,NLEN)
  153.        IF (OPEN$A(A$WRIT+A$SAMF+A$GETU,NUNAM,NLEN,PUNIT)) GOTO 105
  154.        CALL TNOUA ('CAN''T OPEN ',11)
  155.        GOTO 9000
  156. 105    CONTINUE
  157. C
  158. C  *** DON'T CARE ABOUT BALANCE OF HEADER STUFF, SO SKIP TO NEXT TAPE
  159. C  *** THIS IS THE ACTUAL DATA STUFF
  160. C
  161. 110    CONTINUE
  162.        CALL T$MT (IUNIT,BIGZRO,ZERO,GTPMRK,TSTAT,XCODE)
  163. C
  164. C  *** READ A BLOCK OF THE ACTUAL TAPE DATA, TURN ON THE :200 BIT
  165. C  *** IN EACH CHARACTER
  166. C
  167. 200    CONTINUE
  168.        CALL T$MT (IUNIT,LOC(IBUF),WDATSZ,READRC,STATUS,CODE)
  169.        CALL T$MT (IUNIT,BIGZRO,ZERO,GSTAT,TSTAT,TCODE)
  170.        IF (STATUS(3).EQ.0) GOTO 300
  171.        MAXCHR = STATUS(3) * 2 - 1
  172.        DO 205 I = 1,WDATSZ
  173.        IBUF(I) = OR(IBUF(I),:100200)
  174. 205    CONTINUE
  175.        BUFPNT = 0
  176.        FSTCHR = 1
  177.        LSTCHR = 4
  178. C
  179. C  *** FIRST 4 CHAR OF EACH DATA RECORD AR THE RECORD LENGTH
  180. C  *** IN CHARACTERS (THIS INCLUDES THE 4 CHAR).
  181. C  *** MOVE THE RECORD OUT OF THE TAPE BUFFER INTO A LINE BUFFER
  182. C  *** STUFF A SPACE AT THE END TO TAKE CARE OF ODD CHAR LENGTH RECORDS
  183. C  *** WRITE IT TO THE DISK FILE, BUMP THE TAPE BUFFER POINTERS
  184. C  *** IF LAST CHARA POINTER IS POINTING BEYOND NUMBER OF WORDS
  185. C  *** READ IN THIS BLOCK WE ARE READY TO GET THE NEXT BLOCK
  186. C
  187. 210    CONTINUE
  188.        CALL MSUB$A (IBUF,DATASZ,FSTCHR,LSTCHR,LSIZ,4,1,4)
  189.        DECODE (4,225,LSIZ,ERR=400) ESIZ
  190. 225    FORMAT (I4)
  191.        IF (ESIZ.GT.304) GOTO 5000  /* LINE IS OUT OF RANGE
  192.        LSTCHR = FSTCHR + ESIZ - 1
  193.        CALL MSUB$A (IBUF,DATASZ,FSTCHR,LSTCHR,EARY,304,1,ESIZ)
  194.        RSIZ = ESIZ - 4
  195.        RLEN = (RSIZ + 1) / 2
  196.        FIXODD = RSIZ + 1
  197.        CALL MCHR$A (LBUF,FIXODD,' ',1)
  198.        CALL WTLIN$ (PUNIT,LBUF,RLEN,CODE)
  199.        IF (CODE.NE.0) GOTO 9010
  200.        FSTCHR = FSTCHR + ESIZ
  201.        LSTCHR = FSTCHR + 3
  202.        IF (LSTCHR.GE.MAXCHR) GOTO 300
  203.        GOTO 210
  204. C  *** THE TAPE BUFFER IS NOW EMPTY, IF WE HAVEN'T READ A TAPE MARK
  205. C  *** GO GET THE NEXT DATA BLOCK.
  206. C  *** IF WE HAVE READ A TAPE MARK IT'S END OF FILE, SKIP THE END
  207. C  *** FILE LABEL AND GO GET THE NEXT FILE
  208. C
  209. 300    CONTINUE
  210.        IF (AND(STATUS(2),:400).EQ.0) GOTO 200
  211. 325    CONTINUE
  212.        CALL CLOS$A (PUNIT)
  213.        IF (JOBNO.EQ.1) GOTO 9510
  214. C
  215. C  *** WE GO FORWARD ONE TAPE MARK HERE.
  216. C  *** FRANKLY, I DON'T KNOW IF I'M SKIPPING THE TAPE MARK I READ
  217. C  *** WHEN I TRIED TO GET THE NEXT DATA BLOCK OR IF I'M SKIPPING THE
  218. C  *** THE 'EOF' RECORD, BUT IT SEEMS TO WORK.
  219. C
  220. 350    CONTINUE    /* COME DIRECTLY HERE TO SKIP AN EOF RECORD
  221.        CALL T$MT (IUNIT,BIGZRO,ZERO,GTPMRK,STATUS,CODE)
  222.        CALL T$MT (IUNIT,BIGZRO,ZERO,GSTAT,TSTAT,XCODE)
  223.        GOTO 100
  224. 375    CONTINUE    /* COME DIRECTLY HERE TO SKIP A FILE
  225. C  *** SKIP HEADER TAPE MARK
  226.        CALL T$MT (IUNIT,BIGZRO,ZERO,GTPMRK,STATUS,CODE) /* HEADER
  227.        CALL T$MT (IUNIT,BIGZRO,ZERO,GSTAT,TSTAT,XCODE)
  228.        CALL T$MT (IUNIT,BIGZRO,ZERO,GTPMRK,STATUS,CODE) /* DATA FILE
  229.        CALL T$MT (IUNIT,BIGZRO,ZERO,GSTAT,TSTAT,XCODE)
  230.        GOTO 350  /* GO SKIP THE TRAILER LABEL
  231. C
  232. 400    CONTINUE
  233.        WRITE (1,405) FSTCHR,MAXCHR
  234. 405    FORMAT ('POINTING AT CHAR#',I5,' READ',I5,' CHARS',/,
  235.      *         'IF TAPE MARK GET NEXT FILE ELSE NEXT BLOCK')
  236.        IF (AND(STATUS(2),:400).NE.0) GOTO 325
  237.        GOTO 200
  238. C
  239. C
  240. 5000   CONTINUE
  241.        WRITE (1,5005) ESIZ
  242. 5005   FORMAT ('THAT''S STUPID   RECORD SIZE CAN''T BE ',I5)
  243.        STOP 200
  244. C
  245. C
  246. 9000   CONTINUE
  247.        CALL EXIT
  248. C
  249. 9010   CONTINUE
  250.        WRITE (1,9015) CODE
  251. 9015   FORMAT ('ERROR',I6,' WRITTING DATA FILE')
  252.        GOTO 9000
  253. 9020   CONTINUE
  254.        IF (TCODE.NE.E$NASS) GOTO 9030
  255.        CALL TNOU ('** TAPE NOT ASSIGNED **',23)
  256.        CALL EXIT
  257. 9030   CONTINUE
  258.        IF (TCODE.NE.E$BNWD) GOTO 9040
  259.        CALL TNOU ('** BAD BLOCK SIZE **',20)
  260.        CALL EXIT
  261. 9040   CONTINUE
  262.        WRITE (1,9045) TCODE
  263. 9045   FORMAT ('TAPE ERROR -',I5)
  264.        CALL EXIT
  265. 9500   CONTINUE
  266.        CALL CLOS$A (PUNIT)
  267.        CALL TONL
  268.        CALL TNOU ('      *** END OF TAPE ***',25)
  269.        CALL EXIT
  270. 9510   CONTINUE
  271.        CALL TNOU ('FILE COMPLETE',13)
  272.        CALL EXIT
  273.        END
  274.