dc. DO INTAPE c. Reads fixed block, unlabled tape into VAX files. ,c. C C TAPECOPY PROGRAM XC REQUIRES 'TRANSLATE.MAR' C C PROGRAM WILL READ UNLABELED MAGTAPES CONTAINING FIXED LENGTH C RECORDS. TAPE FILES ARE DEBLOCKED, AND WRITTEN TO DISK C OPTIONALLY, TRAILING SPACES AND CARD SEQUENCE FIELDS LC CAN BE STRIPPED OFF, AND EBCDIC CODES TRANSLATED TO ASCII c.-end.of.info- C xC **********************************************************  PARAMETER BUFSIZE=32000 !INPUT WORKING BUFFER SIZE @C  PARAMETER EOF='870'X  PARAMETER NOLOGNAM='908'X !RETURN CODE l PARAMETER NOPRIV = '24'X !RETURN CODE  PARAMETER IO$_READLBLK = '21'X !READ LOGICAL BLOCK CODE FOR QIO 4 PARAMETER IO$_REWIND = '24'X !REWIND FUNCTION CODE FOR QIO C  INTEGER*2 CHANNEL,ENDFLAG,IOSB(4) ` INTEGER*4 SYS$ASSIGN,SYS$QIOW,RETCODE,OUTRECD CHARACTER OUTFILE*13,BUFFER*32000 ( CHARACTER CARDS*1,TRANS*1,STRIP*1,CODE*1 CHARACTER ANSWER*1 C *************************************************************** T C. 1910 FORMAT( 10A )  C. C SETUP C H WRITE(6,1910) ' "TAPE" is the logical input' RETCODE=SYS$ASSIGN('TAPE',CHANNEL,,)  IF(RETCODE.NE.1) GO TO 9000 t PARAMS = 0 !NO PARAMETERS SET YET  NUMFILE=1 < ENDFLAG=0 C C REWIND THE TAPE h RETCODE = SYS$QIOW(,%VAL(CHANNEL),%VAL(IO$_REWIND),IOSB,,,,,,,,)  IF (RETCODE .NE. 1) GO TO 9000 0C C ************************************************************* C PREPARE FOR OUTPUT \C 5 CONTINUE $ WRITE(6,1910) '$STOP, SKIP, or Filename.typ ? '  READ(5,1000)OUTFILE 1000 FORMAT(A) PC C TEST TO SEE IF WE'RE DONE  IF (OUTFILE .EQ. 'STOP') THEN | STOP 'User requested STOP'  ENDIF DC C SHOULD WE SKIP OVER SOME FILES?  IF (OUTFILE .EQ. 'SKIP') THEN p WRITE(6,1910) '$ SKIP how many files ? '  READ (5,2000) NUMFILES 8 DO 8 I=1,NUMFILES 7 RETCODE=SYS$QIOW(,%VAL(CHANNEL),%VAL(IO$_READLBLK),IOSB,,,  2 %REF(BUFFER(1:1)),%VAL(BUFSIZE),,,,) d IF (IOSB(1) .EQ. EOF) THEN C LAST READ WAS EOF ... TEST FOR EOT (= 2 EOF'S) , IF (ENDFLAG .NE. 0) THEN  STOP 'END OF TAPE'  ELSE X ENDFLAG = 1 !ONE EOF SEEN  NUMFILE = NUMFILE + 1  GO TO 8 !COUNT ONE FILE  ENDIF  ENDIF L ENDFLAG = 0 !NOT END OF FILE  GO TO 7 !CONTINUE READING TO END OF FILE 8 CONTINUE x GO TO 5  ENDIF @C ************************************************************* C GET PARAMETERS FOR THE TAPECOPY  C l IF (PARAMS .EQ. 1 ) GO TO 20 C 4! WRITE(6,1910) ' TAPECOPY PARAMETERS****' ! TRANS = 'N' ! STRIP = 'N' `" OUTRECD = 80 " WRITE(6,1910) '$80 Char. card images (Y/N) ? ' (# READ (5,1000) CARDS # IF (CARDS .NE. 'Y' ) THEN # CARDS = 'N' T$10 CONTINUE $ WRITE(6,1910) '$ Logical record size ? ' % READ(5,2000)OUTRECD %2000 FORMAT(I4) % IF(OUTRECD.GT.BUFSIZE)THEN H& WRITE(6,*)' RECORD SIZE TOO LARGE ' & GO TO 10 ' END IF t' IF(OUTRECD.LE.0)THEN ' OUTRECD=80 <( WRITE(6,*) ' 80 CHAR RECORD ASSUMED' ( END IF ) ENDIF h)C ) WRITE(6,1912) 0*1912 FORMAT ( ' Translate input to ASCII' * 1 ,/,'$ from EBCDIC or BCD (Y/N) ? ') * READ (5,1000) TRANS \+ IF (TRANS .NE. 'Y' ) THEN + TRANS = 'N' $, ELSE ,2500 WRITE(6,1910) '$ EBCDIC or BCD (E/B) ? ' , READ (5,1000) CODE P- IF((CODE.NE.'E').AND.(CODE.NE.'B')) GO TO 2500 - ENDIF .C |. IF (CARDS .EQ. 'Y' ) THEN . WRITE(6,1910) ' Delete Column 73 thru 80, and' D/ WRITE(6,1910) '$strip trailing blanks (Y/N) ? ' / READ (5,1000) STRIP 0 IF (STRIP .NE. 'Y' ) THEN p0 STRIP = 'N' 0 ENDIF 81 ENDIF 1 PARAMS = 1 !PARAMETERS NOW INITIALIZED 2C d2C ******************************************************** 2C PREPARE THE OUTPUT FILE ,3C 320 IBLKSIZE = 0 3 NUMRECS=0 X4 ISTART = 1 4 IREMAIN = 0 5 OPEN(UNIT=1,NAME=OUTFILE,CARRIAGECONTROL='LIST', 5 2 RECORDSIZE=OUTRECD) 5C L6C ********************************************************* 6C GET AN INPUT RECORD 7C x750 BUFFER(ISTART:BUFSIZE) = ' ' !CLEAR INPUT BUFFER 7 IF ((IBLKSIZE+IREMAIN) .GT. BUFSIZE) STOP 'INPUT RECORD TOO LARGE' @8 RETCODE=SYS$QIOW(,%VAL(CHANNEL),%VAL(IO$_READLBLK),IOSB,,, 8 1 %REF(BUFFER(ISTART:ISTART)),%VAL(BUFSIZE),,,,) 9 IF(RETCODE.NE.1)GO TO 9000 l9C 9C CHECK FOR EOF 4: IF(IOSB(1).EQ.EOF)THEN :C :C TEST FOR END OF TAPE `; IF(ENDFLAG.NE.0)THEN ; STOP 'END OF TAPE' (< ELSE < ENDFLAG=1 < CLOSE(UNIT=1) T= WRITE(6,4000)NUMFILE,NUMRECS =4000 FORMAT(' END OF FILE # ',I8,': ',I8,' RECORDS WRITTEN') > NUMFILE = NUMFILE + 1 > GO TO 5 !GET READY FOR NEXT INPUT FILE > END IF H? END IF ?C @C ********************************************************* t@C DE-BLOCK AND WRITE OUTPUT RECORDS @ ENDFLAG = 0 !CLEAR EOF. WE'RE NOW IN A NEW FILE