C C MAG TAPE MUST BE MOUNTED AS A 'FOREIGN VOLUMN' C DIMENSION IBUF(16384),ISTAT(2),IPRM(6) LOGICAL*1 JBUF(8192),NFILE(30) EQUIVALENCE (IBUF,JBUF) C IOATT="1400 IODET="2000 IORLB="1000 IORWD="2400 IOSKIP="2440 IEDAO="363 IEEOF="366 ISIZE=32766 ITI=5 IMT0=4 IOUT=3 CALL GETADR(IPRM,IBUF) IPRM(2)=ISIZE C CALL WTQIO(IOATT,IMT0,1,50,ISTAT) C CALL WTQIO(IORWD,IMT0,1,50,ISTAT) C 100 WRITE(ITI,4000) 4000 FORMAT(/,'$ENTER OUTPUT FILE NAME ? ') READ(ITI,4100) NF,NFILE 4100 FORMAT(Q,30A1) IF(NF.EQ.0) GOTO 6000 CALL ASSIGN(IOUT,NFILE,NF) WRITE(ITI,4200) 4200 FORMAT('$NUMBER OF RECORDS TO COPY ? ') READ(ITI,4300) NCOPY 4300 FORMAT(I5) ICOPY=0 JCOPY=0 C DO 5000 IREC=1,NCOPY CALL WTQIO(IORLB,IMT0,1,50,ISTAT,IPRM,ISW) IF(ISTAT(1).EQ.1)GOTO 400 IF(ISTAT(1).EQ.IEDAO) WRITE(ITI,200) 200 FORMAT(' RECORD SIZE EXCEEDED BUFFER, DATA LOST',/) IF(ISTAT(1).EQ.IEDAO) GOTO 5000 IF(ISTAT(1).EQ.IEEOF) WRITE(ITI,300) 300 FORMAT(' END OF FILE DURING READ',/) 400 ICOPY=ICOPY+1 WRITE(IOUT,900) ISTAT(2) 900 FORMAT(1X,I6) WRITE(IOUT,1000) (JBUF(I),I=1,ISTAT(2)) 1000 FORMAT(128A1) JCOPY=JCOPY+((ISTAT(2)+127)/128)+1 IF(ISTAT(1).EQ.IEEOF) GOTO 5200 5000 CONTINUE 5200 CALL CLOSE(IOUT) WRITE(ITI,7000) ICOPY,JCOPY 7000 FORMAT(/,1X,I8,' RECORDS READ',10X,I8,' RECORDS WRITTEN') GOTO 100 C 6000 STOP 'ALL DONE' END