dc. DO OUTTAPE c. Writes fixed length unlabled tapes from VAX files. ,c. c. -end.of.info- C *** OUTTAPE - THIS PROGRAM WILL COPY A USER-SPECIFIED FILE ONTO AN XC OUTPUT TAPE USING USER-SPECIFIED BLOCKING. C SEE TPOUT.HLP FOR DOCUMENTATION. C C J. THOMPSON DECEMBER 6, 1978 C BUSY TESTS ADDED JANUARY 23, 1979 LC. M. LIVERIGHT COSMETICS C C x IMPLICIT INTEGER*2 (I-O) C @ INTEGER*4 IO$_SKIPFILE,IO$_READLBLK,IO_$WRITELBLK,IO$_WRITEOF,  1 IO$_REWIND,SS$_ENDOFFILE,SS$_ENDOFTAPE,SS$_NORMAL  EXTERNAL IO$_SKIPFILE,IO$_READLBLK,IO$_WRITELBLK,IO$_WRITEOF, l 1 IO$_REWIND,SS$_ENDOFFILE,SS$_ENDOFTAPE,SS$_NORMAL  INTEGER*4 SYS$ASSIGN,SYS$QIOW,RETCODE,FLENGTH,IBUF4(6000) 4 INTEGER*4 RCOUNT,IBLK,NBYTES C  COMMON/AAA/ IBUF(12000),IOSB(4) ` COMMON/BBB/ IFILE,NSKIP,LRECW,LRECB EQUIVALENCE (IBUF(1),IBUF4(1)) ( C CHARACTER INFILE*63 !FILENAME GOES HERE C T BUSY=0 !TAPE NOT ASSIGNED WHEN THIS IS ZERO IFILE=0 !INPUT FILE COUNTER  C WRITE(6,*) 'INTERMETRICS DISK-TO-TAPE COPY PROGRAM (REV 0.0)' WRITE(6,*) 'OUTPUT TAPE LOGICAL NAME SHOULD BE "TAPE"' H 90 WRITE(6,*) ' ' WRITE(6,*) ' TYPE # OF FILES TO SKIP ON OUTPUT TAPE.'  WRITE(6,*) ' (USE NEGATIVE VALUE TO STOP PROGRAM.)' t READ(5,11,ERR=90) NSKIP  IF(BUSY.GT.0.AND.NSKIP.GT.0) NSKIP=0 !CAN'T SKIP < NSTOP=NSKIP+IFILE  IF(NSKIP.LT.0) GO TO 700 11 FORMAT(I5) hC ZERO SOME COUNTERS AND FLAGS  IBLK=0 !BLOCK COUNTER 0 IEND=0 !END OF INPUT FILE FLAG C GET THE FILENAME FOR INPUT  WRITE(6,*) ' TYPE "FILENAME.TYP" FOR INPUT' \ READ(5,10) INFILE 10 FORMAT(A) $C OPEN INPUT FILE  OPEN(UNIT=1,NAME=INFILE,READONLY,TYPE='OLD',ERR=450) 95 WRITE(6,*) ' TYPE RECORDSIZE IN BYTES (EVEN NUMBER PLEASE)' P READ(5,11) LRECB  LRECW=LRECB/2 !RECORDSIZE IN 16 BIT WORDS  IF(LRECW.LE.0) GO TO 95 |96 WRITE(6,*) ' TYPE BLOCKSIZE IN BYTES (EVEN NUMBER PLEASE)'  READ(5,11) LBLKB D LBLKW=LBLKB/2  IF(LBLKW.LE.0) GO TO 96 C GET TAPE CHANNEL ASSIGNMENTS p IF(BUSY.EQ.1) GO TO 97 !DON'T REASSIGN THE TAPE  RETCODE=SYS$ASSIGN('TAPE',OCHAN,,) 8 IF(RETCODE.NE.%LOC(SS$_NORMAL)) STOP 'TAPE NOT ASSIGNED'  BUSY=1 !INDICATE THAT TAPE HAS BEEN ASSIGNED C d97 RCOUNT=0 !RECORD COUNTER  FLENGTH=0 !LENGTH OF FILE IN BYTES ,C C SKIP OUTPUT FILES SECTION C X ISKIP=1 !SKIP ONE FILE AT A TIME 100 IF(IFILE.EQ.NSTOP) GO TO 400  RETCODE=SYS$QIOW(,%VAL(OCHAN),%VAL(%LOC(IO$_SKIPFILE)),IOSB,,,  1 %VAL(ISKIP),,,,,) !SPACE OVER FILE  IFILE=IFILE+1 L IF(RETCODE.EQ.%LOC(SS$_NORMAL)) GO TO 100 !TEST FOR OK  WRITE(6,3) IOSB(1) !PROBLEMS 3 FORMAT(1H ,'HEXIDECIMAL # OF ERROR = ',Z8) x STOP 'OUTPUT SKIPPING PROBLEMS' C @C READ/WRITE LOOP C  400 KEND=0 l DO 420 I=1,LBLKW,LRECW !FILL THE TAPE BUFFER JSTART=I 4! JSTOP=I+LRECW-1 ! READ(1,13,ERR=450,END=480) (IBUF(J), J=JSTART,JSTOP) ! RCOUNT=RCOUNT+1 !COUNT THE RECORDS READ `" KEND=1 "420 JEND=JSTOP (#13 FORMAT(40A2) #C WRITE THE TAPE BUFFER #440 NBYTES=JEND*2 !NUMBER OF BYTES TO WRITE IN TAPE BLOCK T$ RETCODE=SYS$QIOW(,%VAL(OCHAN),%VAL(%LOC(IO$_WRITELBLK)),IOSB,,, $ 1 IBUF,%VAL(NBYTES),,,,) %C THE FOLLOWING TWO STATEMENTS ARE FOR ERROR CHECKING %C WRITE(6,12) IFILE,IOSB(1),IOSB(2) %C12 FORMAT(1H ,I5,2X,Z5,2X,I8) H& IF(IOSB(1).NE.%LOC(SS$_NORMAL)) GO TO 470 !TEST FOR ERROR & FLENGTH=FLENGTH+NBYTES !COUNT NUMBER OF BYTES IN FILE 'C/// WRITE(6,2) IFILE,IBLK,RCOUNT,NBYTES t'2 FORMAT(' FILE #, BLOCK #, RECORD #, # BYTES = ',4(1X,I8)) ' IBLK=IBLK+1 <( IF(IEND.EQ.0) GO TO 400 !LOOP UNTIL END OF INPUT FILE ( IF(IEND.EQ.1) GO TO 490 !END OF FILE FOUND )C h)C ERRORS )C 0*450 WRITE(6,*) 'INPUT PROBLEMS' * GO TO 800 *470 WRITE(6,3) IOSB(1) !PROBLEMS \+ WRITE(6,*) 'OUTPUT PROBLEMS' + GO TO 800 $,C ,C END OF FILE TESTS ,C P-480 IF(KEND.EQ.0) GO TO 490 !TEST IF ANYTHING WAS READ - IEND=1 !SET END OF FILE ON INPUT INDICATOR . GO TO 440 !WRITE CARD IMAGES IN BUFFER (MAY BE PARTIAL BLOCK) |.C DEFINITELY DONE WITH INPUT FILE .490 WRITE(6,7) IFILE,FLENGTH D/7 FORMAT(' FILE',I4,1X,'COPIED TO TAPE. FILE-LENGTH = ', / 1 I10) 0 RETCODE=SYS$QIOW(,%VAL(OCHAN),%VAL(%LOC(IO$_WRITEOF)),,,,,,,,,) p0 IFILE=IFILE+1 !INCREMENT FILE COUNT 0 CLOSE(UNIT=1) 81 GO TO 90 !LOOP FOR MORE FILES 1C 2C ALL DONE - CLEAN UP d2C 2700 RETCODE=SYS$QIOW(,%VAL(OCHAN),%VAL(%LOC(IO$_WRITEOF)),,,,,,,,,) ,3 RETCODE=SYS$QIOW(,%VAL(OCHAN),%VAL(%LOC(IO$_WRITEOF)),,,,,,,,,) 3800 RETCODE=SYS$QIO(,%VAL(OCHAN),%VAL(%LOC(IO$_REWIND)),,,,,,,,,) 3 STOP '*** DONE ***' X4 END