C C AUTHOR: C R. STODOLA C THE INSTITUTE FOR CANCER RESEARCH C 7701 BURHOLME AVE. C PHILADELPHIA, PA. 19111 C C ******************************************************* C * * C * THIS SOFTWARE WAS DEVELOPED WITH SUPPORT * C * FROM THE NATIONAL INSTITUTES OF HEALTH: * C * NIH CA06927 * C * NIH CA22780 * C * * C * DIRECT INQUIRIES TO: * C * COMPUTER CENTER * C * THE INSTITUTE FOR CANCER RESEARCH * C * 7701 BURHOLME AVENUE * C * PHILADELPHIA, PENNSYLVANIA 19111 * C * * C * NO WARRANTY OR REPRESENTATION, EXPRESS OR * C * IMPLIED, IS MADE WITH RESPECT TO THE * C * CORRECTNESS, COMPLETENESS, OR USEFULNESS * C * OF THIS SOFTWARE, NOR THAT USE OF THIS * C * SOFTWARE MIGHT NOT INFRINGE PRIVATELY * C * OWNED RIGHTS. * C * * C * NO LIABILITY IS ASSUMED WITH RESPECT TO * C * THE USE OF, OR FOR DAMAGES RESULTING FROM * C * THE USE OF THIS SOFTWARE * C * * C ******************************************************* C * * C * THIS SOFTWARE WAS DESIGNED FOR USE ON A * C * PDP-11/70 OPERATING UNDER IAS V2.0 USING * C * THE FORTRAN-IV PLUS COMPILER. * C * * C ******************************************************* C C TAPE.FTN -- TAPE CONVERSION PROGRAM. C C R. KING STODOLA C INSTITUTE FOR CANCER RESEARCH C 7701 BURHOLME AVE. C PHILADELPHIA, PA. 19111 C C PROGRAM TO CONVERT FILES TO AND FROM THE FOLLOWING FORMAT: C C ASCII DUMP MODE -- LINES ARE TERMINATED BY CARRIAGE RETURNS C AND LINE FEEDS. DATA IS DUMPED INTO TAPE BLOCKS IN (FOR C OUTPUT) FIXED LENGTH BLOCKS. C FORM FEEDS ARE CONVERTED TO CARRIAGE RETURN, LINE FEED. C C DEC10 DUMP MODE -- SAME AS ABOVE EXCEPT THAT TAPES ARE C PRODUCED WHICH ARE COMPATIBLE WITH THE DEC10 WORD DUMP C FORMAT. C C ASCII BLOCK MODE -- PHYSICAL TAPE RECORDS MAY CONTAIN C A NUMBER OF FIXED LENGTH RECORDS. C C EBCDIC BLOCK MODE -- SAME AS ABOVE, EXCEPT CHARACTERS C ARE IN IBM EBCDIC CODES. C C LINE MODE -- LINE IS COPIED AS IS ONTO TAPE. FOR OUTPUT, C THE MINIMUM RECORD SIZE IS 14 BYTES. RECORDS MAY BE CONVERTED C TO AND FROM EBCDIC IN THIS MODE. C C WHEN READING TAPES, THE USER CAN SPECIFY FIXED LENGTH RECORDS C FOR OUTPUT, OR MAY STRIP TRAILING BLANKS. C C WHEN WRITING TAPES, USERS MAY SPECIFY THAT TABS BE CONVERTED C TO BLANKS. IN LINE MODE, TRAILING BLANKS MAY BE STRIPPED. C IN DUMP MODE, THE USER MAY SPECIFY FIXED LENGTH RECORDS OR C STRIPPED RECORDS. C C WHERE APPLICABLE, IF NEITHER FIXED LENGTH OR STRIPPED RECORDS C ARE SPECIFIED, RECORDS WILL BE NEITHER PADDED OR STRIPPED. C C AS CURRENTLY SUPPLIED, THIS PROGRAM WILL OPERATE UNDER IAS V2.0 C AS A SYSTEM LIBRARY COMMAND (SEE TAPCMD.MAC). C C C C INCLUDE IO PARAMETERS. C INCLUDE 'LB:[1,1]QIOSYS.FTN/NOLIST' INCLUDE 'TAPEPARMS.FTN' C C INCLUDE COMMAND BITS AND ERROR CODE FOR EOF. C PARAMETER TMDU=1,TMDE=2,TMPE=4,TMLE="10,TMEB="20,TMLI="40 PARAMETER TMST="100,TMTA="200,TMBL="400,TMOU="1000,TMIN="2000 PARAMETER ECEOF=-10 C C DEFINE TAPCMD COMMON BLOCKS FOR COMMAND DESCRIPTION. C BYTE FILENM COMMON/TAPTAB/ISWIT,NSWIT,IDEV,IDNM,IFIL,IRECNM,IDUMP,LEN,IBLK, 1 ILINE COMMON/FILTAB/JSWIT,JLEN,FILENM(40) C BYTE BUF(BUFSIZ),LIN(LINSIZ) LOGICAL DEC10,EBCDIC,STRIP,LENGTH,NOTAB C C DEFINE VALID COMBINATIONS. FIRST ELEMENT IS REQUIRED BITS, C SECOND VALUE IS ERROR BITS. C INTEGER COMBO(2,6),ISTAT(2) DATA COMBO/"2001,"1770, "2010,"1743, "2040,"1713, & "1001,"2460, "1410,"2143, "1040,"2413/ C C READ IN AND PARSE COMMAND STRING. C 10 CONTINUE CALL TAPCMD(IER) C C CHECK FOR COMMAND ERROR. C IF(IER)20,50,25 20 IF(IER.EQ.ECEOF)GO TO 40 25 TYPE 30,IER 30 FORMAT(/' COMMAND LINE ERROR ='I6) 40 CALL EXIT C C CHECK FOR A VALID REQUEST. C 50 DO 60 I=1,6 IOM=I IF((ISWIT.AND.COMBO(1,I)).NE.COMBO(1,I))GO TO 60 IF((ISWIT.AND.COMBO(2,I)).EQ.0)GO TO 90 60 CONTINUE 70 TYPE 80 80 FORMAT(/' SYNTAX ERROR') C C FLUSH COMMAND FILES. C 85 CALL FLUSHC CALL EXIT C C CONTINUE SYNTAX CHECK. C 90 IF(ISWIT.AND.TMLE)100,110,100 100 IF((ISWIT.AND.TMST).NE.0)GO TO 70 IF((LEN.LT.2).OR.(LEN.GT.LINSIZ))GO TO 70 110 GO TO (120,120,120,160,170,180),IOM C C CHECK OUTPUT FILE SWITCHES FOR CORRECTNESS AND OPEN OUTPUT C FILE. C 120 IF(JSWIT.AND.TMLE)130,135,130 130 IF((JSWIT.AND.TMST).NE.0)GO TO 70 IF((JLEN.LT.2).OR.(JLEN.GT.LINSIZ))GO TO 70 135 OPEN (UNIT=2,CARRIAGECONTROL='LIST',NAME=FILENM,ERR=140) LENRED=BUFSIZ GO TO (190,190,137),IOM 137 LENRED=ILINE IF(LENRED.LT.10)LENRED=LINSIZ GO TO 190 140 TYPE 150 150 FORMAT(/' UNABLE TO OPEN FILE') GO TO 85 C C CHECK VALIDITY OF OUTPUT DUMP. C 160 IF(((ISWIT.AND.TMDE).NE.0).AND.IDUMP.LT.14)IDUMP=640 IF(IDUMP.LT.14)GO TO 70 IF(MOD(IDUMP,2).NE.0)GO TO 70 GO TO 180 C C CHECK VALIDITY OF OUTPUT BLOCK. C 170 IF(IBLK.LT.1)IBLK=1 IF(IBLK.GT.BUFSIZ/LEN)GO TO 70 C C OPEN INPUT FILE. C 180 OPEN (UNIT=2,TYPE='OLD',NAME=FILENM,ERR=140,READONLY,SHARED) C C ASSIGN TAPE AND ATTACH UNIT. C 190 IF(IDEV.EQ.0)IDEV=DFTAPE IF((IDEV.EQ.2HMM).OR.(IDEV.EQ.2HMT))GO TO 220 200 TYPE 210 210 FORMAT(/' ILLEGAL TAPE DEVICE') GO TO 85 220 IF(IDNM.EQ.0)IDNM=48+DFUNIT IDNM=IDNM-48 IF((IDNM.LT.0).OR.(IDNM.GT.0))GO TO 200 CALL ASNLUN(1,IDEV,IDNM,ISW) IF(ISW.LT.0)GO TO 200 ISCHR=0 IF(IOM.LT.4)ISCHR="100 IF((ISWIT.AND.TMPE).NE.0)ISCHR=ISCHR+"4000 CALL ATTAPE(1,ISCHR,ICHAR,ISTAT,ISW) IF(ISW.LT.0.OR.ISTAT(1).LT.0)GO TO 200 IF(IFIL.LE.0)GO TO 230 CALL TREWND(1,ISTAT,ISW) IF(ISW.LT.0.OR.ISTAT(1).LT.0)GO TO 310 CALL SPFTAP(1,IFIL-1,ISTAT,ISW) IF(ISW.LT.0.OR.ISTAT(1).LT.0)GO TO 310 230 IF(IRECNM.LE.0)GO TO 270 CALL SPBTAP(1,IRECNM,ISTAT,ISW) IF(ISW.LT.0.OR.ISTAT(1).LT.0)GO TO 310 C C BEGIN MOTION. C 270 DEC10=(ISWIT.AND.TMDE).NE.0 EBCDIC=(ISWIT.AND.TMEB).NE.0 IP=1 IL=1 NL=0 IXER=-1 IFLAG=0 GO TO (300,300,300,500,500,500),IOM 300 STRIP=(JSWIT.AND.TMST).NE.0 LENGTH=(JSWIT.AND.TMLE).NE.0 C C READ IN TAPE, CHECK FOR ERRORS. C 305 CALL RDTAPE(1,BUF,LENRED,ISTAT,ISW) IP=1 IF(ISW.LT.0)GO TO 310 IF(ISTAT(1).EQ.IEEOF)GO TO 330 IF(ISTAT(1).GE.0)GO TO 360 C C PROCESS TAPE ERROR. C 310 TYPE 320,ISW,ISTAT 320 FORMAT(/' **** TAPE ERROR:'/,' ISW='I6,/' ISTAT(1)='O6, &' ISTAT(2)='O6) GO TO 350 C C PROCESS END OF FILE MARK. C 330 TYPE 340,NL 340 FORMAT(/' END OF FILE -- 'I6' LINES COPIED.') IXER=0 C C CLOSE FILE, DETACH TAPE. IF ERROR, FLUSH AND EXIT. ELSE, C GO GET NEXT COMMAND. C 350 CLOSE (UNIT=2) CALL DTTAPE(1) IF(IXER)85,10,85 C C PROCESS VALID TAPE RECORD. C 360 NB=ISTAT(2) IF(.NOT.DEC10)GO TO 370 C C PROCESS DEC10 CONVERSION C NW=(NB+4)/5 CALL D10BY(BUF,BUF,NW) GO TO 380 C C PROCESS EBCDIC CONVERSION IF REQUESTED. C 370 IF(EBCDIC)CALL EBASC(BUF,NB) C C PROCESS CHARACTERS. C 380 IF(IP.GT.NB)GO TO 305 390 LB=BUF(IP) LB=LB.AND."177 IP=IP+1 IF(IOM.NE.1)GO TO 410 IF(LB.NE."12.AND.LB.NE."14.AND.LB.NE."15)GO TO 400 C C PROCESS DUMP MODE TERMINATOR. C IF(IFLAG.NE.0)GO TO 380 CALL OUTR(LIN,IL,STRIP,LENGTH,JLEN) NL=NL+1 IFLAG=-1 GO TO 380 400 IFLAG=0 410 IF(IL.GT.LINSIZ)GO TO 413 IF(LB.EQ."11)GO TO 411 IF(LB.LT.32.OR.LB.GT.126)GO TO 413 411 LIN(IL)=LB IL=IL+1 413 GO TO (380,415,420),IOM 415 IF(IL.GT.LEN.OR.IP.GT.NB)GO TO 430 GO TO 390 420 IF(IP.LE.NB)GO TO 390 430 CALL OUTR(LIN,IL,STRIP,LENGTH,JLEN) NL=NL+1 GO TO 380 C C PROCESS OUTPUT. C 500 STRIP=(ISWIT.AND.TMST).NE.0 LENGTH=(ISWIT.AND.TMLE).NE.0 NOTAB=(((ISWIT.AND.TMTA).NE.0).AND.((NSWIT.AND.TMTA).EQ.0)) &.OR.EBCDIC C C READ IN FILE RECORD AND RECORD SIZE. C 510 READ(2,520,END=600)NB,LIN 520 FORMAT(Q,2(A1)) NL=NL+1 IL=1 IF(NB.LT.1)NB=1 NB=MIN(NB,LINSIZ) IF(NOTAB)CALL UNTAB(LIN,NB,LINSIZ) IF(STRIP)CALL STRIPT(LIN,NB) IF(LENGTH)CALL PADT(LIN,NB,LEN) GO TO (530,560,555),IOM-3 530 IF(IL.GT.NB)GO TO 552 IF(IL.LT.0)GO TO 540 LB=LIN(IL) 535 IL=IL+1 540 BUF(IP)=LB IP=IP+1 IF(IP.LE.IDUMP)GO TO 530 NOUT=IDUMP IF(.NOT.DEC10)GO TO 550 NW=(IDUMP+4)/5 CALL BYD10(BUF,BUF,NW) NOUT=NW*5 550 CALL WRTAPE(1,BUF,NOUT,ISTAT,ISW) IF(ISW.LT.0.OR.ISTAT(1).LT.0)GO TO 310 IP=1 IF(IL.LT.0)GO TO 610 GO TO (530,510,510),IOM-3 552 LB="15 IF(IL.EQ.NB+1)GO TO 535 LB="12 IF(IL.EQ.NB+2)GO TO 535 GO TO 510 555 IF(NB.LT.14)CALL PADT(LIN,NB,14) 560 DO 570 I=1,NB BUF(IP)=LIN(I) 570 IP=IP+1 IF(IOM.EQ.6)GO TO 575 IF(IP/LEN.LT.IBLK)GO TO 510 575 NOUT=IP-1 IF(MOD(NOUT,2).NE.0)CALL PADT(BUF,NOUT,NOUT+1) IF(EBCDIC)CALL ASCEB(BUF,NOUT) GO TO 550 600 IL=-1 IF(IP.EQ.1)GO TO 610 LB=0 GO TO (540,575,610),IOM-3 610 CALL WEOF(1,ISTAT,ISW) IF(ISW.LT.0.OR.ISTAT(1).LT.0)GO TO 310 GO TO 330 END SUBROUTINE UNTAB(LIN,NB,MXL) C C REMOVE TABS. C INCLUDE 'TAPEPARMS.FTN/NOLIST' PARAMETER TAB="11,SPACE="40 BYTE LIN(MXL),IB(LINSIZ) DO 10 I=1,NB 10 IB(I)=LIN(I) IS=1 DO 40 I=1,NB L=IB(I) IF(L.NE.TAB)GO TO 30 LS=(IS+7)/8 LS=MIN(MXL,LS*8) DO 20 J=IS,LS 20 LIN(J)=SPACE IS=LS+1 GO TO 40 30 IF(IS.GT.MXL)GO TO 40 LIN(IS)=L IS=IS+1 40 CONTINUE NB=IS-1 RETURN END SUBROUTINE OUTR(LIN,IL,STRIP,LENGTH,JLEN) BYTE LIN(1) LOGICAL STRIP,LENGTH C C WRITE OUT RECORD. C NL=IL-1 IL=1 IF(NL.NE.0)GO TO 25 20 LIN(1)=1H NL=1 25 IF(STRIP)CALL STRIPT(LIN,NL) IF(LENGTH)CALL PADT(LIN,NL,JLEN) IF(NL.GT.255)GO TO 80 60 WRITE(2,70)(LIN(I),I=1,NL) 70 FORMAT(A1) RETURN 80 NL1=NL/2 NL2=NL-NL1 WRITE(2,90)(LIN(I),I=1,NL) 90 FORMAT(A1,A1) RETURN END SUBROUTINE STRIPT(LIN,NB) PARAMETER TAB="11,SPACE="40,NULL=0 BYTE LIN(1) IF(NB.LE.1)RETURN DO 10 I=2,NB IF(LIN(NB).EQ.TAB)GO TO 10 IF(LIN(NB).EQ.SPACE)GO TO 10 IF(LIN(NB).NE.NULL)GO TO 20 10 NB=NB-1 20 RETURN END SUBROUTINE PADT(LIN,NB,LEN) PARAMETER SPACE="40 BYTE LIN(1) IF(NB.GE.LEN)GO TO 20 DO 10 I=NB+1,LEN 10 LIN(I)=SPACE 20 NB=LEN RETURN END