C+
C	Title:	LBCPSR
C	Author:	T. R. Wyant
C	Date:	09-Sep-1987
C	Modified:
C		25-Aug-1989 - T. R. Wyant
C				Special-case M and S, as at least some
C				versions crash on PRSRMS.
C
C	Remarks:
C		Subroutine LBCPSR is the command input section of the
C		program LBC. It obtains input (from whatever source),
C		validates it, assigns LUNs, and opens files as needed.
C		It passes back to the caller the device (and file) spec
C		for both input and output, the starting block on both
C		input and output, and the number of blocks to copy.
C-
	SUBROUTINE LBCPSR

	INCLUDE 'LBCCOM.INC/NOLIST'

	PARAMETER IExSDP = -99	! DIC or DPB size invalid

	INTEGER*2	FSDEV		! PRSRMS bit for device name.
	PARAMETER	(FSDEV	= '200'O)
	INTEGER*2	FSDIR		! PRSRMS bit for directory name.
	PARAMETER	(FSDIR	= '100'O)
	INTEGER*2	FSNAM		! PRSRMS bit for file name.
	PARAMETER	(FSNAM	= '4'O)
	INTEGER*2	FSTYP		! PRSRMS bit for file type.
	PARAMETER	(FSTYP	= '2'O)
	INTEGER*2	FSVER		! PRSRMS bit for file version.
	PARAMETER	(FSVER	= '1'O)
	INTEGER*2	FSLCF		! PRSRMS bit for local file spec.
	PARAMETER	(FSLCF	= FSDEV+FSDIR+FSNAM+FSTYP+FSVER)


	INTEGER*2	ASSERT		! .TRUE. if switch asserted.
	INTEGER*2	ATRPRE		! .TRUE. to perserve attributes.
	INTEGER*2	ATRSEE		! .TRUE. if /PRESERVE seen.
	LOGICAL*1	BYTPRM (12)	! Equiv. to PARAMS.
	LOGICAL*1	BYTSTA		! Byte status.
	CHARACTER*80	CMDBUF		! Command buffer.
	INTEGER*2	CMDEND		! Command buffer length.
	INTEGER*2	CMDLOC		! Location in command buffer.
	INTEGER*2	DATLOC		! Location of date in header buf.
	INTEGER*2	DEVLOC		! Location of device spec.
	INTEGER*2	DEVNAM		! Device name.
	INTEGER*2	DEVUNT		! Unit number.
	INTEGER*2	DIRLEN		! Length of direction text.
	CHARACTER*8	DIRTBL (2)	! Direction for each LUN.
	INTEGER*4	DVBEG (2)	! Beginning block of device.
	INTEGER*4	DVEND (2)	! End block of device.
	INTEGER*4	EXTBLK		! Blocks to extend.
	CHARACTER*64	FILDEF		! File name defaults.
	INTEGER*2	FILDLN		! File name default length.
	INTEGER*2	FILOPN (2)	! .TRUE. if I/O to a file.
	INTEGER*2	PRSFLG		! Flags from parse.
	INTEGER*2	HDRATR (2, 3)	! File attribute list.
	INTEGER*2	HDRBUF (256)	! File header buffer.
	INTEGER*2	HDRFID (2)	! File ID from header.
	LOGICAL*1	HDRFCH (2)	! File characteristics from hdr.
	INTEGER*2	HDRUFA (16)	! User attributes from header.
	INTEGER*2	HDRPRO		! File protection from header.
	INTEGER*4	HDRHIB		! High block number.
	INTEGER*4	HDREOB		! EOF block number.
	INTEGER*2	HDRFBY		! First free byte.
	INTEGER*2	IDSW		! Directive status word.
	INTEGER*2	IOXLB (2)	! Logical block I/O codes.
	INTEGER*2	IOXVB (2)	! Virtual block I/O codes.
	INTEGER*2	ITER8		! General iteration.
	INTEGER*4	JASK		! Input function.
	INTEGER*4	JSWAP		! Word swap function.
	INTEGER*2	KWDEND		! Keyword end.
	INTEGER*2	KWDLEN		! Keyword length.
	INTEGER*2	LUNBUF (6)	! GETLUN buffer.
	INTEGER*2	LUNTBL (2)	! I/O LUN table.
	INTEGER*4	NBLOKS		! Number of blocks used.
	INTEGER*2	NEWLGL (2)	! .TRUE. if new file legal.
	INTEGER*2	NEWUSD (2)	! .TRUE. if new file created.
	INTEGER*2	PBLK (20)	! Parse block.
	INTEGER*2	PRSALO (2)	! Allowed file spec elements
	CHARACTER*64	PRSDEV		! Parsed device.
	INTEGER*2	PRSDLN		! Parsed device length.
	INTEGER*2	PRSSUP		! .TRUE. unless M or S.
	INTEGER*2	SPCEND		! Specification end.
	INTEGER*2	SWILOC		! Switch location.
	INTEGER*2	SYNEND		! Syntax element end.

	EQUIVALENCE	(HDRBUF (  2),	HDRFID (1))
	EQUIVALENCE	(HDRBUF (  6),	HDRPRO)
	EQUIVALENCE	(HDRBUF (  7),	HDRFCH (1))
	EQUIVALENCE	(HDRBUF (  8),	HDRUFA (1))

	EQUIVALENCE	(HDRUFA (  3),	HDRHIB)
	EQUIVALENCE	(HDRUFA (  5),	HDREOB)
	EQUIVALENCE	(HDRUFA (  7),	HDRFBY)

	EQUIVALENCE	(LUNBUF ( 1),	DEVNAM)
	EQUIVALENCE	(LUNBUF ( 2),	DEVUNT)

	EQUIVALENCE	(PARAMS ( 1),	BYTPRM (1))
	EQUIVALENCE	(PARAMS ( 3),	EXTBLK)

	EQUIVALENCE	(STATUS ( 1),	BYTSTA)


	DATA	DIRTBL	/'input', 'output'/
	DATA	IOXLB	/IORLB, IOWLB/
	DATA	IOXVB	/IORVB, IOWVB/
	DATA	LUNTBL	/LUNIN, LUNOUT/
	DATA	NEWLGL	/.FALSE., .TRUE./
	DATA	PRSALO	/FSLCF,		! Local file spec on input.
     1			 FSLCF/		! Local file spec on output.

C
C	Initialize the program.
C
	CALL ERRSET (29, , .FALSE., , .FALSE.)	! File not found.
	CALL ERRSET (30, , .FALSE., , .FALSE.)	! Open error.
	CALL ERRSET (43, , .FALSE., , .FALSE.)	! File name error.
	CALL ERRSET (64, , .FALSE., , .FALSE.)	! Input conversion.
	CALL GETTSK (PBLK)			! Get task info.
	PRSSUP = (PBLK (15) .GT. 2)		! PRSRMS supp.
	OPEN (UNIT=LUNTRC, NAME='LBCTRACE', TYPE='NEW')	! Trace LUN.
	FILDEF = 'SY:[]LBC.DAT;'		! Default file name.
	OUTFID (1) = 0				! No file ID info yet.
	HDRFCH (1) = '200'O			! Assume output contig.
	HDRATR (1, 1) = -'12'O .AND. '377'O	! Set up the QIO
	CALL GETADR (HDRATR(2, 1), HDRBUF)	!    parameter block for
	HDRATR (1, 2) = 0			!    an IO.RAT to read
	PARAMS (1) = 0				!    a file header.
	CALL GETADR (PARAMS(2), HDRATR)		!	.
	PARAMS (3) = 0				!	.
	PARAMS (4) = 0				!	.
	PARAMS (5) = 0				!	.
	PARAMS (6) = 0				!	.
	OUTNEW = .FALSE.			! Output file not new.

C
C	Get the MCR command line if appropriate.
C
	IF (.NOT. INTERA) THEN
	    INTERA = .TRUE.			! Assume interactive.
	    CALL GETMCR (CMDBUF, CMDEND)	! (attempt to) get cmd.
	    IF (CMDEND .GT. 0)			! If got one, uppercase
     1		CALL CMDSQZ (CMDBUF, CMDEND)	!    and squeeze.
	    IF (CMDEND .GT. 0) THEN
		CMDLOC = INDEX (CMDBUF(:CMDEND), ' ')
		IF (CMDLOC .GT. 0) THEN
		    INTERA = .FALSE.
		    CMDLOC = CMDLOC + 1
		  END IF
	      END IF
	  END IF
	IF (INTERA) THEN
	    CMDLOC = 1
	    CMDEND = 0
	  END IF

C
C	Set up device error assumptions.
C
	EXSTAT = EXSERR			! Exit with error.
	ERRDEV = 1			! Error on input device.
	STATYP = DSWR5			! Exec directive error.
	FRCXIT = 0			! Default exit.
	CSIZBK = IMXBLK			! Init. blocks/operation
	CSIZMX = -1			! No buffer size, yet.
	ATRPRE = .FALSE.		! No attribute preservation.
	ATRSEE = .FALSE.		! /PRESERVE not seen.
	JCUINB = -1			! No input block.
	JCUOUB = -1			! No output block.
	CPYSIZ = -1			! No copy size.
	WRITE (LUNTO, 2010) ' '
2010	FORMAT (16A)

C
C	FOR (each of the devices in question) DO
C		BEGIN
C
	DO 2090 ERRDEV = 1, 2

C
C		Prompt for the device if necessary.
C
	    IF (CMDLOC .GT. CMDEND) THEN
		DIRLEN = INDEX (DIRTBL(ERRDEV), ' ')
		WRITE (LUNTO, 2010) '$Enter ', DIRTBL(ERRDEV)(:DIRLEN),
     1			'device or file name: '
		CMDLOC = 1
		READ (LUNTI, 2020, END=9900) CMDEND, CMDBUF
2020		FORMAT (Q, A)
		CALL CMDSQZ (CMDBUF, CMDEND)
	      END IF
	    WRITE (LUNTRC, 2720) 'Command location', CMDLOC,
     1			'Command length', CMDEND,
     2			CMDBUF(:CMDEND)

C
C		Parse the device name out of the input.
C
	    SPCEND = INDEX (CMDBUF(CMDLOC:CMDEND), ' ') - 1
	    IF (SPCEND .LT. 0) SPCEND = LEN(CMDBUF(CMDLOC:CMDEND))
	    SPCEND = SPCEND + CMDLOC - 1

	    SYNEND = INDEX (CMDBUF(CMDLOC:SPCEND), '/') - 1
	    IF (SYNEND .LT. 0) SYNEND = LEN(CMDBUF(CMDLOC:SPCEND))
	    SYNEND = SYNEND + CMDLOC - 1

	    DEVSLN(ERRDEV) = SYNEND - CMDLOC + 1
	    DEVSPC(ERRDEV) = CMDBUF(CMDLOC:SYNEND)
	    WRITE (LUNTRC, 2720) 'Device spec location', CMDLOC,
     1			'Device spec end', SYNEND
	    CMDLOC = SYNEND + 1

C
C		Pick up the switches, if any:
C
2200	    IF (CMDLOC .LE. SPCEND) THEN
		SWILOC = CMDLOC
		SYNEND = SPCEND
		IF (CMDBUF(CMDLOC:CMDLOC) .NE. '/') GO TO 8200
		SYNEND = INDEX (CMDBUF(CMDLOC+1:SPCEND), '/') - 1
		IF (SYNEND .LT. 0) SYNEND = LEN(CMDBUF(CMDLOC+1:SPCEND))
		SYNEND = SYNEND + CMDLOC+1 - 1
		WRITE (LUNTRC, 2720) 'Syntax element location', CMDLOC,
     1			'Syntax element end', SYNEND
		KWDEND = INDEX (CMDBUF(CMDLOC+1:SPCEND), ':') - 1
		IF (KWDEND .LT. 0)
     1		    KWDEND = INDEX (CMDBUF(CMDLOC+1:SPCEND), '=') - 1
		IF (KWDEND .LT. 0) KWDEND = LEN(CMDBUF(CMDLOC+1:SPCEND))
		KWDEND = KWDEND + CMDLOC+1 - 1
		WRITE (LUNTRC, 2720) 'Keyword location', CMDLOC,
     1			'Keyword end', KWDEND

		CMDLOC = CMDLOC + 1
		ASSERT = .TRUE.
		IF (CMDBUF(CMDLOC:CMDLOC) .EQ. '-') THEN
		    ASSERT = .FALSE.
		    CMDLOC = CMDLOC + 1
		  ELSE IF (CMDBUF(CMDLOC:CMDLOC+1) .EQ. 'NO') THEN
		    ASSERT = .FALSE.
		    CMDLOC = CMDLOC + 2
		  END IF

		KWDLEN = KWDEND - CMDLOC + 1
		IF (KWDLEN .LE. 0) GO TO 8200
		IF (INDEX( 'BUFFER', CMDBUF(CMDLOC:KWDEND))
     1			.EQ. 1) THEN
		    READ (CMDBUF(KWDEND+2:SYNEND), 2220) CSIZMX
2220		    FORMAT (I)
		  ELSE IF (INDEX( 'NUMBER', CMDBUF(CMDLOC:KWDEND))
     1			.EQ. 1) THEN
		    READ (CMDBUF(KWDEND+2:SYNEND), 2220) CPYSIZ
		  ELSE IF (INDEX( 'PRESERVE', CMDBUF(CMDLOC:KWDEND))
     1			.EQ. 1) THEN
		    ATRPRE = ASSERT
		    ATRSEE = .TRUE.
		  ELSE IF (INDEX( 'START', CMDBUF(CMDLOC:KWDEND))
     1			.EQ. 1) THEN
		    READ (CMDBUF(KWDEND+2:SYNEND), 2220) JCUBLK(ERRDEV)
		  ELSE
		    GO TO 8200
		  END IF
		CMDLOC = SYNEND + 1
		GO TO 2200
	      END IF
	    CMDLOC = SPCEND + 2

C
C		Assign the LUN to the device.
C
	    FILOPN (ERRDEV) = .FALSE.
	    NEWUSD (ERRDEV) = .FALSE.
	    STATUS (1) = IExSDP
	    IF (PRSSUP) THEN
		CALL PRSRMS ( , , LUNTBL(ERRDEV), DEVSPC(ERRDEV),
     1			DEVSLN(ERRDEV), PRSDEV, LEN(PRSDEV), PRSDLN,
     2			PBLK, 40, , , 0, STATUS(1))
		PRSFLG = PBLK (2)
	      END IF
	    IF (STATUS(1) .EQ. IExSDP) THEN
		PRSSUP = .FALSE.
		PRSFLG = 0
		PRSDLN = DEVSLN(ERRDEV)
		PRSDEV = DEVSPC(ERRDEV)(:PRSDLN)
		DEVLOC = INDEX (PRSDEV(:PRSDLN), ':')
		IF (DEVLOC .GT. 0) THEN
		    PRSFLG = PRSFLG .OR. FSDEV
		    READ (PRSDEV(:DEVLOC-1), 2030) DEVNAM, DEVUNT
2030		    FORMAT (A2, O6)
		    CALL ASNLUN (LUNTBL (ERRDEV),
     1				DEVNAM, DEVUNT, STATUS(1))
		  END IF
		IF (DEVLOC .LT. PRSDLN) PRSFLG = PRSFLG .OR. FSNAM
	      END IF
	    IF (STATUS(1) .LT. 0) THEN
		ERRTXT = '\Failed to assign LUN to %VA\'
		GO TO 9000
	      END IF

C
C		Reparse to generate the file name.
C
	    FILDLN = INDEX(FILDEF,';')
	    IF (PRSSUP) THEN
		CALL PRSRMS ( , , LUNTBL(ERRDEV), DEVSPC(ERRDEV),
     1			DEVSLN(ERRDEV), PRSDEV, LEN(PRSDEV), PRSDLN,
     2			PBLK, 40, FILDEF, FILDLN, 0, STATUS(1))
		IF (STATUS(1) .LT. 0 .AND. STATUS(1) .NE. IExSDP) THEN
		    ERRTXT = '\Internal error reparsing spec %VA\'
		    GO TO 9000
		  END IF
	      END IF

CX
CX	Note to the curious:
CX		PRSRMS is a system sybroutine under RSX-11M+ V3.0.
CX		It takes as input a filespec, possibly containing
CX		logical names. The output is an expanded filespec, with
CX		defaults (if any) filled in. The parse block filled in
CX		as follows (all locations refer to OUTPUT file spec):
CX
CX			Word	Use
CX			----	-------------------------------------
CX			 1	Status (expands on cause of failure)
CX			 2	Flags (see next table)
CX			 3-4	Length and address of node spec
CX			 5-6	Length and address of device spec
CX			 7-8	Length and address of directory spec
CX			 9-10	Length and address of file name spec
CX			11-12	Length and address of file type spec
CX			13-14	Length and address of version number
CX			15-16	Length and address of trailing string
CX			17-18	Length and address of node access ctrl
CX			19	Type of first input elem. that could be
CX				a logical name.
CX			20	Unused.
CX
CX		The flags are defined as follows:
CX
CX			Mask	Meaning if set.
CX			------	--------------------------------------
CX			0001	Version present in input
CX			0002	File type present in input
CX			0004	File name present in input
CX			0010	Wildcard version present in input
CX			0020	Wildcard file type present in input
CX			0040	Wildcard file name present in input
CX			0100	Directory present in input
CX			0200	Device present in input
CX			0400	Node name present in input
CX			1000	Wildcard directory present in input
CX			2000	Quoted file name and type in input
CX

C
C		Exclude forbidden file spec elements.
C
	    IF ((PRSFLG .AND. .NOT. PRSALO(ERRDEV)) .NE. 0) THEN
		ERRTXT = '\Unsupported file specification in %VA\'
		STATYP = 0
		GO TO 9000
	      END IF

C
C		Get the device characteristics.
C
	    CALL GETLUN (LUNTBL(ERRDEV), LUNBUF, STATUS(1))
	    IF (STATUS(1) .LT. 0) THEN
		ERRTXT = '\Failed to get LUN information on %VA\'
		GO TO 9000
	      END IF

C
C		IF (we have a device name only) THEN
C			BEGIN
C
	    IF ((PRSFLG .AND. .NOT. FSDEV) .EQ. 0) THEN

C
C			Get the real device name.
C
		PRSDLN = INDEX (PRSDEV(:PRSDLN), ':')
		DEVSPC(ERRDEV) = PRSDEV(:PRSDLN)
		DEVSLN(ERRDEV) = PRSDLN

C
C			Screen out non-disks.
C
		IF ((LUNBUF (3) .AND. .NOT. UC1DNO) .NE. UC1DSK) THEN
		    STATYP = 0
		    ERRTXT = '\Logical I/O not supported on %VA\'
		    GO TO 9000
		  END IF

C
C			Set it up as a device.
C
		DVBEG(ERRDEV) = 0
		IOFUNC(ERRDEV) = IOXLB(ERRDEV)

C
C			Get the size of the device.
C
		LUNBUF(4) = LUNBUF(4) .AND. 'FF'X
		DVEND(ERRDEV) = JSWAP(LUNBUF(4)) - 1
		IF (DVEND(ERRDEV) .LE. 0) THEN
		    ERRTXT = '\Size of %VA is unknown to the system\'
		    STATYP = 0
		    STATUS(1) = -92
		    GO TO 9000
		  END IF

C
C			END	! if "device name only" code;
C		    ELSE	! if we have any part of a file spec
C			BEGIN	! container file code.
C
	      ELSE

C
C			Get the real file name.
C
		DEVSPC(ERRDEV) = PRSDEV(:PRSDLN)
		DEVSLN(ERRDEV) = PRSDLN

C
C			Update the default.
C
		FILDEF = DEVSPC(ERRDEV)(:DEVSLN(ERRDEV))

C
C			Set it up as a file.
C
		DVBEG(ERRDEV) = 1
		IOFUNC(ERRDEV) = IOXVB(ERRDEV)

C
C			Try to open it as an old file;
C
CX			NOTE: BUFFERCOUNT=-1 specifies block access.
C
		NEWUSD (ERRDEV) = .TRUE.
		FILOPN(ERRDEV) = .TRUE.
		IF (NEWLGL(ERRDEV)) THEN
		    OPEN (UNIT=LUNTBL(ERRDEV), NAME=FILDEF, TYPE='OLD',
     1			BUFFERCOUNT=-1,
     2			ACCESS='DIRECT', RECL=128, ERR=2070)
		  ELSE
		    OPEN (UNIT=LUNTBL(ERRDEV), NAME=FILDEF, TYPE='OLD',
     1			BUFFERCOUNT=-1, READONLY, SHARED,
     2			ACCESS='DIRECT', ERR=8000)
		  END IF
		NEWUSD (ERRDEV) = .FALSE.

C
C			Use the ACP QIO function to get the file
C				characteristics.
C
		CALL WTQIO (IORAT, LUNTBL(ERRDEV), EFSYNC, , STATUS,
     1			PARAMS, IDSW)
		IF (IDSW .LT. 0) THEN
		    GO TO 8110
		  ELSE IF (BYTSTA .LT. 0) THEN
		    GO TO 8100
		  END IF

C
C			Dump the acquired header data to the trace LUN.
C
		WRITE (LUNTRC, 2050) 'File number', HDRFID(1),
     1			'File sequence', HDRFID(2),
     2			'Protection', HDRPRO,
     3			'User characteristics', HDRFCH(1),
     4			'Record type/attributes', HDRUFA(1),
     5			'Record size', HDRUFA(2),
     6			'High block (high)', HDRUFA(3),
     7			'High block (low)', HDRUFA(4),
     6			'EOF block (high)', HDRUFA(5),
     7			'EOF block (low)', HDRUFA(6),
     8			'First free byte', HDRUFA(7)
2050	FORMAT (' LBC -- Debug -- ', (X, T18, A, :, ' =', O,
     1			' (octal)', :))
		DVEND(ERRDEV) = JSWAP(HDRUFA(3))
		GO TO 2080

CX
CX			Do error analysis on the output file open.
CX
2070		CONTINUE
		CALL ERRSNS (STATUS(2), STATUS(1), STATYP)
		IF (STATUS(2) .NE. 29) GO TO 8010

C
C			Set up the file size.
C
2080		IF (NEWLGL(ERRDEV)) THEN
		    DVEND (ERRDEV) = 'FFFFFF'X
		  END IF

C
C			END	! of container file code.
C
	      END IF

C
C		END	! of device input loop.
C
2090	    CONTINUE

C
C	Copy the latest file information into the common area.
C
	OUTPRO = HDRPRO			! Protection.
	CALL MOVW (16, HDRUFA, OUTUFA)	! User attributes.
	DATLOC = (HDRBUF(1) .AND. '377'O) + 6
	CALL MOVW (18, HDRBUF(DATLOC), OUTDAT)	! Creation date.

C
C	For debug, display the device sizes obtained.
C
	WRITE (LUNTRC, 2720) DEVSPC(1)(:DEVSLN(1)), 1,
     1			'Input device start', DVBEG(1),
     2			'Input device end', DVEND(1),
     3			DEVSPC(2)(:DEVSLN(2)), 2,
     4			'Output device start', DVBEG(2),
     5			'Output device end', DVEND(2)
2720	FORMAT (' LBC -- Debug -- ', (X, T18, A, :, ' =', I, :))

C
C	IF we are interactive THEN
C		BEGIN
C
	IF (INTERA) THEN
C
C		If both input and output are files,
C			find out if full copy.
C
	    IF (FILOPN(1) .AND. NEWUSD(2) .AND. .NOT. ATRSEE) THEN
		ATRPRE = LASK (27, 'Shall I copy the whole file',
     1			.TRUE., LUNTO, LUNTI, 3, 'LBC')
	      END IF

C
C		IF (we are preserving attributes) THEN
C			Default to full file copy
C
	    IF (ATRPRE) THEN
		JCUINB = DVBEG(1)
		JCUOUB = DVBEG(2)
		CPYSIZ = DVEND(1) - DVBEG(1) + 1

C
C		    ELSE	! If not preserving attributes
C			BEGIN
C
	      ELSE

C
C			Prompt for the starting block on the
C				input device.
C
		IF (JCUINB .EQ. -1)
     1		    JCUINB = JASK (36,
     2			'Enter starting block on input device',
     3			DVBEG(1), DVEND(1), DVBEG(1),
     4			LUNTO, LUNTI, 3, 'LBC')

C
C			Prompt for the starting block on the
C				output device.
C
		IF (JCUOUB .EQ. -1)
     1		    JCUOUB = JASK (37,
     2			'Enter starting block on output device',
     3			DVBEG(2), DVEND(2), DVBEG(2),
     4			LUNTO, LUNTI, 3, 'LBC')

C
C			Prompt for the number of blocks to copy.
C	
		IF (CPYSIZ .EQ. -1) THEN
		    CPYSIZ = MIN(DVEND(1)-JCUINB,DVEND(2)-JCUOUB) + 1
		    CPYSIZ = JASK (30, 'Enter number of blocks to copy',
     1			1, CPYSIZ, CPYSIZ,
     2			LUNTO, LUNTI, 3, 'LBC')
		  END IF

C
C			Prompt for the buffer size in 512-byte blocks.
C
		IF (CSIZMX .EQ. -1)
     1		    CSIZMX = JASK (36,
     2			'Enter buffer size in 512-byte blocks',
     3			1, IMXBLK, IMXBLK,
     4			LUNTO, LUNTI, 3, 'LBC')

C
C		END;	! of determining location and size of copy;
C	    ELSE	! if not interactive
C		Default and validate the copy size.
C
	      END IF
	  ELSE
	    IF (CPYSIZ .EQ. -1) CPYSIZ = DVEND(1) - DVBEG(1) + 1
	    STATYP = 0
	    DO 2960 ERRDEV = 1, 2
		IF (JCUBLK(ERRDEV) .EQ. -1)
     1			JCUBLK(ERRDEV) = DVBEG(ERRDEV)
		IF (JCUBLK(ERRDEV) .LT. DVBEG(ERRDEV) .OR.
     1			JCUBLK(ERRDEV).GT. DVEND(ERRDEV)) THEN
		    ERRTXT = '\Start block on %VA out of range\'
		    GO TO 9000
		  END IF
		IF (JCUBLK(ERRDEV)+CPYSIZ-1 .GT. DVEND(ERRDEV)) THEN
		    ERRTXT = '\Can''t copy past end of %VA\'
		    GO TO 9000
		  END IF
2960		CONTINUE
	    IF (NEWUSD(2) .AND. .NOT. ATRSEE) THEN
		ATRPRE = FILOPN(1)
	      END IF
	  END IF

C
C	If still no buffer size, default it.
C
	IF (CSIZMX .LT. 0) CSIZMX = IMXBLK

C
C	IF (attribute preservation specified) AND (it's not legal) THEN
C		Error out.
C
	IF (ATRPRE .AND. (DVBEG(1) .NE. 1 .OR. DVBEG(2) .NE. 1 .OR.
     1			CPYSIZ .NE. DVEND(1) - DVBEG(1) + 1 .OR.
     2			.NOT. FILOPN(1) .OR. .NOT. NEWUSD(2))) THEN
	    ERRTXT = '\Must copy whole file to preserve attributes\'
	    GO TO 8210
	  END IF

C
C	For debug, display the copy information.
C
	WRITE (LUNTRC, 2720) 'Copy starts at input block', JCUINB,
     1			'Copy starts at output block', JCUOUB,
     2			'Copy size (in blocks) is', CPYSIZ

C
C	IF (the output is to a file) THEN
C		BEGIN
C
	IF (FILOPN(2)) THEN
	    NBLOKS = JCUOUB + CPYSIZ - 1

C
C		Set up the file attributes list in common.
C
	    ATRLST (1, 1) = 32*'400'O + '4'O
	    CALL GETADR (ATRLST(2, 1), OUTUFA)
	    ATRLST (1, 2) = 2*'400'O + '2'O
	    CALL GETADR (ATRLST(2, 2), OUTPRO)
	    ATRLST (1, 3) = 35*'400'O + '15'O
	    CALL GETADR (ATRLST(2, 3), OUTDAT)
	    ATRLST (1, 4) = 0

C
C		IF (the output is a new file) THEN
C			BEGIN
C
	    IF (NEWUSD(2)) THEN

C
C			Try to make the file contiguous (or not)
C				based on whether the input file is.
C
		IF (HDRFCH(1) .LT. 0) THEN
		    NBLOKS = -NBLOKS
		    ITER8 = 2
		  ELSE
		    ITER8 = 1
		  END IF

C
C			Open it as contiguously as possible.
C
5030		CONTINUE
		NBLOKS = -NBLOKS
		ITER8 = ITER8 - 1
		IF (ITER8 .LT. 0) GO TO 8000
		OPEN (UNIT=LUNTBL(2), NAME=DEVSPC(2)(:DEVSLN(2)),
     1			TYPE='NEW',
     2			BUFFERCOUNT=-1, INITIALSIZE=NBLOKS,
     3			ACCESS='DIRECT', RECL=128, ERR=5030)
		OUTNEW = .TRUE.

C
C			Use the ACP QIO function to get the file
C				characteristics.
C
		ERRDEV = 2		! Error on output device.
		CALL WTQIO (IORAT, LUNTBL(2), EFSYNC, , STATUS,
     1			PARAMS, IDSW)
		IF (IDSW .LT. 0) THEN
		    GO TO 8110
		  ELSE IF (BYTSTA .LT. 0) THEN
		    GO TO 8100
		  END IF

C
C			Load up the end of file markers.
C
		NBLOKS = ABS (NBLOKS)		! Recover value.
		HDRHIB = JSWAP (NBLOKS)		! Set high block to end.
		HDREOB = JSWAP (NBLOKS + 1)	! Set eof block past end
		HDRFBY = 0			! First free byte is 0.

C
C			Dump the acquired header data to the trace LUN.
C
		WRITE (LUNTRC, 2050) 'File number', HDRFID(1),
     1			'File sequence', HDRFID(2),
     2			'Protection', HDRPRO,
     3			'User characteristics', HDRFCH(1),
     4			'Record type/attributes', HDRUFA(1),
     5			'Record size', HDRUFA(2),
     6			'High block (high)', HDRUFA(3),
     7			'High block (low)', HDRUFA(4),
     6			'EOF block (high)', HDRUFA(5),
     7			'EOF block (low)', HDRUFA(6),
     8			'First free byte', HDRUFA(7)

C
C			END;	! of new file code.
C		    ELSE	! If it's an existing file
C			BEGIN
C			
	      ELSE

C
C			Update only the user attributes;
C
		ATRLST (1, 2) = 0

C
C			Extend the file (if needed);
C
		IF (NBLOKS .GT. JSWAP (HDRHIB)) THEN

		    PARAMS (1) = 0
		    PARAMS (2) = 0
		    PARAMS (5) = 0
		    PARAMS (6) = 0
		    EXTBLK = JSWAP (NBLOKS - JSWAP (HDRHIB))
		    BYTPRM (6) = EXENA	! Enable extend.
		    ERRDEV = 2		! Error on output device.
		    CALL WTQIO (IOEXT, LUNTBL(2), EFSYNC, , STATUS,
     1			PARAMS, IDSW)
		    IF (IDSW .LT. 0) THEN
			GO TO 8150
		      ELSE IF (BYTSTA .LT. 0) THEN
			GO TO 8140
		      END IF

		    HDRHIB = JSWAP (NBLOKS)	! Set high block to end.
		    HDREOB = JSWAP (NBLOKS + 1)	! Set eof block past end
		    HDRFBY = 0			! First free byte is 0.
		  ELSE			! If no need to extend file,
		    HDRFID(1) = 0		! Disable header update.
		  END IF

C
C			END;	! of processing an old file;
C
	      END IF

C
C		Get the file ID of the new file;
C
	    OUTFID(1) = HDRFID(1)
	    OUTFID(2) = HDRFID(2)
	    OUTFID(3) = 0

C
C		Set up the attribute list for the output file.
C

C
C		IF (not preserving file characteristics) THEN
C			Copy the characteristics of the new
C				file into common;
C
	    IF (.NOT. ATRPRE) THEN
		OUTPRO = HDRPRO
		CALL MOVW (16, HDRUFA, OUTUFA)
		DATLOC = (HDRBUF(1) .AND. '377'O) + 6
		CALL MOVW (18, HDRBUF(DATLOC), OUTDAT)
	      END IF

C
C		END;	! of setting up the output file;
C
	  END IF

C
C	Set exit status to success.
C
	EXSTAT = EXSSUC
	GO TO 9000

CX
CX	Error handlers.
CX

CX
CX	File open error.
CX
8000	CALL ERRSNS (STATUS(2), STATUS(1), STATYP)
8010	ERRTXT = '\File open error on %VA\'
	IF (STATYP .LT. 0) THEN
	    STATYP = DSWR5
	  ELSE
	    STATYP = IOR5
	  END IF

CX
CX	Header read error.
CX
8100	STATYP = IOR5
8110	ERRTXT = '\Header read error on %VA\'
	GO TO 9000

CX
CX	File extend error.
CX
8140	STATYP = IOR5
8150	ERRTXT = '\File extend error on %VA\'
	GO TO 9000

CX
CX	Switch error. This has to go here, because ERRDEV can
CX		not be set to zero inside the loop.
CX
8200	WRITE (ERRTXT, 2010) '\Switch "', CMDBUF(SWILOC:SYNEND),
     1			'" is illegal\'
8210	STATYP = 0
	ERRDEV = 0
	GO TO 9000

C
C	Return to caller.
C
9000	RETURN
9900	CALL EXIT
	END