C+
C	Title:	LBCCOP
C	Author:	T. R. Wyant
C	Date:	04-Sep-1987
C	Modified:
C	Remarks:
C		Subroutine LBCCOP performs the copy operation for 
C		Program LBC. As many blocks as possible are copied,
C		with the size of the I/O operations being adjusted up
C		or down as errors are encountered. A block is skipped
C		only if it cannot be read or written in isolation.
C-
	SUBROUTINE LBCCOP

	INCLUDE 'LBCCOM.INC/NOLIST'

	PARAMETER	IExVER	= -4	! Parity error on device.
	PARAMETER	IExDAO	= -13	! Data overrun.
	PARAMETER	IExRER	= -32	! Device read error.
	PARAMETER	IExWER	= -33	! Device write error.
	PARAMETER	IExBBE	= -56	! Bad block on device.
	PARAMETER	IExBCC	= -66	! Block check, CRC, or framing.

	INTEGER*2	BLKBUF (IMXBLK*256)	! Block buffer.
	LOGICAL*1	BYTSTA		! Byte status.
	INTEGER*4	CSIZBY		! Current I/O size in bytes.
	INTEGER*4	CDONBY		! Bytes actually transferred.
	INTEGER*2	IDSW		! Directive status word.
	INTEGER*2	LUNTBL (2)	! Luns, each device.
	INTEGER*2	TRCLEN		! Trace text length.
	CHARACTER*16	TRCTXT (2)	! Trace text, each device.

	EQUIVALENCE	(PARAMS (2), CSIZBY)
	EQUIVALENCE	(STATUS (1), BYTSTA)
	EQUIVALENCE	(STATUS(2), CDONBY)

	DATA	LUNTBL	/LUNIN, LUNOUT/
	DATA	TRCTXT	/'Reading', 'Writing'/

C
C	Initialize the copy.
C
	CSIZBY = CSIZBK*512			! Init. bytes/operation
	CALL GETADR (PARAMS, BLKBUF)		! QIO parameters.
	STATYP = IOR5
	EXSTAT = EXSERR
	CDONBY = 0				! Hi part of count.
	PARAMS (3) = 0
	PARAMS (6) = 0

C
C	Now, perform the copy operation as follows:
C
3000	CONTINUE

C
C	If we're at the end of the device, we're done.
C
	IF (CPYSIZ .LE. 0) GO TO 8000

C
C	Size the operation to the work remaining.
C
	IF (CSIZBK .GT. CPYSIZ) THEN
	    CSIZBK = CPYSIZ
	    CSIZBY = CSIZBK*512
	  END IF

	DO 3290 ERRDEV = 1, 2
C
C		Load the QIO parameter block with the logical block
C			number of the operation.
C
	    PARAMS (4) = ICUBLK (2, ERRDEV)
	    PARAMS (5) = ICUBLK (1, ERRDEV)

C
C		Perform a logical block I/O to handle the next batch
C			of data.
C
3200	    CALL WTQIO (IOFUNC (ERRDEV), LUNTBL(ERRDEV), EFSYNC, ,
     1		STATUS, PARAMS, IDSW)
	    IF (IDSW .LT. 0) THEN
		STATYP = DSWR5
		STATUS(1) = IDSW
		ERRTXT = '\Operation failed on %VA\'
		GO TO 9000
	      END IF

C
C		Trace the results of the operation.
C
	    TRCLEN = INDEX (TRCTXT(ERRDEV), ' ') - 1
	    WRITE (LUNTRC, 3210) TRCTXT(ERRDEV)(:TRCLEN), CSIZBK,
     1			JCUBLK(ERRDEV), STATUS(1), STATUS(2)
3210	    FORMAT (' LBC -- Debug -- ', A, I4, :, ' blocks starting',
     1				' at block', I10, '.', /,
     2		    17X, 'I/O Status =', I6, ',', I6, '.')

C
C		If (the operation failed for an I/O error) THEN
C			BEGIN
C			If (it was for more than 1 block) THEN
C				cut the size in half
C			    ELSE
C				Report failure and skip.
C			Go retry the logical block read.
C			END.
C
	    IF (BYTSTA .LT. 0) THEN
		IF (CSIZBK .GT. 1) THEN
		    CSIZBK = (CSIZBK+1)/2
		    CSIZBY = CSIZBK*512
		    GO TO 3200
		  ELSE
		    IF (BYTSTA .EQ. IExVER .OR.		! Parity.
     1			    BYTSTA .EQ. IExDAO .OR.	! Overrun.
     2			    BYTSTA .EQ. IExRER .OR.	! Read error.
     3			    BYTSTA .EQ. IExWER .OR.	! Write error.
     4			    BYTSTA .EQ. IExBBE .OR.	! Bad block.
     5			    BYTSTA .EQ. IExBCC)		! CRC.
     6			EXSTAT = EXSWAR
		    ERRTXT = '\Operation failed on %VA block %T\'
		    JCUINB = JCUINB + 1
		    JCUOUB = JCUOUB + 1
		    CPYSIZ = CPYSIZ - 1
		    GO TO 9000
		  END IF
	      END IF

C
C		IF (we didn't get as many bytes as we expected) THEN
C			Make the operation size equal to the number
C				we did get.
C
	    IF (CSIZBY .NE. CDONBY) THEN
		CSIZBK = CDONBY/512
		CSIZBY = CSIZBK*512
	      END IF

C
C		END	! of I/O operation.
C
3290	    CONTINUE

C
C	Update the position on the disk.
C
	JCUINB = JCUINB + CSIZBK
	JCUOUB = JCUOUB + CSIZBK
	CPYSIZ = CPYSIZ - CSIZBK

C
C	If (this operation was for less than the maximum blocks) THEN
C		Double it and clamp to the maximum.
C
	IF (CSIZBK .LT. CSIZMX) THEN
	    CSIZBK = MIN (CSIZMX, CSIZBK*2)
	    CSIZBY = CSIZBK*512
	  END IF

C
C	Repeat as needed until the copy is done.
C
	GO TO 3000

C
C	Done.
C
8000	CONTINUE

C
C	Close files, if needed.
C
	CLOSE (UNIT=LUNTBL(1))
	CLOSE (UNIT=LUNTBL(2))

C
C	If needed, use the ACP QIO function to set the
C				output file characteristics.
C
	ERRDEV = 2
	IF (OUTFID(1) .NE. 0) THEN
	    WRITE (LUNTRC, 3210) 'Updating header.'
		WRITE (LUNTRC, 2050) 'File number', OUTFID(1),
     1			'File sequence', OUTFID(2),
     2			'Reserved', OUTFID(3),
     3			'Protection', OUTPRO,
     4			'Record type/attributes', OUTUFA(1),
     5			'Record size', OUTUFA(2),
     6			'High block (high)', OUTUFA(3),
     7			'High block (low)', OUTUFA(4),
     6			'EOF block (high)', OUTUFA(5),
     7			'EOF block (low)', OUTUFA(6),
     8			'First free byte', OUTUFA(7)
2050	FORMAT (' LBC -- Debug -- ', (X, T18, A, :, ' =', O,
     1			' (octal)', :))
	    CALL GETADR (PARAMS, OUTFID, ATRLST)
	    PARAMS (3) = 0
	    PARAMS (4) = 0
	    PARAMS (5) = 0
	    PARAMS (6) = 0
	    CALL WTQIO (IOWAT, LUNTBL(ERRDEV), EFSYNC, , STATUS,
     1			PARAMS, IDSW)
	    IF (IDSW .LT. 0) THEN
		STATYP = DSWR5
		ERRTXT = '\Header write error on %VA\'
		GO TO 9000
	      ELSE IF (BYTSTA .LT. 0) THEN
		ERRTXT = '\Header write error on %VA\'
		STATYP = IOR5
		GO TO 9000
	      END IF
	  END IF

C
C	Success.
C
	EXSTAT = EXSSUC
	ERRDEV = 0
	ERRTXT = '\Done\'
	STATYP = 0
	FRCXIT = 1
	GO TO 9000

9000	RETURN
	END