d C
È C	TAPECOPY PROGRAM
°	PARAMETER BUFSIZE=7200		!INPUT WORKING BUFFER SIZE
C				!CHANGE BUFSIZE TO PROCESS LARGER BLOCKSIZES
xC
Ü	PARAMETER EOF='879'X
@	PARAMETER NOLOGNAM='908'X	!RETURN CODE
¤	PARAMETER NOPRIV = '24'X	!RETURN CODE
	PARAMETER IO$_READLBLK = '21'X	!READ LOGICAL BLOCK CODE FOR QIO
l	PARAMETER IO$_REWIND   = '24'X	!REWIND FUNCTION CODE FOR QIO
ÐC
4	INTEGER*2 CHANNEL,ENDFLAG,IOSB(4),firstblock
˜	INTEGER*4 SYS$ASSIGN,SYS$QIOW,RETCODE,OUTRECD
ü	CHARACTER OUTFILE*13,BUFFER*(BUFSIZE),cr
ð
	DATA CR /'0D'X/	!CARRIAGE RETURN CHARACTER
01000	FORMAT (A)
”2000	FORMAT (I4)
øC	***************************************************************
\C	SETUP
ÀC
$	WRITE(6,*)' THIS PROGRAM READS INPUT FROM LOGICAL NAME "TAPE"'
ˆ	RETCODE=SYS$ASSIGN('TAPE',CHANNEL,,)
ì	IF(RETCODE.NE.1) GO TO 9000
P	NUMFILE=1
´	ENDFLAG=0
	firstblock=1
|C
àC	REWIND THE TAPE
D	RETCODE = SYS$QIOW(,%VAL(CHANNEL),%VAL(IO$_REWIND),IOSB,,,,,,,,)
¨	IF (RETCODE .NE. 1) GO TO 9000
C
pC	*************************************************************
Ô100	continue
”C	IBLKSIZE = 0	!# OF BYTES ACTUALLY READ
øC	NUMRECS=0	!# OF RECORDS
\D	ISTART = 1	!BEGINNING OF INPUT BUFFER
ÀD	IREMAIN = 0	!# OF BYTES LEFT FROM PREVIOUS BLOCK
$EC
PFC
´FC	*********************************************************
GC	*********************************************************
|GC	GET AN INPUT RECORD
àGC
DH200	BUFFER(ISTART:BUFSIZE) = ' '	!CLEAR INPUT BUFFER
¨H	IF ((IBLKSIZE+IREMAIN) .GT. BUFSIZE) STOP 'INPUT RECORD TOO LARGE'
I	RETCODE=SYS$QIOW(,%VAL(CHANNEL),%VAL(IO$_READLBLK),IOSB,,,
pI	1	%REF(BUFFER(ISTART:ISTART)),%VAL(BUFSIZE),,,,)
ÔI	IF(RETCODE.NE.1)GO TO 9000	!CHECK FOR ERROR RETURN
8JC
œJC	CHECK FOR EOF OR ZERO LENGTH BLOCK
 K	IF((IOSB(1).EQ.EOF).OR.(IOSB(2).EQ.0)) THEN
dKC
ÈKC	   TEST FOR END OF TAPE
,L	   IF(ENDFLAG.NE.0)THEN
L		STOP 'END OF TAPE'
ôL	   ELSE		!END OF CURRENT INPUT FILE
XM		ENDFLAG=1
¼M		firstblock=1 ! start new file soon
„NC				REPORT SUMMARY STATISTICS
èN		WRITE(6,4000)NUMFILE,NUMRECS
LO4000		FORMAT(' END OF FILE # ',I8,': ',I8,' RECORDS WRITTEN')
°O		NUMFILE = NUMFILE + 1
P		GO TO 100	!GET READY FOR NEXT INPUT FILE
xP	   END IF
ÜP	END IF
@QC
¤QC	DE-BLOCK AND WRITE OUTPUT RECORDS
R	ENDFLAG = 0	!CLEAR EOF. THERE IS STILL DATA TO PROCESS
lR	IBLKSIZE = IOSB(2)	!SIZE OF INPUT DATA PHYSICAL RECORD
ÐR	IF ((IBLKSIZE.LT.OUTRECD) .AND. (RFORMAT.EQ.'F')) THEN
4S		WRITE(6,4100)IBLKSIZE
˜S4100		FORMAT(' REC HAS ',I4,'BYTES...IGNORE IT')
üS		GO TO 200
`T		END IF
ÄT	NUMBYTES = IBLKSIZE + IREMAIN !TOTAL # OF CHARS IN BUFFER
(UC
ŒUC
ðUC	***************************************************************
@jC	**************************************************************
¤jC	VARIABLE LENGTH RECORD PROCESSING (FORMAT 3)
kC
lk700	if(firstblock.eq.1) then
Ðk		if(buffer(1:4).eq.'VOL1') go to 200
4l		if(buffer(1:4).eq.'HDR2') go to 200
˜l		if(buffer(1:4).eq.'EOF1') go to 200
ül		if(buffer(1:4).eq.'EOF2') go to 200
`m		if(buffer(1:4).ne.'HDR1') go to 702
Äm		namelen=0
(n		outfile=' '
Œn		do 704 i=5,14
ðn		if(buffer(i:i).ne.' ') then
To			namelen=namelen+1
¸o			outfile(namelen:namelen)=buffer(i:i)
p			endif
€p704		continue
äp		close(unit=1)
Hq		open(unit=1,name=outfile,carriagecontrol='list',
¬q	1	 recordsize=133)
r		write(6,9091) outfile
tr9091		format(' new output file ',a20)
Ør701		istart=1
<s		iremain=0
 s		goto 200
t		endif
ht702	L = 1	!BEGINNING OF RECORD POINTER
Ìt	K = 1	!END OF RECORD POINTER
0uC
”uC******* SEARCH FOR CARRIAGE RETURN/LINE FEED DELIMITER
øu710	IF (BUFFER(K:K) .EQ. CR) GO TO 720
*v	if(ichar(buffer(k:k)).eq.0) goto 701
\v	K = K+1		!DIDN'T FIND <CR>, CONTINUE THE SCAN
Àv	IF (K .ge. numbytes) GO TO 730  !PAST END OF BLOCK; SKIP TRAILING NULLS 
$w	GO TO 710
ˆwC
ìwC	FOUND END OF VARIABLE LENGTH RECORD
Px720	WRITE (1,1000)BUFFER(L:K-1)
´x	NUMRECS = NUMRECS+1	!BUMP OUTPUT RECORD COUNT
y	K = K+2	!BUMP POINTER PAST THE <LF> CHARACTER
|y	L = K	!PREPARE TO SCAN FOR NEXT RECORD
àyc	IF (MOD(NUMRECS,100).EQ.0) WRITE(6,4200)NUMRECS
Dz	GO TO 710
¨zC
{730	iremain=max(0,numbytes-l+1)
p{	istart=iremain+1
Ô{	buffer(1:iremain)=buffer(L:numbytes)
8|	goto 200
œ|C	**************************************************************
 }C	ERROR PROCESSING
d}9000	IF (RETCODE .EQ. NOLOGNAM) THEN
È}		WRITE(6,*)' ********************************'
,~		WRITE(6,*)' LOGICAL NAME "TAPE" NOT ASSIGNED'
~		WRITE(6,*)' ********************************'
ô~		ENDIF
X	IF (RETCODE .EQ. NOPRIV) THEN
¼		WRITE(6,*)' ***********************************'
 €		WRITE(6,*)' "TAPE" MUST BE MOUNTED/FOREIGN'
„€		WRITE(6,*)' ***********************************'
è€		ENDIF
L		WRITE(6,3000)RETCODE
°3000		FORMAT(' ******************************************'/
‚	2		' SYSTEM CALL RETURN CODE = ',Z8,' HEX'/
x‚	3	       ' ******************************************')
Ü‚	END