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 EQUIVALENCE(LLN(1),LINE(1,1)) DIMENSION IBF(4200) INTEGER *2 IBF C NOTE LINE AND IBF ARE THE SAME AREA AND THEIR DIMENSIONS C MUST BE COMPATIBLE! 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 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 =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 (5,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',/, B ' =U ENTER UNIT RECORD MODE',/, 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.'U') 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.'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(5,5727) 5727 FORMAT(' TO SWAP BYTES ENTER 1, ELSE 0') READ (5,5726)ISWPF 5726 FORMAT(I1) WRITE(5,5725) 5725 FORMAT(' TO SWAP WORDS ENTER 1, ELSE 0') READ(5,5726)IWDSF WRITE(5,5724) 5724 FORMAT(' ENTER 0 FOR OCTAL, 1 FOR DECIMAL 16,2=DEC 32,3=IBM FP') READ(5,5726)IDSPF 5728 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.'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(5,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 MREAD(LINE,8200,NREAD,MFLAG) 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(5,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(5,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 (5,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 (5,12001)IUNIT IF (JERR.NE.6) WRITE (5,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 (5,7000)JJJJ,IUNIT,NRECS D7000 FORMAT(' ICMD=',A2,' IUNIT= ',I4,'NRECS= ',I4 ) 10005 GO TO 100 END