	PROGRAM DISK_ERASE	! Version 2.1
C***************************************************************************
C***
C***	PROGRAM DISK_ERASE	  Version 2.1
C***
C***	Author :	Jeff C. Cameron
C***			jcam90502@jcameron.com
C***			http://www.jcameron.com
C***
C***	For more VMS stuff :
C***			http://www.jcameron.com/vms
C***
C***	Abstract :
C***
C***	    This program is designed to write fixed and random patterns
C***	to each physical block of a disk drive on a OpenVMS system. This
C***	software will run on OpenVMS version 5.0 or higher. The program
C***	prompt the user for a disk device specification, and then present
C***	the user with a menu of operations. The operations include writing
C***	any one of many fixed patterns or user specified patterns (with or 
C***	without verify), and the ability to check any block on the disk.
C***
C***	Modification History :
C***
C***	Date		Version		Description
C*** -----------------------------------------------------------------------
C***	13-MAR-1990	1.2		Increased Internal buffer size to
C***					allow full track reads and writes, up
C***					to 8000 words.
C***	13-MAR-1990	1.2		VMS 5.x update to include new disk 
C***					types.
C***	06-DEC-1993	1.3		Added logfile for certification.
C***	06-JUN-1994	2.0		Increased buffer size for very large
C***					disks up to 100 sectors per track.
C***					This corrected a bug that occured 
C***					when automatic verify was enabled,
C***					and the total number of sectors on 
C***					disk was greater than 15. Additionally
C***					new disk types were added from the
C***					($DCDEF) include file for FORTRAN
C***					Version 6.1.
C***	27-MAY-1996	2.1		Included verification errors in
C***					output log file.
C*** -----------------------------------------------------------------------
C***
C***	Credits :
C***
C***	    Thanks to Glenn Martin for his modifications to increase the
C***	buffer size to enable full track reads and writes which improved
C***	performance considerably.
C***
C***	Usage :
C***
C***	    This program source file contains all of the FORTRAN code
C***	necessary to compile and link the executable image. The source
C***	should be compiled with the /EXTEND qualifier because some
C***	source lines extend beyond column 72.
C***
C***	    This program uses the OpenVMS screen management facility
C***	to provide various a menus, so it is recommended that it be run
C***	from a VT100 or compatible video terminal.
C***
C***	    This program supports all disk drives sanctioned by digital
C***	as being known disk types. The disk to be erased must be mounted 
C***	foreign to the process prior to running this disk erase program.
C***
C***	    Prior to running this program, the desired disk must be online
C***	and mounted foreign to the running process. In addition, the running
C***	process must have LOGICAL I/O privileges to the desired disk device.
C***
C***	    Additional documentation may be found in the file DISKERAS.TXT
C***	or AA_READ_ME.FIRST which came with this source.
C***
C***************************************************************************
	IMPLICIT INTEGER*4 (S)
	INCLUDE '($SMGDEF)'
	PARAMETER (SMG$_EOF = '00128402'X)	! REMOVE WHEN DEC FIXES BUG
	INTEGER*4 SMGSTAT,PBID, TITLEID,MENUID,DISKID,INSID,ERRID, KBID
	COMMON /SMG_COMMON/ SMGSTAT,PBID,TITLEID,MENUID,DISKID,INSID,ERRID,KBID
C
	PARAMETER (MAXBUFF = 51200)
	LOGICAL*4 DISK_OPENED
	INTEGER*4 DISK_CHAN
	INTEGER*4 DISK_BUFF (MAXBUFF), VERIFY_BUFF (MAXBUFF)
	LOGICAL*4 PROCEDE
	COMMON /DISK_IO/ DISK_OPENED,DISK_CHAN,DISK_BUFF,PROCEDE,VERIFY_BUFF
C
	CHARACTER*40 TITLE /'Disk Erase Utility - V2.1'/
	CHARACTER*80 CREDIT 
	1 /'By Jeff C. Cameron - NORTHROP Electronic Systems Division'/
	CHARACTER*40 DISK_TITLE /'Disk Information'/
	CHARACTER*64 NONE
	INTEGER*4 CTL_MASK
	INTEGER*4 CONTROL_C /'00000008'X/
	INTEGER*4 CONTROL_Y /'02000000'X/
C
	INTEGER*4	ISTAT
C
C***	Logfile common
	INTEGER*4	LOG
	CHARACTER*12	USER
	CHARACTER*9	TODAY
	CHARACTER*8	NOW
	COMMON /LOGFILE/ LOG,USER,TODAY,NOW
C
	EXTERNAL AST_ROUTINE
C
C***	FORMATS
 1	FORMAT (A)
C
C***	Open logfile
	LOG = 15
	OPEN (UNIT=LOG,FILE='DISKERASE',
	1     DEFAULTFILE='SYS$DISK:[]DISKERASE.LOG',
	2     STATUS='NEW',
	3     CARRIAGECONTROL='LIST',
	4     IOSTAT=ISTAT)
	IF (ISTAT .NE. 0) THEN
	    TYPE *,'%DISKERASE-F-LOGOPENFAIL, failed to open logfile.'
	    CALL RT_ERROR (0,ISTAT)
	    CALL EXIT
	ELSE
	    WRITE (LOG,1) ' >>> SECURITY DISK ERASE CERTIFICATION LOG <<<'
	    CALL GET_USERNAME (USER)
	    CALL DATE (TODAY)
	    CALL TIME (NOW)
	    WRITE (LOG,1) ' DiskErase V1.3 Activated on ' // TODAY
	    WRITE (LOG,1) ' at ' // NOW
	    WRITE (LOG,1) ' by user ' // USER
	ENDIF
C
C***	BEGIN BY CREATING THE PASTEBOARD.
	SMGSTAT = SMG$CREATE_PASTEBOARD (PBID,'SYS$OUTPUT',,,)
	IF (.NOT. SMGSTAT) THEN
	    CALL LIB$STOP (%VAL(SMGSTAT))
	ELSE
	ENDIF
C
C***	ENABLE CONTROL-Y AND CONTROL-C TRAPPING
	CTL_MASK = CONTROL_Y + CONTROL_C
	SMGSTAT = SMG$SET_OUT_OF_BAND_ASTS (PBID,CTL_MASK,AST_ROUTINE,)
	IF (.NOT. SMGSTAT) THEN
	    CALL LIB$STOP (%VAL(SMGSTAT))
	ELSE
	ENDIF
C
C***	NOW CREATE THE VIRTUAL DISPLAYS
C***	>>> TITLE
	SMGSTAT = SMG$CREATE_VIRTUAL_DISPLAY (3,80,TITLEID,,SMG$M_BOLD,)
	IF (.NOT. SMGSTAT) THEN
	    TYPE *,' >>> Failed to create TITLE virtual display. <<<'
	    CALL LIB$STOP (%VAL(SMGSTAT))
	ELSE
	ENDIF
C
	SMGSTAT = SMG$PASTE_VIRTUAL_DISPLAY (TITLEID,PBID,1,1,)
	IF (.NOT. SMGSTAT) THEN
	    TYPE *,' >>> Failed to paste TITLE virtual display. <<<'
	    CALL LIB$STOP (%VAL(SMGSTAT))
	ELSE
	ENDIF
C
C>>>	Menu
	SMGSTAT = SMG$CREATE_VIRTUAL_DISPLAY (14,38,MENUID,SMG$M_BORDER,,)
	IF (.NOT. SMGSTAT) THEN
	    TYPE *,' >>> Failed to create MENU virtual display. <<<'
	    CALL LIB$STOP (%VAL(SMGSTAT))
	ELSE
	ENDIF
C
	SMGSTAT = SMG$PASTE_VIRTUAL_DISPLAY (MENUID,PBID,5,2,)
	IF (.NOT. SMGSTAT) THEN
	    TYPE *,' >>> Failed to paste MENU virtual display. <<<'
	    CALL LIB$STOP (%VAL(SMGSTAT))
	ELSE
	ENDIF
C
C>>>	Disk
	SMGSTAT = SMG$CREATE_VIRTUAL_DISPLAY (14,38,DISKID,SMG$M_BORDER,,)
	IF (.NOT. SMGSTAT) THEN
	    TYPE *,' >>> Failed to create DISK virtual display. <<<'
	    CALL LIB$STOP (%VAL(SMGSTAT))
	ELSE
	ENDIF
C
	SMGSTAT = SMG$PASTE_VIRTUAL_DISPLAY (DISKID,PBID,5,42,)
	IF (.NOT. SMGSTAT) THEN
	    TYPE *,' >>> Failed to paste MENU virtual display. <<<'
	    CALL LIB$STOP (%VAL(SMGSTAT))
	ELSE
	ENDIF
C
C>>>	Instructions
	SMGSTAT = SMG$CREATE_VIRTUAL_DISPLAY (2,80,INSID,,SMG$M_REVERSE,)
	IF (.NOT. SMGSTAT) THEN
	    TYPE *,' >>> Failed to create INSTRUCTIONS virtual display. <<<'
	    CALL LIB$STOP (%VAL(SMGSTAT))
	ELSE
	ENDIF
C
	SMGSTAT = SMG$PASTE_VIRTUAL_DISPLAY (INSID,PBID,20,1,)
	IF (.NOT. SMGSTAT) THEN
	    TYPE *,' >>> Failed to paste INSTRUCTIONS virtual display. <<<'
	    CALL LIB$STOP (%VAL(SMGSTAT))
	ELSE
	ENDIF
C
C>>>	Error
	SMGSTAT = SMG$CREATE_VIRTUAL_DISPLAY (2,80,ERRID,,
	1	  SMG$M_BOLD+SMG$M_REVERSE,)
	IF (.NOT. SMGSTAT) THEN
	    TYPE *,' >>> Failed to create ERROR virtual display. <<<'
	    CALL LIB$STOP (%VAL(SMGSTAT))
	ELSE
	ENDIF
C
	SMGSTAT = SMG$PASTE_VIRTUAL_DISPLAY (ERRID,PBID,22,1,)
	IF (.NOT. SMGSTAT) THEN
	    TYPE *,' >>> Failed to paste ERROR virtual display. <<<'
	    CALL LIB$STOP (%VAL(SMGSTAT))
	ELSE
	ENDIF
C
C***	CREATE VIRTUAL KEYBOARD
	SMGSTAT = SMG$CREATE_VIRTUAL_KEYBOARD (KBID,'SYS$INPUT',,)
	IF (.NOT. SMGSTAT) THEN
	    TYPE *,' >>> Failed to create virtual keyboard. <<<'
	    CALL LIB$STOP (%VAL(SMGSTAT))
	ELSE
	ENDIF
C
C***	TITLE
	LT = LENGTH (TITLE)
	ICOL = (80 - (LT*2)) / 2
	SMGSTAT = SMG$PUT_CHARS_HIGHWIDE (TITLEID,TITLE(:LT),1,ICOL,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	LC = LENGTH (CREDIT)
	ICOL = (80 - LC) / 2
	SMGSTAT = SMG$PUT_CHARS (TITLEID,CREDIT(:LC),3,ICOL,,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C	
	LD = LENGTH (DISK_TITLE)
	ICOL = (40 - LD) / 2
	SMGSTAT = SMG$PUT_CHARS (DISKID,DISK_TITLE(:LD),1,ICOL,,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
C***	PRESENT MENU
C
	NONE = 'NONE'
	CALL SHOW_DISK_INFO (NONE,NONE,'                    ',0,0,0,0)
	ITEM_NUMBER = 1
 100	CALL PRESENT_MENU (ITEM_NUMBER)
C
	IF (ITEM_NUMBER .EQ. 1) THEN
	    CALL SELECT_DISK
	    ITEM_NUMBER = 2
	    GO TO 100
	ELSE IF (ITEM_NUMBER .EQ. 2) THEN
	    CALL WRITE_PATTERNS
	    ITEM_NUMBER = 3
	    GO TO 100
	ELSE IF (ITEM_NUMBER .EQ. 3) THEN
	    CALL CHECK_DISK
	    ITEM_NUMBER = 4
	    GO TO 100
	ELSE
	ENDIF
C
C***	DELETE VIRTUAL KEYBOARD, DISPLAYS, and PASTEBOARD.
 1000	SMGSTAT = SMG$DELETE_VIRTUAL_KEYBOARD (KBID)
	CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$DELETE_VIRTUAL_DISPLAY (TITLEID)
	CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$DELETE_VIRTUAL_DISPLAY (MENUID)
	CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$DELETE_VIRTUAL_DISPLAY (DISKID)
	CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$DELETE_VIRTUAL_DISPLAY (INSID)
	CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$DELETE_VIRTUAL_DISPLAY (ERRID)
	CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$DELETE_PASTEBOARD (PBID,1)
	CALL SYS_SIGNAL (SMGSTAT)
C
C***	IF A DISK CHANNEL IS OPEN, DEASSIGN IT
	IF (DISK_OPENED) THEN
	    ISTAT = SYS$DASSGN (%VAL(DISK_CHAN))
	    IF (.NOT. ISTAT) CALL LIB$SIGNAL (%VAL(ISTAT))
	ELSE
	ENDIF
C
C***	Close the log file
	TYPE *,' Logfile : DISKERASE.LOG'
	CALL DATE (TODAY)
	CALL TIME (NOW)
	WRITE (LOG,1) ' Diskerase terminated at ' // TODAY // ' ' // NOW
	CLOSE (UNIT=LOG)
	CALL EXIT
	END
	BLOCKDATA DISK_ERASE_BLOCK_DATA
C
	INTEGER*4 SMGSTAT,PBID, TITLEID,MENUID,DISKID,INSID,ERRID, KBID
	COMMON /SMG_COMMON/ SMGSTAT,PBID,TITLEID,MENUID,DISKID,INSID,ERRID,KBID
C
	PARAMETER (MAXBUFF = 51200)
	LOGICAL*4 DISK_OPENED
	INTEGER*4 DISK_CHAN
	INTEGER*4 DISK_BUFF (MAXBUFF), VERIFY_BUFF (MAXBUFF)
	LOGICAL*4 PROCEDE
	COMMON /DISK_IO/ DISK_OPENED,DISK_CHAN,DISK_BUFF,PROCEDE,VERIFY_BUFF
C
	DATA DISK_OPENED /.FALSE./
	DATA PROCEDE 	/.FALSE./
C
	CHARACTER*80 DISK_NAME,PHY_DISK_NAME
	CHARACTER*20 DISK_TYPE
	INTEGER*4 NUMBER_OF_SECTORS,NUMBER_OF_TRACKS,NUMBER_OF_CYLINDERS
	INTEGER*4 RECORD_SIZE, DEVICE_CLASS,NUMBER_OF_BLOCKS
	INTEGER*4 LONGWORDS_PER_TRACK,BYTES_PER_TRACK
	COMMON /DISK_INFORMATION/ DISK_NAME,PHY_DISK_NAME,DISK_TYPE,
	1	DEVICE_CLASS,NUMBER_OF_SECTORS,NUMBER_OF_TRACKS,
	2	NUMBER_OF_CYLINDERS,RECORD_SIZE,NUMBER_OF_BLOCKS,
	3	LONGWORDS_PER_TRACK,BYTES_PER_TRACK
C
	DATA NUMBER_OF_BLOCKS /102400/
	END
	SUBROUTINE AST_ROUTINE
	IMPLICIT INTEGER*4 (S)
C***************************************************************************
C***
C***	This routine is the async. system trap routine. It get's executed
C***	whenever the user enters a Control-C or a Control-Y. It will create
C***	a virtual display and ask if the user wants to abort the disk 
C***	operations. If no disk operations are in process, then this routine
C***	does nothing except count how many times the AST routine has run.
C***	If it is run 3 or more times, it stops execution.
C***
C***************************************************************************
	INCLUDE '($SMGDEF)'
	PARAMETER (SMG$_EOF = '00128402'X)	! REMOVE WHEN DEC FIXES BUG
	INTEGER*4 SMGSTAT,PBID, TITLEID,MENUID,DISKID,INSID,ERRID, KBID
	COMMON /SMG_COMMON/ SMGSTAT,PBID,TITLEID,MENUID,DISKID,INSID,ERRID,KBID
C
	PARAMETER (MAXBUFF = 51200)
	LOGICAL*4 DISK_OPENED
	INTEGER*4 DISK_CHAN
	INTEGER*4 DISK_BUFF (MAXBUFF), VERIFY_BUFF (MAXBUFF)
	LOGICAL*4 PROCEDE
	COMMON /DISK_IO/ DISK_OPENED,DISK_CHAN,DISK_BUFF,PROCEDE,VERIFY_BUFF
C
C***	LOCAL DECLARATIONS
	INTEGER*4 LOCALID
	INTEGER*4 KEY
	CHARACTER*80 INTERU /'Disk Erasing Interrupted.'/
	CHARACTER*80 PROMPT /'Do you wish to Continue or Abort (C or A) :'/
	CHARACTER*80 ERRLINE /'Please respond with a "C" to continue or "A" to abort.'/
C
	INTEGER*4 AST_COUNT /0/
C
C***	DO NOTHING IF PROCEDE IS FALSE
	AST_COUNT = AST_COUNT + 1
	IF (AST_COUNT .GT. 2) THEN
	    SMGSTAT = SMG$DELETE_PASTEBOARD (PBID,1)
	    CALL SYS_SIGNAL (SMGSTAT)
	    STOP 'Too many ASTs.'
	ELSE
	ENDIF
C
	IF (PROCEDE) THEN
	    AST_COUNT = 0
	    LI = LENGTH (INTERU)
	    LP = LENGTH (PROMPT)
	    IF (LP .GT. LI) THEN
		L = LP + 4
	    ELSE
		L = LI + 4
	    ENDIF
C
	    SMGSTAT = SMG$CREATE_VIRTUAL_DISPLAY (2,L,LOCALID,SMG$M_BORDER,
	1	      SMG$M_BOLD,)
	    IF (.NOT. SMGSTAT) CALL SYS_SIGNAL (SMGSTAT)
C
	    ICOL = (80 - L) / 2
	    SMGSTAT = SMG$PASTE_VIRTUAL_DISPLAY (LOCALID,PBID,11,ICOL,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    ICOL = (L - LI) / 2
	    SMGSTAT = SMG$PUT_CHARS (LOCALID,INTERU(:LI),1,ICOL,
	1	      SMG$M_BOLD+SMG$M_BLINK,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
 10	    ICOL = (L - LP) / 2
	    SMGSTAT = SMG$SET_CURSOR_ABS (LOCALID,2,ICOL)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    LP = LENGTH (PROMPT)
	    KEY = 0
	    SMGSTAT = SMG$READ_KEYSTROKE (KBID,KEY,PROMPT(:LP),,LOCALID)
	    IF (SMGSTAT .NE. SMG$_EOF) CALL SYS_SIGNAL (SMGSTAT)
	    SMGSTAT = SMG$ERASE_DISPLAY (ERRID,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    IF ((KEY .EQ. SMG$K_TRM_LOWERCASE_C) .OR. 
	1       (KEY .EQ. SMG$K_TRM_UPPERCASE_C)) THEN
C
C***		They want to continue.
	        PROCEDE = .TRUE.
	    ELSE IF ((KEY .EQ. SMG$K_TRM_LOWERCASE_A) .OR. 
	1            (KEY .EQ. SMG$K_TRM_UPPERCASE_A)) THEN
C
C***		They want to abort.
	        PROCEDE = .FALSE.
		CALL MAKELOG_ENTRY ('Operation interrupted by Control-Y.')
	    ELSE
C
C***		They pressed an invalid key.
	        LE = LENGTH (ERRLINE)
	        ICOL = (80 - LE) / 2
	        SMGSTAT = SMG$PUT_WITH_SCROLL (ERRID,ERRLINE(:LE),,,,,)
	        CALL SYS_SIGNAL (SMGSTAT)
	        SMGSTAT = SMG$RING_BELL (ERRID,1)
	        CALL SYS_SIGNAL (SMGSTAT)
		GO TO 10
	    ENDIF
C
	    SMGSTAT = SMG$DELETE_VIRTUAL_DISPLAY (LOCALID)
	    CALL SYS_SIGNAL (SMGSTAT)
	ELSE
	ENDIF
C
	RETURN
	END
	SUBROUTINE PRESENT_MENU (ITEM)
	IMPLICIT INTEGER*4 (S)
	INTEGER*4 ITEM
C***************************************************************************
C***
C***	THIS ROUTINE PRESENTS THE MAIN MENU AND RETURN A SELECTION NUMBER
C***
C***	PARAMETER :
C***
C***		ITEM	(I*4)	RETURNED MENU ITEM SELECTED OR -1 FOR EOF
C***
C***************************************************************************
	INCLUDE '($SMGDEF)'
	PARAMETER (SMG$_EOF = '00128402'X)	! REMOVE WHEN DEC FIXES BUG
	INTEGER*4 SMGSTAT,PBID, TITLEID,MENUID,DISKID,INSID,ERRID, KBID
	COMMON /SMG_COMMON/ SMGSTAT,PBID,TITLEID,MENUID,DISKID,INSID,ERRID,KBID
C
C***	ITEM DEFINITIONS
	CHARACTER*24 MENULIST (4) /'1.  Select Disk Device  ',
	1			   '2.  Write Disk Patterns ',
	2			   '3.  Check Disk Blocks   ',
	3			   '4.  Exit back to DCL    '/
C
	CHARACTER*80 INSLINE 
	1 /'Use the up/down arrow keys, or number keys to select item, then press return.'/
	CHARACTER*80 ERRLINE /'Invalid Key Choice.'/
	CHARACTER*40 MENU_TITLE /'Main Menu'/
C
	INTEGER*4 ATTRIBUTE,KEY
C------------------------------------------------------------------------
	LE = LENGTH (ERRLINE)
C
C***	CLEAR menu, instructions, and error pasteboards
	SMGSTAT = SMG$ERASE_DISPLAY (MENUID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$ERASE_DISPLAY (INSID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$ERASE_DISPLAY (ERRID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
C***	Menu title	
	LM = LENGTH (MENU_TITLE)
	ICOL = (40 - LM) / 2
	SMGSTAT = SMG$PUT_CHARS (MENUID,MENU_TITLE(:LM),1,ICOL,,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
C***	Instructions
	LI = LENGTH (INSLINE)
	SMGSTAT = SMG$PUT_WITH_SCROLL (INSID,INSLINE(:LI),,,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
C***	Now Write the menu, with the selected one highlighted
 50	DO I = 1, 4
	    IROW = 2 * I + 1
	    IF (I .EQ. ITEM) THEN
		ATTRIBUTE = SMG$M_BOLD + SMG$M_REVERSE
	    ELSE
		ATTRIBUTE = 0
	    ENDIF
C
	    SMGSTAT = SMG$PUT_CHARS (MENUID,MENULIST(I),IROW,8,,ATTRIBUTE,,)
	    CALL SYS_SIGNAL (SMGSTAT)
	END DO
C
	SMGSTAT = SMG$READ_KEYSTROKE (KBID,KEY,,,MENUID)
	IF (SMGSTAT .NE. SMG$_EOF) CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$ERASE_DISPLAY (ERRID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	IF (KEY .EQ. SMG$K_TRM_UP) THEN
C
C***	    UP ARROW
	    ITEM = ITEM - 1
	    IF (ITEM .LE. 0) ITEM = 4
	ELSE IF (KEY .EQ. SMG$K_TRM_DOWN) THEN
C
C***	    DOWN ARROW
	    ITEM = ITEM + 1
	    IF (ITEM .GT. 4) ITEM = 1
	ELSE IF (KEY .EQ. SMG$K_TRM_CTRLW) THEN
C
C***	    CONTROL-W
	    SMGSTAT = SMG$ERASE_PASTEBOARD (PBID)
	    CALL SYS_SIGNAL (SMGSTAT)
	    SMGSTAT = SMG$REPAINT_SCREEN (PBID)
	    CALL SYS_SIGNAL (SMGSTAT)
	ELSE IF (KEY .EQ. SMG$K_TRM_CTRLZ) THEN
C
C***	    CONTROL-Z
	    ITEM = 4
	    RETURN
	ELSE IF ((KEY .EQ. SMG$K_TRM_ONE) .OR.
	1        (KEY .EQ. SMG$K_TRM_KP1)) THEN
C
C***	    ITEM 1
	    ITEM = 1
	ELSE IF ((KEY .EQ. SMG$K_TRM_TWO) .OR.
	1        (KEY .EQ. SMG$K_TRM_KP2)) THEN
C
C***	    ITEM 2
	    ITEM = 2
	ELSE IF ((KEY .EQ. SMG$K_TRM_THREE) .OR.
	1        (KEY .EQ. SMG$K_TRM_KP3)) THEN
C
C***	    ITEM 3
	    ITEM = 3
	ELSE IF ((KEY .EQ. SMG$K_TRM_FOUR) .OR.
	1        (KEY .EQ. SMG$K_TRM_KP4)) THEN
C
C***	    ITEM 4
	    ITEM = 4
	ELSE IF ((KEY .EQ. SMG$K_TRM_CR) .OR.
	1        (KEY .EQ. SMG$K_TRM_ENTER) .OR.
	2	 (KEY .EQ. SMG$K_TRM_DO)) THEN
C
C***	    ITEM SELECTED
	    RETURN
	ELSE
C
C***	    INVALID KEY
	    ICOL = (80 - LE) / 2
	    SMGSTAT = SMG$PUT_WITH_SCROLL (ERRID,ERRLINE(:LE),,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
	    SMGSTAT = SMG$RING_BELL (ERRID,1)
	    CALL SYS_SIGNAL (SMGSTAT)
	ENDIF
	GO TO 50
C
	END
	SUBROUTINE SELECT_DISK
	IMPLICIT INTEGER*4 (S)
C***************************************************************************
C***
C***	THIS ROUTINE PRESENTS A PROMPT TO INPUT THE DISK TO WORK ON, THEN
C***	OPENS A VMS I/O CHANNEL TO THAT DISK. IF THERE IS A DISK ALREADY
C***	SELECTED AND OPENED, IT WILL BE RELEASED.
C***
C***************************************************************************
	INCLUDE '($SMGDEF)'
	INCLUDE '($DCDEF)'
	PARAMETER (SMG$_EOF = '00128402'X)	! REMOVE WHEN DEC FIXES BUG
	INTEGER*4 SMGSTAT,PBID, TITLEID,MENUID,DISKID,INSID,ERRID, KBID
	COMMON /SMG_COMMON/ SMGSTAT,PBID,TITLEID,MENUID,DISKID,INSID,ERRID,KBID
C
	CHARACTER*80 DISK_NAME,PHY_DISK_NAME
	CHARACTER*20 DISK_TYPE
	INTEGER*4 NUMBER_OF_SECTORS,NUMBER_OF_TRACKS,NUMBER_OF_CYLINDERS
	INTEGER*4 RECORD_SIZE, DEVICE_CLASS,NUMBER_OF_BLOCKS
	INTEGER*4 LONGWORDS_PER_TRACK,BYTES_PER_TRACK
	COMMON /DISK_INFORMATION/ DISK_NAME,PHY_DISK_NAME,DISK_TYPE,
	1	DEVICE_CLASS,NUMBER_OF_SECTORS,NUMBER_OF_TRACKS,
	2	NUMBER_OF_CYLINDERS,RECORD_SIZE,NUMBER_OF_BLOCKS,
	3	LONGWORDS_PER_TRACK,BYTES_PER_TRACK
C
	PARAMETER (MAXBUFF = 51200)
	LOGICAL*4 DISK_OPENED
	INTEGER*4 DISK_CHAN
	INTEGER*4 DISK_BUFF (MAXBUFF), VERIFY_BUFF (MAXBUFF)
	LOGICAL*4 PROCEDE
	COMMON /DISK_IO/ DISK_OPENED,DISK_CHAN,DISK_BUFF,PROCEDE,VERIFY_BUFF
C
	LOGICAL*4 MOUNTED_FOREIGN
	CHARACTER*80 INSLINE 
	1 /'Enter name of disk to process, or Control-Z to return to main menu.'/
	CHARACTER*80 NOTDISK /' is not a valid disk device.'/
	CHARACTER*80 NOTMFOR /' is not mounted foreign to this process.'/
	CHARACTER*80 ERRLINE
	CHARACTER*40 MENU_TITLE /'Select Disk Device'/
C
	INTEGER*4 ITYPE
C------------------------------------------------------------------------
	LND = LENGTH (NOTDISK)
	LNF = LENGTH (NOTMFOR)
C
C***	CLEAR menu, instructions, and error pasteboards
	SMGSTAT = SMG$ERASE_DISPLAY (MENUID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$ERASE_DISPLAY (INSID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$ERASE_DISPLAY (ERRID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
C***	Menu title	
	LM = LENGTH (MENU_TITLE)
	ICOL = (40 - LM) / 2
	SMGSTAT = SMG$PUT_CHARS (MENUID,MENU_TITLE(:LM),1,ICOL,,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
C***	Instructions
	LI = LENGTH (INSLINE)
	SMGSTAT = SMG$PUT_WITH_SCROLL (INSID,INSLINE(:LI),,,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
C***	GET THE NAME OF THE DISK
 10	SMGSTAT = SMG$SET_CURSOR_ABS (MENUID,7,4)
	CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$ERASE_LINE (MENUID,7,4)
	CALL SYS_SIGNAL (SMGSTAT)
C
	SMGSTAT = SMG$READ_STRING (KBID,DISK_NAME,'Disk:',LEN(DISK_NAME),
	1	  ,,,LDN,,MENUID,)
	IF (SMGSTAT .EQ. SMG$_EOF) RETURN
	CALL SYS_SIGNAL (SMGSTAT)
C
	SMGSTAT = SMG$ERASE_DISPLAY (ERRID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	CALL DISK_INFO (DISK_NAME,DEVICE_CLASS,PHY_DISK_NAME,ITYPE,
	1		NUMBER_OF_CYLINDERS,NUMBER_OF_SECTORS,
	2		NUMBER_OF_TRACKS,RECORD_SIZE,MOUNTED_FOREIGN)
	IF (DEVICE_CLASS .NE. DC$_DISK) THEN
	    ERRLINE = DISK_NAME(:LDN) // NOTDISK (:LND)
	    LE = LENGTH (ERRLINE)
	    SMGSTAT = SMG$PUT_WITH_SCROLL (ERRID,ERRLINE(:LE),,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
	    SMGSTAT = SMG$RING_BELL (ERRID,1)
	    CALL SYS_SIGNAL (SMGSTAT)
	    GO TO 10
	ELSE IF (.NOT. MOUNTED_FOREIGN) THEN
	    ERRLINE = DISK_NAME(:LDN) // NOTMFOR (:LNF)
	    LE = LENGTH (ERRLINE)
	    SMGSTAT = SMG$PUT_WITH_SCROLL (ERRID,ERRLINE(:LE),,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
	    SMGSTAT = SMG$RING_BELL (ERRID,1)
	    CALL SYS_SIGNAL (SMGSTAT)
	    GO TO 10
	ELSE
C
	    CALL TRANSLATE_DISK_TYPE (ITYPE,DISK_TYPE)
C
	    NUMBER_OF_BLOCKS = NUMBER_OF_SECTORS 
	1		     * NUMBER_OF_TRACKS 
	2		     * NUMBER_OF_CYLINDERS
C
	    BYTES_PER_TRACK  = RECORD_SIZE
	1		     * NUMBER_OF_SECTORS
C
	    IF (BYTES_PER_TRACK .GT. (MAXBUFF*4)) BYTES_PER_TRACK = MAXBUFF * 4
C
	    LONGWORDS_PER_TRACK = BYTES_PER_TRACK / 4
C
	    CALL SHOW_DISK_INFO (DISK_NAME,PHY_DISK_NAME,DISK_TYPE,
	2		NUMBER_OF_SECTORS,RECORD_SIZE,
	3		NUMBER_OF_TRACKS,NUMBER_OF_CYLINDERS,
	4		NUMBER_OF_BLOCKS,BYTES_PER_TRACK)
	ENDIF
C
C***	IF A DISK IS ALREADY SELECTED, CLOSE IT
	IF (DISK_OPENED) THEN
	    ISTAT = SYS$DASSGN (DISK_CHAN)
	    IF (.NOT. ISTAT) CALL LIB$STOP (%VAL(ISTAT))
	    DISK_OPENED = .FALSE.
	ELSE
	ENDIF
C
C***	OPEN A NEW DISK CHANNEL
	LPDN = LENGTH (PHY_DISK_NAME)
	ISTAT = SYS$ASSIGN (PHY_DISK_NAME(:LPDN),DISK_CHAN,,)
	IF (.NOT. ISTAT) THEN
	    CALL LIB$STOP (%VAL(ISTAT))
	ELSE
	    DISK_OPENED = .TRUE.
	    CALL MAKELOG_ENTRY ('Disk '//PHY_DISK_NAME(1:LPDN)//' selected.')
	ENDIF
C
	RETURN
	END
	SUBROUTINE WRITE_PATTERNS
	IMPLICIT INTEGER*4 (S)
C***************************************************************************
C***
C***	THIS ROUTINE PRESENTS 4 AVAILABLE PATTERNS TO WRITE IN A MENU,
C***	AND ALSO GIVES THE USER THE OPTION TO TURN THE AUTOMATIC VERIFY
C***	FLAG ON AND OFF.
C***
C***            1.  All ones.             
C***		2.  All zeros.            
C***		3.  Random Data.          
C***		4.  User defined character
C***
C***************************************************************************
	INCLUDE '($SMGDEF)'
	INCLUDE '($DCDEF)'
	PARAMETER (SMG$_EOF = '00128402'X)	! REMOVE WHEN DEC FIXES BUG
	INTEGER*4 SMGSTAT,PBID, TITLEID,MENUID,DISKID,INSID,ERRID, KBID
	COMMON /SMG_COMMON/ SMGSTAT,PBID,TITLEID,MENUID,DISKID,INSID,ERRID,KBID
C
	PARAMETER (MAXBUFF = 51200)
	LOGICAL*4 DISK_OPENED
	INTEGER*4 DISK_CHAN
	INTEGER*4 DISK_BUFF (MAXBUFF), VERIFY_BUFF (MAXBUFF)
	LOGICAL*4 PROCEDE
	COMMON /DISK_IO/ DISK_OPENED,DISK_CHAN,DISK_BUFF,PROCEDE,VERIFY_BUFF
C
	CHARACTER*80 DISK_NAME,PHY_DISK_NAME
	CHARACTER*20 DISK_TYPE
	INTEGER*4 NUMBER_OF_SECTORS,NUMBER_OF_TRACKS,NUMBER_OF_CYLINDERS
	INTEGER*4 RECORD_SIZE, DEVICE_CLASS,NUMBER_OF_BLOCKS
	INTEGER*4 LONGWORDS_PER_TRACK,BYTES_PER_TRACK
	COMMON /DISK_INFORMATION/ DISK_NAME,PHY_DISK_NAME,DISK_TYPE,
	1	DEVICE_CLASS,NUMBER_OF_SECTORS,NUMBER_OF_TRACKS,
	2	NUMBER_OF_CYLINDERS,RECORD_SIZE,NUMBER_OF_BLOCKS,
	3	LONGWORDS_PER_TRACK,BYTES_PER_TRACK
C
C***	ITEM DEFINITIONS
	CHARACTER*26 PAT_LIST (5) /'1.  All ones.             ',
	1			   '2.  All zeros.            ',
	2			   '3.  Random Data.          ',
	3			   '4.  User defined character',
	4                          '5.  Toggle Verify ON/OFF  '/
C
	CHARACTER*80 COMPLETE_MESS
	1 /'Disk Pattern write completed.'/
	CHARACTER*80 INSLINE1 
	1 /'Select data pattern to write to disk, with number or arrow keys,'/
	CHARACTER*80 INSLINE2 
	1 /'then press RETURN or Control-Z to return to main menu.'/
	CHARACTER*80 ERRLINE /'Invalid Key Choice.'/
	CHARACTER*80 NODLINE /'WARNING:No disk is selected. Patterns will be written to NULL.'/
 	CHARACTER*40 MENU_TITLE /'Write Patterns to Disk'/
C
	INTEGER*4 ATTRIBUTE,KEY,PATTERN
	LOGICAL*4 VERIFY /.TRUE./
	CHARACTER*21 VSTATE
	CHARACTER*21 VON  /'Automatic Verify ON. '/
	CHARACTER*21 VOFF /'Automatic Verify OFF.'/
C
C------------------------------------------------------------------------
	IF (.NOT. DISK_OPENED) THEN
C
C***	    NO DISK IS OPEN
	    LN = LENGTH (NODLINE)
	    ICOL = (80 - LN) / 2
	    SMGSTAT = SMG$PUT_WITH_SCROLL (ERRID,NODLINE(:LN),,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
	    SMGSTAT = SMG$RING_BELL (ERRID,1)
	    CALL SYS_SIGNAL (SMGSTAT)
	ELSE
	ENDIF
C
	LE = LENGTH (ERRLINE)
C
C***	CLEAR menu, instructions, and error pasteboards
	SMGSTAT = SMG$ERASE_DISPLAY (MENUID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$ERASE_DISPLAY (INSID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$ERASE_DISPLAY (ERRID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
C***	Menu title	
	LM = LENGTH (MENU_TITLE)
	ICOL = (40 - LM) / 2
	SMGSTAT = SMG$PUT_CHARS (MENUID,MENU_TITLE(:LM),1,ICOL,,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
C***	Instructions
	LI = LENGTH (INSLINE1)
	SMGSTAT = SMG$PUT_WITH_SCROLL (INSID,INSLINE1(:LI),,,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	LI = LENGTH (INSLINE2)
	SMGSTAT = SMG$PUT_WITH_SCROLL (INSID,INSLINE2(:LI),,,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	PATTERN = 1
C
C***	Now Write the menu, with the selected one highlighted
 50	IF (VERIFY) THEN
	    VSTATE = VON
	    ATTRIBUTE = SMG$M_REVERSE + SMG$M_BLINK + SMG$M_BOLD
	ELSE
	    VSTATE = VOFF
	    ATTRIBUTE = SMG$M_REVERSE 
	ENDIF
C
	SMGSTAT = SMG$PUT_CHARS (MENUID,VSTATE,13,8,,ATTRIBUTE,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	DO I = 1, 5
	    IROW = 2 * I + 1
	    IF (I .EQ. PATTERN) THEN
		ATTRIBUTE = SMG$M_BOLD + SMG$M_REVERSE
	    ELSE
		ATTRIBUTE = 0
	    ENDIF
C
	    SMGSTAT = SMG$PUT_CHARS (MENUID,PAT_LIST(I),IROW,8,,ATTRIBUTE,,)
	    CALL SYS_SIGNAL (SMGSTAT)
	END DO
C
	SMGSTAT = SMG$READ_KEYSTROKE (KBID,KEY,,,MENUID)
	IF (SMGSTAT .NE. SMG$_EOF) CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$ERASE_DISPLAY (ERRID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	IF (KEY .EQ. SMG$K_TRM_UP) THEN
C
C***	    UP ARROW
	    PATTERN = PATTERN - 1
	    IF (PATTERN .LE. 0) PATTERN = 5
	ELSE IF (KEY .EQ. SMG$K_TRM_DOWN) THEN
C
C***	    DOWN ARROW
	    PATTERN = PATTERN + 1
	    IF (PATTERN .GT. 5) PATTERN = 1
	ELSE IF (KEY .EQ. SMG$K_TRM_CTRLW) THEN
C
C***	    CONTROL-W
	    SMGSTAT = SMG$ERASE_PASTEBOARD (PBID)
	    CALL SYS_SIGNAL (SMGSTAT)
	    SMGSTAT = SMG$REPAINT_SCREEN (PBID)
	    CALL SYS_SIGNAL (SMGSTAT)
	ELSE IF (KEY .EQ. SMG$K_TRM_CTRLZ) THEN
C
C***	    CONTROL-Z
	    RETURN
	ELSE IF ((KEY .EQ. SMG$K_TRM_ONE) .OR.
	1        (KEY .EQ. SMG$K_TRM_KP1)) THEN
C
C***	    ITEM 1
	    PATTERN = 1
	ELSE IF ((KEY .EQ. SMG$K_TRM_TWO) .OR.
	1        (KEY .EQ. SMG$K_TRM_KP2)) THEN
C
C***	    ITEM 2
	    PATTERN = 2
	ELSE IF ((KEY .EQ. SMG$K_TRM_THREE) .OR.
	1        (KEY .EQ. SMG$K_TRM_KP3)) THEN
C
C***	    ITEM 3
	    PATTERN = 3
	ELSE IF ((KEY .EQ. SMG$K_TRM_FOUR) .OR.
	1        (KEY .EQ. SMG$K_TRM_KP4)) THEN
C
C***	    ITEM 4
	    PATTERN = 4
	ELSE IF ((KEY .EQ. SMG$K_TRM_FIVE) .OR.
	1        (KEY .EQ. SMG$K_TRM_KP5)) THEN
C
C***	    ITEM 5
	    PATTERN = 5
	ELSE IF ((KEY .EQ. SMG$K_TRM_CR) .OR.
	1        (KEY .EQ. SMG$K_TRM_ENTER) .OR.
	2	 (KEY .EQ. SMG$K_TRM_DO)) THEN
C
C***	    ITEM SELECTED
	    IF (PATTERN .EQ. 5) THEN
		VERIFY = .NOT. VERIFY
	    ELSE
	        CALL WRITE_PATTERN_TO_DISK (PATTERN,VERIFY)
C
		LI = LENGTH (COMPLETE_MESS) + 1
		COMPLETE_MESS (LI:LI) = CHAR (7)
		SMGSTAT = SMG$PUT_WITH_SCROLL (INSID,COMPLETE_MESS(:LI),,
	1		  SMG$M_BOLD,,,)
		CALL SYS_SIGNAL (SMGSTAT)
C
		LI = LENGTH (INSLINE1)
		SMGSTAT = SMG$PUT_WITH_SCROLL (INSID,INSLINE1(:LI),,,,,)
		CALL SYS_SIGNAL (SMGSTAT)
C
		LI = LENGTH (INSLINE2)
		SMGSTAT = SMG$PUT_WITH_SCROLL (INSID,INSLINE2(:LI),,,,,)
		CALL SYS_SIGNAL (SMGSTAT)
	    ENDIF
	ELSE
C
C***	    INVALID KEY
	    ICOL = (80 - LE) / 2
	    SMGSTAT = SMG$PUT_WITH_SCROLL (ERRID,ERRLINE(:LE),,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
	    SMGSTAT = SMG$RING_BELL (ERRID,1)
	    CALL SYS_SIGNAL (SMGSTAT)
	ENDIF
	GO TO 50
C
	END
	SUBROUTINE WRITE_PATTERN_TO_DISK (PATTERN,VERIFY)
	IMPLICIT INTEGER*4 (S)
	INTEGER*4 PATTERN
	LOGICAL*4 VERIFY
C***************************************************************************
C***
C***	This routine will write the chosen pattern to disk.
C***
C***************************************************************************
	INCLUDE '($IODEF)'
	INCLUDE '($SMGDEF)'
	PARAMETER (SMG$_EOF = '00128402'X)	! REMOVE WHEN DEC FIXES BUG
	INTEGER*4 SMGSTAT,PBID, TITLEID,MENUID,DISKID,INSID,ERRID, KBID
	COMMON /SMG_COMMON/ SMGSTAT,PBID,TITLEID,MENUID,DISKID,INSID,ERRID,KBID
C
	CHARACTER*80 DISK_NAME,PHY_DISK_NAME
	CHARACTER*20 DISK_TYPE
	INTEGER*4 NUMBER_OF_SECTORS,NUMBER_OF_TRACKS,NUMBER_OF_CYLINDERS
	INTEGER*4 RECORD_SIZE, DEVICE_CLASS,NUMBER_OF_BLOCKS
	INTEGER*4 LONGWORDS_PER_TRACK,BYTES_PER_TRACK
	COMMON /DISK_INFORMATION/ DISK_NAME,PHY_DISK_NAME,DISK_TYPE,
	1	DEVICE_CLASS,NUMBER_OF_SECTORS,NUMBER_OF_TRACKS,
	2	NUMBER_OF_CYLINDERS,RECORD_SIZE,NUMBER_OF_BLOCKS,
	3	LONGWORDS_PER_TRACK,BYTES_PER_TRACK
C
	PARAMETER (MAXBUFF = 51200)
	LOGICAL*4 DISK_OPENED
	INTEGER*4 DISK_CHAN
	INTEGER*4 DISK_BUFF (MAXBUFF), VERIFY_BUFF (MAXBUFF)
	LOGICAL*4 PROCEDE
	COMMON /DISK_IO/ DISK_OPENED,DISK_CHAN,DISK_BUFF,PROCEDE,VERIFY_BUFF
C
	LOGICAL*4 RANDOM
	INTEGER*4 WORD_PATTERN,BLOCK_NUMBER
	INTEGER*4 SEED /19480125/
C
	CHARACTER*80 INSLINE 
	1 /'Enter hexadecimal word pattern (8 hexadecimal characters), or Control-Z.'/
	CHARACTER*80 PROCLINE 
	1 /'DISK ERASURE IN PROGRESS. Enter Control-C or Control-Y to interrupt.'/
	CHARACTER*80 TMCLINE 
	1 /'Too many hexadecimal characters. Must be <= 8.'/
	CHARACTER*80 INHLINE 
	1 /'Invalid hexadecimal characters. Please reenter.'/
	CHARACTER*80 VERERRMES
	CHARACTER*10 HEX_PAT, BLKNUMCH
	CHARACTER*8 ZEROS /'00000000'/
	INTEGER*4 LONGWORD
	BYTE BYTEARR (4)
	EQUIVALENCE (BYTEARR(1),LONGWORD)
	CHARACTER*4 VER
C
	LOGICAL*4 SUBSET
	EXTERNAL SUBSET
C
C------------------------------------------------------------------------
	RANDOM = .FALSE.
C
C***	PRESET PATTERNS
	IF (VERIFY) THEN
	    VER = 'on. '
	ELSE
	    VER = 'off.'
	ENDIF
C
	IF (PATTERN .EQ. 1) THEN
C
C***	    ALL 1 s
	    WORD_PATTERN = -1
	    CALL MAKELOG_ENTRY ('Beginning writing all ones, with verify ' // VER)
	ELSE IF (PATTERN .EQ. 2) THEN
C
C***	    ALL 0 s
	    WORD_PATTERN = 0
	    CALL MAKELOG_ENTRY ('Beginning writing all zeros, with verify ' // VER)
	ELSE IF (PATTERN .EQ. 3) THEN
C
C***	    RANDOM
	    RANDOM = .TRUE.
	    CALL MAKELOG_ENTRY ('Beginning writing random data, with verify ' // VER)
	ELSE
C
C***	    User defined pattern
	    SMGSTAT = SMG$ERASE_DISPLAY (INSID,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
	    SMGSTAT = SMG$ERASE_DISPLAY (ERRID,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
	    LI = LENGTH (INSLINE)
 	    SMGSTAT = SMG$PUT_WITH_SCROLL (INSID,INSLINE(:LI),,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
 20	    SMGSTAT = SMG$SET_CURSOR_ABS (MENUID,14,4)
	    CALL SYS_SIGNAL (SMGSTAT)
	    SMGSTAT = SMG$ERASE_LINE (MENUID,14,4)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    SMGSTAT = SMG$READ_STRING (KBID,HEX_PAT,'Hex Pattern:',
	1	      LEN(HEX_PAT),,,,LHP,,MENUID,)
	    IF (SMGSTAT .EQ. SMG$_EOF) RETURN
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    SMGSTAT = SMG$ERASE_DISPLAY (ERRID,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    IF (LHP .GT. 8) THEN
	        LT = LENGTH (TMCLINE)
 	        SMGSTAT = SMG$PUT_WITH_SCROLL (ERRID,TMCLINE(:LT),,,,,)
	        CALL SYS_SIGNAL (SMGSTAT)
		GO TO 20
	    ELSE IF (LHP .LT. 8) THEN
		NZ = 8 - LHP
	        IZ = LHP + 1
		HEX_PAT (IZ:8) = ZEROS(1:NZ)
	    ELSE
	    ENDIF
	    LHP = 8
C
C***	    ARE THEY ALL HEX CHARS
	    CALL UPCASE (HEX_PAT)
	    IF (.NOT. SUBSET(HEX_PAT(1:LHP),'0123456789ABCDEF')) THEN
	        LH = LENGTH (INHLINE)
 	        SMGSTAT = SMG$PUT_WITH_SCROLL (ERRID,INHLINE(:LH),,,,,)
	        CALL SYS_SIGNAL (SMGSTAT)
		GO TO 20
	    ELSE
	    ENDIF
	    DECODE (8,88,HEX_PAT(1:8)) WORD_PATTERN
 88	    FORMAT (Z8)
	    CALL MAKELOG_ENTRY ('Beginning writing user defined pattern of ' //
	1	HEX_PAT(1:LHP) // ', with verify ' // VER)
	ENDIF
C
C***	FILL BUFFER IF NOT RANDOM PATTERN
	IF (.NOT. RANDOM) THEN
	    DO I = 1,LONGWORDS_PER_TRACK
		DISK_BUFF (I) = WORD_PATTERN
	    END DO
	ELSE
	ENDIF
C
	SMGSTAT = SMG$PUT_CHARS (DISKID,'Current Block : ',14,2,,,,)
	CALL SYS_SIGNAL (SMGSTAT)
	LP = LENGTH (PROCLINE)
 	SMGSTAT = SMG$PUT_WITH_SCROLL (INSID,PROCLINE(:LP),,,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	BLOCK_NUMBER = 0
	PROCEDE = .TRUE.
	DO WHILE ((BLOCK_NUMBER .LT. NUMBER_OF_BLOCKS) .AND. PROCEDE)
C
C***	    DO ONLY IF A DISK IS OPENED
	    IF (DISK_OPENED) THEN
C
C***	        IF RANDOM FILL BUFFER WITH RANDOM DATA
	        IF (RANDOM) THEN
	            DO I = 1,LONGWORDS_PER_TRACK
	   	        DISK_BUFF (I) = RAN (SEED) * 2147483647.0 
	            END DO
	        ELSE
	        ENDIF
C
C***	        ISSUE THE QIO
	        ISTAT = SYS$QIOW	(,
	1				%VAL(DISK_CHAN),
	2				%VAL(IO$_WRITELBLK),
	3				,
	4				,
	5				,
	6				%REF(DISK_BUFF),
	7				%VAL(BYTES_PER_TRACK),
	8				%VAL(BLOCK_NUMBER),
	9				,
	1				,
	1				)
	        IF (.NOT. ISTAT) CALL SYS_SIGNAL (ISTAT)
C
C***	        IF VERIFY FLAG IS SET RE READ AND CHECK THE BUFFER
	        IF (VERIFY) THEN
	            ISTAT = SYS$QIOW	(,
	1				%VAL(DISK_CHAN),
	2				%VAL(IO$_READLBLK),
	3				,
	4				,
	5				,
	6				%REF(VERIFY_BUFF),
	7				%VAL(BYTES_PER_TRACK),
	8				%VAL(BLOCK_NUMBER),
	9				,
	1				,
	1				)
	            IF (.NOT. ISTAT) CALL SYS_SIGNAL (ISTAT)
	            NUM_VER_ERR = 0
C
		    DO I = 1,LONGWORDS_PER_TRACK
		        IF (VERIFY_BUFF(I) .NE. DISK_BUFF(I)) NUM_VER_ERR = NUM_VER_ERR + 1
		    END DO
C
	            IF (NUM_VER_ERR .NE. 0) THEN
		        ENCODE (80,90,VERERRMES) NUM_VER_ERR,BLOCK_NUMBER
 90		        FORMAT (I6,' verification errors on logical block',I10,'.')
		        LV = LENGTH (VERERRMES)
	 	        SMGSTAT = SMG$PUT_WITH_SCROLL (ERRID,VERERRMES(:LV),,,,,)
		        CALL SYS_SIGNAL (SMGSTAT)
			CALL MAKELOG_ENTRY (VERERRMES(:LV))
	            ELSE
	            ENDIF
	        ELSE
	        ENDIF
C
	    ELSE
	    ENDIF
C
	    IF ((MOD(BLOCK_NUMBER,(NUMBER_OF_SECTORS*8)) .EQ. 0) .OR.
	1	(BLOCK_NUMBER .LE. 1) .OR.
	2	(BLOCK_NUMBER .GE. (NUMBER_OF_BLOCKS - 1))) THEN
		ENCODE (10,30,BLKNUMCH) BLOCK_NUMBER
 30		FORMAT (I10)
		SMGSTAT = SMG$PUT_CHARS (DISKID,BLKNUMCH,14,22,
	1	          ,SMG$M_UNDERLINE,,)
		CALL SYS_SIGNAL (SMGSTAT)
	    ELSE
	    ENDIF
C
	    BLOCK_NUMBER = BLOCK_NUMBER + NUMBER_OF_SECTORS
	END DO
C
	ENCODE (10,30,BLKNUMCH) NUMBER_OF_BLOCKS
	SMGSTAT = SMG$PUT_CHARS (DISKID,BLKNUMCH,14,22,
	1	                 ,SMG$M_UNDERLINE,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	PROCEDE = .FALSE.
	SMGSTAT = SMG$ERASE_DISPLAY (INSID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
	CALL MAKELOG_ENTRY ('Write operation complete, with verify ' // VER)
C
	RETURN
	END
	SUBROUTINE CHECK_DISK	
	IMPLICIT INTEGER*4 (S)
C***************************************************************************
C***
C***	This routine will alow the user to specify a disk block to examine.
C***
C***************************************************************************
	INCLUDE '($SMGDEF)'
	PARAMETER (SMG$_EOF = '00128402'X)	! REMOVE WHEN DEC FIXES BUG
	INTEGER*4 SMGSTAT,PBID, TITLEID,MENUID,DISKID,INSID,ERRID, KBID
	COMMON /SMG_COMMON/ SMGSTAT,PBID,TITLEID,MENUID,DISKID,INSID,ERRID,KBID
C
	INCLUDE '($IODEF)'
C
	PARAMETER (MAXBUFF = 51200)
	LOGICAL*4 DISK_OPENED
	INTEGER*4 DISK_CHAN
	INTEGER*4 DISK_BUFF (MAXBUFF), VERIFY_BUFF (MAXBUFF)
	LOGICAL*4 PROCEDE
	COMMON /DISK_IO/ DISK_OPENED,DISK_CHAN,DISK_BUFF,PROCEDE,VERIFY_BUFF
C
	CHARACTER*80 DISK_NAME,PHY_DISK_NAME
	CHARACTER*20 DISK_TYPE
	INTEGER*4 NUMBER_OF_SECTORS,NUMBER_OF_TRACKS,NUMBER_OF_CYLINDERS
	INTEGER*4 RECORD_SIZE, DEVICE_CLASS,NUMBER_OF_BLOCKS
	INTEGER*4 LONGWORDS_PER_TRACK,BYTES_PER_TRACK
	COMMON /DISK_INFORMATION/ DISK_NAME,PHY_DISK_NAME,DISK_TYPE,
	1	DEVICE_CLASS,NUMBER_OF_SECTORS,NUMBER_OF_TRACKS,
	2	NUMBER_OF_CYLINDERS,RECORD_SIZE,NUMBER_OF_BLOCKS,
	3	LONGWORDS_PER_TRACK,BYTES_PER_TRACK
C
C***	LOCAL DECLARATIONS
	INTEGER*4 LOCALID,TEMPID
	INTEGER*4 KEY
	INTEGER*4 CURRENT_BLOCK
C
	CHARACTER*80 INSTRUCT1 
	1 /'<Up> = Previous Block, <Down> = Next Block, <^Z> = Main Menu, or'/
	CHARACTER*80 INSTRUCT2 
	1 /'<Pound> (#) to select a specific block by number.'/
	CHARACTER*80 ERRLINE /'Invalid key.'/
	CHARACTER*80 ERRINT /'Invalid integer. Please respecify.'/
	CHARACTER*80 ERRNUM
	CHARACTER*72 BLOCK_LINE
	CHARACTER*10 BLOCK_LABEL,BLOCK_IN
	CHARACTER*26 BLOCK_PROMPT /'Enter Logical Block Number'/
C
	LOGICAL*4 SUBSET
	EXTERNAL SUBSET
C
C***	Create the display window.
	CURRENT_BLOCK = 0
	SMGSTAT = SMG$CREATE_VIRTUAL_DISPLAY (16,78,LOCALID,SMG$M_BORDER,,)
	IF (.NOT. SMGSTAT) CALL SYS_SIGNAL (SMGSTAT)
C
	SMGSTAT = SMG$PASTE_VIRTUAL_DISPLAY (LOCALID,PBID,3,2,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	SMGSTAT = SMG$ERASE_DISPLAY (ERRID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	LI = LENGTH (INSTRUCT1)
	SMGSTAT = SMG$PUT_WITH_SCROLL (INSID,INSTRUCT1(:LI),,,,,)
	CALL SYS_SIGNAL (SMGSTAT)
	LI = LENGTH (INSTRUCT2)
	SMGSTAT = SMG$PUT_WITH_SCROLL (INSID,INSTRUCT2(:LI),,,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
C***	Display Current Block
 25	IF (DISK_OPENED) THEN
	    ISTAT = SYS$QIOW	(,
	1			%VAL(DISK_CHAN),
	2			%VAL(IO$_READLBLK),
	3			,
	4			,
	5			,
	6			%REF(VERIFY_BUFF),
	7			%VAL(RECORD_SIZE),
	8			%VAL(CURRENT_BLOCK),
	9			,
	1			,
	1			)
	    IF (.NOT. ISTAT) CALL SYS_SIGNAL (ISTAT)
	ELSE
	    DO I = 1,127,4
		VERIFY_BUFF (I)   = 4hNo D
		VERIFY_BUFF (I+1) = 4hisk 
		VERIFY_BUFF (I+2) = 4hSele
		VERIFY_BUFF (I+3) = 4hcted
	    END DO
	ENDIF
C
	ENCODE (10,11,BLOCK_LABEL) CURRENT_BLOCK
 11	FORMAT (I10)
	SMGSTAT = SMG$LABEL_BORDER (LOCALID,
	1	'Logical Block Number '//BLOCK_LABEL,SMG$K_TOP,,SMG$M_REVERSE,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	DO I = 0,15
	    ENCODE (72,12,BLOCK_LINE) (VERIFY_BUFF(K+(I*8)),K=1,8)
 12	    FORMAT (8(1X,Z8.8))
	    SMGSTAT = SMG$PUT_CHARS (LOCALID,BLOCK_LINE,I+1,3,,SMG$M_BOLD,,)
	    CALL SYS_SIGNAL (SMGSTAT)
	END DO
C
C***	NOW read keystroke
 10	SMGSTAT = SMG$READ_KEYSTROKE (KBID,KEY,,,LOCALID)
	IF (SMGSTAT .NE. SMG$_EOF) CALL SYS_SIGNAL (SMGSTAT)
C
	SMGSTAT = SMG$ERASE_DISPLAY (ERRID,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	IF (KEY .EQ. SMG$K_TRM_CTRLZ) THEN
C
C***	    Exit
	    GO TO 100
C
	ELSE IF (KEY .EQ. SMG$K_TRM_UP) THEN
C
C***	    Previous Block
	    CURRENT_BLOCK = CURRENT_BLOCK - 1
	    IF (CURRENT_BLOCK .LT. 0) CURRENT_BLOCK = NUMBER_OF_BLOCKS - 1
	ELSE IF (KEY .EQ. SMG$K_TRM_DOWN) THEN
C
C***	    Next Block
	    CURRENT_BLOCK = CURRENT_BLOCK + 1
	    IF (CURRENT_BLOCK .GE. NUMBER_OF_BLOCKS) CURRENT_BLOCK = 0
	ELSE IF (KEY .EQ. SMG$K_TRM_NUMBER_SIGN) THEN
C
C***	    SPECIFY A SPECIFIC LOGICAL BLOCK NUMBER
	    SMGSTAT = SMG$CREATE_VIRTUAL_DISPLAY (2,30,TEMPID,SMG$M_BORDER,,)
	    IF (.NOT. SMGSTAT) CALL SYS_SIGNAL (SMGSTAT)
C
	    SMGSTAT = SMG$PASTE_VIRTUAL_DISPLAY (TEMPID,PBID,9,25,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    SMGSTAT = SMG$PUT_CHARS (TEMPID,BLOCK_PROMPT,1,3,,SMG$M_BOLD,,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
 30	    SMGSTAT = SMG$ERASE_LINE (TEMPID,2,8)
	    CALL SYS_SIGNAL (SMGSTAT)
	    SMGSTAT = SMG$READ_STRING (KBID,BLOCK_IN,'LBN:',LEN(BLOCK_IN),
	1	      ,,,LB,,TEMPID,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    SMGSTAT = SMG$ERASE_DISPLAY (ERRID,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    IF (SUBSET (BLOCK_IN(1:LB),'0123456789')) THEN
		DECODE (LB,31,BLOCK_IN(1:LB)) NUMBER
 31	        FORMAT (I<LB>)
		IF (NUMBER .GE. NUMBER_OF_BLOCKS) THEN
		    ENCODE (80,32,ERRNUM) NUMBER_OF_BLOCKS
 32		    FORMAT ('Valid logical block numbers are from 0 to ',I,
	1		    ', please respecify.')
		    LN = LENGTH (ERRNUM)
		    SMGSTAT = SMG$PUT_WITH_SCROLL (ERRID,ERRNUM(:LN),,,,,)
		    CALL SYS_SIGNAL (SMGSTAT)
		    SMGSTAT = SMG$RING_BELL (ERRID,1)
		    CALL SYS_SIGNAL (SMGSTAT)
		    GO TO 30
		ELSE
		    CURRENT_BLOCK = NUMBER
		ENDIF
	    ELSE
	        LI = LENGTH (ERRINT)
	        SMGSTAT = SMG$PUT_WITH_SCROLL (ERRID,ERRINT(:LI),,,,,)
	        CALL SYS_SIGNAL (SMGSTAT)
	        SMGSTAT = SMG$RING_BELL (ERRID,1)
	        CALL SYS_SIGNAL (SMGSTAT)
	        GO TO 30
	    ENDIF
C
	    SMGSTAT = SMG$DELETE_VIRTUAL_DISPLAY (TEMPID)
	    CALL SYS_SIGNAL (SMGSTAT)
	ELSE
C
C***	    They pressed an invalid key.
	    LE = LENGTH (ERRLINE)
	    SMGSTAT = SMG$PUT_WITH_SCROLL (ERRID,ERRLINE(:LE),,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
	    SMGSTAT = SMG$RING_BELL (ERRID,1)
	    CALL SYS_SIGNAL (SMGSTAT)
	    GO TO 10
	ENDIF
	GO TO 25
C
 100	SMGSTAT = SMG$DELETE_VIRTUAL_DISPLAY (LOCALID)
	CALL SYS_SIGNAL (SMGSTAT)
C
	RETURN
	END
	SUBROUTINE DISK_INFO (DISKNAME,DEVCLASS,DEVNAME,DEVTYPE,
	1		      NUMCYL,NUMSEC,NUMTRA,RECSIZ,MOUNTFOR)
	CHARACTER*64 DISKNAME
	INTEGER*4 DEVCLASS
	CHARACTER*64 DEVNAME
	INTEGER*4 DEVTYPE
	INTEGER*4 NUMCYL,NUMSEC,NUMTRA,RECSIZ
	LOGICAL*4 MOUNTFOR
C***************************************************************************
C***
C***	THIS ROUTINE WILL RETURN THE DISK INFORMATION FOR THE SPECIFIED DISK.
C***	IF THE SPECIFIED DISK IS NOT A DISK DEVICE THEN DEVCLASS WILL NOT BE
C***	EQUAL TO DC$_DISK (AS DEFINED BY THE ($DCDEF) INCLUDE).
C***
C***	PARAMETERS :
C***
C***		DISKNAME	(C*64)	NAME OF DISK FOR WHICH INFORMATION
C***					IS DESIRED.
C***
C***		DEVCLASS	(I*4)	RETURNED DEVICE CLASS. (SHOULD BE
C***					EQUAL TO DC$_DISK)
C***
C***		DEVNAME		(C*64)	RETURNED ACTUAL DEVICE NAME.
C***
C***		DEVTYPE		(I*4)	RETURNED DEVICE TYPE.
C***
C***		NUMCYL		(I*4)	RETURNED NUMBER OF CYLINDERS.
C***
C***		NUMSEC		(I*4)	RETURNED NUMBER OF SECTORS.
C***
C***		NUMTRA		(I*4)	RETURNED NUMBER OF TRACKS.
C***
C***		RECSIZ		(I*4)	RETURNED SIZE OF RECORDS.
C***
C***		MOUNTFOR	(L*4)	RETURNED FLAG INDICATING IF DISK
C***					IS MOUNTED FOREIGN.
C***
C***************************************************************************
	INCLUDE '($SSDEF)'
	INCLUDE '($SYSSRVNAM)'
	INCLUDE '($DVIDEF)'
	INCLUDE '($JPIDEF)'
	INCLUDE '($DCDEF)'
C
C***	I/O STATUS BLOCK
	STRUCTURE /IOSTATBLK/
		INTEGER*2 DISK_STATUS
		INTEGER*2 BYTE_COUNT_HI
		INTEGER*2 BYTE_COUNT_LO
		INTEGER*2 UNUSED
	END STRUCTURE
	RECORD /IOSTATBLK/ IOSB
C
C***	ITEM LIST
	STRUCTURE /GETDVI_ITEM/
            UNION
		MAP
		    INTEGER*2 BUFFER_LEN,ITEM_CODE
                    INTEGER*4 BUFFER_ADDR,RET_LEN_ADDR
		ENDMAP
		MAP
		    INTEGER*4 END_LIST /0/
		ENDMAP
	    END UNION
	END STRUCTURE
	RECORD /GETDVI_ITEM/ ITEM_LIST(10)
C
	INTEGER*4 NULLARG (2)
C
	INTEGER*4 L_DEVCLASS
	CHARACTER*64 L_DEVNAME
	INTEGER*4 L_DEVTYPE
	INTEGER*4 L_NUMCYL,L_NUMSEC,L_NUMTRA,L_RECSIZ
	LOGICAL*4 L_MOUNTFOR
	INTEGER*4 OWN_PID, MY_PID
	INTEGER*4 DUMMY
C
C***	INITIALIZE ITEMLIST FOR SYS$GETJPIW
 	ITEM_LIST(1).ITEM_CODE = JPI$_PID
	ITEM_LIST(1).BUFFER_LEN = 4
	ITEM_LIST(1).BUFFER_ADDR = %LOC(MY_PID)
	ITEM_LIST(1).RET_LEN_ADDR = %LOC(DUMMY)

	ITEM_LIST(2).ITEM_CODE = 0
	ITEM_LIST(2).BUFFER_LEN = 0
	ITEM_LIST(2).BUFFER_ADDR = 0
	ITEM_LIST(2).RET_LEN_ADDR = 0
C
	ISTAT = SYS$GETJPIW (,,,ITEM_LIST,,,)
	CALL SYS_SIGNAL (ISTAT)
C
C***	INITIALIZE ITEMLIST FOR SYS$GETDVIW
 	ITEM_LIST(1).ITEM_CODE = DVI$_DEVCLASS
	ITEM_LIST(1).BUFFER_LEN = 4
	ITEM_LIST(1).BUFFER_ADDR = %LOC(L_DEVCLASS)
	ITEM_LIST(1).RET_LEN_ADDR = %LOC(DUMMY)

	ITEM_LIST(2).ITEM_CODE = DVI$_DEVNAM
	ITEM_LIST(2).BUFFER_LEN = LEN (L_DEVNAME)
	ITEM_LIST(2).BUFFER_ADDR = %LOC(L_DEVNAME)
	ITEM_LIST(2).RET_LEN_ADDR = %LOC(DUMMY)

	ITEM_LIST(3).ITEM_CODE = DVI$_DEVTYPE
	ITEM_LIST(3).BUFFER_LEN = 4
	ITEM_LIST(3).BUFFER_ADDR = %LOC(L_DEVTYPE)
	ITEM_LIST(3).RET_LEN_ADDR = %LOC(DUMMY)

	ITEM_LIST(4).ITEM_CODE = DVI$_CYLINDERS
	ITEM_LIST(4).BUFFER_LEN = 4
	ITEM_LIST(4).BUFFER_ADDR = %LOC(L_NUMCYL)
	ITEM_LIST(4).RET_LEN_ADDR = %LOC(DUMMY)
C
	ITEM_LIST(5).ITEM_CODE = DVI$_SECTORS
	ITEM_LIST(5).BUFFER_LEN = 4
	ITEM_LIST(5).BUFFER_ADDR = %LOC (L_NUMSEC)
	ITEM_LIST(5).RET_LEN_ADDR = %LOC (DUMMY)
C
	ITEM_LIST(6).ITEM_CODE = DVI$_TRACKS
	ITEM_LIST(6).BUFFER_LEN = 4
	ITEM_LIST(6).BUFFER_ADDR = %LOC (L_NUMTRA)
	ITEM_LIST(6).RET_LEN_ADDR = %LOC (DUMMY)
C
	ITEM_LIST(7).ITEM_CODE = DVI$_DEVBUFSIZ
	ITEM_LIST(7).BUFFER_LEN = 4
	ITEM_LIST(7).BUFFER_ADDR = %LOC (L_RECSIZ)
	ITEM_LIST(7).RET_LEN_ADDR = %LOC (DUMMY)
C
	ITEM_LIST(8).ITEM_CODE = DVI$_FOR
	ITEM_LIST(8).BUFFER_LEN = 4
	ITEM_LIST(8).BUFFER_ADDR = %LOC (L_MOUNTFOR)
	ITEM_LIST(8).RET_LEN_ADDR = %LOC (DUMMY)
C
	ITEM_LIST(9).ITEM_CODE = DVI$_PID
	ITEM_LIST(9).BUFFER_LEN = 4
	ITEM_LIST(9).BUFFER_ADDR = %LOC (OWN_PID)
	ITEM_LIST(9).RET_LEN_ADDR = %LOC (DUMMY)
C
	ITEM_LIST(10).ITEM_CODE = 0
	ITEM_LIST(10).BUFFER_LEN = 0
	ITEM_LIST(10).BUFFER_ADDR = 0
	ITEM_LIST(10).RET_LEN_ADDR = 0
C
C***	MAKE THE SYSTEM SERVICE CALL
	LD = LENGTH (DISKNAME)
	ISTAT = SYS$GETDVIW (,,DISKNAME(:LD),ITEM_LIST,IOSB,,,NULLARG)
	IF ((ISTAT .EQ. SS$_IVDEVNAM) .OR. (ISTAT .EQ. SS$_IVLOGNAM) .OR.
	1   (ISTAT .EQ. SS$_NOSUCHDEV)) THEN
	    L_DEVCLASS = 0
	ELSE
	    CALL SYS_SIGNAL (ISTAT)
	ENDIF
C
C***	RETURN VALUES FOR DISK
	DEVCLASS = L_DEVCLASS
	IF (L_DEVCLASS .EQ. DC$_DISK) THEN
	    DEVNAME = L_DEVNAME
	    DEVTYPE = L_DEVTYPE
	    NUMCYL = L_NUMCYL
	    NUMSEC = L_NUMSEC
	    NUMTRA = L_NUMTRA
	    RECSIZ = L_RECSIZ
	    IF (MY_PID .EQ. OWN_PID) THEN
	        MOUNTFOR = L_MOUNTFOR
	    ELSE
		MOUNTFOR = .FALSE.
	    ENDIF
	ELSE
	    DEVNAME = 'NON-DISK'
	    DEVTYPE = 0
	    NUMCYL = 0
	    NUMSEC = 0
	    NUMTRA = 0
	    RECSIZ = 0
	    MOUNTFOR = .FALSE.
	ENDIF
C
	RETURN
	END

	SUBROUTINE SHOW_DISK_INFO (NAME,FULLNAME,TYPE,
	1			   NSEC,RSIZ,TRKS,CYLS,BLKS,BPTR)
	IMPLICIT INTEGER*4 (S)
	CHARACTER*64 NAME,FULLNAME
	CHARACTER*20 TYPE
	INTEGER*4 NSEC,RSIZ,TRKS,CYLS,BLKS,BPTR
C*********************************************************************
C***
C***	THIS ROUTINE WILL DISPLAY THE DISK INFORMATION IN THE DISK
C***	DISPLAY WINDOW.
C***
C***	PARAMETERS :
C***
C***		NAME		(C*64)	SPECIFIED DISK NAME.
C***
C***		FULLNAME	(C*64)  FULL DISKNAME.
C***
C***		TYPE		(C*20)  DISK TYPE.
C***
C***		NSEC		(I*4)	NUMBER OF SECTORS.
C***
C***		RSIZ		(I*4)	RECORD SIZE.
C***
C***		TRKS		(I*4)	NUMBER OF TRACKS.
C***
C***		CYLS		(I*4)	NUMBER OF CYLINDERS.
C***
C***		BLKS		(I*4)	NUMBER OF LOGICAL BLOCKS.
C***
C***		BPTR		(I*4)	NUMBER OF BYTES PER TRACK.
C***
C*********************************************************************
	INCLUDE '($SMGDEF)'
	PARAMETER (SMG$_EOF = '00128402'X)	! REMOVE WHEN DEC FIXES BUG
	INTEGER*4 SMGSTAT,PBID, TITLEID,MENUID,DISKID,INSID,ERRID, KBID
	COMMON /SMG_COMMON/ SMGSTAT,PBID,TITLEID,MENUID,DISKID,INSID,ERRID,KBID
C
	CHARACTER*40 L_NAME
	CHARACTER*32 L_FULLNAME, L_TYPE
	CHARACTER*10 L_NSEC, L_RSIZ, L_TRKS, L_CYLS, L_BLKS, L_BPTR
C
	LN = LENGTH (NAME)
	IF (NAME(1:4) .NE. 'NONE') THEN
	    L_NAME = NAME
	    L_FULLNAME = FULLNAME
	    L_TYPE = TYPE
	    ENCODE (10,10,L_NSEC) NSEC
	    ENCODE (10,10,L_RSIZ) RSIZ
	    ENCODE (10,10,L_TRKS) TRKS
	    ENCODE (10,10,L_CYLS) CYLS
	    ENCODE (10,10,L_BLKS) BLKS
	    ENCODE (10,10,L_BPTR) BPTR
 10	FORMAT (I10)
	ELSE
	    L_NAME = 'NONE'
	    L_FULLNAME = ' '
	    L_TYPE = ' '
	    L_NSEC = ' ' 
	    L_RSIZ = ' ' 
	    L_TRKS = ' ' 
	    L_CYLS = ' ' 
	    L_BLKS = ' ' 
	    L_BPTR = ' ' 
C
	    SMGSTAT = SMG$PUT_CHARS (DISKID,'NAME',4,2,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    SMGSTAT = SMG$PUT_CHARS (DISKID,'TYPE',6,2,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    SMGSTAT = SMG$PUT_CHARS (DISKID,'SECTORS',8,2,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    SMGSTAT = SMG$PUT_CHARS (DISKID,'TRACKS',10,2,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    SMGSTAT = SMG$PUT_CHARS (DISKID,'TRKSIZ',12,2,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    SMGSTAT = SMG$PUT_CHARS (DISKID,'BLKSIZ',8,20,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    SMGSTAT = SMG$PUT_CHARS (DISKID,'CYLNDRS',10,20,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	    SMGSTAT = SMG$PUT_CHARS (DISKID,'BLOCKS',12,20,,,,)
	    CALL SYS_SIGNAL (SMGSTAT)
C
	ENDIF
C
	ICOL = (40 - LN) / 2
	SMGSTAT = SMG$ERASE_LINE (DISKID,2,1)
	CALL SYS_SIGNAL (SMGSTAT)
	SMGSTAT = SMG$PUT_CHARS (DISKID,L_NAME(:LN),2,ICOL,,,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	SMGSTAT = SMG$PUT_CHARS (DISKID,L_FULLNAME,4,7,,SMG$M_UNDERLINE,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	SMGSTAT = SMG$PUT_CHARS (DISKID,L_TYPE,6,7,,SMG$M_UNDERLINE,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	SMGSTAT = SMG$PUT_CHARS (DISKID,L_NSEC,8,9,,SMG$M_UNDERLINE,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	SMGSTAT = SMG$PUT_CHARS (DISKID,L_TRKS,10,9,,SMG$M_UNDERLINE,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	SMGSTAT = SMG$PUT_CHARS (DISKID,L_BPTR,12,9,,SMG$M_UNDERLINE,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	SMGSTAT = SMG$PUT_CHARS (DISKID,L_RSIZ,8,27,,SMG$M_UNDERLINE,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	SMGSTAT = SMG$PUT_CHARS (DISKID,L_CYLS,10,27,,SMG$M_UNDERLINE,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
	SMGSTAT = SMG$PUT_CHARS (DISKID,L_BLKS,12,27,,SMG$M_UNDERLINE,,)
	CALL SYS_SIGNAL (SMGSTAT)
C
C***	Make log entry if there is data
	IF (L_NAME(1:4) .NE. 'NONE') THEN
	    CALL MAKELOG_ENTRY ('------ Disk Information -------')
	    CALL MAKELOG_ENTRY ('Disk name    :' // L_NAME(1:LN))
	    CALL MAKELOG_ENTRY ('Full name    :' // L_FULLNAME)
	    CALL MAKELOG_ENTRY ('Disk type    : ' // L_TYPE)
	    CALL MAKELOG_ENTRY ('Sectors      :' // L_NSEC)
	    CALL MAKELOG_ENTRY ('Tracks       :' // L_TRKS)
	    CALL MAKELOG_ENTRY ('Track size   :' // L_BPTR)
	    CALL MAKELOG_ENTRY ('Block size   :' // L_RSIZ)
	    CALL MAKELOG_ENTRY ('Cylinders    :' // L_CYLS)
	    CALL MAKELOG_ENTRY ('Total blocks :' // L_BLKS)
	    CALL MAKELOG_ENTRY ('-------------------------------')
	ELSE
	ENDIF
C
	RETURN
	END
	SUBROUTINE TRANSLATE_DISK_TYPE (TYPECODE,NAME)
	INTEGER*4 TYPECODE
	CHARACTER*20 NAME
C***************************************************************************
C***
C***	THIS ROUTINE WHEN PASSED THE DISK TYPE CODE WILL RETURN A CHARACTER
C***	STRING NAME OF THE DISK TYPE.
C***
C***	PARAMETERS :
C***
C***		TYPECODE	(I*4)	VMS INPUT TYPECODE AS OBTAINED BY
C***					DVI$_DEVTYPE ITEM FROM SYS$GETDVI 
C***					SYSTEM SERVICE.
C***
C***		NAME		(C*20)	RETURNED DISK TYPE NAME
C***
C***************************************************************************
	INCLUDE '($DCDEF)'
C
C***	
	IF (TYPECODE .EQ. DT$_RK06) THEN
	    NAME = 'RK06'
	ELSE IF (TYPECODE .EQ. DT$_RK07) THEN
	    NAME = 'RK07'
	ELSE IF (TYPECODE .EQ. DT$_RP04) THEN
	    NAME = 'RP04'
	ELSE IF (TYPECODE .EQ. DT$_RP05) THEN
	    NAME = 'RP05'
	ELSE IF (TYPECODE .EQ. DT$_RP06) THEN
	    NAME = 'RP06'
	ELSE IF (TYPECODE .EQ. DT$_RM03) THEN
	    NAME = 'RM03'
	ELSE IF (TYPECODE .EQ. DT$_RP07) THEN
	    NAME = 'RP07'
	ELSE IF (TYPECODE .EQ. DT$_RP07HT) THEN
	    NAME = 'RP07HT'
	ELSE IF (TYPECODE .EQ. DT$_RL01) THEN
	    NAME = 'RL01'
	ELSE IF (TYPECODE .EQ. DT$_RL02) THEN
	    NAME = 'RL02'
	ELSE IF (TYPECODE .EQ. DT$_RX02) THEN
	    NAME = 'RX02'
	ELSE IF (TYPECODE .EQ. DT$_RX04) THEN
	    NAME = 'RX04'
	ELSE IF (TYPECODE .EQ. DT$_RM80) THEN
	    NAME = 'RM80'
	ELSE IF (TYPECODE .EQ. DT$_TU58) THEN
	    NAME = 'TU58'
	ELSE IF (TYPECODE .EQ. DT$_RM05) THEN
	    NAME = 'RM05'
	ELSE IF (TYPECODE .EQ. DT$_RX01) THEN
	    NAME = 'RX01'
	ELSE IF (TYPECODE .EQ. DT$_ML11) THEN
	    NAME = 'ML11'
	ELSE IF (TYPECODE .EQ. DT$_RB02) THEN
	    NAME = 'RB02'
	ELSE IF (TYPECODE .EQ. DT$_RB80) THEN
	    NAME = 'RB80'
	ELSE IF (TYPECODE .EQ. DT$_RA80) THEN
	    NAME = 'RA80'
	ELSE IF (TYPECODE .EQ. DT$_RA81) THEN
	    NAME = 'RA81'
	ELSE IF (TYPECODE .EQ. DT$_RA60) THEN
	    NAME = 'RA60'
	ELSE IF (TYPECODE .EQ. DT$_RZ01) THEN
	    NAME = 'RZ01'
	ELSE IF (TYPECODE .EQ. DT$_RC25) THEN
	    NAME = 'RC25'
	ELSE IF (TYPECODE .EQ. DT$_RZF01) THEN
	    NAME = 'RZF01'
	ELSE IF (TYPECODE .EQ. DT$_RCF25) THEN
	    NAME = 'RCF25'
	ELSE IF (TYPECODE .EQ. DT$_RD51) THEN
	    NAME = 'RD51'
	ELSE IF (TYPECODE .EQ. DT$_RX50) THEN
	    NAME = 'RX50'
	ELSE IF (TYPECODE .EQ. DT$_RD52) THEN
	    NAME = 'RD52'
	ELSE IF (TYPECODE .EQ. DT$_RD53) THEN
	    NAME = 'RD53'
	ELSE IF (TYPECODE .EQ. DT$_RD26) THEN
	    NAME = 'RD26'
	ELSE IF (TYPECODE .EQ. DT$_RA82) THEN
	    NAME = 'RA82'
	ELSE IF (TYPECODE .EQ. DT$_RD31) THEN
	    NAME = 'RD31'
	ELSE IF (TYPECODE .EQ. DT$_RD54) THEN
	    NAME = 'RD54'
	ELSE IF (TYPECODE .EQ. DT$_CRX50) THEN
	    NAME = 'CRX50'
	ELSE IF (TYPECODE .EQ. DT$_RRD50) THEN
	    NAME = 'RRD50'
	ELSE IF (TYPECODE .EQ. DT$_GENERIC_DU) THEN
	    NAME = 'GENERIC_DU'
	ELSE IF (TYPECODE .EQ. DT$_RX33) THEN
	    NAME = 'RX33'
	ELSE IF (TYPECODE .EQ. DT$_RX18) THEN
	    NAME = 'RX18'
	ELSE IF (TYPECODE .EQ. DT$_RA70) THEN
	    NAME = 'RA70'
	ELSE IF (TYPECODE .EQ. DT$_RA90) THEN
	    NAME = 'RA90'
	ELSE IF (TYPECODE .EQ. DT$_RD32) THEN
	    NAME = 'RD32'
	ELSE IF (TYPECODE .EQ. DT$_DISK9) THEN
	    NAME = 'DISK9'
	ELSE IF (TYPECODE .EQ. DT$_RX35) THEN
	    NAME = 'RX35'
	ELSE IF (TYPECODE .EQ. DT$_RF30) THEN
	    NAME = 'RF30'
	ELSE IF (TYPECODE .EQ. DT$_RF70) THEN
	    NAME = 'RF70'
	ELSE IF (TYPECODE .EQ. DT$_RF71) THEN
	    NAME = 'RF71'
	ELSE IF (TYPECODE .EQ. DT$_RD33) THEN
	    NAME = 'RD33'
	ELSE IF (TYPECODE .EQ. DT$_ESE20) THEN
	    NAME = 'ESE20'
	ELSE IF (TYPECODE .EQ. DT$_TU56) THEN
	    NAME = 'TU56'
	ELSE IF (TYPECODE .EQ. DT$_RZ22) THEN
	    NAME = 'RZ22'
	ELSE IF (TYPECODE .EQ. DT$_RZ23) THEN
	    NAME = 'RZ23'
	ELSE IF (TYPECODE .EQ. DT$_RZ24) THEN
	    NAME = 'RZ24'
	ELSE IF (TYPECODE .EQ. DT$_RZ55) THEN
	    NAME = 'RZ55'
	ELSE IF (TYPECODE .EQ. DT$_RRD40S) THEN
	    NAME = 'RRD40S'
	ELSE IF (TYPECODE .EQ. DT$_RRD40) THEN
	    NAME = 'RRD40'
	ELSE IF (TYPECODE .EQ. DT$_GENERIC_DK) THEN
	    NAME = 'GENERIC_DK'
	ELSE IF (TYPECODE .EQ. DT$_RX23) THEN
	    NAME = 'RX23'
	ELSE IF (TYPECODE .EQ. DT$_RF31) THEN
	    NAME = 'RF31'
	ELSE IF (TYPECODE .EQ. DT$_RF72) THEN
	    NAME = 'RF72'
	ELSE IF (TYPECODE .EQ. DT$_RAM_DISK) THEN
	    NAME = 'RAM_DISK'
	ELSE IF (TYPECODE .EQ. DT$_RZ25) THEN
	    NAME = 'RZ25'
	ELSE IF (TYPECODE .EQ. DT$_RZ56) THEN
	    NAME = 'RZ56'
	ELSE IF (TYPECODE .EQ. DT$_RZ57) THEN
	    NAME = 'RZ57'
	ELSE IF (TYPECODE .EQ. DT$_RX23S) THEN
	    NAME = 'RX23S'
	ELSE IF (TYPECODE .EQ. DT$_RX33S) THEN
	    NAME = 'RX33S'
	ELSE IF (TYPECODE .EQ. DT$_RA92) THEN
	    NAME = 'RA92'
	ELSE IF (TYPECODE .EQ. DT$_SSTRIPE) THEN
	    NAME = 'SSTRIPE'
	ELSE IF (TYPECODE .EQ. DT$_RZ23L) THEN
	    NAME = 'RZ23L'
	ELSE IF (TYPECODE .EQ. DT$_RX26) THEN
	    NAME = 'RX26'
	ELSE IF (TYPECODE .EQ. DT$_RZ57I) THEN
	    NAME = 'RZ57I'
	ELSE IF (TYPECODE .EQ. DT$_RZ31) THEN
	    NAME = 'RZ31'
	ELSE IF (TYPECODE .EQ. DT$_RZ58) THEN
	    NAME = 'RZ58'
	ELSE IF (TYPECODE .EQ. DT$_SCSI_MO) THEN
	    NAME = 'SCSI_MO'
	ELSE IF (TYPECODE .EQ. DT$_RWZ01) THEN
	    NAME = 'RWZ01'
	ELSE IF (TYPECODE .EQ. DT$_RRD42) THEN
	    NAME = 'RRD42'
	ELSE IF (TYPECODE .EQ. DT$_CD_LOADER_1) THEN
	    NAME = 'CD_LOADER_1'
	ELSE IF (TYPECODE .EQ. DT$_ESE25) THEN
	    NAME = 'ESE25'
	ELSE IF (TYPECODE .EQ. DT$_RFH31) THEN
	    NAME = 'RFH31'
	ELSE IF (TYPECODE .EQ. DT$_RFH72) THEN
	    NAME = 'RFH72'
	ELSE IF (TYPECODE .EQ. DT$_RF73) THEN
	    NAME = 'RF73'
	ELSE IF (TYPECODE .EQ. DT$_RFH73) THEN
	    NAME = 'RFH73'
	ELSE IF (TYPECODE .EQ. DT$_RA72) THEN
	    NAME = 'RA72'
	ELSE IF (TYPECODE .EQ. DT$_RA71) THEN
	    NAME = 'RA71'
	ELSE IF (TYPECODE .EQ. DT$_RAH72) THEN
	    NAME = 'RAH72'
	ELSE IF (TYPECODE .EQ. DT$_RF32) THEN
	    NAME = 'RF32'
	ELSE IF (TYPECODE .EQ. DT$_RF35) THEN
	    NAME = 'RF35'
	ELSE IF (TYPECODE .EQ. DT$_RFH32) THEN
	    NAME = 'RFH32'
	ELSE IF (TYPECODE .EQ. DT$_RFH35) THEN
	    NAME = 'RFH35'
	ELSE IF (TYPECODE .EQ. DT$_RFF31) THEN
	    NAME = 'RFF31'
	ELSE IF (TYPECODE .EQ. DT$_RF31F) THEN
	    NAME = 'RF31F'
	ELSE IF (TYPECODE .EQ. DT$_RZ72) THEN
	    NAME = 'RZ72'
	ELSE IF (TYPECODE .EQ. DT$_RZ73) THEN
	    NAME = 'RZ73'
	ELSE IF (TYPECODE .EQ. DT$_RZ35) THEN
	    NAME = 'RZ35'
	ELSE IF (TYPECODE .EQ. DT$_RZ24L) THEN
	    NAME = 'RZ24L'
	ELSE IF (TYPECODE .EQ. DT$_RZ25L) THEN
	    NAME = 'RZ25L'
	ELSE IF (TYPECODE .EQ. DT$_RZ55L) THEN
	    NAME = 'RZ55L'
	ELSE IF (TYPECODE .EQ. DT$_RZ56L) THEN
	    NAME = 'RZ56L'
	ELSE IF (TYPECODE .EQ. DT$_RZ57L) THEN
	    NAME = 'RZ57L'
	ELSE IF (TYPECODE .EQ. DT$_RA73) THEN
	    NAME = 'RA73'
	ELSE IF (TYPECODE .EQ. DT$_RZ26) THEN
	    NAME = 'RZ26'
	ELSE IF (TYPECODE .EQ. DT$_RZ36) THEN
	    NAME = 'RZ36'
	ELSE IF (TYPECODE .EQ. DT$_RZ74) THEN
	    NAME = 'RZ74'
	ELSE IF (TYPECODE .EQ. DT$_ESE52) THEN
	    NAME = 'ESE52'
	ELSE IF (TYPECODE .EQ. DT$_ESE56) THEN
	    NAME = 'ESE56'
	ELSE IF (TYPECODE .EQ. DT$_ESE58) THEN
	    NAME = 'ESE58'
	ELSE IF (TYPECODE .EQ. DT$_RZ27) THEN
	    NAME = 'RZ27'
	ELSE IF (TYPECODE .EQ. DT$_RZ37) THEN
	    NAME = 'RZ37'
	ELSE IF (TYPECODE .EQ. DT$_RZ34L) THEN
	    NAME = 'RZ34L'
	ELSE IF (TYPECODE .EQ. DT$_RZ35L) THEN
	    NAME = 'RZ35L'
	ELSE IF (TYPECODE .EQ. DT$_RZ36L) THEN
	    NAME = 'RZ36L'
	ELSE IF (TYPECODE .EQ. DT$_RZ38) THEN
	    NAME = 'RZ38'
	ELSE IF (TYPECODE .EQ. DT$_RZ75) THEN
	    NAME = 'RZ75'
	ELSE IF (TYPECODE .EQ. DT$_RZ59) THEN
	    NAME = 'RZ59'
	ELSE IF (TYPECODE .EQ. DT$_RZ13) THEN
	    NAME = 'RZ13'
	ELSE IF (TYPECODE .EQ. DT$_RZ14) THEN
	    NAME = 'RZ14'
	ELSE IF (TYPECODE .EQ. DT$_RZ15) THEN
	    NAME = 'RZ15'
	ELSE IF (TYPECODE .EQ. DT$_RZ16) THEN
	    NAME = 'RZ16'
	ELSE IF (TYPECODE .EQ. DT$_RZ17) THEN
	    NAME = 'RZ17'
	ELSE IF (TYPECODE .EQ. DT$_RZ18) THEN
	    NAME = 'RZ18'
	ELSE IF (TYPECODE .EQ. DT$_EZ51) THEN
	    NAME = 'EZ51'
	ELSE IF (TYPECODE .EQ. DT$_EZ52) THEN
	    NAME = 'EZ52'
	ELSE IF (TYPECODE .EQ. DT$_EZ53) THEN
	    NAME = 'EZ53'
	ELSE IF (TYPECODE .EQ. DT$_EZ54) THEN
	    NAME = 'EZ54'
	ELSE IF (TYPECODE .EQ. DT$_EZ58) THEN
	    NAME = 'EZ58'
	ELSE IF (TYPECODE .EQ. DT$_EF51) THEN
	    NAME = 'EF51'
	ELSE IF (TYPECODE .EQ. DT$_EF52) THEN
	    NAME = 'EF52'
	ELSE IF (TYPECODE .EQ. DT$_EF53) THEN
	    NAME = 'EF53'
	ELSE IF (TYPECODE .EQ. DT$_EF54) THEN
	    NAME = 'EF54'
	ELSE IF (TYPECODE .EQ. DT$_EF58) THEN
	    NAME = 'EF58'
	ELSE IF (TYPECODE .EQ. DT$_RF36) THEN
	    NAME = 'RF36'
	ELSE IF (TYPECODE .EQ. DT$_RF37) THEN
	    NAME = 'RF37'
	ELSE IF (TYPECODE .EQ. DT$_RF74) THEN
	    NAME = 'RF74'
	ELSE IF (TYPECODE .EQ. DT$_RF75) THEN
	    NAME = 'RF75'
	ELSE IF (TYPECODE .EQ. DT$_HSZ10) THEN
	    NAME = 'HSZ10'
	ELSE IF (TYPECODE .EQ. DT$_RZ28) THEN
	    NAME = 'RZ28'
	ELSE IF (TYPECODE .EQ. DT$_FD1) THEN
	    NAME = 'FD1'
	ELSE IF (TYPECODE .EQ. DT$_FD2) THEN
	    NAME = 'FD2'
	ELSE IF (TYPECODE .EQ. DT$_FD3) THEN
	    NAME = 'FD3'
	ELSE IF (TYPECODE .EQ. DT$_FD4) THEN
	    NAME = 'FD4'
	ELSE IF (TYPECODE .EQ. DT$_FD5) THEN
	    NAME = 'FD5'
	ELSE IF (TYPECODE .EQ. DT$_FD6) THEN
	    NAME = 'FD6'
	ELSE IF (TYPECODE .EQ. DT$_FD7) THEN
	    NAME = 'FD7'
	ELSE IF (TYPECODE .EQ. DT$_FD8) THEN
	    NAME = 'FD8'
	ELSE IF (TYPECODE .EQ. DT$_RZ29) THEN
	    NAME = 'RZ29'
	ELSE IF (TYPECODE .EQ. DT$_RZ26L) THEN
	    NAME = 'RZ26L'
	ELSE IF (TYPECODE .EQ. DT$_RRD43) THEN
	    NAME = 'RRD43'
	ELSE IF (TYPECODE .EQ. DT$_RRD44) THEN
	    NAME = 'RRD44'
	ELSE IF (TYPECODE .EQ. DT$_HSX00) THEN
	    NAME = 'HSX00'
	ELSE IF (TYPECODE .EQ. DT$_HSX01) THEN
	    NAME = 'HSX01'
	ELSE IF (TYPECODE .EQ. DT$_RZ26B) THEN
	    NAME = 'RZ26B'
	ELSE IF (TYPECODE .EQ. DT$_RZ27B) THEN
	    NAME = 'RZ27B'
	ELSE IF (TYPECODE .EQ. DT$_RZ28B) THEN
	    NAME = 'RZ28B'
	ELSE IF (TYPECODE .EQ. DT$_RZ29B) THEN
	    NAME = 'RZ29B'
	ELSE IF (TYPECODE .EQ. DT$_RZ73B) THEN
	    NAME = 'RZ73B'
	ELSE IF (TYPECODE .EQ. DT$_RZ74B) THEN
	    NAME = 'RZ74B'
	ELSE IF (TYPECODE .EQ. DT$_RZ75B) THEN
	    NAME = 'RZ75B'
	ELSE IF (TYPECODE .EQ. DT$_RWZ21) THEN
	    NAME = 'RWZ21'
	ELSE IF (TYPECODE .EQ. DT$_RZ27L) THEN
	    NAME = 'RZ27L'
	ELSE IF (TYPECODE .EQ. DT$_HSZ20) THEN
	    NAME = 'HSZ20'
	ELSE IF (TYPECODE .EQ. DT$_HSZ40) THEN
	    NAME = 'HSZ40'
	ELSE IF (TYPECODE .EQ. DT$_HSZ15) THEN
	    NAME = 'HSZ15'
	ELSE IF (TYPECODE .EQ. DT$_RZ26M) THEN
	    NAME = 'RZ26M'
	ELSE IF (TYPECODE .EQ. DT$_RW504) THEN
	    NAME = 'RW504'
	ELSE IF (TYPECODE .EQ. DT$_RW510) THEN
	    NAME = 'RW510'
	ELSE IF (TYPECODE .EQ. DT$_RW514) THEN
	    NAME = 'RW514'
	ELSE IF (TYPECODE .EQ. DT$_RW516) THEN
	    NAME = 'RW516'
	ELSE IF (TYPECODE .EQ. DT$_RWZ52) THEN
	    NAME = 'RWZ52'
	ELSE IF (TYPECODE .EQ. DT$_RWZ53) THEN
	    NAME = 'RWZ53'
	ELSE IF (TYPECODE .EQ. DT$_RWZ54) THEN
	    NAME = 'RWZ54'
	ELSE IF (TYPECODE .EQ. DT$_RWZ31) THEN
	    NAME = 'RWZ31'
	ELSE IF (TYPECODE .EQ. DT$_EZ31) THEN
	    NAME = 'EZ31'
	ELSE IF (TYPECODE .EQ. DT$_EZ32) THEN
	    NAME = 'EZ32'
	ELSE IF (TYPECODE .EQ. DT$_EZ33) THEN
	    NAME = 'EZ33'
	ELSE IF (TYPECODE .EQ. DT$_EZ34) THEN
	    NAME = 'EZ34'
	ELSE IF (TYPECODE .EQ. DT$_EZ35) THEN
	    NAME = 'EZ35'
	ELSE IF (TYPECODE .EQ. DT$_EZ31L) THEN
	    NAME = 'EZ31L'
	ELSE IF (TYPECODE .EQ. DT$_EZ32L) THEN
	    NAME = 'EZ32L'
	ELSE IF (TYPECODE .EQ. DT$_EZ33L) THEN
	    NAME = 'EZ33L'
	ELSE IF (TYPECODE .EQ. DT$_RZ28L) THEN
	    NAME = 'RZ28L'
	ELSE IF (TYPECODE .EQ. DT$_RWZ51) THEN
	    NAME = 'RWZ51'
	ELSE IF (TYPECODE .EQ. DT$_EZ56R) THEN
	    NAME = 'EZ56R'
	ELSE IF (TYPECODE .EQ. DT$_RAID0) THEN
	    NAME = 'RAID0'
	ELSE IF (TYPECODE .EQ. DT$_RAID5) THEN
	    NAME = 'RAID5'
	ELSE
	    NAME = '>> UNKNOWN <<'
	ENDIF
C
	RETURN
	END
	SUBROUTINE SYS_SIGNAL (STATUS)
	INTEGER*4 STATUS
C*********************************************************************
C***
C***	This routine will take the status longword returned by a VMS
C***	system service, or runtime library routine and report to the
C***	SYS$OUTPUT device the error status. Since LIB$SIGNAL will
C***	stop the image if the severity is fatal, this routine will
C***    mask off the severity bit (bit 2) changing the error to a 
C***	warning.
C***
C***	PARAMETER :
C***
C***		STATUS	(I*4) VMS STATUS LONGWORD
C***
C*********************************************************************
C*MCT
	INTEGER*4 LOCAL_STATUS
C
C***	ONLY PROCESS IF THERE IS AN ERROR
	IF (.NOT. STATUS) THEN
	    LOCAL_STATUS = STATUS
	    IF (BJTEST(LOCAL_STATUS,2)) LOCAL_STATUS = LOCAL_STATUS - 4
	    CALL LIB$SIGNAL (%VAL(LOCAL_STATUS))
	ELSE
	ENDIF
C
	RETURN
	END
	INTEGER*4 FUNCTION LENGTH (STRING) !	SUBROUTINE LENGTH
	CHARACTER *(*) STRING
C************************************************************************
C***
C***	THIS FUNCTION DIFFERS FROM THE STANDARD LEN FUNCTION ONLY
C***	IN THAT IT RETURNS THE POSITION OF THE LAST NON-BLANK,
C***	NON-TAB, OR NON-NULL CHARACTER IN THE STRING, RATHER THAN 
C***	THE CAPACITY OF THE STRING VARIABLE.
C***
C************************************************************************
C*MCT
	CHARACTER*1 TAB  /'09'X/
	CHARACTER*1 NULL /'00'X/
C
C***	FIRST DETERMINE THE ACTUAL SIZE OF THE STRING VARIABLE
	I = LEN (STRING)
	IF (I .LE. 0) THEN
	    LENGTH = 0
	    RETURN
	ELSE
	ENDIF
C
10      DO WHILE (((STRING(I:I) .EQ. ' ')   .OR.
	1	   (STRING(I:I) .EQ. TAB)   .OR.
	2	   (STRING(I:I) .EQ. NULL)) .AND.
	3	  (I .GT. 0))
	    I = I - 1
	END DO
	LENGTH = LIMIT (I,0,255)
	END
	INTEGER*4 FUNCTION LIMIT (VALUE,MINIMUM,MAXIMUM) !	SUBROUTINE LIMIT
C	SUBROUTINE LIMIT
	INTEGER*4 VALUE		! INPUT VALUE TO BE LIMITED
	INTEGER*4 MINIMUM	! LOWER LIMIT VALUE
	INTEGER*4 MAXIMUM	! UPPER LIMIT VALUE
C************************************************************************
C***
C***	THIS FUNCTION WILL CLIP VALUE BETWEEN THE MINIMUM LIMIT AND
C***	THE MAXIMUM LIMIT.
C***
C***	PARAMETERS :
C***
C***		VALUE	(I*4)	INPUT VALUE TO BE LIMITED
C***
C***		MINIMUM	(I*4)	LOWWER LIMIT VALUE
C***
C***		MAXIMUM	(I*4)	UPPER LIMIT VALUE
C***
C************************************************************************
C*MCT
	IF (VALUE .GT. MAXIMUM) THEN
	   LIMIT = MAXIMUM
C
	ELSE IF (VALUE .LT. MINIMUM) THEN
	   LIMIT = MINIMUM
C
	ELSE
	   LIMIT = VALUE
	ENDIF
	RETURN
	END
	LOGICAL FUNCTION SUBSET (STRING,CHARSET)
C	SUBROUTINE SUBSET
	CHARACTER*(*) STRING
	CHARACTER*(*) CHARSET
C**************************************************************************
C***
C***	THIS FUNCTION RETURNS TRUE IF ALL CHARACTERS IN THE FIRST CHARACTER
C***	STRING EXIST IN THE SECOND CHARACTER STRING.
C***
C***	PARAMETERS :
C***
C***		STRING	(C*?)	STRING TO BE TESTED
C***
C***		CHARSET	(C*?)	STRING CONTAINING VALID CHARACTERS.
C***
C**************************************************************************
C*MCT
C
	LS = LEN (STRING)
	LC = LEN (CHARSET)
C
C***	CHECK EACH CHARACTER
	DO I = 1,LS
	    DO J = 1,LC
		IF (STRING(I:I) .EQ. CHARSET(J:J)) GO TO 100
	    END DO
	    SUBSET = .FALSE.
	    RETURN
C
C***	    CHARACTER FOUND
 100	    CONTINUE
	END DO
	SUBSET = .TRUE.
	RETURN 
	END
	SUBROUTINE UPCASE (STRING)
	CHARACTER*(*) STRING
C************************************************************************
C***
C***	THIS ROUTINE WILL CONVERT ALL LOWERCASE CHARACTERS IN A STRING
C***	TO UPPERCASE
C***
C***	PARAMETER :
C***
C***		STRING	(C*?)	CHARACTER STRING TO BE CONVERTED
C***
C************************************************************************
C*MCT
C
	J = LEN (STRING)
C
	DO I = 1,J
	   IF (LGE(STRING(I:I),'a') .AND. 
	1      LLE(STRING(I:I),'z')) 
	2	STRING (I:I) = CHAR (ICHAR (STRING(I:I)) - 32)
	END DO
	RETURN
	END
	SUBROUTINE GET_USERNAME (USER)
	IMPLICIT NONE
	CHARACTER*(*)	USER
C**********************************************************************
C***
C***	THIS SUBROUTINE GETS THE USERNAME OF THE CURRENT PROCESS
C***
C***	PARAMETER :
C***		USER	(C*?)	RETURNED USERNAME. MINIMUM SIZE OF
C***				 PARAMETER IS 12 CHARACTERS.
C***
C**********************************************************************
C*VIS
C
C***	Constants
	INCLUDE		'($JPIDEF)'
C
C***	LOCAL DECLARATIONS
	CHARACTER*12	USERNAME
	INTEGER*4	SIZE,ISTAT
	INTEGER*4	ITMLST (3)
	INTEGER*2	ITLST (2)
	EQUIVALENCE	(ITMLST,ITLST)
C
C***	Externals
	INTEGER*4	SYS$GETJPIW
	EXTERNAL 	SYS$GETJPIW
C
C***	BEGIN
	ITLST(1) = 12		! USER NAME BUFFER IS 12 BYTES
	ITLST(2) = JPI$_USERNAME
	ITMLST (2) = %LOC (USERNAME)
	ITMLST (3) = %LOC (SIZE)
	ISTAT = SYS$GETJPIW (,,,ITMLST,,,)
	USER = USERNAME
C
	RETURN
	END
	SUBROUTINE MAKELOG_ENTRY (ENTRY)
	IMPLICIT NONE
	CHARACTER*(*)	ENTRY
C******************************************************************************
C***
C***	This routine makes a timestamped entry in the log file.
C***
C***	PARAMETERS :
C***
C***		ENTRY		(C*?)	Input entry description text.
C***
C***	Author :	Jeff Cameron
C***
C***	Modification history :
C***
C***	Programmer	Date		Description
C*** ----------------------------------------------------------------------
C***	Jeff Cameron	06-DEC-1993	Initially written
C*** ----------------------------------------------------------------------
C***
C******************************************************************************
C
C***	Constants
C
C***	Common blocks
C
C***	Logfile common
	INTEGER*4	LOG
	CHARACTER*12	USER
	CHARACTER*9	TODAY
	CHARACTER*8	NOW
	COMMON /LOGFILE/ LOG,USER,TODAY,NOW
C
C***	Local declarations
C
C***	Externals
C
C***	Formats
 1	FORMAT (A)
C------------------------------------------------------------------------------
C
C***	Begining of executable code.
	CALL DATE (TODAY)
	CALL TIME (NOW)
	WRITE (LOG,1) TODAY // ' ' // NOW // ' : ' // ENTRY
C
C***	All done
	RETURN
	END
	SUBROUTINE RT_ERROR (OUT,ERROR)
	INTEGER*4 OUT		! LOGICAL UNIT TO REPORT TO
	INTEGER*4 ERROR		! FORTRAN RUNTIME ERROR NUMBER
C************************************************************************
C***
C***	THIS ROUTINE WILL REPORT THE RUN-TIME ERROR TO THE LOGICAL UNIT
C***	SPECIFIED.
C***    TWO ERROR TYPES ARE SUPPORTED, 1-68 = SYSTEM: 100-126 = NRTC
C***
C************************************************************************
C*MCT
C
	CHARACTER*40 MESS
	CHARACTER*40 MESSAGE (68), DSK_TAPE (27)
C
	DATA	MESSAGE	/'Not a FORTRAN specific error            ', !  1
	1		 ' * Undefined *                          ', !  2
	1		 ' * Undefined *                          ', !  3
	1		 ' * Undefined *                          ', !  4
	1		 ' * Undefined *                          ', !  5
	1		 ' * Undefined *                          ', !  6
	1		 ' * Undefined *                          ', !  7
	1		 ' * Undefined *                          ', !  8
	1		 ' * Undefined *                          ', !  9
	1		 ' * Undefined *                          ', ! 10
	1		 ' * Undefined *                          ', ! 11
	1		 ' * Undefined *                          ', ! 12
	1		 ' * Undefined *                          ', ! 13
	1		 ' * Undefined *                          ', ! 14
	1		 ' * Undefined *                          ', ! 15
	1		 ' * Undefined *                          ', ! 16
	1		 'Syntax error in NAMELIST input          ', ! 17
	1		 'Too many values for NAMELIST variable   ', ! 18
	1		 'Inv. ref. to variable in NAMELIST input ', ! 19
	1		 'REWIND error                            ', ! 20
	1		 'Duplicate file specifications           ', ! 21
	1		 'Input record too long                   ', ! 22
	1		 'BACKSPACE error                         ', ! 23
	1		 'End-Of-File during read                 ', ! 24
	1		 'Record number outside of range          ', ! 25
	1		 'OPEN or DEFINE FILE required            ', ! 26
	1		 'Too many records in I/O statement       ', ! 27
	1		 'CLOSE error                             ', ! 28
	1		 'File not found                          ', ! 29
	1		 'Open failure                            ', ! 30
	1		 'Mixed file access modes                 ', ! 31
	1		 'Invalid Logical Unit Number             ', ! 32
	1		 'ENDFILE error                           ', ! 33
	1		 'Unit already open                       ', ! 34 
	1		 'Segmented record format error           ', ! 35
	1		 'Attempt to access non-existent record   ', ! 36
	1		 'Inconsistent record number              ', ! 37
	1		 'Error during write operation            ', ! 38
	1		 'Error during read operation             ', ! 39 
	1		 'Recursive I/O operation                 ', ! 40
	1		 'Insufficient virtual memory             ', ! 41
	1		 'No such device                          ', ! 42
	1		 'File name specification error           ', ! 43
	1		 'Inconsistent record type                ', ! 44
	1		 'Keyword value error in OPEN statement   ', ! 45
	1		 'Inconsistent OPEN/CLOSE parameters      ', ! 46
	1		 'Write to READONLY file                  ', ! 47
	1		 'Invalid argument to Runtime lib routine ', ! 48
	1		 'Invalid key specification               ', ! 49
	1		 'Inconsistent key change or duplication  ', ! 50
	1		 'Inconsistent file organization          ', ! 51
	1		 'Specified record locked                 ', ! 52
	1		 'No current record                       ', ! 53
	1		 'REWRITE error                           ', ! 54
	1		 'DELETE error                            ', ! 55
	1		 'UNLOCK error                            ', ! 56
	1		 'FIND error                              ', ! 57
	1		 ' * Undefined *                          ', ! 58
	1		 'List directed I/O syntax error          ', ! 59
	1		 'Infinite format loop                    ', ! 60
	1		 'Format/variable-type mismatch           ', ! 61
	1		 'Syntax error in format                  ', ! 62
	1		 'Output conversion error                 ', ! 63
	1		 'Input conversion error                  ', ! 64
	1		 ' * Undefined *                          ', ! 65
	1		 'Output statement overflows record       ', ! 66
	1		 'Input statement requires too much data  ', ! 67
	1		 'Variable format expression value error  '/ ! 68
C
	DATA   DSK_TAPE /'DSK_OPEN: LUN less than 1               ', ! 100
	1		 'DSK_OPEN: LUN greater than 40		  ', ! 101
	1		 'DSK_OPEN: LUN previously opened by DSK  ', ! 102
	1		 'DSK_OPEN: Record Size too Small	  ', ! 103
	1		 'DSK_OPEN: Record Size Exceedes 8192	  ', ! 104
	1		 'DSK_OPEN: File previosly OPENED by Sys. ', ! 105
	1		 'DSK_OPEN: Accessing Formatted File	  ', ! 106
	1		 'DSK_LINK: LUN Less than 1		  ', ! 107
	1		 'DSK_LINK: LUN Greater than 40		  ', ! 108
	1		 'DSK_LINK: LUN Previously Opened by DSK  ', ! 109
	1		 'DSK_LINK: Record Size too small	  ', ! 110
	1		 'DSK_LINK: Record Size Exceedes 8192	  ', ! 111
	1		 'DSK_LINK: Access is UNKNOWN File no OPEN', ! 112
	1		 'DSK_LINK: File not Opened UNFORMATTED	  ', ! 113
	1		 'DSK_LINK: File not Created SEQUENTIAL	  ', ! 114
	1		 'DSK_LINK: File Access not Opened DIRECT ', ! 115
	1		 'DSK_LINK: FILENAME =not LUN Filename    ', ! 116
	1		 'DSK_LINK: REC_SIZE =not File Record Size', ! 117
	1		 'DSK_CLOSE: LUN  not Opened by DSK_SUBS  ', ! 118
	1		 'DSK_I/O: Inconsistant Record Length	  ', ! 119
	1		 'DSK_OPEN: *** not defined	***	  ', ! 120
	1                'ADSK_: File NOT Accessed - Record Size 0', ! 121
	1                'ADSK_: No Available DSK_ Luns           ', ! 122
	1                'ADSK_: Mis-Match of File-Array-Crop Size', ! 123
	1		 'ADSK_: File NOT Opened Successfully     ', ! 124
	1		 'ADSK_: I/O ERROR - Transfer Terminated  ', ! 125
	1		 'ADSK_: DSK_CLOSE Error Return           '/ ! 126
C
	LOGICAL MESS_ONLY
C
C **********************************************************************
C 
C **    PROCESS THE CALL
C
C **********************************************************************
C
	MESS_ONLY = .FALSE.
	GO TO 10
C
	ENTRY RT_MESSAGE (MESS,ERROR)
	MESS_ONLY = .TRUE.
	GO TO 10
C	
 10	IF (ERROR .EQ. 0) THEN
	   IF (MESS_ONLY) MESS = ' '
	   RETURN
	ELSE IF ( ERROR .GE. 100 .AND. ERROR .LT. 127 ) THEN
	   ERRP = ERROR - 99
	   IF (MESS_ONLY) THEN
		MESS = DSK_TAPE(ERRP)
	   ELSE
           	IF ( OUT .EQ. 0 ) THEN 
              	    TYPE 13,ERROR,DSK_TAPE(ERRP)
           	ELSE
	      	    WRITE (OUT,13) ERROR,DSK_TAPE(ERRP)
	   	ENDIF
 13	   FORMAT (' %%% DISK_SUBS or TAPE_SUBS Run-Time Error Number ',
     1     I5,'. %%%',/,
     2     1X,'(',A40,')' )
	   ENDIF
	ELSE IF (ERROR .LT. 0 .OR. ERROR .GT. 68) THEN
	   IF (MESS_ONLY) THEN
	       ENCODE (40,11,MESS) ERROR
	   ELSE
	       IF ( OUT .EQ. 0 ) THEN
	          TYPE 11,ERROR
	       ELSE
	          WRITE (OUT,11) ERROR
	       ENDIF
 11	       FORMAT (' %FORTRAN Run-Time error : ',I5,'.')
	   ENDIF
	ELSE
	   IF (MESS_ONLY) THEN
		MESS = MESSAGE (ERROR)
	   ELSE
	        IF ( OUT .EQ. 0 ) THEN
	            TYPE 12,ERROR, MESSAGE(ERROR)
	        ELSE
	            WRITE (OUT,12) ERROR, MESSAGE (ERROR)
	        ENDIF
	   ENDIF
 12	   FORMAT (' %%% FORTRAN Run-Time error number : ',I5,'. %%%',/,
	1          1X,'(',A40,')')
	ENDIF
C
	RETURN
	END
