C BIGTAPE.FTN C TAPE POSITION CONTROL TASK AND TAPE-DISK UTILITY FOR C FIXED RECORD LENGTH RECORDS IN ASCII/EBCDIC. C THIS PROGRAM HAS MANY OPTIONS (TYPE 'HELP' TO LIST) C AND ALLOWS MANUAL CONTROL OF TAPE MOTION AND READ/WRITE C ACCESS TO FILES ON TAPE. BEST AT CARD IMAGE FILES BLOCKED C UP TO 100. TAPE MAY BE IN ASCII OR EBCDIC AND CAN BE READ C OR WRITTEN IN EITHER. ALSO CAN READ RECORD LENGTHS OTHER C THAN 80 USING THE "B UNIT,BLKSIZE" COMMAND. C C ROOT FOR TPP TASK C TAPE POSITION CONTROLLER AND 80-BYTE/RECORD DATA COPIER INTEGER*2 IPTRS DIMENSION IPTRS(4),IDESC(7) DIMENSION LINE(80,100),LLN(8000) BYTE LINE,LLN,LLINE(8000) EQUIVALENCE(LLN(1),LINE(1,1)) EQUIVALENCE(LLN(1),LLINE(1)) DIMENSION IBF(4200) INTEGER *2 IBF C NOTE LINE AND IBF ARE THE SAME AREA AND THEIR DIMENSIONS C MUST BE COMPATIBLE! BYTE OLINE DIMENSION OLINE(132) DIMENSION RBF(110) REAL * 4 RBF EQUIVALENCE(RBF(1),IBF(1)) EQUIVALENCE(IBF(1),LINE(1)) BYTE AA,BB BYTE CCC DIMENSION CCC(2) EQUIVALENCE (AA,CCC(1)),(BB,CCC(2)) EQUIVALENCE (JJJ,CCC(1)) INTEGER * 4 IRECCT C DO TAPE OPERATIONS KSZ=80 C MVBIT <> 0 MEANS REVERSE 4 BIT GROUPS OFF TAPE. C ACTUALLY GETS NEXT INT., READS IN THAT. MVBIT=0 MULTRC=1 100 CONTINUE IBCDFG=0 DO 4300 I4300=1,4200 4300 IBF(I4300)=0 CALL GETCML(LINE,3HTPP,MCRSZ,72) IRECCT=0 CALL FFINIT(IPTRS,LINE,MCRSZ,IERR) CALL FFSTR(IPTRS,JJJ,2) D JJJJ=JJJ BB=32 ICMD=JJJ CALL FFINTG(IPTRS,IUNIT) C FREE FORMAT COMMANDS: C LETTER,NUMBER[,NUMBER] C WHERE C LETTER=R,REWIND UNIT (0 OR 1) C =E, WRITE ENDFILE ON UNIT 0 OR 1 C =S, SKIP +- N RECORDS ON UNIT 0 OR 1 C =F, SKIP +- N FILES ON UNIT 0 OR 1 C =C, COPY PDP11 FILE TO TAPE C =W, WRITE TAPE FILE TO DISK. C =P, COPY PDP11 FIILE TO TAPE IN EBCDIC FOR PUNCH C =I, COPY TAPE FILE TO PDP11, TAPE IN EBCDIC C =G, GET DG FORMAT TAPE FILE, DUMP TO PDP11 C (200 BIT CLEARED ON INPUT IN ALL BYTES) C =O, OUTPUT TAPE WITH RECORDS TERMINATED BY C.R. C O UNIT,BLKFACTOR,FLAG (FLAG=1 MEANS SET 200 C BIT IN ALL OUTPUT CHARS, =ANYTHING ELSE C MEANS LEAVE 200 BIT OFF ALWAYS. C =A,CHARAC ALTER TAPE CHARAC TO VALUE CHARAC C (FOR OTHERS SEE "HELP" PRINTOUT) IEBFLG=0 C IF EBCDIC, SET IEBFLG NONZERO. CALL ALUN(IUNIT) C ASSIGN 'MAGLUN' (GLOBAL) TO MM0: OR MM1: IF (ICMD.EQ.'X') CALL EXIT IF (ICMD.NE.'H') GO TO 4592 C WRITE HELP MESSAGE WRITE (6,4591) 4591 FORMAT(' CMD UNIT COUNT,EXTRA INFO ',/, 1 ' CMD=R REWIND UNIT',/, 2 ' =E WRITE EOF ON UNIT',/, 3 ' =S SKIP COUNT RECORDS (+ OR -)',/, 4 ' =F SKIP COUNT FILES (+ OR -)',/, 5 ' =C COPY PDP11 FILE TO TAPE IN ASCII, BLK FACTOR=COUNT',/, 6 ' =W WRITE TAPE FILE TO DISK IN ASCII,BLK FACTOR=COUNT',/, 7 ' =P WRITE PDP11 FILE TO TAPE IN EBCDIC, BLK FAC=COUNT',/, 8 ' =I INPUT EBCDIC FILE TAPE TO PDP11, BLK FAC. = COUNT',/, 9 ' =A ALTER TAPE CHARAC. TO COUNT',/, A ' =B SET RECORD SIZE TO COUNT') WRITE(6,4391) 4391 FORMAT(' =Z ENTER UNIT RECORD MODE',/, 1 ' =G GET DG FORMAT TAPE FILE, DUMP TO PDP11',/, 1 ' =J GET DG FORMAT TAPE AND READ IN AS 7TRK',/, 2 ' =O WRITE TAPE, RCRDS TERM BY CR;FLAG=1==>SET 200 BIT',/, 3 ' =U READ IN AS G OPTION BUT BIG RECORDS ALLOWED',/, A ' =V SET BIT REVERSE FLAG TO COUNT. 0=NONE, 1=SWAP 4BITS',/, C ' =M SET MULTIPLE RECORD MODE(DEFAULT)',/, D ' =D ENTER TAPE DUMP MODE (ASKS MORE QUESTIONS)',/, E ' =X EXIT',/, F ' =H PRINT THIS MESSAGE',/, G ' =Y READ BCD TAPE INTO PDP11 FILE, BLK FACTOR=COUNT',/, H ' UNIT = 0 OR 1 FOR MM0: OR MM1:',/, I ' COUNT, EXTRA=EXTRA NUMERIC INFORMATION AS REQUIRED') 4592 CONTINUE IF (ICMD.NE.'Z') GO TO 8364 MULTRC=0 8364 CONTINUE IF (ICMD.NE.'M') GO TO 8363 MULTRC=1 8363 CONTINUE IF (ICMD.NE.'A') GO TO 5566 C ALTER CHARACTERISTICS OF TAPE CALL FFINTG(IPTRS,ICHARA) CALL MSETCH(ICHARA) 5566 CONTINUE IF (ICMD.NE.'B') GOTO 5366 CALL FFINTG(IPTRS,KSZ) IF(KSZ.LT.1.OR.KSZ.GT.160)KSZ=80 5366 CONTINUE IF (ICMD.NE.'V') GOTO 3208 CALL FFINTG(IPTRS,MVBIT) 3208 CONTINUE IF (ICMD.NE.'I') GO TO 6770 IRECCT=0 IEBFLG=1 GO TO 6775 6770 CONTINUE IF (ICMD.NE.'Y') GO TO 2398 IRECCT=0 IBCDFG=1 GO TO 6775 2398 CONTINUE IF (ICMD.NE.'P') GO TO 6769 IRECCT=0 IEBFLG=1 GO TO 6774 6769 CONTINUE IF (ICMD.NE.'D') GO TO 5730 C DUMP TAPE C MUST FIND OUT HOW TO DO IT. ASK FOLLOWING OPTIONS: C 1. SWAP BYTES? C 2. SWAP WORDS? C 3. DUMP OCTAL 16/OCTAL 32/DECIMAL 32/FLOATING PDP11/FLOATING IBM C ASSUME OCTAL DUMP AT FIRST CCCCCC WRITE(6,5727) 5727 FORMAT(' TO SWAP BYTES ENTER 1, ELSE 0') READ (5,5726)ISWPF 5726 FORMAT(I1) WRITE(6,5725) 5725 FORMAT(' TO SWAP WORDS ENTER 1, ELSE 0') READ(5,5726)IWDSF WRITE(6,5724) 5724 FORMAT(' ENTER 0 FOR OCTAL, 1 FOR DECIMAL 16,2=DEC 32,3=IBM FP') READ(5,5726)IDSPF 5728 CONTINUE CALL BCLR(IBF,4000) CALL MREAD(IBF,8000,JRECCT,JFLG) CALL ERFLG(JFLG,JFLG) IF (JFLG.EQ.1.OR.JFLG.EQ.2.OR.JFLG.EQ.3.OR.JFLG.EQ.6)GOTO 5729 IF (ISWPF.NE.0)CALL SWPBYT(IBF,JRECCT) IF (IWDSF.NE.0)CALL WRDSWP(IBF,JRECCT) NWD2=JRECCT/4 C NWD2 IS NO. 32 BIT WORDS IF (NWD2.LT.1) GO TO 5729 IF (IDSPF.NE.3) GO TO 5722 DO 5723 III=1,NWD2 RBF(III)=FLTIBM(RBF(III)) 5723 CONTINUE 5722 CONTINUE C NOW HAVE DATA IN FROM RECORD C NOW DISPLAY DATA (MAKE IT OK FOR A TERMINAL) N2DO=JRECCT/2 IF (IDSPF.EQ.3)N2DO=JRECCT/4 C IF DISPLAY TTPE=4, DUMP ASCII IF (IDSPF.EQ.4)NN2D=JRECCT/80 IF (IDSPF.NE.4)NN2D=N2DO/8 IDSPF1=IDSPF+1 MMM0=1 DO 5721 III=1,NN2D GO TO (5720,5719,5718,5717,4716),IDSPF1 5720 CONTINUE C 16 BIT OCTAL MMMM=MMM0+7 WRITE(6,5716)MMM0,(IBF(IV),IV=MMM0,MMMM) MMM0=MMM0+8 5716 FORMAT(1X,I4,8O7) GO TO 5721 5719 CONTINUE C 16 BIT DECIMAL MMMM=MMM0+7 WRITE(6,5715)MMM0,(IBF(IV),IV=MMM0,MMMM) MMM0=MMM0+8 5715 FORMAT(1X,I4,8I7) GO TO 5721 5718 CONTINUE C 32 BIT DECIMAL MMMM=MMM0+7 WRITE(6,5714)MMM0,(IBF(IV),IV=MMM0,MMMM) MMM0=MMM0+8 5714 FORMAT(1X,I4,8I9) GO TO 5721 5717 CONTINUE C IBM F.P. MMMM=MMM0+8 WRITE(6,5713)MMM0,(RBF(IV),IV=MMM0,MMMM) MMMM=MMMM+8 5713 FORMAT(1X,8F10.4) GO TO 5721 4716 CONTINUE C ASCII MMMM=MMM0+40 WRITE(6,5712)(IBF(IV),IV=MMM0,MMMM) MMM0=MMM0+40 5712 FORMAT(1X,40A2) GO TO 5721 5721 CONTINUE IF (MULTRC.NE.0)GO TO 5728 5729 CONTINUE GO TO 10005 5730 CONTINUE IF (ICMD.NE.'O') GO TO 7330 C OUTPUT DATA TERMINATED BY C.R. ONLY CALL FFINTG(IPTRS,IBLKF) IF (IBLKF.LE.0)IBLKF=1 IF (IBLKF.GT.100)IBLKF=100 C OUTPUT 0,1 FOR 1 72 CHAR RECORD. A 3RD PARAMETER WILL SEE IF C WE NEED TO SET 200 BIT IN WHOLE RECORD IBITST=0 CALL FFINTG(IPTRS,IBITST) C IF WE SEE OUTPUT 0,1,1 THEN SET BIT. OTHER VALUES LEAVE IT OFF. CALL GETCML(LINE,3HDGO,MCRSZ,72) CALL ASSIGN(3,LINE,MCRSZ) ITXTI=1 7329 CONTINUE ITXTI=1 ITXTI2=ITXTI+68 DO 7328 IREC=1,IBLKF READ(3,102,END=7327,ERR=7327)(LLINE(IIII),IIII=ITXTI,ITXTI2) LLINE(ITXTI2+1)=13 ITXTI=ITXTI+70 ITXTI2=ITXTI2+70 7328 CONTINUE NWRTB=72*IBLKF LLINE(NWRTB+1)=0 C NO. BYTES IN 3 RECORDS (INCLUDING 3 C.R. CHARACTERS), +1 TO MAKE EVEN IF (IBITST.EQ.1)CALL SET8(LINE,NWRTB) CALL MWRITE(LINE,NWRTB,NFLAG) CALL ERFLG(NFLAG,NFLAG) IF (NFLAG.EQ.6.OR.NFLAG.EQ.1.OR.NFLAG.EQ.3 1 .OR.NFLAG.EQ.2)GOTO 10005 GO TO 7329 7327 CONTINUE C ENDFILE SEEN...CLOSE AND GO AWAY CALL CLOSE(3) GO TO 10005 7330 CONTINUE IF (ICMD.EQ. 'U') GOTO 6399 IF ((ICMD.NE.'J').AND.(ICMD.NE.'G')) GO TO 6300 C GET DG TAPE DATA (RECORDS TERMINATED BY C.R.) C C NOTE: FORMAT OF DATA GENERAL (RDOS) TAPES IS C 255 WORDS DATA CHARACTERS C 1 WORD FILE NUMBER (0-99=LEGAL RANGE) C 1 WORD FILE NUMBER (0-99=LEGAL RANGE) C TOTAL 257 WORDS IUUUU=0 GO TO 6398 6399 CONTINUE IUUUU=1 6398 CONTINUE C CALL GETCML(LINE,3HDGI,MCRSZ,72) C CALL ASSIGN(3,LINE,MCRSZ) LINE(MCRSZ+1,1)=0 OPEN (UNIT=3,TYPE='NEW',CARRIAGECONTROL='LIST',DISPOSE='SAVE', 1 RECORDSIZE=180, 2 NAME=LINE,INITIALSIZE=10,EXTENDSIZE=12) ITXTO=1 6299 CONTINUE C READ TAPE, THEN OUTPUT TO PDP11 WITH RECORD BOUNDARIES AT C.R. ITXTI=1 CALL BCLR(LINE,4000) CALL MREAD(LINE,8000,NREAD,MFLAG) CALL ERFLG(MFLAG,MFLAG) IF (MFLAG.EQ.6.OR.MFLAG.EQ.1.OR.MFLAG.EQ.3.OR.MFLAG.EQ.2)GOTO 98 C SWAP NIBBLES IF 7TRK INPUT USED (DUMP MODE OF COURSE.) IF (ICMD.EQ.'J')CALL BITSWP(LINE,NREAD) C REMOVE H.O. BIT FROM ALL TEXT BYTES... CALL OFF8(LINE,NREAD) C NREAD=NUMBER BYTES FOUND IN BUFFER C COPY DATA TO OLINE UNTIL: C 1. A C.R. CHAR IS ENCOUNTERED IN OUTPUT, OR C 2. TAPE DATA IS EXHAUSTED C THROW OUT CONTROL CHARACTERS (ZERO FILL) C C THE FOLLOWING WILL ENSURE ONLY 255 WORDS (510 BYTES) ARE USED AS TEXT IF (IUUUU.NE.1)NREAD=510 C 97 CONTINUE ISAVE=LLINE(ITXTI) ITXTI=ITXTI+1 IF (ISAVE.EQ.13) GO TO 96 C 96 IS TO EMIT LINE. OTHERWISE NOT DONE LINE YET, SO SAVE CHAR C AFTER PRINTABILITY CHECK AND GO ON C **** CC FORMFEED KLUDGE CC **** CC C IF (ISAVE.NE.12) GO TO 5252 CC FORMFEED IN INPUT. REMOVE IT AND OUTPUT A FORM FEED C5251 FORMAT(1H1) CC FLUSH OUT ANY OUTPUT UP TO HERE AND THEN EMIT THE FORMFEED C IF (ITXTO.GT.1)WRITE (3,94)(OLINE(I95),I95=1,ITXTO) C ITXTO=1 C ITXTI=ITXTI-1 C LLINE(ITXTI)=32 C WRITE(3,5251) C GO TO 5250 C5252 CONTINUE CC CC **** CC END OF FORMFEED KLUDGE CC ** NOTE KLUDGE APPLIES ONLY TO DG INPUT THAT USES FORTRAN CARRIAGE CTL. C **** C CHECK PRINTABLE CHARACTERS AND FILTER OUT EVERYTHING ELSE. IF (((ISAVE.NE.9).AND.(ISAVE.NE.12)).AND. 1 ((ISAVE.LT.32).OR.(ISAVE.GT.127))) ISAVE=0 OLINE(ITXTO)=ISAVE IF (ITXTO.LT.130)ITXTO=ITXTO+1 IF (ITXTI.LT.NREAD) GO TO 97 C READ MORE TAPE IF WE MUST, TO GET NEXT PART OF LINE GO TO 6299 96 CONTINUE C HERE EMIT OUTPUT LINE AND CLEAR ITXTO POINTER WRITE (3,94)(OLINE(I95),I95=1,ITXTO) 94 FORMAT(131A1) ITXTO=1 5250 DO 95 I95=1,132 OLINE(I95)=0 95 CONTINUE C WHEN DONE WRITING THIS RECORD, GO TRY FOR MORE. GO TO 97 98 CALL CLOSE(3) GO TO 10005 6300 CONTINUE IF (ICMD.NE.'W') GO TO 7776 C WRITE PDP11 FILE FROM TAPE FILE. USER GIVES NAME. IRECCT=0 6775 CALL FFINTG(IPTRS,IBKFAC) IF (IBKFAC.LT.1)IBKFAC=1 IF (IBKFAC.GT.100)IBKFAC=100 C ALLOW FOR CASE OF LONG RECORDS BY HAND HERE. CRUDE SOLUTION ONLY! IF ((IBKFAC*KSZ).GT.8000)WRITE(6,6561)KSZ 6561 FORMAT(' ** BLOCK FACTOR TOO LONG FOR RECORD SIZE ',I4) IF ((IBKFAC*KSZ).GT.8000)IBKFAC=8000/KSZ CALL GETCML(LINE,3HINP,MCRSZ,72) LINE(MCRSZ+1,1)=0 C CALL ASSIGN(3,LINE,MCRSZ) OPEN (UNIT=3,TYPE='NEW',CARRIAGECONTROL='LIST',DISPOSE='SAVE', 1 RECORDSIZE=180, 2 NAME=LINE,INITIALSIZE=10,EXTENDSIZE=12) 112 CONTINUE CALL BCLR(LINE,4000) CALL MREAD(LINE,8200,NREAD,MFLAG) IF (MVBIT.NE.0)CALL BITSWP(LINE,NREAD) CALL ERFLG(MFLAG,MFLAG) IF (MFLAG.EQ.6.OR.MFLAG.EQ.1.OR.MFLAG.EQ.3.OR.MFLAG.EQ.2)GOTO 115 C TRANSLATE EBCDIC TO ASCII IRECCT=IRECCT+1 KTMP=IBKFAC*KSZ IF (IEBFLG.NE.0)CALL EA(LINE(1,1),LINE(1,1),KTMP) IF (IBCDFG.NE.0)CALL BCDASC(LINE(1,1),KTMP) DO 3001 ICNT=1,IBKFAC C FIND END OF RECORD AND CHOP OFF TRAILING SPACES. IF(KSZ.NE.80)GOTO 4302 DO 4301 IW=1,78 IWW=81-IW IF (LINE(IWW,ICNT).NE.32) GOTO 4302 4301 CONTINUE 4302 CONTINUE KTMP=KSZ*(ICNT-1)+1 KTMP2=KTMP+KSZ-1 IF(KSZ.EQ.80)KTMP2=KTMP+IWW-1 WRITE(3,122)(LLN(III),III=KTMP,KTMP2) 122 FORMAT(180A1) 3001 CONTINUE IF (MULTRC.EQ.0) GO TO 115 C SINGLE INPUT IF UNIT MODE SELECTED. GO TO 112 115 CONTINUE WRITE(6,7676)IRECCT 7676 FORMAT(' TPP-- ',I10,' RECORDS PROCESSED') CLOSE(UNIT=3) C CALL CLOSE(3) GO TO 10005 7776 CONTINUE IF (ICMD.NE.'C') GO TO 7777 C COPY FILE. GET PDP11 FILE SPECS FIRST. IRECCT=0 6774 CONTINUE CALL FFINTG(IPTRS,IBKFAC) IF (IBKFAC.LT.1)IBKFAC=1 IF (IBKFAC.GT.100)IBKFAC=100 CALL GETCML(LINE,3HWRT,MCRSZ,72) C READ IN FILE SPECS. CALL ASSIGN(3,LINE,MCRSZ) CALL FDBSET(3,'READONLY','SHARE') C SET UP ONLY READ ACCESS NEEDED FOR FILE. C WRITE 1ST RECORD=FILE NAME SPECS C ********* C GO TO 110 101 CONTINUE DO 3002 ICNT=1,IBKFAC READ(3,102,END=103,ERR=105)(LINE(III,ICNT),III=1,80) 102 FORMAT(80A1) 110 CONTINUE C TRANSLATE ASCII TO EBCDIC IF (IEBFLG.NE.0)CALL AE(LINE(1,ICNT),LINE(1,ICNT),80) 3002 CONTINUE IRECCT=IRECCT+1 CALL MWRITE(LINE,80*IBKFAC,NFLAG) CALL ERFLG(NFLAG,NFLAG) IF (NFLAG.EQ.3.OR.NFLAG.EQ.6) GO TO 105 GO TO 101 103 CONTINUE WRITE(6,7676)IRECCT IF (IBKFAC.EQ.1) GO TO 3004 CALL MWRITE(LINE,80*IBKFAC,NFLAG) CALL ERFLG(NFLAG,NFLAG) 3004 CONTINUE C READ TO END-OF-FILE C WRITE 2 EOF ON TAPE AND BACKSPACE OVER ONE OF THEM. CALL MEOF(2) CALL MSKIPR(-1) C THAT DOES IT. CALL CLOSE(3) GO TO 10005 105 CONTINUE WRITE (6,106) 106 FORMAT(' TPP--WRITE ERROR FOR SOME REASON--OPERATION ABORTED.') CALL CLOSE(3) GO TO 10005 7777 CONTINUE IF (ICMD.NE.'R') GO TO 1000 C REWIND TAPE CALL MREWIN GO TO 10000 1000 CONTINUE IF (ICMD.NE.'E') GO TO 2000 C WRITE AN EOF ON TAPE CALL MEOF(1) GO TO 10000 2000 CONTINUE IF (ICMD.NE.'S') GO TO 3000 C SKIP RECORDS. GET RECORD COUNT FROM STRING CALL FFINTG(IPTRS,NRECS) CALL MSKIPR(NRECS) GO TO 10000 3000 IF (ICMD.NE.'F') GO TO 12000 C SKIP FILES. GET FILE COUNT FROM STRING. CALL FFINTG(IPTRS,NRECS) CALL MSKIPF(NRECS) 10000 CONTINUE C HERE HAVE DONE A TAPE I/O OP. TEST STATUS. CALL MSTAT(JERR) C DECODE ERRORS CALL ERFLG(JERR,JERR) IF (JERR.LE.0) GO TO 12000 IF (JERR.EQ.6) WRITE (6,12001)IUNIT IF (JERR.NE.6) WRITE (6,12002)IUNIT 12002 FORMAT(' TPP -- I/O ERROR ON UNIT MM',I1,': -OPERATION ABORTED') 12001 FORMAT(' TPP -- TAPE UNIT MM',I1,': UNMOUNTED') 12000 CONTINUE D WRITE (6,7000)JJJJ,IUNIT,NRECS D7000 FORMAT(' ICMD=',A2,' IUNIT= ',I4,'NRECS= ',I4 ) 10005 GO TO 100 END