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 THIS VERSION ALLOWS THE CREATION OF FILES FROM A UNIX (V6) TAR C TAPE (3/1/82) CRUDELY. 2 OUTPUT FILES WILL BE CREATED; THE C FIRST WILL BE CALLED "TARDIR.DIR" AND WILL CONTAIN JUST THE C FULL UNIX PATHNAME ON THE TAPE IN THE ORDER THE PATHS ARE C ENCOUNTERED. THE SECOND NAMES WILL BE THE LAST (NAME) PART C OF THE PATHNAME AND THESE WILL BE ENTERED INTO THE CURRENT C DIRECTORY AS FOUND. IT IS EXPECTED THAT THE TARDIR.DIR C MAY BE EDITED TO COPY FILES FROM THE CURRENT ACCOUNT C (POSSIBLY USING A PIP /BR DIRECTORY TO GET VERSION NUMBERS C IN THE SAME ORDER) INTO ACCOUNTS WANTED. THIS IS A VERY VERY C CRUDE METHOD BUT ALLOWS ONE TO CAPTURE FILES AS ONE C DESIRES. C NOTE THAT THE DIMENSION OF LLN IS NOW 11000 BYTES TO C ALLOW DEFAULT UNIX STYLE BLOCKS TO FIT. C ===> SINCE 1ST DATA BYTE IS 407,410,411 FOR MOST UNIX BINARY C FILES, TRY AND KEEP TRACK OF THIS AND FILL IN AN * INTO TARDIR.DIR C ENTRY FOR SUCH CASES. THIS SHOULD FACILITATE LISTING ONLY SOURCE C FILES (UNIX DOES A POOR JOB KEEPING THESE IDENTIFIABLE OTHERWISE) C AND WILL RESULT IN NOT TREATING LF AS A SEPARATOR FOR BINARY DATA C ALSO. 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(11000) 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(514) 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 INTEGER*4 NFILBY,NFILB2,BPBK INTEGER*4 IVAL EXTERNAL IVAL DATA BPBK/512/ C DO TAPE OPERATIONS C SET FLAG THAT UNIX BINARY FLAG NOT SEEN (FOR T MODE) IUXBN=0 KSZ=80 C MVBIT <> 0 MEANS REVERSE 4 BIT GROUPS OFF TAPE. C ACTUALLY GETS NEXT INT., READS IN THAT. MVBIT=0 MULTRC=1 20 CONTINUE IBCDFG=0 DO 22 I4300=1,4200 22 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 28 C WRITE HELP MESSAGE WRITE (6,24) 24 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,26) 26 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 ' =T READ U.V6 TAR TAPES TO PDP & CREATE TARDIR.DIR',/, I ' UNIT = 0 OR 1 FOR MM0: OR MM1:',/, J ' COUNT, EXTRA=EXTRA NUMERIC INFORMATION AS REQUIRED') 28 CONTINUE IF (ICMD.NE.'Z') GO TO 30 MULTRC=0 30 CONTINUE IF (ICMD.NE.'M') GO TO 32 MULTRC=1 32 CONTINUE IF (ICMD.NE.'A') GO TO 34 C ALTER CHARACTERISTICS OF TAPE CALL FFINTG(IPTRS,ICHARA) CALL MSETCH(ICHARA) 34 CONTINUE IF (ICMD.NE.'B') GOTO 36 CALL FFINTG(IPTRS,KSZ) IF(KSZ.LT.1.OR.KSZ.GT.160)KSZ=80 36 CONTINUE IF (ICMD.NE.'V') GOTO 38 CALL FFINTG(IPTRS,MVBIT) 38 CONTINUE IF (ICMD.NE.'I') GO TO 40 IRECCT=0 IEBFLG=1 GO TO 132 40 CONTINUE IF (ICMD.NE.'Y') GO TO 42 IRECCT=0 IBCDFG=1 GO TO 132 42 CONTINUE IF (ICMD.NE.'P') GO TO 44 IRECCT=0 IEBFLG=1 GO TO 152 44 CONTINUE IF (ICMD.NE.'D') GO TO 84 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,46) 46 FORMAT(' TO SWAP BYTES ENTER 1, ELSE 0') READ (5,48)ISWPF 48 FORMAT(I1) WRITE(6,50) 50 FORMAT(' TO SWAP WORDS ENTER 1, ELSE 0') READ(5,48)IWDSF WRITE(6,52) 52 FORMAT(' ENTER 0 FOR OCTAL, 1 FOR DECIMAL 16,2=DEC 32,3=IBM FP') READ(5,48)IDSPF 54 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 82 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 82 IF (IDSPF.NE.3) GO TO 58 DO 56 III=1,NWD2 RBF(III)=FLTIBM(RBF(III)) 56 CONTINUE 58 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 80 III=1,NN2D GO TO (60,64,68,72,76),IDSPF1 60 CONTINUE C 16 BIT OCTAL MMMM=MMM0+7 WRITE(6,62)MMM0,(IBF(IV),IV=MMM0,MMMM) MMM0=MMM0+8 62 FORMAT(1X,I4,8O7) GO TO 80 64 CONTINUE C 16 BIT DECIMAL MMMM=MMM0+7 WRITE(6,66)MMM0,(IBF(IV),IV=MMM0,MMMM) MMM0=MMM0+8 66 FORMAT(1X,I4,8I7) GO TO 80 68 CONTINUE C 32 BIT DECIMAL MMMM=MMM0+7 WRITE(6,70)MMM0,(IBF(IV),IV=MMM0,MMMM) MMM0=MMM0+8 70 FORMAT(1X,I4,8I9) GO TO 80 72 CONTINUE C IBM F.P. MMMM=MMM0+8 WRITE(6,74)MMM0,(RBF(IV),IV=MMM0,MMMM) MMMM=MMMM+8 74 FORMAT(1X,8F10.4) GO TO 80 76 CONTINUE C ASCII MMMM=MMM0+40 WRITE(6,78)(IBF(IV),IV=MMM0,MMMM) MMM0=MMM0+40 78 FORMAT(1X,40A2) GO TO 80 80 CONTINUE IF (MULTRC.NE.0)GO TO 54 82 CONTINUE GO TO 188 84 CONTINUE IF (ICMD.NE.'O') GO TO 92 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 86 CONTINUE ITXTI=1 ITXTI2=ITXTI+68 DO 88 IREC=1,IBLKF READ(3,156,END=90,ERR=90)(LLINE(IIII),IIII=ITXTI,ITXTI2) LLINE(ITXTI2+1)=13 ITXTI=ITXTI+70 ITXTI2=ITXTI2+70 88 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 188 GO TO 86 90 CONTINUE C ENDFILE SEEN...CLOSE AND GO AWAY CALL CLOSE(3) GO TO 188 92 CONTINUE IF (ICMD.EQ. 'U') GOTO 94 IF ((ICMD.NE.'J').AND.(ICMD.NE.'G')) GO TO 112 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 96 94 CONTINUE IUUUU=1 96 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 98 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 110 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 100 CONTINUE ISAVE=LLINE(ITXTI) ITXTI=ITXTI+1 IF (ISAVE.EQ.13) GO TO 102 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 100 C READ MORE TAPE IF WE MUST, TO GET NEXT PART OF LINE GO TO 98 102 CONTINUE C HERE EMIT OUTPUT LINE AND CLEAR ITXTO POINTER WRITE (3,104)(OLINE(I95),I95=1,ITXTO) 104 FORMAT(131A1) ITXTO=1 106 DO 108 I95=1,132 OLINE(I95)=0 108 CONTINUE C WHEN DONE WRITING THIS RECORD, GO TRY FOR MORE. GO TO 100 110 CALL CLOSE(3) GO TO 188 112 CONTINUE IF (ICMD.NE.'T') GO TO 130 C HANDLE UNIX TAR INPUT TAPES C NOTE: FORMAT IS EMPIRICALLY DERIVED FROM DUMP OF UNIX V6 TAR TAPE IFRST=0 IUXBN=0 IUUUU=1 CALL ASSIGN(4,'TARDIR.DIR') 114 CONTINUE C CALL BCLR(LINE,5480) CALL MREAD(LINE,10900,NREAD,MFLAG) CALL ERFLG(MFLAG,MFLAG) C CHECK FOR EOF,EOT, ETC. C NOTE WE PROCESS TO 1ST EOF ALWAYS IF (MFLAG.EQ.6.OR.MFLAG.EQ.1.OR.MFLAG.EQ.3.OR.MFLAG.EQ.2)GOTO5020 WRITE(4,5000)(LLINE(III),III=1,64) 5000 FORMAT(1X,32A1,40A1) CALL OFF8(LINE,NREAD) C MASSAGE THE FILE NAME TO GET THE LAST PART LSLSH=1 LSTN=1 KPER=0 C FIND FILENAME FROM PATH NAME IF(LLINE(1).EQ.'.')LLINE(1)=32 DO 5001 N5001=1,70 IF(LLINE(N5001).EQ.'/')LSLSH=N5001 C END SCAN ON ANY CONTROL CHARACTERS IF(LLINE(N5001).LE.31)GO TO 5002 C FOLD FUNNY CHARACTERS INTO VALID RSX ONES FOR FILESPECS IF(LLINE(N5001).EQ.'_')LLINE(N5001)='0' IF(LLINE(N5001).EQ.'$')LLINE(N5001)='1' C ELIMINATE ALL BUT LAST PERIOD OF FILENAME IF(LLINE(N5001).EQ.'.'.AND.KPER.NE.0)LLINE(KPER)='2' IF(LLINE(N5001).EQ.'.')KPER=N5001 C MAKE FILENAMES UPPER CASE IF(LLINE(N5001).GT.96)LLINE(N5001)=LLINE(N5001)-32 5001 CONTINUE 5002 LSTN=N5001 LLINE(LSTN)=0 C FORCE LEGAL LENGTH FILE NAME BY ZEROING BYTE AFTER TOO MANY CHARS IF(KPER.GE.LSLSH)GOTO 6500 C HERE THERE IS NO PERIOD AFTER THE LAST SLASH... ZERO THE 9TH CHAR C AFTER THE BUFFER C THUS LLINE(LSLSH+1) THRU LLINE(LSLSH+9) ARE FILE NAME LLINE(LSLSH+10)=0 GOTO 6502 6500 CONTINUE C HERE THERE IS A PERIOD IN THE FILENAME. CLR THE 3RD CHAR AFTER IT C SO ALL'S WELL... LLINE(KPER+4)=0 C SINCE FILE NAME MIGHT STILL BE TOO LONG, CHECK THAT (KPER-LSLSH_ C DOES NOT EXCEED MAX RSX LIMIT OF 10 AND ZERO FILENAME IF IT DOES C AFTER 9 CHARS IF((KPER-LSLSH).GT.10)LLINE(LSLSH+10)=0 6502 CONTINUE C LINE(125) ON IS LENGTH OF FILE IN BYTES (IN OCTAL) NFILBY=IVAL(LLINE(125)) OPEN (UNIT=3,TYPE='NEW',CARRIAGECONTROL='LIST',DISPOSE='SAVE', 1 RECORDSIZE=512, 2 NAME=LLINE(LSLSH+1),INITIALSIZE=10,EXTENDSIZE=12) C FLAG FIRST RECORD SITUATION AND NONBINARY FOR STARTERS. IFRST=0 IUXBN=0 ITXTO=1 116 CONTINUE C READ TAPE, THEN OUTPUT TO PDP11 WITH RECORD BOUNDARIES AT C.R. ITXTI=1 CALL BCLR(LINE,5490) CALL MREAD(LINE,10900,NREAD,MFLAG) NFILB2=NREAD C CHECK FOR BINARY FILE. IF (IFRST.NE.0) GOTO 6430 IFRST=1 IF (IBF(1).LT."407.OR.IBF(1).GT."411) GOTO 6430 C FLAG THIS A BINARY FILE WRITE(4,5008)IBF(1) 5008 FORMAT(' ====>PRECEDING FILE BINARY TYPE ',O6) IUXBN=1 6430 CONTINUE C COMPUTE BYTES LEFT THIS FILE IF(NFILB2.GT.NFILBY)GOTO 6001 NFILBY=NFILBY-NFILB2 GOTO 6002 6001 CONTINUE NREAD=NFILBY NFILBY=0 6002 CONTINUE CALL ERFLG(MFLAG,MFLAG) IF (MFLAG.EQ.6.OR.MFLAG.EQ.1.OR.MFLAG.EQ.3.OR.MFLAG.EQ.2)GOTO5020 C REMOVE H.O. BIT FROM ALL TEXT BYTES... C 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 118 CONTINUE ISAVE=LLINE(ITXTI) ITXTI=ITXTI+1 C ALLOW END OF RECORD IF EITHER C.R. OR L.F. SEEN C UNIX USES LF AS END OF RECORD BUT ALLOW EITHER. IF (IUXBN.NE.0) GOTO 6347 IF (ISAVE.EQ.10) GO TO 120 IF (ISAVE.EQ.13) GO TO 120 6347 CONTINUE OLINE(ITXTO)=ISAVE C WRITE OUTPUT AFTER 512 BYTES EVEN IF NO LF SEEN YET. IF (ITXTO.GE.512) GOTO 120 ITXTO=ITXTO+1 C READ MORE TAPE IF WE MUST, TO GET NEXT PART OF LINE IF (ITXTI.LE.NREAD)GO TO 118 IF(NFILBY.EQ.0) GOTO 120 C THE ABOVE CLOSES THE FILE IF WE GOT TO END OF THE INPUT FILE ON THE TAR GO TO 116 120 CONTINUE C HERE EMIT OUTPUT LINE AND CLEAR ITXTO POINTER WRITE (3,122)(OLINE(I95),I95=1,ITXTO) 122 FORMAT(132A1,132A1,132A1,120A1) ITXTO=1 124 DO 126 I95=1,512 OLINE(I95)=0 126 CONTINUE C WHEN DONE WRITING THIS RECORD, GO TRY FOR MORE. C CONTINUE TO USE BUFFER UNLESS WE REACHED END FILE ON LAST WRITE IF (ITXTI.GT.NREAD.AND.NFILBY.LE.0)GOTO 128 GO TO 118 128 CALL CLOSE(3) C GO TRY ANOTHER FILE TILL EOF GO TO 114 5020 CALL CLOSE(4) CALL CLOSE(3) GO TO 188 130 CONTINUE IF (ICMD.NE.'W') GO TO 150 C WRITE PDP11 FILE FROM TAPE FILE. USER GIVES NAME. IRECCT=0 132 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,134)KSZ 134 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) 136 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 146 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 144 ICNT=1,IBKFAC C FIND END OF RECORD AND CHOP OFF TRAILING SPACES. IF(KSZ.NE.80)GOTO 140 DO 138 IW=1,78 IWW=81-IW IF (LINE(IWW,ICNT).NE.32) GOTO 140 138 CONTINUE 140 CONTINUE KTMP=KSZ*(ICNT-1)+1 KTMP2=KTMP+KSZ-1 IF(KSZ.EQ.80)KTMP2=KTMP+IWW-1 WRITE(3,142)(LLN(III),III=KTMP,KTMP2) 142 FORMAT(180A1) 144 CONTINUE IF (MULTRC.EQ.0) GO TO 146 C SINGLE INPUT IF UNIT MODE SELECTED. GO TO 136 146 CONTINUE WRITE(6,148)IRECCT 148 FORMAT(' TPP-- ',I10,' RECORDS PROCESSED') CLOSE(UNIT=3) C CALL CLOSE(3) GO TO 188 150 CONTINUE IF (ICMD.NE.'C') GO TO 170 C COPY FILE. GET PDP11 FILE SPECS FIRST. IRECCT=0 152 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 154 CONTINUE DO 160 ICNT=1,IBKFAC READ(3,156,END=162,ERR=166)(LINE(III,ICNT),III=1,80) 156 FORMAT(80A1) 158 CONTINUE C TRANSLATE ASCII TO EBCDIC IF (IEBFLG.NE.0)CALL AE(LINE(1,ICNT),LINE(1,ICNT),80) 160 CONTINUE IRECCT=IRECCT+1 CALL MWRITE(LINE,80*IBKFAC,NFLAG) CALL ERFLG(NFLAG,NFLAG) IF (NFLAG.EQ.3.OR.NFLAG.EQ.6) GO TO 166 GO TO 154 162 CONTINUE WRITE(6,148)IRECCT IF (IBKFAC.EQ.1) GO TO 164 CALL MWRITE(LINE,80*IBKFAC,NFLAG) CALL ERFLG(NFLAG,NFLAG) 164 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 188 166 CONTINUE WRITE (6,168) 168 FORMAT(' TPP--WRITE ERROR FOR SOME REASON--OPERATION ABORTED.') CALL CLOSE(3) GO TO 188 170 CONTINUE IF (ICMD.NE.'R') GO TO 172 C REWIND TAPE CALL MREWIN GO TO 178 172 CONTINUE IF (ICMD.NE.'E') GO TO 174 C WRITE AN EOF ON TAPE CALL MEOF(1) GO TO 178 174 CONTINUE IF (ICMD.NE.'S') GO TO 176 C SKIP RECORDS. GET RECORD COUNT FROM STRING CALL FFINTG(IPTRS,NRECS) CALL MSKIPR(NRECS) GO TO 178 176 IF (ICMD.NE.'F') GO TO 184 C SKIP FILES. GET FILE COUNT FROM STRING. CALL FFINTG(IPTRS,NRECS) CALL MSKIPF(NRECS) 178 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 184 IF (JERR.EQ.6) WRITE (6,182)IUNIT IF (JERR.NE.6) WRITE (6,180)IUNIT 180 FORMAT(' TPP -- I/O ERROR ON UNIT MM',I1,': -OPERATION ABORTED') 182 FORMAT(' TPP -- TAPE UNIT MM',I1,': UNMOUNTED') 184 CONTINUE D WRITE (6,186)JJJJ,IUNIT,NRECS D186 FORMAT(' ICMD=',A2,' IUNIT= ',I4,'NRECS= ',I4 ) 188 GO TO 20 END INTEGER*4 FUNCTION IVAL(LIADDR) INTEGER*4 IACC,IWRK,I10 BYTE LIADDR(12) DATA I10/8/ C COMPUTE A NUMBER IN OCTAL IACC=0 DO 1000 N1000=1,12 KSW=0 II=0 II=LIADDR(N1000).AND.127 IF(II.GE.48.AND.II.LT.58)GOTO 1001 IF(KSW.NE.0)GOTO 1002 IWRK=0 GOTO 1000 1001 IWRK=II-48 IACC=IACC*I10+IWRK KSW=1 1000 CONTINUE 1002 IVAL=IACC RETURN END