Google
 

Trailing-Edge - PDP-10 Archives - tops10_integ_tools_v4_10jan-86 - 70,6067/dumpr1/dumper.txt
There are 3 other files named dumper.txt in the archive. Click here to see a list.
	.TITLE		ALLDEF
	$MTDEF		GLOBAL
	$TPADEF		GLOBAL
	.END
	SUBROUTINE COMMAND(COMLINE,STATE,KEY,STATUS)
C
C	This subroutine processes a command line by calling
C	the LIB$TPARSE run-time library routines.  It will
C	create a "standard" parameter block for LIB$TPARSE,
C	and then call it.  Any status code returned by
C	LIB$TPARSE will be returned as STATUS.
C
C	This version uses the following LIB$TPARSE options:
C	TPA$M_BLANKS = off, treat blanks as separators
C	TPA$M_ABBRFM = off, abbreviations must be unique
C	TPA$M_ABBREV = on,  abbreviations are allowed
C
C	COMLINE -- Command line to parse
C	STATE   -- State table address
C	KEY     -- Keyword table address
C	STATUS  -- Integer status of command
C
	IMPLICIT COMPLEX (A-Z)
C
	CHARACTER COMLINE*(*)
	INTEGER*4 STATE,KEY
	INTEGER*4 STATUS
C
	INTEGER*4 LIB$TPARSE
C
C	The parameter block for LIB$TPARSE
C
	INTEGER*4 TPBLOK(0:8)
	EXTERNAL TPA$L_COUNT,TPA$L_OPTIONS,TPA$L_STRINGCNT
	EXTERNAL TPA$L_STRINGPTR,TPA$L_TOKENCNT,TPA$L_TOKENPTR
	EXTERNAL TPA$B_CHAR,TPA$L_NUMBER,TPA$L_PARAM
	EXTERNAL TPA$M_BLANKS,TPA$M_ABBRFM,TPA$M_ABBREV
	EXTERNAL TPA$M_AMBIG,TPA$K_COUNT0
C
C	Initialize the LIB$TPARSE parameter block
C
	TPBLOK(%LOC(TPA$L_COUNT)/4) = %LOC(TPA$K_COUNT0)
	TPBLOK(%LOC(TPA$L_OPTIONS)/4) = %LOC(TPA$M_ABBREV)
	TPBLOK(%LOC(TPA$L_STRINGCNT)/4) = LEN(COMLINE)
	TPBLOK(%LOC(TPA$L_STRINGPTR)/4) = %LOC(COMLINE)
	STATUS = LIB$TPARSE(TPBLOK,STATE,KEY)
	IF (.NOT.STATUS) THEN
	 CALL ERRORM(STATUS)
	 WRITE(6,100) COMLINE
100	FORMAT(1X,A)
	 WRITE(6,110)
110	FORMAT(<TPBLOK(%LOC(TPA$L_STRINGPTR)/4)-%LOC(COMLINE)+1>X,'^')
	ENDIF
	RETURN
	END
	.TITLE	CVT		CONVERT DEC-10 DATATYPES FOR VAX
;+
;	CVT -- A SUBROUTINE PACKAGE FOR THE DUMPER/BACKUP
;	TAPE READING UTILITIES.  THESE SUBROUTINES CONVERT
;	DEC-10 DATATYPES INTO THOSE USABLE ON THE VAX.
;
;	ENTRY POINTS:
;	CVT36	TO CONVERT 5 BYTE DEC-10 MAGTAPE RECORDS INTO
;		THE PROPERLY ALIGNED 36 BIT VALUES (2 WORDS
;		PER VALUE)
;	CVT72   TO CONVERT 9 BYTE CCC TU70 DEC-10 MAGTAPE RECORDS
;		INTO THE PROPERLY ALIGNED 36 BIT VALUES (2 WORDS
;		PER VALUE DONE 2 AT A TIME).
;	CVTASZ	TO CONVERT ASCIZ STRINGS TO 8 BIT ASCII DATA
;		AND TO APPEND IT TO THE SUPPLIED STRING.
;	CVTHALF	TO CONVERT 18 BIT HALFWORDS TO TWO LONGWORD
;		INTEGERS.
;	CVTSIX	TO CONVERT A SIX SIXBIT CHARACTERS TO 8 BIT
;		ASCII AND TO APPEND IT TO THE SUPPLIED STRING
;	COPY5	TO COPY THE OUTPUT OF CVT36 OR CVT72 INTO A
;		BYTE STREAM
;	COPYASC	TO COPY 7-BIT ASCII DATA INTO A BYTE STREAM.
;-
;	COMPBS	TO COMPARE A BYTE ARRAY TO A STRING
.ENTRY	CVT36,^M<R2,R3,R4>
;+
;	ENTRY POINT: CVT36
;	CALLING SEQUENCE:
;	CALL CVT36(A,B,C)
;	A -- A BYTE ARRAY CONTAINING THE DATA TO BE CONVERTED
;	B -- A 2 BY C LONGWORD ARRAY TO RECIEVE THE DATA.
;	C -- THE NUMBER OF WORDS TO CONVERT
;-
	MOVL	4(AP),R3		;GET THE INPUT ADDRESS
	MOVL	8(AP),R4		;GET THE OUTPUT ADDRESS
	MOVL	@12(AP),R2		;AND THE COUNT
CVTL:
	INSV	(R3),#28,#8,(R4)	;NOW MOVE THINGS AROUND
	INSV	1(R3),#20,#8,(R4)	;LIKE SO...
	INSV	2(R3),#12,#8,(R4)
	INSV	3(R3),#4,#8,(R4)
	INSV	4(R3),#0,#4,(R4)
	ADDL2	#5,R3			;MOVE ALONG TO NEXT 36-BIT WORD
	ADDL2	#8,R4			;AND TO NEXT QUADWORD
	SOBGTR	R2,CVTL
	RET
.ENTRY	CVT72,^M<R2,R3,R4>
;+
;	ENTRY POINT: CVT72
;	CALLING SEQUENCE:
;	CALL CVT72(A,B,C)
;	A -- A BYTE ARRAY CONTAINING THE DATA TO BE CONVERTED
;	B -- A 2 BY C LONGWORD ARRAY TO RECIEVE THE DATA.
;	C -- THE NUMBER OF WORDS TO CONVERT
;-
	MOVL	4(AP),R3		;GET THE INPUT ADDRESS
	MOVL	8(AP),R4		;GET THE OUTPUT ADDRESS
	MOVL	@12(AP),R2		;AND THE COUNT
	ASHL	#-1,R2,R2
CVTL2:
	INSV	(R3),#28,#8,(R4)	;NOW MOVE THINGS AROUND
	INSV	1(R3),#20,#8,(R4)	;LIKE SO...
	INSV	2(R3),#12,#8,(R4)
	INSV	3(R3),#4,#8,(R4)
	EXTZV	#4,#4,4(R3),R0
	INSV	R0,#0,#4,(R4)
	INSV	4(R3),#32,#4,8(R4)
	INSV	5(R3),#24,#8,8(R4)
	INSV	6(R3),#16,#8,8(R4)
	INSV	7(R3),#8,#8,8(R4)
	INSV	8(R3),#0,#8,8(R4)
	ADDL2	#9,R3			;MOVE ALONG TO NEXT 72-BIT WORD
	ADDL2	#16,R4			;AND TO NEXT PAIR OF QUADWORDS
	SOBGTR	R2,CVTL2
	RET
.ENTRY CVTASZ,^M<R2,R3>
;+
;	ENTRY POINT: CVTASZ
;	CALLING SEQUENCE:
;	CALL CVTASZ(DAT,LINE,LINEL)
;	DAT   -- IS THE START OF THE 2 BY N LONGWORD ARRAY
;	THAT CONTAINS THE ASCIZ STRING
;	LINE  -- A BYTE ARRAY TO RECIEVE THE DATA
;	LINEL -- THE INDEX TO THE BYTE ARRAY
;-
	DAT = 4
	LINE = 8
	LINEL = 12
;
	MOVAL	@DAT(AP),R0
	MOVAL	@LINE(AP),R1
	ADDL2	@LINEL(AP),R1
	DECL	R1
CAL:
	EXTZV	#29,#7,(R0),R2
	TSTL	R2
	BEQL	CAE
	MOVB	R2,(R1)+
	INCL	@LINEL(AP)
	EXTZV	#22,#7,(R0),R2
	TSTL	R2
	BEQL	CAE
	MOVB	R2,(R1)+
	INCL	@LINEL(AP)
	EXTZV	#15,#7,(R0),R2
	TSTL	R2
	BEQL	CAE
	MOVB	R2,(R1)+
	INCL	@LINEL(AP)
	EXTZV	#8,#7,(R0),R2
	TSTL	R2
	BEQL	CAE
	MOVB	R2,(R1)+
	INCL	@LINEL(AP)
	EXTZV	#1,#7,(R0),R2
	TSTL	R2
	BEQL	CAE
	MOVB	R2,(R1)+
	INCL	@LINEL(AP)
	ADDL2	#8,R0
	BRB	CAL
;
CAE:
	RET
.ENTRY CVTHALF,0
;+
;	ENTRY POINT: CVTHALF
;	CALLING SEQUENCE:
;	CALL CVTHALF(DAT,RH,LH)
;	DAT IS THE DATA TO BE CONVERTED
;	RH IS THE RIGHT HALF (LOW ORDER) 18 BITS OF DAT
;	LH IS THE LEFT HALF (HIGH ORDER) 18 BITS OF DAT
;-
	DAT = 4
	RH = 8
	LH = 12
;
	MOVAL	@DAT(AP),R0
	EXTZV	#0,#18,(R0),R1
	MOVL	R1,@RH(AP)
	EXTZV	#18,#18,(R0),R1
	MOVL	R1,@LH(AP)
	RET
.ENTRY	CVTSIX,0
;+
;	ENTRY POINT: CVTSIX
;	CALLING SEQUENCE:
;	CALL CVTSIX(DAT,LINE,LINEL)
;	DAT    -- THE QUADWORD CONTAINING THE SIXBIT DATA
;	LINE   -- THE LINE TO APPEND THE STRING TO
;	LINEL  -- THE CURRENT LENGTH OF THE LINE
;-
	MOVAL	@LINE(AP),R0
	ADDL2	@LINEL(AP),R0
	DECL	R0
;
	EXTZV	#30,#6,@DAT(AP),R1
	ADDL2	#32,R1
	MOVB	R1,(R0)+
	EXTZV	#24,#6,@DAT(AP),R1
	ADDL2	#32,R1
	MOVB	R1,(R0)+
	EXTZV	#18,#6,@DAT(AP),R1
	ADDL2	#32,R1
	MOVB	R1,(R0)+
	EXTZV	#12,#6,@DAT(AP),R1
	ADDL2	#32,R1
	MOVB	R1,(R0)+
	EXTZV	#6,#6,@DAT(AP),R1
	ADDL2	#32,R1
	MOVB	R1,(R0)+
	EXTZV	#0,#6,@DAT(AP),R1
	ADDL2	#32,R1
	MOVB	R1,(R0)+
	ADDL2	#6,@LINEL(AP)
	RET
.ENTRY	COPY5,^M<R2,R3,R4>
;+
;	ENTRY POINT: COPY5
;	CALLING SEQUENCE:
;	CALL COPY5(A,B,C)
;	A -- A 2 BY C LONGWORD ARRAY WITH THE DATA.
;	B -- A BYTE ARRAY TO RECIEVE THE DATA
;	C -- THE NUMBER OF WORDS TO CONVERT
;-
	A = 4
	B = 8
	C = 12
;
	MOVL	@C(AP),R0
	MOVAL	@A(AP),R1
	MOVAL	@B(AP),R2
C5L:
	MOVL	(R1),(R2)+
	MOVB	4(R1),(R2)+
	ADDL2	#8,R1
	SOBGTR	R0,C5L
	RET
.ENTRY COPYASC,^M<R2,R3>
;+
;	ENTRY POINT: COPYASC
;	CALLING SEQUENCE:
;	CALL CVTASZ(DAT,LINE,NUM)
;	DAT   -- IS THE START OF THE 2 BY N LONGWORD ARRAY
;	THAT CONTAINS THE ASCIZ STRING
;	LINE  -- A BYTE ARRAY TO RECIEVE THE DATA
;	NUM -- THE NUMBER OF 5 BYTE WORDS TO PROCESS
;-
	DAT = 4
	LINE = 8
	NUM = 12
;
	MOVAL	@DAT(AP),R0
	MOVAL	@LINE(AP),R1
	MOVL	@NUM(AP),R2
CAC:
	EXTZV	#29,#7,(R0),R3
	MOVB	R3,(R1)+
	EXTZV	#22,#7,(R0),R3
	MOVB	R3,(R1)+
	EXTZV	#15,#7,(R0),R3
	MOVB	R3,(R1)+
	EXTZV	#8,#7,(R0),R3
	MOVB	R3,(R1)+
	EXTZV	#1,#7,(R0),R3
	MOVB	R3,(R1)+
	ADDL2	#8,R0
	SOBGTR	R2,CAC
	RET
.ENTRY	COMPBS,^M<R2,R3,R4>
;+
;	ENTRY POINT: COMPBS
;	CALLING SEQUENCE:
;	CALL COMPBS(N,BYTES,STRING)
;	N       -- NUMBER OF BYTES TO COMPARE
;	BYTES   -- BYTE ARRAY TO COMPARE
;	STRING  -- CHARACTER STRING TO COMPARE
;-
	MOVAL	@12(AP),R1
	CMPC3	@4(AP),@8(AP),@4(R1)
	BNEQ	NOTEQ
	MOVL	#-1,R0
	RET
NOTEQ:	MOVL	#0,R0
	RET
;
	.END
	SUBROUTINE CVTDATE(DATE,LINE,LINEL)
C
C	TO CONVERT UNIVERSAL DATE/TIME FOR THE DEC-10
C	INTO A PRINTABLE STRING.  THE UNIVERSAL DATE
C	TIME IS:
C	LEFT HALF -- NUMBER OF DAYS FROM 17-NOV-1858
C	RIGHT HALF -- FRACTIONAL DAY
C
	INTEGER DATE(2)
	BYTE LINE(256)
	INTEGER LINEL
	INTEGER DAYS,FRAC
	INTEGER IDAY,IDAYS,YEAR,HOUR,MIN,ISECS,LEAP,QUADS
	CHARACTER MONTH*3
	REAL SECS
	BYTE CDATE(20)
	CHARACTER*20 DATEC
	EQUIVALENCE (DATEC,CDATE)
C
	CALL CVTHALF(DATE,FRAC,DAYS)
	DAYS = DAYS+321
	QUADS = DAYS/1461
	DAYS = DAYS-QUADS*1461
	YEAR = QUADS*4
	LEAP = 0
	IF (DAYS.GT.1095) THEN
	 YEAR = YEAR+1861
	 DAYS = DAYS-1096
	ELSE IF (DAYS.GT.730) THEN
	 YEAR = YEAR+1860
	 DAYS = DAYS-730
	 LEAP = 1
	ELSE IF (DAYS.GT.364) THEN
	 YEAR = YEAR+1859
	 DAYS = DAYS-365
	ELSE
	 YEAR = YEAR+1858
	ENDIF
	IDAYS = DAYS+1
	IF (LEAP+152.GT.IDAYS) THEN
	 IF (LEAP+60.GT.IDAYS) THEN
	  IF (32.GT.IDAYS) THEN
	   MONTH = 'JAN'
	   IDAY = IDAYS
	  ELSE
	   MONTH = 'FEB'
	   IDAY = IDAYS-31
	  ENDIF
	 ELSE IF (LEAP+91.GT.IDAYS) THEN
	  MONTH = 'MAR'
	  IDAY = IDAYS-(59+LEAP)
	 ELSE IF (LEAP+121.GT.IDAYS) THEN
	  MONTH = 'APR'
	  IDAY = IDAYS-(90+LEAP)
	 ELSE
	  MONTH = 'MAY'
	  IDAY = IDAYS-(120+LEAP)
	 ENDIF
	ELSE
	 IF (LEAP+244.GT.IDAYS) THEN
	  IF (LEAP+182.GT.IDAYS) THEN
	   MONTH = 'JUN'
	   IDAY = IDAYS-(151+LEAP)
	  ELSE IF (LEAP+213.GT.IDAYS) THEN
	   MONTH = 'JUL'
	   IDAY = IDAYS-(181+LEAP)
	  ELSE
	   MONTH = 'AUG'
	   IDAY = IDAYS-(212+LEAP)
	  ENDIF
	 ELSE IF (LEAP+305.GT.IDAYS) THEN
	  IF (LEAP+274.GT.IDAYS) THEN
	   MONTH = 'SEP'
	   IDAY = IDAYS-(243+LEAP)
	  ELSE
	   MONTH = 'OCT'
	   IDAY = IDAYS-(273+LEAP)
	  ENDIF
	 ELSE IF (LEAP+335.GT.IDAYS) THEN
	  MONTH = 'NOV'
	  IDAY = IDAYS-(304+LEAP)
	 ELSE
	  MONTH = 'DEC'
	  IDAY = IDAYS-(334+LEAP)
	 ENDIF
	ENDIF
	SECS = (FRAC*27*25)/(2**11)
	HOUR = IFIX(SECS)/(60*60)
	MIN = MOD(IFIX(SECS)/60,60)
	ISECS = MOD(IFIX(SECS),60)
	WRITE(DATEC,10) IDAY,MONTH,YEAR,HOUR,MIN,ISECS
10	FORMAT(I2,'-',A3,'-',I4,' ',I2.2,':',I2.2,':',I2.2)
	DO I=1,20,1
	LINE(LINEL+I-1) = CDATE(I)
	ENDDO
	LINEL = LINEL+20
	RETURN
	END
	INTEGER*4 FUNCTION EOT_COMMAND(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the EOT command action routine.  It is called when
C	the user wants to move the magtape to the end of tape.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	INTEGER*2 IOSB(4)
	INTEGER*4 STATUS
	EXTERNAL IO$_SKIPFILE,SS$_VOLINV
	EXTERNAL DUMPER_NTDSEL
	INTEGER*4 SYS$QIOW
	LOGICAL FLAG
C
	IF (.NOT.GOTDEV) THEN
	 CALL ERRORM(%LOC(DUMPER_NTDSEL))
	 EOT_COMMAND = 1
	 RETURN
	ENDIF
C
	FLAG = .TRUE.
	DO WHILE (FLAG)
	 CALL MTSKPF(CHANNEL,10000,STATUS)
	 IF (.NOT.STATUS) FLAG = .FALSE.
	 IF (STATUS.EQ.%LOC(SS$_VOLINV)) THEN
	 WRITE(*,20) DEVNAME(1:DEVLEN)
20	FORMAT(' The magtape must be mounted before this program can',/,
	1 ' access it.  Exit and type "$ MOUNT/FOR ',A,'" before',/,
	2 ' trying again.')
	 ENDIF
	ENDDO
	EOT_COMMAND = 1
	RETURN
	END
	INTEGER*4 FUNCTION GO_COMMAND(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the GO command action routine.  It is called when
C	the save set is to be processed.  The value of GOVALUE is
C	the number of save sets to process.  Default value is one.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	EXTERNAL SS$_ENDOFFILE,SS$_ENDOFVOLUME
	EXTERNAL DUMPER_STDBLK,DUMPER_CCCBLK
	EXTERNAL DUMPER_NTDSEL,DUMPER_UNKBLK
C
C	Local data storage:
C	BUFFER -- The input buffer from the magtape
C	BUFLEN -- The buffer length (a constant)
C	ACTLEN -- The actual number of bytes read in by a read
C	STATUS -- The status of the I/O transfer
C	HEADER -- The reformatted DEC-10/20 information
C
	INTEGER*4 BUFLEN
	PARAMETER (BUFLEN=2720)
	BYTE BUFFER(BUFLEN)
	INTEGER*4 ACTLEN,STATUS
	INTEGER*4 HEADER(2,32)
C
	IF (.NOT.GOTDEV) THEN
	 CALL ERRORM(%LOC(DUMPER_NTDSEL))
	 GO_COMMAND = 1
	 RETURN
	ENDIF
C
C	Initialize the validation tables
C
	DO I=1,RESMAX
	 VALIDD(I) = .FALSE.
	 VALIDF(I) = .FALSE.
	ENDDO
	CDIRLEN = 0
C
	DO WHILE (GOVALUE.GT.0)
	 CALL MTREAD(CHANNEL,BUFFER,BUFLEN,ACTLEN,STATUS)
	 IF (.NOT.STATUS) THEN
	  IF (STATUS.EQ.%LOC(SS$_ENDOFFILE)) THEN
	   IF (EOFSEEN) THEN
	    CALL ERRORM(%LOC(SS$_ENDOFVOLUME))
	    GOVALUE = 0
	   ELSE
	    GOVALUE = GOVALUE-1
	    EOFSEEN = .TRUE.
	   ENDIF
	  ELSE
	   GOVALUE = 0
	  ENDIF
	 ELSE
	  EOFSEEN = .FALSE.
	  IF (ACTLEN.EQ.2720) THEN
	   IF (BLKTYP.NE.STDBLK) THEN
	    CALL ERRORM(%LOC(DUMPER_STDBLK))
	    BLKTYP = STDBLK
	   ENDIF
	   CALL CVT36(BUFFER,HEADER,32)
	   CALL PROCESS(BUFFER,HEADER)
	  ELSE IF (ACTLEN.EQ.2448) THEN
	   IF (BLKTYP.NE.CCCBLK) THEN
	    CALL ERRORM(%LOC(DUMPER_CCCBLK))
	    BLKTYP = CCCBLK
	   ENDIF
	   CALL CVT72(BUFFER,HEADER,32)
	   CALL PROCESS(BUFFER,HEADER)
	  ELSE
	   CALL ERRORM(%LOC(DUMPER_UNKBLK),ACTLEN)
	   CALL MTSKPF(CHANNEL,1,STATUS)
	   GOVALUE = GOVALUE-1
	   EOFSEEN = .TRUE.
	  ENDIF
	 ENDIF
	ENDDO
	GO_COMMAND = 1
	RETURN
	END
	INTEGER*4 FUNCTION HELP_COMMAND(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the HELP command action routine.  It is called when
C	the user wants to get HELP.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	CHARACTER*1 ANS
C
	WRITE(*,10)
10	FORMAT(
	1 1X,'Magtape Handling Commands:',/,
	1 7X,'USE drive -- Use the magtape drive "drive"',/,
	1 7X,'EOT -- Skip to the end of tape',/,
	1 7X,'REWIND -- Rewind the magtape',/,
	1 7X,'SKIP n -- Skip ''n'' save sets (negative means reverse)',/,
	2 1X,'File Processing Commands:',/,
	2 7X,'GO n -- Process ''n'' save sets',/,
	2 7X,'RESET -- Reset the list of RESTORE commands',/,
	2 7X,'RESTORE vaxdir=files -- Restore the files on tape to the',/,
	2 7X,'VAX directory specified (may be repeated)',/,
	2 7X,'WHAT -- Lists the RESTORE commands that are active',/,
	2 7X,'Type Control-C to abort the processing of a GO command',/,
	2 1X,'Type RETURN to get the remainder of the HELP')
	READ(*,15) ANS
15	FORMAT(A)
	WRITE(*,20)
20	FORMAT(
	3 1X,'File Listing Commands:',/,
	3 7X,'FILES -- The files restored will be listed on the user''s',
	3 ' terminal',/,
	3 7X,'LIST -- Allows the user to select a tape directory listing',/,
	3 7X,'SILENT -- Reverses the action of the FILES command',/,
	4 1X,'Mode Selection Commands:',/,
	4 7X,'ASCII -- Convert files to VAX ASCII format',/,
	4 7X,'BINARY -- Convert files to VAX BINARY format',/,
	4 7X,'NONE -- Set output record attribute to NONE',/,
	4 7X,'CR -- Set output record attribute to Carriage Return',/,
	4 7X,'FORTRAN -- Set output record attribute to FORTRAN mode',/,
	5 1X,'Miscellaneous Commands:',/,
	5 7X,'HELP -- Print this message',/,
	5 7X,'STOP, EXIT, or QUIT -- Leave the program',/,
	5 1X,'All commands may be typed in lower or upper case',
	5 ' letters and',/,1x,'may be abbreviated to the minimum',
	5 ' unique number of letters.',/,1x,'For example: REST',
	5 ' can abbreviate RESTORE.')
	HELP_COMMAND = 1
	RETURN
	END
	INTEGER*4 FUNCTION REW_COMMAND(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the REWIND command action routine.  It is called
C	when the user wants to rewind the magtape back to the
C	start of the tape.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INTEGER*4 SYS$QIOW
	INTEGER*4 STATUS
	INTEGER*2 IOSB(4)
	EXTERNAL IO$_REWIND
	EXTERNAL DUMPER_NTDSEL
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	IF (.NOT.GOTDEV) THEN
	 CALL ERRORM(%LOC(DUMPER_NTDSEL))
	 EOT_COMMAND = 1
	 RETURN
	ENDIF
C
	STATUS = SYS$QIOW(,%VAL(CHANNEL),IO$_REWIND,IOSB,,
	1 ,,,,,,)
	IF (.NOT.STATUS) CALL ERRORM(STATUS)
	REW_COMMAND = 1
	RETURN
	END
	INTEGER*4 FUNCTION SKIP_COMMAND(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the SKIP command action routine.  It is called when
C	the user wants to skip forward or backward save sets.
C	If the skip value supplied is negative, the program will
C	skip back save sets.  If positive, the program will skip
C	forward save sets.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	INTEGER*2 IOSB(4)
	INTEGER*4 STATUS
	EXTERNAL IO$_SKIPFILE,SS$_VOLINV
	EXTERNAL DUMPER_NTDSEL
	LOGICAL FLAG
	INTEGER*4 SKIPIT,COUNT
C
	IF (.NOT.GOTDEV) THEN
	 CALL ERRORM(%LOC(DUMPER_NTDSEL))
	 SKIP_COMMAND = 1
	 RETURN
	ENDIF
C
C	Skip in the direction desired... subtract one from
C	0 and less skips.
C
	IF (SIGN.EQ.ICHAR('-')) THEN
	 COUNT = -SKIPNO
	ELSE
	 COUNT = SKIPNO
	ENDIF
	CALL MTSKPF(CHANNEL,COUNT,STATUS)
	IF (STATUS.EQ.%LOC(SS$_VOLINV)) THEN
	WRITE(*,20) DEVNAME(1:DEVLEN)
20	FORMAT(' The magtape must be mounted before this program can',/,
	1 ' access it.  Stop and type "$ MOUNT/FOR ',A,'" before',/,
	2 ' trying again.')
	ENDIF
C
	SKIP_COMMAND = 1
	RETURN
	END
	INTEGER*4 FUNCTION USE_COMMAND(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the USE command action routine.  It is called when
C	the device is to be selected.  The common variable DEVNAME
C	has the characters in the name, and the common variable
C	DEVLEN is the number of characters in that name.  The
C	channel assignment made by SYS$ASSIGN will be put into
C	the common variable CHANNEL.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	INTEGER*4 SYS$ASSIGN,SYS$DASSGN
	INTEGER*4 STATUS
	EXTERNAL DUMPER_ERRDPD,DUMPER_ERRATD
C
	IF (GOTDEV) THEN
	 STATUS = SYS$DASSGN(%VAL(CHANNEL))
	 IF (.NOT.STATUS) THEN
	  CALL ERRORM(%LOC(DUMPER_ERRDPD))
	  CALL ERRORM(STATUS)
	 ENDIF
	ENDIF
C
	STATUS = SYS$ASSIGN(DEVNAME(1:DEVLEN),CHANNEL,,)
	IF (.NOT.STATUS) THEN
	 CALL ERRORM(%LOC(DUMPER_ERRATD),DEVNAME(1:DEVLEN))
	 CALL ERRORM(STATUS)
	 GOTDEV = .FALSE.
	ELSE
	 GOTDEV = .TRUE.
	ENDIF
	USE_COMMAND = 1
	RETURN
	END
	INTEGER*4 FUNCTION USE_NAME(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the GO command action routine.  It is called when
C	when the device name has been entered.  The name is copied
C	from TOKEN into DEVNAME, and TLEN is copied into DEVLEN.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INTEGER*4 I
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	DEVLEN = MIN(64,%LOC(TLEN))
	DO I=1,DEVLEN,1
	 DEVNAME(I:I) = CHAR(TOKEN(I))
	ENDDO
C
	USE_NAME = 1
	RETURN
	END
C	Start of include file DMPCOM.FOR
C
C	Common block for DUMPER program
C
C	DMPCOM holds the integer and logical common variables
C	SIGN    -- Sign of value (if any)
C	SKIPNO  -- Number of save sets to skip
C	DONE    -- If .TRUE., leave the program
C	GOVALUE -- Number of save sets to process
C	CHANNEL -- Channel number of the magtape
C	DEVLEN  -- Length of the device name
C	GOTDEV  -- If .TRUE., a device has been assigned
C	BLKTYP -- The type of data block on the tape.  It can have
C	the values NONE, STDBLK, and CCCBLK for undefined, standard,
C	and CCC stupid TU70 format.
C	EOFSEEN -- Flag indicating if the previous operation
C	caused the end of file to be found
C	FILEOK  -- Flag indicating if an output file is open
C	and that the data is to be copied to the output file.
C	IOMODE -- This indicates the type of input conversion
C	that is to be done.  If equal to BINARY, the data is
C	copied to the output without conversion into 5 bytes
C	per DEC 10/20 word.  If equal to ASCII, the data is
C	copied to the output with 7 bit bytes converted to
C	8 bit bytes.
C	PRMODE -- Printing mode flag.  If equal to SILENT, then
C	no file names are echoed on the terminal.  If equal to
C	FILES, then the file names are printed on the terminal
C	as they are copied.
C	ORMODE -- Output Record Mode.  If equal to NONE, then
C	no carriage control attributes are set on the output
C	file.  If equal to CR, then the Carriage Return attribute
C	is set for the output file.  If equal to FORTRAN, then
C	the FORTRAN attribute is set for the output file.
C	LIST   -- Listing flag.  If .TRUE., then a file is opened
C	on channel 2 to recieve the listing of the file data.
C
	INTEGER*4 SIGN,SKIPNO
	LOGICAL*4 DONE,GOTDEV
	INTEGER*4 GOVALUE,CHANNEL
	INTEGER*2 BLKTYP,NONE,STDBLK,CCCBLK
	PARAMETER (NONE=0,STDBLK=1,CCCBLK=2)
	LOGICAL*4 EOFSEEN
	LOGICAL*4 FILEOK
	INTEGER*2 IOMODE,BINARY,ASCII
	PARAMETER (ASCII=0,BINARY=1)
	INTEGER*2 PRMODE,SILENT,FILES
	PARAMETER (SILENT=0,FILES=1)
	INTEGER*2 ORMODE,CR,FORTRAN
	PARAMETER (CR=1,FORTRAN=2)
	LOGICAL*4 LIST
C
	COMMON /DMPCOM/SIGN,SKIPNO,DONE,GOVALUE,CHANNEL,
	1 DEVLEN,GOTDEV,BLKTYP,EOFSEEN,FILEOK,IOMODE,
	2 PRMODE,ORMODE,LIST
C
C	DMPCHR common holds the character variables for dumper
C	DEVNAME -- Name of the magtape device
C
	CHARACTER*64 DEVNAME
	COMMON /DMPCHR/DEVNAME
C
C	End of include file DMPCOM.FOR
C	BEGIN OF DMPHEAD.FOR INCLUDE FILE
C	CONTAINS EQUIVALENCES USED FOR DUMPER/BACKUP FORMAT HEADERS
C
C	FOR ALL HEADER BLOCKS:
C	G$TYPE -- THE TYPE OF HEADER
C	1=LABEL RECORD, 2=START OF SAVE SET, 3=END OF SAVE SET,
C	4=FILE RECORD, 5=UFD RECORD, 6=END OF VOLUME, 7=COMMENT
C	G$SEQ  -- A SEQUENCE NUMBER UNIQUE FOR THAT RECORD.
C	THIS NUMBER IS INCREMENTED FOR EACH RECORD WRITTEN.
C	G$RTNM -- THE RELATIVE TAPE NUMBER FOR THIS TAPE
C	WITHIN A SAVE SET.
C	G$FLAG -- VARIOUS BITS THAT DEPEND UPON THE TYPE OF
C	RECORD INVOLVED.  CURRENTLY, FOR ALL BUT DATA RECORDS,
C	THIS WORD IS ZERO.  FOR FILE DATA RECORDS, THE FOLLOWING
C	ASSIGNMENTS HAVE BEEN MADE.
C	 GF$EOF -- (DEC-10 BIT 0) THE FLAG SET IF THIS IS THE
C	 LAST TAPE BLOCK FOR THIS DISK FILE.  BOTH THIS AND
C	 GF$SOF CAN BE SET FOR SHORT ONE BLOCK FILES.
C	 GF$RPT -- (DEC-10 BIT 1) THIS FLAG IS SET IF THIS
C	 BLOCK REPEATS THE PREVIOUS ONE.  THIS IS USED IF A
C	 TAPE ERROR OCCURRED FOR THE PREVIOUS RECORD.
C	 GF$NCH -- (DEC-10 BIT 2) THIS IS SET IF A CHECKSUM
C	 FOR THE BLOCK HAS NOT BEEN COMPUTED.
C	 GF$SOF -- (DEC-10 BIT 3) THIS IS SET IF THIS IS THE
C	 FIRST TAPE BLOCK FOR A FILE.
C	G$CHK  -- CONTAINS THE CHECKSUM FOR THE TAPE RECORD
C	UNLESS GF$NCH IS SET.
C	G$SIZ  -- THE NUMBER OF FILE DATA WORDS IN THIS BLOCK.
C	G$LND  -- THE NUMBER OF WORDS TO SKIP BEFORE FILE DATA
C	BEGINS.
C
	INTEGER G$TYPE,G$SEQ,G$RTNM,G$FLAG,G$CHK,G$SIZ,G$LND
	PARAMETER (G$TYPE=1,G$SEQ=2,G$RTNM=3,G$FLAG=4,G$CHK=5,
	1 G$SIZ=6,G$LND=7)
	INTEGER GF$EOF,GF$RPT,GF$NCH,GF$SOF
	PARAMETER (GF$EOF=8,GF$RPT=4,GF$NCH=2,GF$SOF=1)
C
C	IN LABEL RECORDS (G$TYPE WORD IS 1):
C	L$RLNM -- SIXBIT WORD CONTAINING THE REEL NAME
C	L$DATE -- DATE/TIME OF THE LABELLING IN DEC-10
C	UNIVERSAL FORMAT (LEFT HALF IS NUMBER OF DAYS
C	SINCE 17-NOV-1859, AND RIGHT HALF IS FRACTIONS
C	OF A DAY)
C	L$DSTR -- DATE/TIME BEFORE WHICH THE TAPE CANNOT BE
C	SCRATCHED.  BEFORE THIS TIME, ONLY APPENDS CAN BE DONE
C	L$DEV  -- SIXBIT WORD DEFINING THE PHYSICAL DEVICE
C	NAME OF THE MAGTAPE DRIVE USED TO WRITE THE LABEL
C	L$FMT  -- A NUMBER INDICATING THE BACKUP FORMAT
C	L$BVER -- THE BACKUP VERSION USED TO WRITE THE LABEL
C
	INTEGER L$RLNM,L$DATE,L$DSTR,L$DEV,L$FMT,L$BVER
	PARAMETER (L$RLNM=13,L$DATE=14,L$DSTR=15,L$DEV=16,L$FMT=17,
	1 L$BVER=18)
C
C	FOR START AND END OF SAVE SET RECORDS:
C	S$SVER -- SYSTEM VERSION NUMBER
C	S$FMT  -- BACKUP FORMAT NUMBER
C	S$BVER -- BACKUP VERSION NUMBER
C	S$DATE -- DATE/TIME OF WRITING THE DATA IN UNIVERSAL
C	TIME FORMAT (SEE L$DATE DESCRIPTION)
C	S$DEV  -- PHYSICAL DEVICE NAME OF THE MAGTAPE DRIVE
C	USED TO WRITE THE DATA (IN SIXBIT)
C	S$APR  -- THE SERIAL NUMBER OF THE CPU WRITING THE DATA
C
	INTEGER S$SVER,S$FMT,S$BVER,S$DATE,S$DEV,S$APR
	PARAMETER (S$SVER=17,S$FMT=14,S$BVER=15,S$DATE=13,S$DEV=19,
	1 S$APR=18)
C
C	FOR UFD RECORDS:
C	D$STR  -- SIXBIT WORD CONTAINING THE STRUCTURE NAME
C	D$LVL  -- NUMBER FOR THE NESTING LEVEL OF THE
C	DIRECTORY.  0=UFD, 1-5=SFD LEVEL
C	D$PCHK -- CHECKSUM OF THE O$NAME FULL PATH NAME BLOCK
C
	INTEGER D$STR,D$LVL,D$PCHK
	PARAMETER (D$STR=13,D$LVL=14,D$PCHK=15)
C
C	FOR FILE DATA RECORDS:
C	F$PCHK -- CHECKSUM OF THE FULL PATHNAME BLOCK (O$NAME)
C	F$RDW  -- RELATIVE DATA WORD OF THE FIRST WORD ON TAPE
C	FOR THE FILE
C	F$PTH  -- A TWELVE WORD BLOCK USED TO STORE INFORMATION
C	SUITABLE TO RESTORE THE FILE.  IT HOLDS ENOUGH ROOM FOR
C	A TOPS-10 FILE IN A UFD OF UP TO 5 CHARACTERS EACH IN
C	THE PPN.  STORED AS 7 BIT BYTES AS: DATA TYPE, LENGTH IN
C	WORDS, ASCII DATA.  DATA TYPES ARE:  1=DEVICE, 2=FILENAME,
C	3=EXTENSION, 32+N=NTH DIRECTORY ENTRY.
C
	INTEGER F$PCHK,F$RDW,F$PTH
	PARAMETER (F$PCHK=13,F$RDW=14,F$PTH=15)
C
C	END OF DMPHEAD.FOR INCLUDE FILE
	.TITLE		DMPMESS DUMPER error and information messages
	.FACILITY	DUMPER,2049
	.SEVERITY	INFORMATIONAL
	STDBLK		<Using standard BACKUP block size>
	CCCBLK		<Using CCC TU70 BACKUP block size>
	NTDSEL		<No tape drive has been selected by the USE command>
	UNKBLK/FAO=1	<Unknown block length !UL, skipping this save set>
	ERRDPD		<Error deassigning previous tape drive>
	ERRATD/FAO=1	<Error assigning tape drive !AS>
	RESMAX		<Maximum number of restore commands reached>
	RESIGN		<Program limit exceeded, restore command ignored>
	RESSFD		<Tape name has too many SFD's>
	RESDNM		<Directory name is too long>
	RESFNM		<File name is too long>
	ABLIST		<Error in filename, listing disabled>
	NOLIST		<No listing will be generated>
	IDFE/FAO=1	<Internal dumper filespec error !/with !AS>
	NOCTLC		<No Control-C interrupt handler created>
	ABORT		<Processing aborted by user, to restart type GO>
	.END
C	START OF DMPREC.FOR INCLUDE FILE
C
C	THIS CONTAINS PARAMETERS FOR DUMPER/BACKUP OVERHEAD
C	REGIONS CONTAINED IN THE DATA PORTION OF RECORDS.
C	THESE REGIONS ARE PRECEEDED BY A WORD CONTAINING
C	A CONTROL WORD OF THE FORM:
C	LEFT HALF = TYPE OF REGION
C	RIGHT HALF = LENGTH OF REGION IN WORDS INCLUDING THIS WORD
C	ALLOWABLE TYPES ARE:
C	O$NAME -- TO GIVE THE FULL PATH IDENTIFICATION OF THE FILE
C	WITHOUT PUNCTUATION.  IT CONSISTS OF SEVERAL SUB-BLOCKS
C	THAT ARE DESCRIBED BELOW.
C	O$FILE -- A BLOCK CONTAINING THE FILE ATTRIBUTES.  IT HAS
C	A FIXED FORMAT THAT IS DESCRIBED BELOW.
C	O$DIRT -- RESERVED FOR DIRECTORY ATTRIBUTES
C	O$SYSN -- THE SYSTEM HEADER LINE IN ASCII FOLLOWED BY A
C	ZERO BYTE.
C	O$SSNM -- THE SAVE SET NAME IN ASCII FOLLOWED BY A ZERO BYTE.
C
	INTEGER O$FILE,O$DIRT,O$SYSN,O$SSNM
	PARAMETER (O$NAME=1,O$FILE=2,O$DIRT=3,O$SYSN=4,O$SSNM=5)
C
C	IN A O$NAME REGION:
C	THE SUB-BLOCKS ARE IN STANDARD ORDER; DEVICE, DIRECTORIES
C	(TOP DOWN), FILE NAME, EXTENSION, VERSION, AND GENERATION.
C	MISSING SUB-BLOCKS CORRESPOND TO PORTIONS OF THE PATH
C	SPECIFICATION THAT ARE OMITTED.  EACH SUB-BLOCK IS OF THE
C	FORM:
C	LEFT HALF  -- TYPE OF SUB-BLOCK
C	RIGHT HALF -- LENGTH OF SUB-BLOCK IN WORDS INCLUDING THIS ONE
C	THE REST OF EACH SUB-BLOCK IS AN ASCIZ (TRAILING ZERO BYTE)
C	STRING WITH NO LEADING OR IMBEDDED ZERO BYTES.
C	N$DEV  -- DEVICE NAME
C	N$NAME -- FILE NAME
C	N$EXT  -- EXTENSION
C	N$VER  -- VERSION
C	N$GEN  -- GENERATION
C	N$UFD  -- USER FILE DIRECTORY
C	N$SFD1 -- SUB-FILE DIRECTORY (LEVEL 1)
C	N$SFD2 THROUGH 5 ARE OTHER SFD'S (LEVEL 2 THROUGH 5)
C
	INTEGER N$DEV,N$NAME,N$EXT,N$VER,N$GEN,N$UFD,N$SFD1,
	1 N$SFD2,N$SFD3,N$SFD4,N$SFD5
	PARAMETER (N$DEV=1,N$NAME=2,N$EXT=3,N$VER=4,N$GEN=5,
	1 N$UFD=32,N$SFD1=33,N$SFD2=34,N$SFD3=35,N$SFD4=36,N$SFD5=37)
C
C	FOR FILE ATTRIBUTE BLOCKS:
C	THIS IS A FIXED REGION WITH THE FOLLOWING OFFSETS:
C	A$FHLN -- LENGTH IN WORDS OF THE HEADER
C	A$FLGS -- RESERVED FOR FLAGS
C	A$WRIT -- DATE/TIME OF LAST WRITE
C	A$ALLS -- ALLOCATED SIZE IN WORDS
C	A$MODE -- MODE OF LAST WRITE
C	A$LENG -- LENGTH IN BYTES
C	A$BSIZ -- BYTE SIZE (7 OR 36)
C	A$VERS -- VERSION ID (.JBVER FORMAT)
C	THE DATE/TIME ENTRY IS IN DEC-10 UNIVERSAL FORMAT WITH
C	THE LEFT HALF BEING THE NUMBER OF DAYS SINCE NOV. 17, 1858,
C	AND THE RIGHT HALF BEING THE FRACTION OF THE DAY.
C
	INTEGER A$FHLN,A$FLGS,A$WRIT,A$ALLS,A$MODE,A$LENG,A$BSIZ,A$VERS
	PARAMETER (A$FHLN=1,A$FLGS=2,A$WRIT=3,A$ALLS=4,A$MODE=5,
	1 A$LENG=6,A$BSIZ=7,A$VERS=8)
C
C	END OF DMPREC.FOR INCLUDE FILE
C       Start of include file DMPRES.FOR
C
C       Common block for DUMPER program RESTORE command
C
C       RESMAX   -- Number of restore commands allowed
C       TAPEMAX  -- Number of filespec parts on the tape
C       RESCNT   -- Current index into restore tables
C       VAXDIR   -- Directories to restore to
C       VAXLEN   -- Length of VAXDIR entry
C       TAPENAME -- DEC 10/20 filespec parts in order
C       (1=UFD, 2 to TAPEMAX-2=SFD, TAPEMAX-1=FILE,TAPEMAX=EXT)
C       TAPELEN  -- Length of corresponding TAPENAME entry
C       VALIDF   -- Valid file table.  If .TRUE., then the
C       corresponding name is still valid (so far).
C       VALIDD   -- Valid directory table.  If .TRUE., then
C       the corresponding directory name is still ok.
C       NVDIR    -- If .TRUE., then no directories are valid.
C       CURDIR   -- Current directory name.
C       CDIRLEN  -- Length of current directory name (0 if none).
C	STNAME   -- Selected tape name
C	STEXT    -- Selected extension
C	STNLEN   -- Selected Name Length
C	STELEN   -- Selected Extension Length
C
	INTEGER*4 RESMAX,TAPEMAX,RESCNT,VAXLEN,TAPELEN,TAPECNT
	LOGICAL VALIDF,VALIDD,NVDIR
	INTEGER*4 CDIRLEN,STNLEN,STELEN
	PARAMETER (RESMAX=100,TAPEMAX=8)
	DIMENSION VAXLEN(RESMAX),TAPELEN(TAPEMAX,RESMAX)
	DIMENSION VALIDF(RESMAX),VALIDD(RESMAX)
	COMMON /RESCOM/ RESCNT,TAPECNT,VAXLEN,TAPELEN
	1 ,VALIDF,VALIDD,CDIRLEN,NVDIR,STNLEN,STELEN
C
	CHARACTER*64 VAXDIR(RESMAX)
	CHARACTER*32 TAPENAME(TAPEMAX,RESMAX)
	CHARACTER*256 CURDIR
	CHARACTER*9 STNAME
	CHARACTER*3 STEXT
	COMMON /RESCOMC/ VAXDIR,TAPENAME,CURDIR,STNAME,STEXT
C
C       End of include file DMPCOM.FOR
	.TITLE  DMPSTATE        DUMPER PROGRAM STATE TABLES
	.LIBRARY        'DUMPER'
;+
;       This segment defines the tables required for the
;       LIB$TPARSE finite state parser.  The global variables
;       are:
;       DMPINIT -- The initial state of the parser tables
;       DMPKEY  -- The keyword list of the parser tables
;       VDINIT  -- The initial state of directory tables
;       VDKEY   -- The keyword list of the directory tables
;       VFINIT  -- The initial state of file tables
;       VFKEY   -- The keyword list of the file tables
;-
	DMPCOM
	DMPCHR
;Comma definition...since I had problems with ','
	COMMA = 44
;
	$INIT_STATE     DMPINIT,DMPKEY
;
	$STATE
	$TRAN           'QUIT',STOP
	$TRAN           'EXIT',STOP
	$TRAN           'STOP',STOP
	$TRAN           'REWIND',REWIND
	$TRAN           'EOT',EOT
	$TRAN           'SKIP',SKIP
	$TRAN           'GO',GO
	$TRAN           'HELP',HELP
	$TRAN           'USE',USE
	$TRAN           'RESTORE',RESTORE
	$TRAN           'RESET',RESET
	$TRAN           'WHAT',WHAT
	$TRAN           'ASCII',ASCII
	$TRAN           'BINARY',BINARY
	$TRAN           'SILENT',SILENT
	$TRAN           'FILES',FILES
	$TRAN           'LISTING',LISTING
	$TRAN           'NONE',NONE
	$TRAN           'CR',CR
	$TRAN           'FORTRAN',FORTRAN
	$TRAN           TPA$_EOS,TPA$_EXIT
;+
;       STOP COMMAND
;-
	$STATE          STOP
	$TRAN           TPA$_EOS,TPA$_EXIT,,1,DONE
;+
;       REWIND COMMAND
;-
	$STATE          REWIND
	$TRAN           TPA$_EOS,TPA$_EXIT,REW_COMMAND
;+
;       EOT COMMAND
;-
	$STATE          EOT
	$TRAN           TPA$_EOS,TPA$_EXIT,EOT_COMMAND
;+
;       SKIP COMMAND
;-
	$STATE          SKIP
	$TRAN           TPA$_DECIMAL,SKIP_END,,,SKIPNO
	$TRAN           '-',,,,SIGN
;
	$STATE
	$TRAN           TPA$_DECIMAL,,,,SKIPNO
;
	$STATE          SKIP_END
	$TRAN           TPA$_EOS,TPA$_EXIT,SKIP_COMMAND
;+
;       GO COMMAND
;-
	$STATE          GO
	$TRAN           TPA$_DECIMAL,,,,GOVALUE
	$TRAN           TPA$_LAMBDA,,,1,GOVALUE
;
	$STATE
	$TRAN           TPA$_EOS,TPA$_EXIT,GO_COMMAND
;+
;       HELP COMMAND
;-
	$STATE          HELP
	$TRAN           TPA$_EOS,TPA$_EXIT,HELP_COMMAND
;+
;       USE Command
;-
	$STATE          USE
	$TRAN           TPA$_STRING,,USE_NAME
;
	$STATE
	$TRAN           ':'
	$TRAN           TPA$_EOS,TPA$_EXIT,USE_COMMAND
;
	$STATE
	$TRAN           TPA$_EOS,TPA$_EXIT,USE_COMMAND
;+
;       RESTORE Command
;-
	$STATE          RESTORE
	$TRAN           '[',,RES_VDIR
;VAX directory parsing
	$STATE
	$TRAN           '-',VMIN,RES_VMIN
	$TRAN           TPA$_SYMBOL,,RES_VNAME
	$TRAN           TPA$_LAMBDA
;
	$STATE          VDOT
	$TRAN           '.',,RES_VDOT
	$TRAN           ']',VEQ
;
	$STATE
	$TRAN           TPA$_SYMBOL,VDOT,RES_VNAME
;
	$STATE          VMIN
	$TRAN           '-',VMIN,RES_VMIN
	$TRAN           TPA$_LAMBDA,VDOT
;
;End of VAX directory, start of 10/20 directory
	$STATE          VEQ
	$TRAN           '='
;
	$STATE
	$TRAN           '['
;UFD/SFD processing
	$STATE          TNAM
	$TRAN           TPA$_SYMBOL,,RES_TNAME
	$TRAN           '*',,RES_TSTAR
;
	$STATE
	$TRAN           COMMA,TNAM,RES_TDOT
	$TRAN           '.',TNAM,RES_TDOT
	$TRAN           ']',,RES_TBR
;File name
	$STATE
	$TRAN           TPA$_SYMBOL,,RES_TNAME
	$TRAN           '*',,RES_TSTAR
	$TRAN           '.',EXT,RES_TDOT
;
	$STATE
	$TRAN           '.',,RES_TDOT
	$TRAN           TPA$_EOS,TPA$_EXIT,RES_COMMAND
;Extension
	$STATE          EXT
	$TRAN           TPA$_SYMBOL,,RES_TNAME
	$TRAN           '*',,RES_TSTAR
	$TRAN           TPA$_EOS,TPA$_EXIT,RES_COMMAND
;
	$STATE
	$TRAN           TPA$_EOS,TPA$_EXIT,RES_COMMAND
;+
; RESET Command -- Reset the restore tables
;-
	$STATE          RESET
	$TRAN           TPA$_EOS,TPA$_EXIT,RESET_COMMAND
;+
; WHAT Command -- Print the restore information
;-
	$STATE          WHAT
	$TRAN           TPA$_EOS,TPA$_EXIT,WHAT_COMMAND
;+
; ASCII Command -- normal text mode
;-
	$STATE          ASCII
	$TRAN           TPA$_EOS,TPA$_EXIT,SET_ASCII
;+
; BINARY Command -- read binary files from the tape
;-
	$STATE          BINARY
	$TRAN           TPA$_EOS,TPA$_EXIT,SET_BINARY
;+
; SILENT Command -- do not print any messages
;-
	$STATE          SILENT
	$TRAN           TPA$_EOS,TPA$_EXIT,SET_SILENT
;+
; FILES Command -- print out the names of files processed
;-
	$STATE          FILES
	$TRAN           TPA$_EOS,TPA$_EXIT,SET_FILES
;+
; LISTING Command -- generate a listing of all files on the tape
;-
	$STATE          LISTING
	$TRAN           TPA$_EOS,TPA$_EXIT,SET_LIST
;+
; NONE Command -- no carriage control files
;-
	$STATE          NONE
	$TRAN           TPA$_EOS,TPA$_EXIT,SET_NONE
;+
; CR Command -- carriage control files
;-
	$STATE          CR
	$TRAN           TPA$_EOS,TPA$_EXIT,SET_CR
;+
; FORTRAN Command -- FORTRAN format files
;-
	$STATE          FORTRAN
	$TRAN           TPA$_EOS,TPA$_EXIT,SET_FORT
;
	$END_STATE
	.PAGE
;+
; Restore processing state tables
;-
	$INIT_STATE     VDINIT,VDKEY
;
	$STATE
	$TRAN           TPA$_SYMBOL
	$TRAN           '[',UFD
;
	$STATE
	$TRAN           ':'
;
	$STATE          UFD
	$TRAN           TPA$_SYMBOL,,VAL_DIR
;
	$STATE
	$TRAN           ']',TPA$_EXIT
	$TRAN           '.',UFD
;
	$END_STATE
;
	$INIT_STATE     VFINIT,VFKEY
;
	$STATE
	$TRAN           TPA$_SYMBOL,,VAL_NAME
;
	$STATE
	$TRAN           '.'
;
	$STATE
	$TRAN           TPA$_SYMBOL,,VAL_EXT
	$TRAN           TPA$_LAMBDA
;
	$STATE
	$TRAN           TPA$_LAMBDA,TPA$_EXIT,VAL_OPEN
;
	$END_STATE
;
	.END
	PROGRAM DUMPER
C
C       A program to read files from a DEC-10 BACKUP format
C       magtape or from a DEC-20 DUMPER format magtape.
C
C       COMLINE -- Command line from user
C       COMLEN  -- Length of command line
C       STATUS  -- Status code from I/O routines
C
	IMPLICIT COMPLEX (A-Z)
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	CHARACTER*255 COMLINE
	INTEGER*2 COMLEN
	INTEGER*4 STATUS
C
C       External addresses that are needed
C
	EXTERNAL DMPINIT,DMPKEY
C
C	Goodies for Control-C interrupt handling
C
	INTEGER*4 SYS$ASSIGN,SYS$QIOW,SYS$DASSGN
	EXTERNAL IO$_SETMODE,IO$M_CTRLCAST
	EXTERNAL DUMPER_NOCTLC,DUMPER_ABORT,INTHAND
	INTEGER*4 IOFUNC
C
C	Init for Control-C Interrupt handling
C
	STATUS = SYS$ASSIGN('TT',TERCHAN,,)
	IF (.NOT.STATUS) THEN
	 CALL ERRORM(%LOC(DUMPER_NOCTLC))
	 ABFLAG = .FALSE.
	ELSE
	 ABFLAG = .TRUE.
	ENDIF
	IOFUNC = %LOC(IO$_SETMODE)+%LOC(IO$M_CTRLCAST)
C
C       Now enter the main loop.  Essentially, it inputs
C       a command line, dispatches to the appropriate
C       part of the program that handles the action desired.
C
	DONE = .FALSE.
	BLKTYP = NONE
	EOFSEEN = .TRUE.
	DO WHILE (.NOT.DONE)
	 IF (ABFLAG) THEN
	  STATUS = SYS$QIOW(,%VAL(TERCHAN),%VAL(IOFUNC),,,,
	1 INTHAND,,,,,)
	  IF (.NOT.STATUS) THEN
	   CALL ERRORM(%LOC(DUMPER_NOCTLC))
	   CALL ERRORM(STATUS)
	  ENDIF
	  ABFLAG = .FALSE.
	 ENDIF
	 SIGN = 0
	 GOVALUE = 0
	 CALL LIB$GET_INPUT(COMLINE,'Command:  ',COMLEN)
	 CALL STR$UPCASE(COMLINE(1:COMLEN),COMLINE(1:COMLEN))
	 CALL COMMAND(COMLINE(1:COMLEN),DMPINIT,DMPKEY,STATUS)
	 IF (.NOT.STATUS) WRITE(*,110)
110     FORMAT(' For help, type HELP')
	 IF (ABFLAG) CALL ERRORM(%LOC(DUMPER_ABORT))
	ENDDO
	END
	SUBROUTINE INTHAND
C
C	This will set the flags so that the DUMPER program will come
C	to a stop (a restartable one, by the way...). Normally called
C	as a result of the user typing Control-C.
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	GOVALUE = 0
	ABFLAG = .TRUE.
	RETURN
	END
	BLOCK DATA
C
C       Common block initialization for DUMPER
C
	INCLUDE 'DMPCOM.FOR'
	DATA SIGN,SKIPNO,DONE,GOVALUE,CHANNEL,DEVLEN,GOTDEV
	1 /0,0,.FALSE.,0,0,0,.FALSE./
	DATA EOFSEEN,FILEOK,IOMODE/.FALSE.,.FALSE.,ASCII/
	DATA DEVNAME/' '/
	INCLUDE 'DMPRES.FOR'
	DATA RESCNT/1/
	END
	PROGRAM DUMPERDIR
C
C	THIS PROGRAM TAKES DUMPER/BACKUP SAVE SETS AND
C	PRODUCES A LISTING OF THE FILES AND THEIR ATTRIBUTES
C	FOR THE USER.
C
	CHARACTER*2720 JUNK
	BYTE JHEAD(160),JDATA(2560)
	EQUIVALENCE (JUNK,JHEAD),(JUNK(161:161),JDATA)
C
	INTEGER*4 HEADER(2,32),DAT(2,512)
C
	BYTE LINE(256)
	INTEGER LINEL
	CHARACTER*64 IFILE,OFILE
	INTEGER IFILEL,OFILEL
	INTEGER LND
C
	INCLUDE 'DMPHEAD.FOR/NOLIST'
C
	WRITE(6,10)
10	FORMAT('$Enter name of file:  ')
	READ(5,20) IFILEL,IFILE
20	FORMAT(Q,A)
	OPEN(UNIT=1,NAME=IFILE(1:IFILEL),RECORDSIZE=2720,TYPE='OLD',
	1 READONLY)
	WRITE(6,30)
30	FORMAT('$Enter the output file name:')
	READ(5,20) OFILEL,OFILE
	OPEN(UNIT=2,NAME=OFILE(1:OFILEL),TYPE='NEW',RECORDSIZE=512,
	1 CARRIAGECONTROL='FORTRAN')
C
C	GET A HEADER...
C
35	READ(1,20,END=1000) JUNKL,JUNK
	CALL CVT36(JHEAD,HEADER,32)
	I = HEADER(1,1)
	LND = '3FFFF'X.AND.HEADER(1,G$LND)
	GOTO (100,200,300,400,500,600,700) I
	WRITE(6,40) HEADER(2,1),HEADER(1,1)
40	FORMAT(' HEADER WORD IS ',I,' / ',I)
	GOTO 35
C
100	CONTINUE
	WRITE(2,110)
110	FORMAT(' FOUND A WORTHLESS LABEL RECORD')
	GOTO 35
C
200	CONTINUE
	LINEL = 1
	CALL CVTDATE(HEADER(1,S$DATE),LINE,LINEL)
	WRITE(2,210) (LINE(I),I=1,LINEL-1)
210	FORMAT(' START OF SAVE SET WRITTEN AT ',256(A1,:))
	LINEL = 1
	CALL CVTSIX(HEADER(1,S$DEV),LINE,LINEL)
	WRITE(2,220) HEADER(1,S$SVER),HEADER(1,S$FMT),HEADER(1,S$BVER),
	1 HEADER(1,S$APR),(LINE(I),I=1,LINEL-1)
220	FORMAT(' WITH SYSTEM VERSION ',O12,' BACKUP FORMAT = ',O12,/,
	1 ' BACKUP VERSION ',O12,' USING CPU SERIAL NUMBER ',O12,/,
	2 ' AND MAGTAPE DRIVE ',256(A1,:))
	IF (LND.NE.0) CALL OVERHEAD(2,JDATA,LND)
	GOTO 35
C
300	CONTINUE
	LINEL = 1
	CALL CVTDATE(HEADER(1,S$DATE),LINE,LINEL)
	WRITE(2,310) (LINE(I),I=1,LINEL-1)
310	FORMAT(' END OF SAVE SET WRITTEN AT ',256(A1,:))
	LINEL = 1
	CALL CVTSIX(HEADER(1,S$DEV),LINE,LINEL)
	WRITE(2,320) HEADER(1,S$SVER),HEADER(1,S$FMT),HEADER(1,S$BVER),
	1 HEADER(1,S$APR),(LINE(I),I=1,LINEL-1)
320	FORMAT(' WITH SYSTEM VERSION ',O12,' BACKUP FORMAT = ',O12,/,
	1 ' BACKUP VERSION ',O12,' USING CPU SERIAL NUMBER ',O12,/,
	2 ' AND MAGTAPE DRIVE ',256(A1,:))
	IF (LND.NE.0) CALL OVERHEAD(2,JDATA,LND)
	GOTO 35
C
400	CONTINUE
	IF (LND.NE.0) CALL OVERHEAD(2,JDATA,LND)
	GOTO 35
C
500	CONTINUE
	WRITE(6,510)
510	FORMAT(' UFD RECORD READ')
	GOTO 35
C
600	CONTINUE
	WRITE(6,610)
610	FORMAT(' END OF VOLUME???')
	GOTO 35
C
700	CONTINUE
	WRITE(6,710)
710	FORMAT(' COMMENT?')
	GOTO 35
C
1000	CONTINUE
	CLOSE(UNIT=1)
	CLOSE(UNIT=2)
	END
	.TITLE	ERRORM		Error message reporting tool
;+
;	This routine simplifies the reporting of errors
;	by taking a single argument (the error number) and
;	using $PUTMSG to deliver it to the user.  No checking
;	of any kind is done and the routine is re-entrant.
;-
	.ENTRY	ERRORM,0
;+
;	Allocate the storage on the stack for the message
;	vector.  Since this will be a singularly stupid routine,
;	the message vector will always be 8 bytes (flags=0,
;	arg count=1, and message number as supplied).
;-
	MOVZBL		(AP),R0
	SOBGTR		R0,HAVEARGS		; FAO arguments supplied
	BRB		NOARGS
;
HAVEARGS:
	ASHL		#2,R0,R1
	ADDL2		#12,R1
	SUBL2		R1,SP
	ASHL		#-2,R1,(SP)
	MOVW		#0,2(SP)
	MOVL		@4(AP),4(SP)
	MOVL		R0,8(SP)
	MOVAL		8(AP),R1
	MOVAL		12(SP),R2
FAOL:
	MOVL		(R1)+,(R2)+
	SOBGTR		R0,FAOL
	BRB		PM
;
NOARGS:
	SUBL2		#8,SP
	MOVW		#1,(SP)
	MOVW		#0,2(SP)
	MOVL		@4(AP),4(SP)
PM:
	MOVL		SP,R0
	$PUTMSG_S	(R0),,
	RET
;
	.END
	PROGRAM IBM2VAX
C
C	A FRESH START ON A PROGRAM TO READ EBCDIC LABELLED AND
C	UNLABELLED TAPES.
C
C	MTREC  -- THE RECORD READ IN FROM THE TAPE
C	FILENM -- THE FILENAME OF THE OUTPUT FILE
C	FILELN -- THE LENGTH OF THE FILE NAME
C	TAPE   -- THE DEVICE NAME OF THE MAGTAPE
C	CHAN   -- CHANNEL NUMBER ASSIGNED TO TAPE
C	MTLEN  -- LENGTH OF MAGTAPE DATA READ IN
C	STATUS -- STATUS CODE FROM SYSTEM & INTERNAL ROUTINES
C	VOLREC -- VOLUME ID RECORD
C	HDRREC -- HEADER ID RECORD
C	LBL    -- LABEL FLAG (L=YES, U=NO)
C
	CHARACTER*32767 MTREC
	CHARACTER*64 FILENM
	INTEGER*2 FILELN
	CHARACTER*6 TAPE
	INTEGER*4 CHAN
	INTEGER*4 MTLEN
	INTEGER*4 STATUS
	CHARACTER*80 VOLREC,HDRREC
	CHARACTER*1 LBL
C
C	VOL1 VOLUME LABEL INFORMATION
C	VOLID  -- VOLUME ID (VOL1, BUT OTHERS WILL BE IGNORED)
C	VOLNAM -- VOLUME NAME (NAME OF THE TAPE)
C	OWNER  -- OWNER'S NAME (WHATEVER THAT MIGHT BE)
C	VERSION -- VERSION OF THE TAPE LABELS (1,2, OR 3)
C
	CHARACTER*4 VOLID
	CHARACTER*6 VOLNAM
	CHARACTER*13 OWNER
	CHARACTER*1 VERSION
	EQUIVALENCE (VOLREC(1:1),VOLID),(VOLREC(5:5),VOLNAM)
	EQUIVALENCE (VOLREC(38:38),OWNER),(VOLREC(80:80),VERSION)
C
C	HDR1 FILE HEADER INFORMATION
C	HDRID  -- HEADER ID (HDR1 OR HDR2, OTHERS IGNORED)
C	FILEID -- NAME OF FILE ON TAPE
C	CRDATE -- CREATION DATE ( YYDDD, YY-YEAR, DDD-DAY NUM (1-366)
C
	CHARACTER*4 HDRID
	CHARACTER*17 FILEID
	CHARACTER*6 CRDATE
	EQUIVALENCE (HDRREC(1:1),HDRID),(HDRREC(5:5),FILEID)
	EQUIVALENCE (HDRREC(42:42),CRDATE)
C
C	HDR1 FILE HEADER INFORMATION
C	RECFMT -- RECORD FORMAT (F-FIXED, D-VARIABLE, U-UNDEFINED)
C	BLKSIZ -- BLOCK SIZE, ZERO FILLED
C	RECSIZ -- RECORD SIZE, ZERO FILLED
C	BOL    -- BUFFER OFFSET LENGTH (COMMONLY SKIPS BLOCK SEQ. NO)
C
	CHARACTER*1 RECFMT
	CHARACTER*5 BLKSIZ
	CHARACTER*5 RECSIZ
	CHARACTER*2 BOL
	EQUIVALENCE (HDRREC(5:5),RECFMT),(HDRREC(6:6),BLKSIZ)
	EQUIVALENCE (HDRREC(11:11),RECSIZ),(HDRREC(51:51),BOL)
C
C	VARIABLES USED FOR UNBLOCKING DATA
C	BLKLEN -- BLOCK LENGTH
C	RECLEN -- RECORD LENGTH
C	LABELS -- IF TRUE, THE TAPE HAS LABELS
C	DBLANK -- IF TRUE, REMOVE TRAILING BLANKS
C	ANS    -- ANSWER TO YES/NO QUESTION
C
	INTEGER*4 BLKLEN,RECLEN
	LOGICAL LABELS
	LOGICAL DBLANK
	CHARACTER*1 ANS
C
C	EXTERNAL ACCESS
C
C
	INTEGER*4 SYS$ASSIGN
	EXTERNAL SS$_ENDOFFILE
	EXTERNAL SS$_ENDOFTAPE
C
C	INITIAL DATA VALUES
C
	DATA BLKLEN,RECLEN/80,80/
C
C	BEGIN BY ASKING THE USER WHICH MAGTAPE TO USE
C
	WRITE(5,10)
10	FORMAT('$Enter the tape drive name:  ')
	READ(6,20) TAPE
20	FORMAT(A)
	CALL STR$UPCASE(TAPE,TAPE)
	STATUS = SYS$ASSIGN(TAPE,CHAN,,)
	IF (.NOT.STATUS) CALL LIB$STOP(STATUS)
	CALL REWMT(CHAN,STATUS)
	IF (.NOT.STATUS) CALL LIB$STOP(STATUS)
C
C	NOW THAT WE HAVE THE MAGTAPE DRIVE ASSIGNED,
C	ASK THE USER IF THE TAPE HAS LABELS.
C
30	CONTINUE
	WRITE(5,40)
40	FORMAT('$Is the tape labelled (L) or unlabelled (U)?  ')
	READ(6,20) LBL
	CALL STR$UPCASE(LBL,LBL)
	IF (LBL.EQ.'L') GOTO 100
	IF (LBL.EQ.'U') GOTO 500
	WRITE(5,50)
50	FORMAT(' What?')
	GOTO 30
C
C	A LABELLED TAPE... CHECK OUT THE VOLUME ID
C
100	CONTINUE
	MTLEN = 32767
	CALL READMT(CHAN,MTREC,MTLEN,STATUS)
	IF (.NOT.STATUS) THEN
	 IF (STATUS.EQ.%LOC(SS$_ENDOFTAPE)) GOTO 1000
	 IF (STATUS.EQ.%LOC(SS$_ENDOFFILE)) GOTO 150
	 WRITE(6,110)
110	FORMAT(' Error reading tape label')
	 CALL LIB$STOP(STATUS)
	ENDIF
	IF (MTLEN.NE.80) THEN
	 WRITE(6,120) MTLEN
120	FORMAT(' Tape label is not 80 bytes long, was ',i5,' bytes long')
	 GOTO 10000
	ENDIF
	CALL LIB$TRA_EBC_ASC(MTREC(1:80),VOLREC)
	IF (VOLID(1:3).NE.'VOL') THEN
	 WRITE(6,130) VOLREC
130	FORMAT(' Invalid volume label:',/,A80)
	 GOTO 10000
	ENDIF
	IF (VOLID(4:4).EQ.'1') THEN
	 WRITE(6,140) VOLNAM,OWNER,VERSION
140	FORMAT(' VOLUME HEADER:',/,' TAPE NAME = "',A,'"  OWNER = "',
	1 A,'"',/,' VOLUME LABELS ARE TYPE ',A)
	ELSE
	 GOTO 100
	ENDIF
	N = 1
	CALL SKIPF(CHAN,N,STATUS)
	IF (.NOT.STATUS) THEN
	 CALL LIB$STOP(STATUS)
	ENDIF
C
C	LOOK AT THE FILE HEADER(S)
C
150	CONTINUE
C
C	AN UNLABELLED TAPE... GET THE INFO FROM THE USER
C
500	CONTINUE
	WRITE(6,510)
510	FORMAT(' Enter SKIP to skip a file, STOP to quit, or',
	1 'a filename to read a file',/,'$Action:')
	READ(5,520) FILELN,FILENM
520	FORMAT(Q,A)
	CALL STR$UPCASE(FILENM(1:FILELN),FILENM(1:FILELN))
	IF (FILENM(1:4).EQ.'STOP') GOTO 10000
	IF (FILENM(1:FILELN).EQ.'SKIP') THEN
	 WRITE(6,530)
530	FORMAT('$Skip how many files?  ')
	 READ(5,*) N
	 CALL SKIPF(CHAN,N,STATUS)
	 IF (.NOT.STATUS) THEN
	  WRITE(6,540) N
540	FORMAT(' Error detected skipping files,',i5,' files skipped')
	 ENDIF
	 GOTO 500
	ENDIF
C
C	GET THE BLOCK LENGTH AND RECORD LENGTH FROM
C	THE USER FOR THIS FILE.
C
	WRITE(6,550) RECLEN
550	FORMAT('$Enter the record length (Default=',I5,'):  ')
	READ(5,*) N
	IF (N.NE.0) RECLEN = N
	WRITE(6,560) BLKLEN
560	FORMAT('$Enter the block length (Default=',I5,'):  ')
	READ(5,*) N
	IF (N.NE.0) BLKLEN = N
	IF (MOD(BLKLEN,RECLEN).NE.0) WRITE(6,570)
570     FORMAT(' ?Blocksize is not a multiple of record size')
C
C	OPEN THE OUTPUT FILE
C
	OPEN(UNIT=1,NAME=FILENM(1:FILELN),TYPE='NEW',INITIALSIZE=1,
	1 EXTENDSIZE=1,CARRIAGECONTROL='LIST',RECL=MIN(RECLEN,256),
	2 ERR=580)
	GOTO 600
C
580	CONTINUE
	WRITE(6,590) FILENM(1:FILELN)
590	FORMAT(' Error opening file ',A)
	GOTO 500
C
C	COPY THE DATA FROM THE TAPE AND PUT IT INTO THE FILE
C
600	CONTINUE
	WRITE(6,610)
610	FORMAT('$Do you wish to remove trailing blanks?  ')
	READ(5,620) ANS
620	FORMAT(A)
	CALL STR$UPCASE(ANS,ANS)
	IF (ANS.EQ.'Y') THEN
	 DBLANK = .TRUE.
	ELSE IF (ANS.EQ.'N') THEN
	 DBLANK = .FALSE.
	ELSE
	 GOTO 600
	ENDIF
C
C	FINALLY, PROCESS THE UNLABELLED TAPE
C
630	CONTINUE
	MTLEN = 32767
	CALL READMT(CHAN,MTREC,MTLEN,STATUS)
	IF (.NOT.STATUS) THEN
	 IF (STATUS.EQ.%LOC(SS$_ENDOFFILE)) GOTO 700
	 IF (STATUS.EQ.%LOC(SS$_ENDOFTAPE)) THEN
	  CLOSE(UNIT=1)
	  GOTO 1000
	 ENDIF
	 WRITE(6,640)
640	FORMAT(' Error reading the magtape')
	 CALL LIB$STOP(STATUS)
	ENDIF
	IF (MTLEN.GT.0) THEN
	 CALL LIB$TRA_EBC_ASC(MTREC(1:MTLEN),MTREC(1:MTLEN))
	 DO I=1,MTLEN,RECLEN
	  IF (DBLANK) THEN
	   DO J=I+RECLEN-1,I,-1
	    IF (MTREC(J:J).NE.' ') GOTO 650
	   ENDDO
650	   CONTINUE
	   WRITE(1,660) MTREC(I:J)
	  ELSE
	   WRITE(1,660) MTREC(I:I+RECLEN-1)
	  ENDIF
	 ENDDO
	ENDIF
660	FORMAT(A)
	GOTO 630
C
C	END OF FILE FOR UNFORMATTED READ
C	CLOSE THE OUTPUT FILE & GO ON
C
700	CONTINUE
	CLOSE(UNIT=1)
	WRITE(6,710)
710	FORMAT(' Done')
	GOTO 600
C
C	END OF TAPE, GIVE THE USER SOME OPTIONS
C
1000	CONTINUE
	WRITE(6,1010)
1010	FORMAT(' End of tape reached',/,
	1 '$Do you wish to Exit (E), Rewind (R), or Unload and exit(U)?  ')
	READ(5,1020) ANS
1020	FORMAT(A)
	CALL STR$UPCASE(ANS,ANS)
	IF (ANS.EQ.'E') GOTO 10000
	IF (ANS.EQ.'R') THEN
	 CALL REWMT(CHAN,STATUS)
	 IF (.NOT.STATUS) CALL LIB$STOP(STATUS)
	 IF (LBL.EQ.'L') GOTO 100
	 GOTO 500
	ELSE IF (ANS.EQ.'U') THEN
	 CALL UNLOMT(CHAN,STATUS)
	 IF (.NOT.STATUS) CALL LIB$STOP(STATUS)
	 GOTO 10000
	ELSE
	 WRITE(6,1030)
1030	FORMAT(' What?')
	 GOTO 1000
	ENDIF
C
C	ALL DONE, EXIT
C
10000	CONTINUE
	END
	SUBROUTINE READMT(CHAN,REC,LENGTH,STATUS)
C
C	A SUBROUTINE TO READ A MAGTAPE RECORD USING LOGICAL I/O
C	CHAN IS THE CHANNEL ASSIGNED TO THE MAGTAPE
C	REC IS THE RECORD TO READ THE DATA INTO
C	LENGTH IS THE LENGTH OF THE DATA READ IN
C	STATUS IS THE CODE RETURNED BY THE SYSTEM SERVICE CALL
C
	INTEGER*4 CHAN
	CHARACTER*32767 REC
	INTEGER*4 LENGTH
	INTEGER*4 STATUS
C
C	IOSB   -- THE I/O STATUS BLOCK
C
	INTEGER*2 IOSB(4)
C
C	SYSTEM EXTERNAL VALUES
C
	EXTERNAL IO$_READLBLK
	INTEGER*4 SYS$QIOW
C
	STATUS = SYS$QIOW(,%VAL(CHAN),IO$_READLBLK,IOSB,
	1 ,,%REF(REC),%VAL(LENGTH),,,,,)
	IF (.NOT.STATUS) THEN
	 WRITE(6,10)
10	FORMAT(' Error reading the magtape')
	 CALL LIB$STOP(STATUS)
	ELSE
	 STATUS = IOSB(1)
	 LENGTH = IOSB(2)
	ENDIF
	RETURN
	END
	SUBROUTINE SKIPF(CHAN,N,STATUS)
C
C	A SUBROUTINE TO SKIP A FILE
C	CHAN IS THE CHANNEL NUMBER OF THE MAGTAPE
C	N IS THE NUMBER OF FILES TO SKIP (NEGATIVE FOR BACKWARDS)
C	STATUS IS THE STATUS OF THE MAGTAPE
C
	INTEGER*4 CHAN,N,STATUS
	INTEGER*2 IOSB(4)
C
C	EXTERNAL ACCESS
C
	EXTERNAL IO$_SKIPFILE
	INTEGER*4 SYS$QIOW
C
	STATUS = SYS$QIOW(,%VAL(ICHAN),IO$_SKIPFILE,IOSB,
	1 ,,%VAL(N),,,,,)
	IF (.NOT.STATUS) THEN
	 WRITE(6,10)
10	FORMAT(' Error skipping files on the magtape')
	 CALL LIB$STOP(STATUS)
	ELSE
	 STATUS = IOSB(1)
	 N = IOSB(2)
	ENDIF
	RETURN
	END
	SUBROUTINE SKIPR(CHAN,N,STATUS)
C
C	A SUBROUTINE TO SKIP A RECORD
C	CHAN IS THE CHANNEL NUMBER OF THE MAGTAPE
C	N IS THE NUMBER OF RECORDS TO SKIP (NEGATIVE FOR BACKWARDS)
C	STATUS IS THE STATUS OF THE MAGTAPE
C
	INTEGER*4 CHAN,N,STATUS
	INTEGER*2 IOSB(4)
C
C	EXTERNAL ACCESS
C
	EXTERNAL IO$_SKIPRECORD
	INTEGER*4 SYS$QIOW
C
	STATUS = SYS$QIOW(,%VAL(ICHAN),IO$_SKIPRECORD,IOSB,
	1 ,,%VAL(N),,,,,)
	IF (.NOT.STATUS) THEN
	 WRITE(6,10)
10	FORMAT(' Error skipping records on the magtape')
	 CALL LIB$STOP(STATUS)
	ELSE
	 STATUS = IOSB(1)
	 N = IOSB(2)
	ENDIF
	RETURN
	END
	SUBROUTINE REWMT(CHAN,STATUS)
C
C	THIS SUBROUTINE WILL REWIND A MAGTAPE TO THE LOAD POINT
C	CHAN IS THE CHANNEL NUMBER OF THE MAGTAPE
C	STATUS IS THE RETURNED STATUS OF THE TAPE
C
	INTEGER*4 CHAN,STATUS
	INTEGER*2 IOSB(4)
C
C	EXTERNAL ACCESS
C
	EXTERNAL IO$_REWIND
	INTEGER*4 SYS$QIOW
C
	STATUS = SYS$QIOW(,%VAL(CHAN),IO$_REWIND,IOSB,
	1 ,,,,,,,)
	IF (.NOT.STATUS) THEN
	 WRITE(6,10)
10	FORMAT(' Error rewinding the magtape')
	 CALL LIB$STOP(STATUS)
	ELSE
	 STATUS = IOSB(1)
	ENDIF
	RETURN
	END
	SUBROUTINE UNLOMT(CHAN,STATUS)
C
C	THIS SUBROUTINE WILL UNLOAD A MAGTAPE 
C	CHAN IS THE CHANNEL NUMBER OF THE MAGTAPE
C	STATUS IS THE RETURNED STATUS OF THE TAPE
C
	INTEGER*4 CHAN,STATUS
	INTEGER*2 IOSB(4)
C
C	EXTERNAL ACCESS
C
	EXTERNAL IO$_REWINDOFF
	INTEGER*4 SYS$QIOW
C
	STATUS = SYS$QIOW(,%VAL(CHAN),IO$_REWINDOFF,IOSB,
	1 ,,,,,,,)
	IF (.NOT.STATUS) THEN
	 WRITE(6,10)
10	FORMAT(' Error unloading the magtape')
	 CALL LIB$STOP(STATUS)
	ELSE
	 STATUS = IOSB(1)
	ENDIF
	RETURN
	END
	PROGRAM MONKEY
C
C	A PROGRAM TO LOOK AT BACKUP SAVE SETS.
C
	CHARACTER*2720 JUNK
	BYTE JHEAD(160),JDATA(2560)
	EQUIVALENCE (JUNK,JHEAD),(JUNK(161:161),JDATA)
C
	INTEGER*4 HEADER(2,32),DAT(2,512)
C
	CHARACTER*2560 LINE
	BYTE LINEB(2560)
	EQUIVALENCE (LINE,LINEB)
	CHARACTER*64 IFILE,OFILE
	INTEGER IFILEL,OFILEL
C
	WRITE(6,10)
10	FORMAT('$Enter name of file:  ')
	READ(5,20) IFILEL,IFILE
20	FORMAT(Q,A)
	OPEN(UNIT=1,NAME=IFILE(1:IFILEL),RECORDSIZE=2720,TYPE='OLD')
	WRITE(6,30)
30	FORMAT('$Enter the output file name:')
	READ(5,20) OFILEL,OFILE
	OPEN(UNIT=2,NAME=OFILE(1:OFILEL),TYPE='NEW',RECORDSIZE=512,
	1 CARRIAGECONTROL='NONE')
C
C	GET A HEADER...
C
35	READ(1,20,END=1000) JUNKL,JUNK
	CALL CVT(JHEAD,HEADER,32)
	I = HEADER(1,1)
	GOTO (100,200,300,400,500,600,700) I
	WRITE(6,40) HEADER(2,1),HEADER(1,1)
40	FORMAT(' HEADER WORD IS ',I,' / ',I)
	GOTO 35
C
100	CONTINUE
	WRITE(6,110)
110	FORMAT(' FOUND A WORTHLESS LABEL RECORD')
	GOTO 35
C
200	CONTINUE
	WRITE(6,210)
210	FORMAT(' START OF SAVE SET')
	GOTO 35
C
300	CONTINUE
	WRITE(6,310)
310	FORMAT(' END OF SAVE SET')
	GOTO 35
C
400	CONTINUE
	IF (HEADER(1,6).NE.0) THEN
	CALL CVT(JDATA,DAT,HEADER(1,6))
	DO I=1,HEADER(1,6),1
	 J=1+(I-1)*5
	 LINEB(J) = LIB$EXTZV(29,7,DAT(1,I))
	 LINEB(J+1) = LIB$EXTZV(22,7,DAT(1,I))
	 LINEB(J+2) = LIB$EXTZV(15,7,DAT(1,I))
	 LINEB(J+3) = LIB$EXTZV(8,7,DAT(1,I))
	 LINEB(J+4) = LIB$EXTZV(1,7,DAT(1,I))
	ENDDO
	DO I=1,J-508,512
	 WRITE(2,410) LINE(I:I+511)
410	FORMAT(A)
	ENDDO
	WRITE(2,410) LINE(I:J+4)
	IF (IAND(8,HEADER(2,4)).NE.0) THEN
	 WRITE(6,420)
420	FORMAT(' END OF FILE REACHED')
	 CLOSE(UNIT=2)
	ENDIF
	ENDIF
	GOTO 35
C
500	CONTINUE
	WRITE(6,510)
510	FORMAT(' UFD RECORD READ')
	GOTO 35
C
600	CONTINUE
	WRITE(6,610)
610	FORMAT(' END OF VOLUME???')
	GOTO 35
C
700	CONTINUE
	WRITE(6,710)
710	FORMAT(' COMMENT?')
	GOTO 35
C
1000	CONTINUE
	CLOSE(UNIT=1)
	CLOSE(UNIT=2)
	END
	SUBROUTINE CVT(A,B,N)
C
C	TO CONVERT A STRING FROM 36BITS IN 5 BYTES TO
C	36 BITS IN 8 BYTES (ALL ALIGNED PROPERLY)
C
	BYTE A(1)
	INTEGER B(2,N)
C
	DO J=1,N,1
	 I=1+(J-1)*5
	 CALL LIB$INSV(A(I),28,8,B(1,J))
	 CALL LIB$INSV(A(I+1),20,8,B(1,J))
	 CALL LIB$INSV(A(I+2),12,8,B(1,J))
	 CALL LIB$INSV(A(I+3),4,8,B(1,J))
	 CALL LIB$INSV(A(I+4),0,4,B(1,J))
	ENDDO
	RETURN
	END
	SUBROUTINE MTOPEN(NAME,CHANNEL,STATUS)
C
C	This subroutine will use the VAX/VMS system services
C	to open a magtape drive and return the channel number
C	assigned to it.  If an error occurs, the STATUS code
C	will be even.
C
	CHARACTER*64 DEVNAME
	INTEGER*2 DEVLEN
	CHARACTER*(*) NAME
	INTEGER*4 CHANNEL,STATUS
	INTEGER*4 SYS$ASSIGN
C
	CALL STR$UPCASE(DEVNAME,NAME)
	DEVLEN = MIN(64,LEN(NAME))
	STATUS = SYS$ASSIGN(DEVNAME(1:DEVLEN),CHANNEL,,)
	RETURN
	END
	SUBROUTINE MTCLOS(CHANNEL,STATUS)
C
C	This subroutine will use the VAX/VMS system services
C	to close the magtape drive previously opened by MTOPEN.
C	If an error occurs, the STATUS code will be even.
C
	INTEGER*4 CHANNEL,STATUS
	INTEGER*4 SYS$DASSGN
C
	STATUS = SYS$DASSGN(%VAL(CHANNEL))
	RETURN
	END
	SUBROUTINE MTSKPF(CHANNEL,COUNT,STATUS)
C
C	This subroutine will use the VAX/VMS system services
C	to skip the magtape the specified number of files for
C	a tape drive previously opened by MTOPEN.  If an error
C	occurs, the STATUS code will be even.
C
	INTEGER*4 CHANNEL,COUNT,STATUS
	INTEGER*4 IOSB(2)
	INTEGER*2 IOSB2(4)
	EQUIVALENCE (IOSB,IOSB2)
C
	EXTERNAL IO$_SKIPFILE,MT$M_BOT
C
	IF (COUNT.LE.0) THEN
	 CALL MTCONT(CHANNEL,IO$_SKIPFILE,COUNT-1,IOSB,STATUS)
10	FORMAT(' Skipped',I5,' files')
	 IF (IAND(%LOC(MT$M_BOT),IOSB(2)).EQ.0) THEN
	  WRITE(*,10) MIN(0,-IOSB2(2)+1)
	  CALL MTCONT(CHANNEL,IO$_SKIPFILE,1,IOSB,STATUS)
	 ELSE
	  WRITE(*,10) MIN(0,-IOSB2(2))
	 ENDIF
	ELSE
	 CALL MTCONT(CHANNEL,IO$_SKIPFILE,COUNT,IOSB,STATUS)
	 WRITE(*,10) IOSB2(2)
	ENDIF
	CALL MTSTAT(IOSB)
	RETURN
	END
	SUBROUTINE MTSKPR(CHANNEL,COUNT,STATUS)
C
C	This subroutine will use the VAX/VMS system services
C	to skip the magtape the specified number of records for
C	a tape drive previously opened by MTOPEN.  If an error
C	occurs, the STATUS code will be even.
C
	INTEGER*4 CHANNEL,COUNT,STATUS
	INTEGER*4 IOSB(2)
	INTEGER*2 IOSB2(4)
	EQUIVALENCE (IOSB,IOSB2)
C
	EXTERNAL IO$_SKIPRECORD
C
	CALL MTCONT(CHANNEL,IO$_SKIPRECORD,COUNT,IOSB,STATUS)
	WRITE(*,10) SIGN(IOSB2(2),COUNT)
10	FORMAT(' Skipped',I5,' records')
	CALL MTSTAT(IOSB)
	RETURN
	END
	SUBROUTINE MTCONT(CHANNEL,ACTION,COUNT,IOSB,STATUS)
C
C	This subroutine is used by MTSKPF and MTSKPR to
C	do the actual work of skipping on the magtape.
C	This will interpret the system and magtape status
C	codes and print the appropriate messages.
C
	INTEGER*4 CHANNEL,ACTION,COUNT,STATUS
	INTEGER*2 IOSB(4)
C
C
	INTEGER*4 SYS$QIOW
	EXTERNAL IO$_SENSEMODE
C
	STATUS = SYS$QIOW(,%VAL(CHANNEL),ACTION,IOSB,,
	1 ,%VAL(COUNT),,,,,)
	IF (.NOT.STATUS) THEN
	 CALL ERRORM(STATUS)
	ELSE IF (.NOT.IOSB(1)) THEN
	 STATUS = IOSB(1)
	 CALL ERRORM(STATUS)
	ENDIF
	RETURN
	END
	SUBROUTINE MTSTAT(IOSB)
C
C	This subroutine will examine the I/O status block
C	supplied and print the appropriate messages.
C
	INTEGER*4 IOSB(2)
C
	EXTERNAL MT$M_LOST,MT$M_EOT,MT$M_BOT
	EXTERNAL MTIO_LOST,MTIO_EOT,MTIO_BOT
C
	IF (IAND(%LOC(MT$M_LOST),IOSB(2)).NE.0) 
	1 CALL ERRORM(%LOC(MTIO_LOST))
	IF (IAND(%LOC(MT$M_EOT),IOSB(2)).NE.0) 
	1 CALL ERRORM(%LOC(MTIO_EOT))
	IF (IAND(%LOC(MT$M_BOT),IOSB(2)).NE.0) 
	1 CALL ERRORM(%LOC(MTIO_BOT))
C
	RETURN
	END
	SUBROUTINE MTREAD(CHANNEL,BUFFER,BUFLEN,ACTLEN,STATUS)
C
C	This subroutine will read a magtape that has been opened
C	by the MTOPEN subroutine.  It will read in one record from
C	the tape into BUFFER, and set ACTLEN to the number of bytes
C	actually read.  STATUS will get the return status from the
C	VAX/VMS $QIOW call.
C
	INTEGER*4 CHANNEL,BUFLEN,ACTLEN,STATUS
	BYTE BUFFER(1)
C NB: BUFFER is dimensioned 1 due to FORTRAN problems...it should be
C dimensioned to BUFLEN.
C
	INTEGER*4 SYS$QIOW
	INTEGER*2 IOSB(4)
	EXTERNAL IO$_READLBLK
C
	STATUS = SYS$QIOW(,%VAL(CHANNEL),IO$_READLBLK,IOSB,,
	1 ,BUFFER,%VAL(BUFLEN),,,,)
	ACTLEN = IOSB(2)
	IF (.NOT.STATUS) THEN
	 CALL ERRORM(STATUS)
	ELSE
	 IF (.NOT.IOSB(1)) THEN
	  STATUS = IOSB(1)
	  CALL ERRORM(STATUS)
	 ENDIF
	ENDIF
	CALL MTSTAT(IOSB)
	RETURN
	END
	SUBROUTINE MTWRIT(CHANNEL,BUFFER,BUFLEN,ACTLEN,STATUS)
C
C	This subroutine will write a magtape that has been opened
C	by the MTOPEN subroutine.  It will write out one record from
C	BUFFER to the tape, and set ACTLEN to the number of bytes
C	actually written.  STATUS will get the return status from the
C	VAX/VMS $QIOW call.
C
	INTEGER*4 CHANNEL,BUFLEN,ACTLEN,STATUS
	BYTE BUFFER(1)
C NB: BUFFER is dimensioned 1 due to FORTRAN problems...it should be
C dimensioned to BUFLEN.
C
	INTEGER*4 SYS$QIOW
	INTEGER*2 IOSB(4)
	EXTERNAL IO$_WRITELBLK
C
	STATUS = SYS$QIOW(,%VAL(CHANNEL),IO$_WRITELBLK,IOSB,,
	1 ,BUFFER,%VAL(BUFLEN),,,,)
	ACTLEN = IOSB(2)
	IF (.NOT.STATUS) THEN
	 CALL ERRORM(STATUS)
	ELSE
	 IF (.NOT.IOSB(1)) THEN
	  STATUS = IOSB(1)
	  CALL ERRORM(STATUS)
	 ENDIF
	ENDIF
	CALL MTSTAT(IOSB)
	RETURN
	END
	.TITLE		MTIOMSG MTIO error and information messages
	.FACILITY	MTIO,2050
	.SEVERITY	WARNING
	LOST		<The magtape position has been lost>
	EOT		<The end of tape has been reached>
	BOT		<The beginning of tape has been reached>
	.END
	SUBROUTINE OVERHEAD(BUFFER,BLEN,FSPEC,FSLEN)
C
C	This segment examines the overhead section of the
C	file data.  The data is printed on the user's terminal.
C
C
C	Parameter list description:
C
C	BUFFER -- Raw data of the input buffer
C	BLEN   -- Length of the overhead region in words
C	FSPEC  -- File specification to return to caller
C	FSLEN  -- Length of the file specification returned
C
	INTEGER*4 BUFLEN
	PARAMETER (BUFLEN=2720)
	BYTE BUFFER(BUFLEN)
	INTEGER*4 BLEN
	CHARACTER*256 FSPEC
	INTEGER*4 FSLEN
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPHEAD.FOR/NOLIST'
	INCLUDE 'DMPREC.FOR/NOLIST'
C
C	Local data description:
C
	INTEGER*4 DAT(2,512)
C
	INTEGER RH,LH
	INTEGER RHS,LHS
	CHARACTER*5 CHARS
	CHARACTER*20 DATIME
	BYTE LINE(256)
	INTEGER LINEL
	CHARACTER*256 CLINE
	EQUIVALENCE (LINE,CLINE)
	BYTE NUM(8)
	CHARACTER CNUM*8
	EQUIVALENCE (NUM,CNUM)
C
	FSLEN = 0
	IF (BLKTYP.EQ.STDBLK) THEN
	 CALL CVT36(BUFFER(161),DAT,BLEN)
	ELSE
	 CALL CVT72(BUFFER(145),DAT,BLEN)
	ENDIF
	K = BLEN
	I = 1
	LINEL = 1
	DO WHILE (K.GT.I)
	 CALL CVTHALF(DAT(1,I),RH,LH)
	 GOTO (905,100,200,300,400,500) LH+1
	 WRITE(6,10) I,RH,LH
10	FORMAT(' ERROR WITH OVERHEAD RECORD, WORD=',I3,' VALUE = ',
	1 2O8.6)
	 GOTO 1000
C
C	NAME RECORD
C
100	CONTINUE
	J = 1+I
	CALL CVTHALF(DAT(1,J),RHS,LHS)
	IF (LHS.EQ.N$DEV) THEN
	 CALL CVTASZ(DAT(1,J+1),LINE,LINEL)
	 J = J+RHS
	 CALL CVTHALF(DAT(1,J),RHS,LHS)
	 LINE(LINEL) = ':'
	 LINEL = LINEL+1
	ENDIF
	IF (LHS.EQ.N$UFD) THEN
	 LINE(LINEL) = '['
	 LINEL = LINEL+1
	 CALL CVTASZ(DAT(1,J+1),LINE,LINEL)
	 J = J+RHS
	 CALL CVTHALF(DAT(1,J),RHS,LHS)
	 DO WHILE (LHS.GT.N$UFD)
	  LINE(LINEL) = ','
	  LINEL = LINEL+1
	  CALL CVTASZ(DAT(1,J+1),LINE,LINEL)
	  J = J+RHS
	  CALL CVTHALF(DAT(1,J),RHS,LHS)
	 ENDDO
	 LINE(LINEL) = ']'
	 LINEL = LINEL+1
	ENDIF
	IF (LHS.EQ.N$NAME) THEN
	 IF (LINEL.EQ.1) THEN
	  LINEL = 4
	  LINE(1) = '['
	  LINE(2) = '_'
	  LINE(3) = ']'
	 ENDIF
	 CALL CVTASZ(DAT(1,J+1),LINE,LINEL)
	 J = J+RHS
	 CALL CVTHALF(DAT(1,J),RHS,LHS)
	ENDIF
	LINE(LINEL) = '.'
	LINEL = LINEL+1
	IF (LHS.EQ.N$EXT) THEN
	 CALL CVTASZ(DAT(1,J+1),LINE,LINEL)
	 J = J+RHS
	 CALL CVTHALF(DAT(1,J),RHS,LHS)
	ENDIF
	IF (LHS.EQ.N$VER) THEN
	 J = J+RHS
	 CALL CVTHALF(DAT(1,J),RHS,LHS)
	ENDIF
	IF (LHS.EQ.N$GEN) THEN
	 LINE(LINEL) = ';'
	 LINEL = LINEL+1
	 CALL CVTASZ(DAT(1,J+1),LINE,LINEL)
	ENDIF
	FSLEN = LINEL-1
	DO I=1,FSLEN
	 IF (LINE(I).EQ.'-') LINE(I) = '_'
	ENDDO
	FSPEC(1:FSLEN) = CLINE(1:FSLEN)
	GOTO 900
C
C	ATTRIBUTE SUB-BLOCK
C
200	CONTINUE
	DO J=LINEL,38,1
	LINE(J) = ' '
	ENDDO
	LINEL = MAX(39,LINEL)
	LINE(LINEL) = ' '
	LINEL = LINEL+1
	WRITE(CNUM,210) (DAT(1,I+A$ALLS)+255)/256
210	FORMAT(I8)
	DO J=1,8
	LINE(LINEL-1+J) = NUM(J)
	ENDDO
	LINE(LINEL+8) = ' '
	LINE(LINEL+9) = ' '
	LINE(LINEL+10) = ' '
	LINEL = LINEL+11
	CALL CVTDATE(DAT(1,I+A$WRIT),LINE,LINEL)
	GOTO 900
C
C	DIRECTORY ATTRIBUTES
C
300	CONTINUE
	GOTO 900
C
C	SYSTEM NAME
C
400	CONTINUE
	IF (LINEL.GT.1) THEN
	LINEL = LINEL-1
	IF (LIST) WRITE(2,910) (LINE(J),J=1,LINEL)
	LINEL = 1
	ENDIF
	CALL CVTASZ(DAT(1,I+1),LINE,LINEL)
	IF (LIST) WRITE(2,410) (LINE(J),J=1,LINEL-1)
410	FORMAT(' SYSTEM NAME = ',256(A1,:))
	LINEL = 1
	GOTO 900
C
C	SAVE SET NAME
C
500	CONTINUE
	IF (LINEL.GT.1) THEN
	LINEL = LINEL-1
	IF (LIST) WRITE(2,910) (LINE(J),J=1,LINEL)
	LINEL = 1
	ENDIF
	CALL CVTASZ(DAT(1,I+1),LINE,LINEL)
	IF (LIST) WRITE(2,510) (LINE(J),J=1,LINEL-1)
510	FORMAT(' SAVE SET NAME = ',256(A1,:))
	LINEL = 1
	GOTO 900
C
C	GO TO THE NEXT REGION
C
900	CONTINUE
	I = I+RH
	ENDDO
C
905	CONTINUE
	LINEL = LINEL-1
	IF (LIST) WRITE(2,910) (LINE(J),J=1,LINEL)
910	FORMAT(1X,<LINEL>A1)
1000	CONTINUE
	RETURN
	END
	PROGRAM PRINT
C
C	A PROGRAM TO LOOK AT BACKUP SAVE SETS.
C
	CHARACTER*2720 JUNK
	BYTE JHEAD(160),JDATA(2560)
	EQUIVALENCE (JUNK,JHEAD),(JUNK(161:161),JDATA)
C
	INTEGER*4 HEADER(2,32),DAT(2,512)
C
	CHARACTER*2560 LINE
	BYTE LINEB(2560)
	EQUIVALENCE (LINE,LINEB)
	CHARACTER*64 IFILE,OFILE
	INTEGER IFILEL,OFILEL
C
	WRITE(6,10)
10	FORMAT('$Enter name of file:  ')
	READ(5,20) IFILEL,IFILE
20	FORMAT(Q,A)
	OPEN(UNIT=1,NAME=IFILE(1:IFILEL),RECORDSIZE=2720,TYPE='OLD',
	1 READONLY)
	WRITE(6,30)
30	FORMAT('$Enter the output file name:')
	READ(5,20) OFILEL,OFILE
	OPEN(UNIT=2,NAME=OFILE(1:OFILEL),TYPE='NEW',RECORDSIZE=512,
	1 CARRIAGECONTROL='FORTRAN')
C
C	GET A HEADER...
C
35	READ(1,20,END=1000) JUNKL,JUNK
	CALL CVT36(JHEAD,HEADER,32)
	CALL WRITER(HEADER,32)
	I = HEADER(1,1)
	GOTO (100,200,300,400,500,600,700) I
	WRITE(6,40) HEADER(2,1),HEADER(1,1)
40	FORMAT(' HEADER WORD IS ',I,' / ',I)
	GOTO 800
C
100	CONTINUE
	WRITE(2,110)
110	FORMAT(' FOUND A WORTHLESS LABEL RECORD')
	GOTO 800
C
200	CONTINUE
	WRITE(2,210)
210	FORMAT(' START OF SAVE SET')
	GOTO 800
C
300	CONTINUE
	WRITE(2,310)
310	FORMAT(' END OF SAVE SET')
	GOTO 800
C
400	CONTINUE
	WRITE(2,410)
410	FORMAT(' FILE DATA RECORD')
	GOTO 800
C
500	CONTINUE
	WRITE(2,510)
510	FORMAT(' UFD RECORD READ')
	GOTO 800
C
600	CONTINUE
	WRITE(2,610)
610	FORMAT(' END OF VOLUME???')
	GOTO 800
C
700	CONTINUE
	WRITE(2,710)
710	FORMAT(' COMMENT?')
	GOTO 800
C
800	CONTINUE
	CALL CVT36(JDATA,DAT,512)
	CALL WRITER(DAT,512)
	WRITE(2,810)
810	FORMAT('1')
	GOTO 35
1000	CONTINUE
	CLOSE(UNIT=1)
	CLOSE(UNIT=2)
	END
	SUBROUTINE WRITER(VALUE,N)
C
C	A SUBROUTINE TO CONVERT N TWO WORD VALUES
C	FROM DEC-10 FORMAT INTO ASCII BY DOING
C	SIXBIT, 7-BIT ASCII AND HALFWORD CONVERSIONS.
C
	INTEGER SIVAL(6),AIVAL(5),HVAL(2)
	CHARACTER*1 SVAL(6),AVAL(5)
	INTEGER VALUE(2,N),N
C
	BYTE LINE(20)
	INTEGER LINEL
C
	DO I=1,N,1
	 K = 1
	 DO J=30,0,-6
	  SIVAL(K) = LIB$EXTZV(J,6,VALUE(1,I))
	  SVAL(K) = CHAR(SIVAL(K)+32)
	  K = K+1
	 ENDDO
	 K = 1
	 DO J=29,1,-7
	  AIVAL(K) = LIB$EXTZV(J,7,VALUE(1,I))
	  IF (AIVAL(K).LE.32) THEN
	   AVAL(K) = ' '
	  ELSE
	   AVAL(K) = CHAR(AIVAL(K))
	  ENDIF
	  K = K+1
	 ENDDO
	 HVAL(1) = LIB$EXTZV(18,18,VALUE(1,I))
	 HVAL(2) = LIB$EXTZV(0,18,VALUE(1,I))
	 LINEL=1
	 CALL CVTDATE(VALUE(1,I),LINE,LINEL)
	 WRITE(2,20) I,SVAL,SIVAL,AVAL,AIVAL,HVAL,LINE
20	FORMAT(' Item ',i3,': ',6a1,2x,6z3.2,2x,5a1,2x,5z3.2,2x,2o7.6,
	1 2X,20A1)
	ENDDO
	RETURN
	END
	SUBROUTINE PROCESS(BUFFER,HEADER)
C
C	This subroutine will process a record of data
C	that has been read from the Magtape.  BUFFER
C	holds the 'raw' data from the tape.  HEADER has
C	the header information already decoded by the
C	GO_COMMAND as per the BLKTYP information.
C
C	Parameter list description:
C
C	BUFFER -- Raw data as read from the magtape
C	HEADER -- Converted DEC 10/20 header record
C
	INTEGER*4 BUFLEN
	PARAMETER (BUFLEN=2720)
	BYTE BUFFER(BUFLEN)
	INTEGER*4 HEADER(2,32)
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPHEAD.FOR/NOLIST'
C
C	FILEDATA -- Converted DEC 10/20 file information
C	LENDATA  -- Length of the file information
C
	INTEGER*4 FILEDATA(2,512)
	INTEGER*4 LENDATA
C
	CALL PREPROC(BUFFER,HEADER)
	IF (FILEOK) THEN
	 LENDATA = HEADER(1,G$SIZ)
	 IF (LENDATA.EQ.0) RETURN
	 IF (BLKTYP.EQ.STDBLK) THEN
	  CALL CVT36(BUFFER(161+5*HEADER(1,G$LND)),FILEDATA,LENDATA)
	 ELSE
	  CALL CVT72(BUFFER(145+9*(HEADER(1,G$LND)/2)),FILEDATA,LENDATA)
	 ENDIF
	 CALL DATAPROC(FILEDATA,HEADER)
	ENDIF
	CALL POSTPROC(BUFFER,HEADER)
	RETURN
	END
	SUBROUTINE PREPROC(BUFFER,HEADER)
C
C	This segment will do the pre-processing that is necessary
C	to handle a block from the tape.  This includes the
C	examination of the filename, opening the output file, and
C	setting program status codes to indicate the progress of
C	the job.
C
C	Parameter list description:
C
C	BUFFER -- Raw data from tape
C	HEADER -- Header information after conversion
C
	INTEGER*4 BUFLEN
	PARAMETER (BUFLEN=2720)
	BYTE BUFFER(BUFLEN)
	INTEGER*4 HEADER(2,32)
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPHEAD.FOR/NOLIST'
C
C	FILESPEC -- DEC 10/20 File specification
C	FSLEN    -- Length of FILESPEC used
C	LND      -- Corrected value of length
C
	CHARACTER*256 FILESPEC
	INTEGER*4 FSLEN
	INTEGER*4 LND
C
	LND = HEADER(1,G$LND) .AND. '3FFFF'X
	IF (LND.NE.0) THEN
	 CALL OVERHEAD(BUFFER,LND,FILESPEC,FSLEN)
	ENDIF
	IF (IAND(HEADER(2,G$FLAG),GF$SOF).NE.0) THEN
	 CALL VALIDATE(FILESPEC,FSLEN)
	ENDIF
	RETURN
	END
	SUBROUTINE POSTPROC(BUFFER,HEADER)
C
C	This segment will do the post-processing of the data
C	buffer.  If the end of file has been reached for a
C	file, the output file is closed, and the status indicating
C	an open file is reset.
C
C	Parameter list description:
C
C	BUFFER -- Raw data from the DEC 10/20 magtape
C	HEADER -- Header information after conversion
C
	INTEGER*4 BUFLEN
	PARAMETER (BUFLEN=2720)
	BYTE BUFFER(BUFLEN)
	INTEGER*4 HEADER(2,32)
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPHEAD.FOR/NOLIST'
C
	IF (IAND(HEADER(2,G$FLAG),GF$EOF).NE.0) THEN
	 CLOSE(UNIT=1)
	ENDIF
	RETURN
	END
	SUBROUTINE DATAPROC(FILEDATA,HEADER)
C
C	This segment takes the converted DEC 10/20 information
C	from the FILEDATA and HEADER areas and converts it
C	into the form to be used by the VAX.  If the file is
C	being processed in BINARY mode, each 36 bit DEC 10/20
C	word is copied into 5 bytes.  If the file is being
C	processed in ASCII mode, each 7 bit byte is extracted
C	from the DEC-10 word and put into a byte for output.
C
C	Parameter list description:
C
C	FILEDATA -- The converted file information
C	HEADER -- The converted file header
C
	INTEGER*4 FILEDATA(2,512),HEADER(2,32)
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPHEAD.FOR/NOLIST'
C
C	OUTBUF -- the output buffer for the file data
C	OUTLEN -- the length of output data
C
	BYTE OUTBUF(2560)
	INTEGER*4 OUTLEN
C
	OUTLEN = 5*HEADER(1,G$SIZ)
	IF (IOMODE.EQ.BINARY) THEN
	 CALL COPY5(FILEDATA,OUTBUF,HEADER(1,G$SIZ))
	 WRITE(1,100) (OUTBUF(I),I=1,OUTLEN)
100	FORMAT(4(640(A1,:),/))
	ELSE
	 CALL COPYASC(FILEDATA,OUTBUF,HEADER(1,G$SIZ))
	 WRITE(1,110) (OUTBUF(I),I=1,OUTLEN)
110	FORMAT(40(64(A1,:),/))
	ENDIF
	RETURN
	END
	INTEGER*4 FUNCTION RES_COMMAND(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the RESTORE command action routine.  It is called when
C	the end of input has been found on a successful RESTORE
C	command.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR'
C
	EXTERNAL DUMPER_RESMAX
C
	RESCNT = RESCNT+1
	IF (RESCNT.GT.RESMAX) THEN
	 CALL ERRORM(%LOC(DUMPER_RESMAX))
	ENDIF
	RES_COMMAND = 1
	RETURN
	END
	INTEGER*4 FUNCTION WHAT_COMMAND(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the WHAT command action routine.  It is called to
C	print out the files/directories that will be restored.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	DO I=1,RESCNT-1
	 WRITE(6,100) VAXDIR(I)(1:VAXLEN(I))
100	FORMAT('$[',A,']=[')
	 IF (TAPELEN(1,I).LE.0) THEN
	  WRITE(6,110) '*'
110	FORMAT('+',A,$)
	 ELSE
	  WRITE(6,110) TAPENAME(1,I)(1:TAPELEN(1,I))
	 ENDIF
	 DO J=2,TAPEMAX-2
	  IF (TAPELEN(J,I).LT.0) THEN
	   WRITE(6,120) '*'
120	FORMAT('+,',A,$)
	  ELSE IF (TAPELEN(J,I).EQ.0) THEN
	   GOTO 130
	  ELSE
	   WRITE(6,120) TAPENAME(J,I)(1:TAPELEN(J,I))
	  ENDIF
	 ENDDO
130	CONTINUE
	 IF (TAPELEN(TAPEMAX-1,I).LT.0) THEN
	  WRITE(6,140) '*'
140	FORMAT('+]',A,'.',$)
	 ELSE IF (TAPELEN(TAPEMAX-1,I).EQ.0) THEN
	  WRITE(6,145) 
145	FORMAT('+].',$)
	 ELSE
	  WRITE(6,140) TAPENAME(TAPEMAX-1,I)(1:TAPELEN(TAPEMAX-1,I))
	 ENDIF
	 IF (TAPELEN(TAPEMAX,I).LT.0) THEN
	  WRITE(6,150) '*'
150	FORMAT('+',A)
	 ELSE IF (TAPELEN(TAPEMAX,I).EQ.0) THEN
	  WRITE(6,155) 
155	FORMAT('+')
	 ELSE
	  WRITE(6,150) TAPENAME(TAPEMAX,I)(1:TAPELEN(TAPEMAX,I))
	 ENDIF
	ENDDO
	WHAT_COMMAND =  1
	RETURN
	END
	INTEGER*4 FUNCTION RESET_COMMAND(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the RESET command action routine.  It is called to
C	reset the restore information.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	RESCNT = 1
	RESET_COMMAND = 1
	RETURN
	END
	INTEGER*4 FUNCTION RES_VDIR(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine called when the VAX filename is
C	started.  It will reset the data being built up.  If the
C	limit of names has already been reached, it will return an
C	error code to be reported.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	EXTERNAL DUMPER_RESIGN
C
C	If the maximum number of restore statements have been
C	processed already, return the 'ignored' message.  If
C	not, then clean out the current values of the restore
C	information in case a previous command line aborted.
C
	IF (RESCNT.GT.RESMAX) THEN
	 RES_VDIR = %LOC(DUMPER_RESIGN)
	ELSE
	 VAXDIR(RESCNT) = ' '
	 VAXLEN(RESCNT) = 0
	 DO I=1,TAPEMAX
	  TAPENAME(I,RESCNT) = ' '
	  TAPELEN(I,RESCNT) = 0
	 ENDDO
	 TAPECNT = 1
	 RES_VDIR = 1
	ENDIF
	RETURN
	END
	INTEGER*4 FUNCTION RES_VNAME(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine called to add to the VAX
C	directory name that will recieve the data.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	EXTERNAL DUMPER_RESDNM
C
C	Save the partial VAX directory name.  Report an error
C	if it is too long.
C
	J = VAXLEN(RESCNT)
	IF (J+%LOC(TLEN).GT.64) THEN
	 RES_VNAME = %LOC(DUMPER_RESDNM)
	ELSE
	 DO I=1,%LOC(TLEN)
	  VAXDIR(RESCNT)(I+J:I+J) = CHAR(TOKEN(I))
	 ENDDO
	 VAXLEN(RESCNT) = J+%LOC(TLEN)
	 RES_VNAME = 1
	ENDIF
	RETURN
	END
	INTEGER*4 FUNCTION RES_VDOT(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine that is called when a period
C	is seen in the VAX directory name.  It will add the period
C	to the current directory name being built.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	EXTERNAL DUMPER_RESDNM
C
C	If the period won't fit in the name, report an error
C
	J = VAXLEN(RESCNT)+1
	IF (J.GT.64) THEN
	 RES_VDOT = %LOC(DUMPER_RESDNM)
	ELSE
	 VAXDIR(RESCNT)(J:J) = '.'
	 VAXLEN(RESCNT) = J
	 RES_VDOT = 1
	ENDIF
	RETURN
	END
	INTEGER*4 FUNCTION RES_TNAME(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine that is called when the
C	tape name information is to be added to.  It will copy
C	the supplied token into the current tape name area if
C	it will fit.  If not, it will return an error message.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	EXTERNAL DUMPER_RESDNM,DUMPER_RESFNM
C
	IF (%LOC(TLEN).GT.32) THEN
	 IF (TAPECNT.GE.TAPEMAX-1) THEN
	  RES_TNAME = %LOC(DUMPER_RESFNM)
	 ELSE
	  RES_TNAME = %LOC(DUMPER_RESDNM)
	 ENDIF
	ELSE
	 DO I=1,%LOC(TLEN)
	  TAPENAME(TAPECNT,RESCNT)(I:I) = CHAR(TOKEN(I))
	 ENDDO
	 TAPELEN(TAPECNT,RESCNT) = %LOC(TLEN)
	 RES_TNAME = 1
	ENDIF
	RETURN
	END
	INTEGER*4 FUNCTION RES_TSTAR(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine that handles the asterisk when
C	found in a DEC 10/20 filename specification.  It merely
C	sets the length of this part of the name to -1.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	TAPELEN(TAPECNT,RESCNT) = -1
	RES_TSTAR = 1
	RETURN
	END
	INTEGER*4 FUNCTION RES_TDOT(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine called when a comma (or period)
C	is seen in a DEC 10/20 directory name.  It will increment
C	the index into the tape name table and signal an error if
C	too many sfd's have been seen.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	EXTERNAL DUMPER_RESSFD
C
	IF (TAPECNT.EQ.TAPEMAX-2) THEN
	 RES_TDOT = %LOC(DUMPER_RESSFD)
	ELSE
	 TAPECNT = TAPECNT+1
	 RES_TDOT = 1
	ENDIF
	RETURN
	END
	INTEGER*4 FUNCTION RES_TBR(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine called to handle the right bracket
C	in the tape name.  It will set the index to the tape name to
C	point to the filename portion.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	TAPECNT = TAPEMAX-1
	RES_TBR = 1
	RETURN
	END
	INTEGER*4 FUNCTION RES_VMIN(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine that is called when a minus
C	is seen in the VAX directory name.  It will add the minus
C	to the current directory name being built.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	EXTERNAL DUMPER_RESDNM
C
C	If the period won't fit in the name, report an error
C
	J = VAXLEN(RESCNT)+1
	IF (J.GT.64) THEN
	 RES_VMIN = %LOC(DUMPER_RESDNM)
	ELSE
	 VAXDIR(RESCNT)(J:J) = '-'
	 VAXLEN(RESCNT) = J
	 RES_VMIN = 1
	ENDIF
	RETURN
	END
	INTEGER*4 FUNCTION SET_ASCII(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine for setting the ASCII I/O mode.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	IOMODE = ASCII
	SET_ASCII = 1
	RETURN
	END
	INTEGER*4 FUNCTION SET_BINARY(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine for setting the BINARY I/O mode.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	IOMODE = BINARY
	SET_BINARY = 1
	RETURN
	END
	INTEGER*4 FUNCTION SET_SILENT(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine for setting the SILENT mode.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	PRMODE = SILENT
	SET_SILENT = 1
	RETURN
	END
	INTEGER*4 FUNCTION SET_FILES(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine for setting the FILES mode.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	PRMODE = FILES
	SET_FILES = 1
	RETURN
	END
	INTEGER*4 FUNCTION SET_LIST(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine for setting the LISTING mode.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	INTEGER*4 L
	CHARACTER*256 NAM
C
	LIST = .TRUE.
	WRITE(6,100)
100	FORMAT(' Enter the listing file name:  ',$)
	READ(5,110) L,NAM
110	FORMAT(Q,A)
	IF (L.EQ.0) THEN
	 IF (LIST) CLOSE(UNIT=2)
	 LIST = .FALSE.
	 SET_LIST = %LOC(DUMPER_NOLIST)
	 RETURN
	ENDIF
	OPEN(UNIT=2,NAME=NAM(1:L),CARRIAGECONTROL='FORTRAN',ERR=120,
	1 INITIALSIZE=1,EXTENDSIZE=1,RECORDSIZE=132,STATUS='NEW')
	SET_LIST = 1
	RETURN
120	CONTINUE
	LIST = .FALSE.
	SET_LIST = %LOC(DUMPER_ABLIST)
	RETURN
	END
	INTEGER*4 FUNCTION SET_NONE(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine for setting the NONE mode.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	ORMODE =  NONE
	SET_NONE = 1
	RETURN
	END
	INTEGER*4 FUNCTION SET_CR(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine for setting the CR mode.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	ORMODE = CR
	SET_CR = 1
	RETURN
	END
	INTEGER*4 FUNCTION SET_FORT(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the action routine for setting the FORTRAN mode.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
C
	ORMODE = FORTRAN
	SET_FORT = 1
	RETURN
	END
	SUBROUTINE VALIDATE(FILESPEC,FSLEN)
C
C	This segment will take a file specification from the
C	BACKUP tape and if this is a file to remove, will then
C	open the file and set FILEOK so that the
C	file will be processed.
C
C	Parameter list arguments:
C
C	FILESPEC -- DEC 10/20 file specification
C	FSLEN    -- Length of the info in FILESPEC
C
	CHARACTER*256 FILESPEC
	INTEGER*4 FSLEN
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
	EXTERNAL DUMPER_IDFE
C
C	LIB$TPARSE parameter information
C
	INTEGER*4 STATUS,LIB$TPARSE
	INTEGER*4 TPBLOK(0:8),STRINGCNT,STRINGPTR
	EXTERNAL TPA$L_COUNT,TPA$L_OPTIONS,TPA$L_STRINGCNT
	EXTERNAL TPA$L_STRINGPTR,TPA$L_TOKENCNT,TPA$L_TOKENPTR
	EXTERNAL TPA$B_CHAR,TPA$L_NUMBER,TPA$L_PARAM
	EXTERNAL TPA$M_BLANKS,TPA$M_ABBRFM,TPA$M_ABBREV
	EXTERNAL TPA$M_AMBIG,TPA$K_COUNT0
C
	EXTERNAL VFINIT,VFKEY
	EXTERNAL VDINIT,VDKEY
C
C	Initialize part of the block
C
	TPBLOK(%LOC(TPA$L_COUNT)/4) = %LOC(TPA$K_COUNT0)
	TPBLOK(%LOC(TPA$L_OPTIONS)/4) = %LOC(TPA$M_ABBREV)
	STRINGCNT = %LOC(TPA$L_STRINGCNT)/4
	STRINGPTR = %LOC(TPA$L_STRINGPTR)/4
C
C	Validate the file name
C
	STELEN = 0
	STNLEN = 0
	FILEOK = .FALSE.
	K = INDEX(FILESPEC(1:FSLEN),']')
	IF (K.EQ.0) THEN
	 CALL ERRORM(%LOC(DUMPER_IDFE),FILESPEC(1:FSLEN))
	 GOVALUE = 0
	 RETURN
	ENDIF
	IF (K.EQ.CDIRLEN) THEN
	 IF (CURDIR(1:K).EQ.FILESPEC(1:K)) THEN
	  IF (NVDIR) RETURN
	  DO I=1,RESCNT-1
	   VALIDF(I) = VALIDD(I)
	  ENDDO
	  TPBLOK(STRINGCNT) = FSLEN-K
	  TPBLOK(STRINGPTR) = %LOC(FILESPEC(K+1:K+1))
	  STATUS = LIB$TPARSE(TPBLOK,VFINIT,VFKEY)
	  IF (STATUS) FILEOK = .TRUE.
	 ELSE
	  DO I=1,RESCNT-1
	   VALIDD(I) = .TRUE.
	  ENDDO
	  TPBLOK(STRINGCNT) = K
	  TPBLOK(STRINGPTR) = %LOC(FILESPEC)
	  TAPECNT = 1
	  STATUS = LIB$TPARSE(TPBLOK,VDINIT,VDKEY)
	  IF (NVDIR) RETURN
	  DO I=1,RESCNT-1
	   VALIDF(I) = VALIDD(I)
	  ENDDO
	  TPBLOK(STRINGCNT) = FSLEN-K
	  TPBLOK(STRINGPTR) = %LOC(FILESPEC(K+1:K+1))
	  STATUS = LIB$TPARSE(TPBLOK,VFINIT,VFKEY)
	  IF (STATUS) FILEOK = .TRUE.
	 ENDIF
	ELSE
	 DO I=1,RESCNT-1
	  VALIDD(I) = .TRUE.
	 ENDDO
	 TPBLOK(STRINGCNT) = K
	 TPBLOK(STRINGPTR) = %LOC(FILESPEC)
	 TAPECNT = 1
	 STATUS = LIB$TPARSE(TPBLOK,VDINIT,VDKEY)
	 IF (NVDIR) RETURN
	 DO I=1,RESCNT-1
	  VALIDF(I) = VALIDD(I)
	 ENDDO
	 TPBLOK(STRINGCNT) = FSLEN-K
	 TPBLOK(STRINGPTR) = %LOC(FILESPEC(K+1:K+1))
	 STATUS = LIB$TPARSE(TPBLOK,VFINIT,VFKEY)
	 IF (STATUS) FILEOK = .TRUE.
	ENDIF
	IF (FILEOK.AND.(PRMODE.EQ.FILES)) WRITE(*,10) FILESPEC(1:FSLEN)
10	FORMAT(' Created from ',A)
	RETURN
	END
	INTEGER*4 FUNCTION VAL_DIR(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the segment that validates directory names from
C	the magtape.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
	LOGICAL COMPBS
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	VAL_DIR = 0
	NVDIR = .FALSE.
	DO I=1,RESCNT-1
	 IF (VALIDD(I)) THEN
	  IF (TAPELEN(TAPECNT,I).EQ.0) THEN
	   VALIDD(I) = .FALSE.
	  ELSE IF (TAPELEN(TAPECNT,I).GT.0) THEN
	   IF (TAPELEN(TAPECNT,I).EQ.%LOC(TLEN)) THEN
	    IF (COMPBS(TAPELEN(TAPECNT,I),TOKEN,TAPENAME(TAPECNT,I))) THEN
	     TAPECNT = TAPECNT+1
	    ELSE
	     VALIDD(I) = .FALSE.
	    ENDIF
	   ELSE
	    VALIDD(I) = .FALSE.
	   ENDIF
	  ENDIF
	  NVDIR = NVDIR .OR. VALIDD(I)
	 ENDIF
	ENDDO
	IF (NVDIR) VAL_DIR = 1
	NVDIR = .NOT.NVDIR
	RETURN
	END
	INTEGER*4 FUNCTION VAL_NAME(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the segment that validates the file name from
C	the magtape.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
	LOGICAL COMPBS
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	VAL_NAME = 0
	DO I=1,RESCNT-1
	 IF (VALIDD(I)) THEN
	  IF (TAPELEN(TAPEMAX-1,I).EQ.0) THEN
	   VALIDF(I) = .FALSE.
	  ELSE IF (TAPELEN(TAPEMAX-1,I).GT.0) THEN
	   IF (TAPELEN(TAPEMAX-1,I).EQ.%LOC(TLEN)) THEN
	    IF (.NOT.COMPBS(TAPELEN(TAPEMAX-1,I),TOKEN,TAPENAME(TAPEMAX-1,I)))
	1 VALIDF(I) = .FALSE.
	   ELSE
	    VALIDF(I) = .FALSE.
	   ENDIF
	  ENDIF
	  IF (VALIDF(I)) VAL_NAME = 1
	 ENDIF
	ENDDO
	IF (VAL_NAME.EQ.1) THEN
	 STNLEN = MIN(9,%LOC(TLEN))
	 DO I=1,STNLEN
	  STNAME(I:I) = CHAR(TOKEN(I))
	 ENDDO
	ENDIF
	RETURN
	END
	INTEGER*4 FUNCTION VAL_EXT(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the segment that validates the extension from
C	the magtape.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
	LOGICAL COMPBS
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	VAL_EXT = 0
	DO I=1,RESCNT-1
	 IF (VALIDD(I)) THEN
	  IF (TAPELEN(TAPEMAX,I).EQ.0) THEN
	   VALIDF(I) = .FALSE.
	  ELSE IF (TAPELEN(TAPEMAX,I).GT.0) THEN
	   IF (TAPELEN(TAPEMAX,I).EQ.%LOC(TLEN)) THEN
	    IF (.NOT.COMPBS(TAPELEN(TAPEMAX,I),TOKEN,TAPENAME(TAPEMAX,I)))
	1 VALIDF(I) = .FALSE.
	   ELSE
	    VALIDF(I) = .FALSE.
	   ENDIF
	  ENDIF
	  IF (VALIDF(I)) VAL_EXT = 1
	 ENDIF
	ENDDO
	IF (VAL_EXT.EQ.1) THEN
	 STELEN = MIN(3,%LOC(TLEN))
	 DO I=1,STELEN
	  STEXT(I:I) = CHAR(TOKEN(I))
	 ENDDO
	ENDIF
	RETURN
	END
	INTEGER*4 FUNCTION VAL_OPEN(OPTION,SLEN,STRING,TLEN,
	1 TOKEN,CHARX,NUMBER,PARAM)
C
C	This is the segment that opens the  output file
C	after validating the names.
C
C	Parameter list description:
C
C	OPT    -- Options given to LIB$TPARSE
C	SLEN   -- Length of remaining string
C	STRING -- Address of remaining string
C	TLEN   -- Length of the matched token
C	TOKEN  -- Address of the matched token
C	CHARX   -- Character matched by a single letter type
C	NUMBER -- Integer value of a matched numeric type
C	PARAM  -- Parameter supplied by state transition
C
	INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
	BYTE STRING(1),TOKEN(1),CHARX
C
	INCLUDE 'DMPCOM.FOR/NOLIST'
	INCLUDE 'DMPRES.FOR/NOLIST'
C
	LOGICAL FAIL
	CHARACTER*1 ANS
	CHARACTER*256 VAXSPEC
	INTEGER*4 VSLEN
	CHARACTER*7 CC(0:2)
	INTEGER*4 RS(0:1)
C
	DATA RS/64,640/
	DATA CC/'NONE','LIST','FORTRAN'/
C
	VAL_OPEN = 0
	FAIL = .FALSE.
	DO I=1,RESCNT
	 IF (VALIDF(I)) THEN
	  VSLEN = 3+VAXLEN(I)+STNLEN+STELEN
	  VAXSPEC(1:VSLEN) = '[' // VAXDIR(I)(1:VAXLEN(I)) // ']' //
	1  STNAME(1:STNLEN) // '.' // STEXT(1:STELEN)
	  OPEN(UNIT=1,NAME=VAXSPEC(1:VSLEN),STATUS='NEW',ERR=50,
	1  CARRIAGECONTROL=CC(ORMODE),RECORDSIZE=RS(IOMODE),
	2  INITIALSIZE=1,EXTENDSIZE=1)
	  VAL_OPEN = 1
	  IF (PRMODE.EQ.FILES) WRITE(*,10) VAXSPEC(1:VSLEN)
10	FORMAT(' Creating ',A)
	  GOTO 200
50	  CONTINUE
	  FAIL = .TRUE.
	  WRITE(*,60) VAXSPEC(1:VSLEN)
60	FORMAT(' Error creating ',A)
	 ENDIF
	ENDDO
C
	IF (FAIL) THEN
70	 WRITE(*,80) 
80	FORMAT(' Errors occurred, enter S to skip this file, A to',/,
	1 ' abort the processing, or F to enter a filename: ',$)
	 READ(5,90) ANS
90	FORMAT(A)
	 IF ((ANS.EQ.'S').OR.(ANS.EQ.'s')) GOTO 200
	 IF ((ANS.EQ.'A').OR.(ANS.EQ.'a')) THEN
	  GO_VALUE = 0
	  RETURN
	 ENDIF
	 IF ((ANS.NE.'F').AND.(ANS.NE.'f')) GOTO 70
	 WRITE(*,100)
100	 FORMAT(' Enter filename: ',$)
	 READ(5,110) VSLEN,VAXSPEC
110	 FORMAT(Q,A)
	 OPEN(UNIT=1,NAME=VAXSPEC(1:VSLEN),STATUS='NEW',ERR=70,
	1 CARRIAGECONTROL=CC(ORMODE),RECORDSIZE=RS(IOMODE),
	2 INITIALSIZE=1,EXTENDSIZE=1)
	 VAL_OPEN = 1
	 IF (PRMODE.EQ.FILES) WRITE(*,10) VAXSPEC(1:VSLEN)
	ENDIF
200	CONTINUE
	RETURN
	END