	LOGICAL FUNCTION INTERACTIVE_INPUT

**
*	LOGICAL FUNCTION INTERACTIVE_INPUT ( )
*
*
*	Returns a .TRUE. result if and only if  the  file  SYS$INPUT  is a
*	a terminal device.
*
*	.INDEX ENVIRONMENT>>
*	.INDEX TERMINAL I/O>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*			   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( PCB$V_BATCH   =   'E'X )
	PARAMETER ( DVI$_DEVCLASS =   '4'X )
	PARAMETER ( DC$_TERM      =  '42'X )
	PARAMETER ( SS$_IVDEVNAM  = '144'X )

	CHARACTER*12 DEVICE
	INTEGER ITMLST(4)
	LOGICAL TERM

	COMMON /USER_DATA_/ PID,PROC_STAT


	DEVICE = 'SYS$INPUT:'

	ASSIGN 10 TO IT

	GO TO 30

10	INTERACTIVE_INPUT = TERM

	RETURN



	ENTRY INTERACTIVE_OUTPUT

**
*	LOGICAL FUNCTION INTERACTIVE_OUTPUT ( )
*
*
*	Returns a .TRUE. result if and only if  the file  SYS$OUTPUT  is a
*	a terminal device.
*
*	.INDEX ENVIRONMENT>>
*	.INDEX TERMINAL I/O>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*			   Dahlgren, Virginia  22448
*

	DEVICE = 'SYS$OUTPUT:'

	ASSIGN 20 TO IT

	GO TO 30

20	INTERACTIVE_OUTPUT = TERM

	RETURN



	ENTRY INTERACTIVE_MODE

**
*	LOGICAL FUNCTION INTERACTIVE_MODE ( )
*
*
*	Returns a .TRUE. result if and only if the file  SYS$COMMAND  is a
*	a terminal device.
*
*	.INDEX ENVIRONMENT>>
*	.INDEX TERMINAL I/O>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	25 Aug 1986	   Dahlgren, Virginia  22448
*

	DEVICE = 'SYS$COMMAND:'

	ASSIGN 25 TO IT

	GO TO 30

25	INTERACTIVE_MODE = TERM

	RETURN



	ENTRY BATCH_MODE

**
*	LOGICAL FUNCTION BATCH_MODE ( )
*
*
*	Returns a .TRUE. result if and only if called from a program  run-
*	ning in a batch process.
*
*	.INDEX ENVIRONMENT>>
*	.INDEX BATCH JOBS>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*			   Dahlgren, Virginia  22448
*

	CALL USER_HAS_PRIV(' ')

	BATCH_MODE = IAND(PROC_STAT,ISHFT(1,PCB$V_BATCH)) .NE. 0

	RETURN



30	TERM = .FALSE.

	CALL ITEM_LIST(ITMLST,DVI$_DEVCLASS,DEVCLASS)

	STATUS = SYS$GETDVIW( , , DEVICE , ITMLST , , , , )

	IF (STATUS.EQ.SS$_IVDEVNAM) GO TO IT,(10,20) ! Name ASSIGNed to file

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	TERM = DEVCLASS .EQ. DC$_TERM

	GO TO IT,(10,20)

	END
	LOGICAL FUNCTION USER_HAS_PRIV( PRIV_NAME )

**
*	LOGICAL FUNCTION USER_HAS_PRIV( priv_name )
*
*
*	This function returns a value of .TRUE. if this  process  has  the
*	named privilege (passed as a character string), or returns a value
*	of  .FALSE.  if this process does not have the privilege or if the
*	name is not the name of a known privilege.
*
*	In addition, other information about this process is  returned  in
*	in common /USER_DATA_/:
*
*	    The PID, process status flags, UIC (longwords),
*
*	    The process name, terminal name (if any), user name (strings),
*
*	    The lengths of the valid parts of the name strings (words).
*
*	The format of this common block is:
*
*		INTEGER*4 PID,PROC_STAT,UIC
*		CHARACTER*16 PROCNAME
*		CHARACTER*8 TERMNAME
*		CHARACTER*12 USERNAME
*		INTEGER*2 PNLEN,TNLEN,UNLEN
*
*		COMMON /USER_DATA_/ PID,PROC_STAT,UIC,
*		1		      PROCNAME,TERMNAME,USERNAME,
*		2		       PNLEN,   TNLEN,   UNLEN
*
*
*	If you desire to see information in addition to this, you can have
*	additional data returned by placing your requests  in  the  ITMLST
*	array in common /USER_PRIV_/.  The format of the common block is:
*
*		INTEGER*4 ITMLST(28)
*		COMMON /USER_PRIV_/ ITMLST
*
*	Your requests may start in ITMLST(22).  See the  writeup  for  the
*	$GETJPI  System  Service  in the VAX/VMS System Services Reference
*	Manual for the format of the request (each request uses 3 elements
*	of ITMLST; the last request must be followed by a zero word).  You
*	may define ITMLST to be longer than 28 elements if necessary.
*
*	.INDEX ENVIRONMENT>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	19 Aug 1983 	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) PRIV_NAME
	CHARACTER*6 PRIV
	CHARACTER*186 PRIVS

	INTEGER*4 PID,PROC_STAT,UIC
	CHARACTER*16 PROCNAME
	CHARACTER*8 TERMNAME
	CHARACTER*12 USERNAME
	INTEGER*2 PNLEN,TNLEN,UNLEN

	COMMON /USER_DATA_/ PID,PROC_STAT,UIC,PROCNAME,TERMNAME,USERNAME,
	1				       PNLEN,   TNLEN,   UNLEN

	PARAMETER ( JPI$_PID      = '319'X )
	PARAMETER ( JPI$_PRCNAM   = '31C'X )
	PARAMETER ( JPI$_PROCPRIV = '204'X )
	PARAMETER ( JPI$_STS      = '305'X)
	PARAMETER ( JPI$_TERMINAL = '31D'X )
	PARAMETER ( JPI$_UIC      = '304'X )
	PARAMETER ( JPI$_USERNAME = '202'X )

	INTEGER*4 ITMLST(28) / 28*0 /

	COMMON /USER_PRIV_/ ITMLST

*	ITMLST(22) through ITMLST(27) can be set by the calling program
*	before the first call to USER_HAS_PRIV, to get additional data
*	about the process.

	INTEGER*4 PRIVILEGES
	LOGICAL*1 FIRST_CALL / .TRUE. /

      DATA PRIVS/'CMKRNLCMEXECSYSNAMGRPNAMALLSPODETACHDIAGNOLOG_IOGROUP 
     1ACNT  PRMCEBPRMMBXPSWAPMALTPRISETPRVTMPMBXWORLD MOUNT OPER  EXQUOT
     2NETMBXVOLPROPHY_IOBUGCHKPRMGBLSYSGBLPFNMAPSHMEM SYSPRVBYPASSSYSLCK
     3'/

	IF (FIRST_CALL) THEN

	    FIRST_CALL = .FALSE.

	    SAVE = ITMLST(22)		! (in case user added items already)

	    CALL ITEM_LIST(ITMLST,JPI$_PID,PID,
	1			  JPI$_PRCNAM,PROCNAME,PNLEN,
	2			  JPI$_PROCPRIV,PRIVILEGES,
	3			  JPI$_STS,PROC_STAT,
	4			  JPI$_TERMINAL,TERMNAME,TNLEN,
	5			  JPI$_UIC,UIC,
	6			  JPI$_USERNAME,USERNAME,UNLEN)

	    ITMLST(22) = SAVE

	    STATUS = SYS$GETJPIW(,,,ITMLST,,,)

	    IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	    UNLEN = STR_LEN(USERNAME)

	ENDIF

	PRIV = PRIV_NAME

	I = INDEX(PRIVS,PRIV)

	IF (MOD(I,6).NE.1) GO TO 100

	IF (PRIVS(I:I+5).NE.PRIV) GO TO 100

	USER_HAS_PRIV = IAND(PRIVILEGES,ISHFT(1,I/6)) .NE. 0

	RETURN

100	USER_HAS_PRIV = .FALSE.

	END
	INTEGER FUNCTION SYMBOL_SUBSTITUTE(LINE,NEWLEN,FOUND)

**
*	INTEGER FUNCTION SYMBOL_SUBSTITUTE( line , [newlen] , [found] )
*
*
*	Performs DCL symbol substitution on any symbol  names  found  in a
*	character  string.   The symbol name must be delimited by apostro-
*	phes (single quotes)(').  There should not be two adjacent opening
*	apostrophes, as in some DCL constructs.   If the substring between
*	apostrophes is not a defined DCL symbol, this is not considered an
*	error.
*
*	You may also re-define the delimiters to be  characters other than
*	apostrophes.  The opening and closing delimiters can be different,
*	if desired.   To do this, place the desired characters in the var-
*	iables OPEN and CLOSE, as defined below:
*
*		CHARACTER*1 OPEN,CLOSE
*		COMMON /SYMBOL_SUBS_/ OPEN,CLOSE
*
*	This routine is useful for processing lines  read  from  SYS$INPUT
*	within command procedures, since these lines do not have automatic
*	symbol substitution performed by DCL.
*	
*	LINE is the character string to be processed.   The optional inte-
*	ger  argument  NEWLEN, if supplied, is set upon exit to the length
*	of LINE, not counting any rightmost blanks or tabs, after any sub-
*	stitutions have been made. The optional integer argument FOUND, if
*	supplied,  is set upon exit  to the number of symbol substitutions
*	made.
*
*	The functional result is the status value SS$_NORMAL,  unless sym-
*	bol  substitution caused non-blank, non-tab characters to be trun-
*	cated from the right end of LINE, in which case the  status  value
*	STR$_TRU is returned.
*
*
*	21 Mar 1986	Allow delimiters other than apostrophes.
*
*	.INDEX DCL SYMBOLS>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	16 Feb 1984	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) LINE

	CHARACTER*256 VALUE

	EXTERNAL SS$_NORMAL, STR$_TRU

	LOGICAL ARG_EXIST

	CHARACTER*1 OPEN,CLOSE

	COMMON /SYMBOL_SUBS_/ OPEN,CLOSE

	DATA OPEN,CLOSE / '''','''' /

	GOOD_LEN = STR_LEN(LINE)

	SYMBOL_SUBSTITUTE = %LOC(SS$_NORMAL)
	SUBS = 0
	COL = 1

10	COL1 = SUBINDEX(LINE, COL, OPEN)
	IF (COL1.EQ.0) GO TO 30

20	COL = SUBINDEX(LINE, COL1+1, CLOSE)
	IF (COL.EQ.0) GO TO 30

	STATUS = LIB$GET_SYMBOL(LINE(COL1+1:COL-1), VALUE, VLEN)

	IF (.NOT.STATUS) THEN	      ! Name between quotes is not a DCL symbol

	    COL1 = COL
	    GO TO 20

	ENDIF	

	SUBS = SUBS + 1

	DELTA = VLEN - (COL - COL1 + 1)

	LINE(COL1:) = VALUE(1:VLEN) // LINE(COL+1:)

	IF (GOOD_LEN+DELTA.GT.LEN(LINE)) THEN

	    SYMBOL_SUBSTITUTE = %LOC(STR$_TRU)
	    GOOD_LEN = LEN(LINE)
	    GO TO 30

	ENDIF

	GOOD_LEN = GOOD_LEN + DELTA
	COL = COL + DELTA + 1
	GO TO 10

30	IF (ARG_EXIST(2)) NEWLEN = GOOD_LEN

	IF (ARG_EXIST(3)) FOUND = SUBS

	END
	INTEGER FUNCTION STR_LEN(STRING)

**
*	INTEGER FUNCTION STR_LEN( string )
*
*
*	Returns, as the functional result, the  length  of  the  character
*	string  argument  STRING,  minus any rightmost blanks and/or tabs.
*
*	.INDEX STRING MANIPULATION>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	26 Feb 1984	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) STRING

	STR_LEN = LEN(STRING)

	DO WHILE (STR_LEN.GT.0)

	    IF ( STRING(STR_LEN:STR_LEN).NE.' ' .AND.
	1		     STRING(STR_LEN:STR_LEN).NE.CHAR(9) ) RETURN

	    STR_LEN = STR_LEN - 1

	ENDDO

	END
	INTEGER FUNCTION SUBINDEX(STRING,COLUMN,PATTERN)

**
*	INTEGER FUNCTION SUBINDEX ( string , column , pattern )
*
*
*	This is very much like the Fortran INDEX built-in function, except
*	that SUBINDEX begins the search at an arbitrary column within  the
*	string.
*
*	STRING is the character string to be searched.  COLUMN is the col-
*	umn number at which to begin the search.  PATTERN is the substring
*	for which we are searching.
*
*	The functional result is zero if the pattern is not found  in  the
*	string.   If the pattern is found, the functional result is set to
*	the column where the first occurrence of the pattern begins.
*
*	The following example shows a common mistake in using SUBINDEX:
*
*	    INCORRECT:   COL = SUBINDEX(STRING(22:),22,' ')
*
*	      CORRECT:   COL = SUBINDEX(STRING,22,' ')
*
*	.INDEX STRING MANIPULATION>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	16 Feb 1984	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) STRING,PATTERN

	INTEGER*2 COLUMN

	SUBINDEX = INDEX(STRING(COLUMN:),PATTERN)

	IF (SUBINDEX.NE.0) SUBINDEX = SUBINDEX + COLUMN - 1

	END
	SUBROUTINE DECLARE_EXIT_HANDLER(ROUTINE,ARGS)

**
*	SUBROUTINE DECLARE_EXIT_HANDLER( routine , [arg2] , ... , [arg9] )
*
*
*	Enables an 'exit handler' routine,  which is a subroutine provided
*	by the user, which VMS calls when the image exits.   More than one
*	exit handler can be enabled; at exit time, they are called in rev-
*	erse order of enabling.  Using DECLARE_EXIT_HANDLER, up to ten ex-
*	it handlers can be enabled.
*
*	Argument ROUTINE is the name of the subroutine to be enabled as an
*	exit handler.  Remember to declare this name EXTERNAL in the call-
*	ing routine.
*
*	The first argument  passed to an exit handler subroutine is always
*	the longword VMS condition value  giving the reason for exit.   Up
*	to eight  other arguments can  optionally be specified.   Remember
*	that if variables are  specified as arguments,  values passed will
*	be the values  at program  exit time,  not the values  at the time
*	DECLARE_EXIT_HANDLER was called.
*
*	If the program decides,  before exiting,  that an exit handler  is
*	no longer needed, it can call CANCEL_EXIT_HANDLER  to tell VMS not
*	to call the exit handler.
*
*	.INDEX PROCESS CONTROL>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	29 Apr 1985	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	INTEGER*4 DESBLK(12,10),STATUS_

	EXTERNAL ROUTINE

	DATA N / 0 /		! Number of exit handlers declared

	N = MIN(N+1,10)

	DESBLK(2,N) = %LOC(ROUTINE)	

	DESBLK(3,N) = MIN(9,NARGS())

	DESBLK(4,N) = %LOC(STATUS_)

	IF (DESBLK(3,N).GT.1) THEN

	    DO I=2,DESBLK(3,N)

		DESBLK(I+3,N) = ARG_ADDRESS(I)

	    ENDDO

	ENDIF

	STATUS_ = SYS$DCLEXH(DESBLK(1,N))

	IF (.NOT.STATUS_) CALL LIB$STOP(%VAL(STATUS))

	RETURN



	ENTRY CANCEL_EXIT_HANDLER(ROUTINE)

**
*	SUBROUTINE CANCEL_EXIT_HANDLER( routine )
*
*
*	Cancels the enabling of an  exit handler routine  which was previ-
*	ously enabled by calling routine  DECLARE_EXIT_HANDLER.   Argument
*	ROUTINE is the name of the exit handler subroutine to be disabled.
*	Remember to declare this name EXTERNAL in the calling routine.
*
*	See routine DECLARE_EXIT_HANDLER for more details.
*
*	.INDEX PROCESS CONTROL>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	29 Apr 1985	   Dahlgren, Virginia  22448
*

	DO I=1,N

	    IF (DESBLK(2,I).EQ.%LOC(ROUTINE)) THEN

		STATUS_ = SYS$CANEXH(DESBLK(1,I))

		IF (.NOT.STATUS_) CALL LIB$STOP(%VAL(STATUS))

		DESBLK(2,I) = 0

	    ENDIF

	ENDDO

	NEW_N = 0

	DO I=1,N

	    IF (DESBLK(2,I).NE.0) NEW_N = I

	ENDDO

	N = NEW_N

	END
	SUBROUTINE CLUSTER_NODE(NODE_NAME,NLEN)

**
*	SUBROUTINE CLUSTER_NODE( node_name , nlen )
*
*
*	Returns the VAXcluster node name  of the node on which this pro-
*	cess is running.   The name is returned  in the character string
*	argument  NODE_NAME, and the length  of the name  is returned in
*	longword integer argument NLEN.
*
*	.INDEX ENVIRONMENT>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	17 Jun 1986	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( SYI$_NODENAME = '10D9'X )

	CHARACTER*(*) NODE_NAME

	INTEGER*4 ITMLST(4),IOSB(2)

	CALL ITEM_LIST(ITMLST,SYI$_NODENAME,NODE_NAME,NLEN)

	STATUS = SYS$GETSYIW(,,,ITMLST,IOSB,,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1)))

	END
	LOGICAL FUNCTION CLUSTER_MEMBER(NODE_NAME)

**
*	LOGICAL FUNCTION CLUSTER_MEMBER( node_name )
*
*
*	Returns an indication of whether the specified node is currently
*	a member of the VAXcluster on which the process is running.  The
*	NODE_NAME argument  is a character string containing the name of
*	the node to be checked.   The string must not  include rightmost
*	blanks; it can be in lowercase.
*
*	.INDEX ENVIRONMENT>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	17 Jun 1986	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( SYI$_CLUSTER_MEMBER = '10CF'X )

	CHARACTER*(*) NODE_NAME

	CHARACTER*16 NODE

	INTEGER*4 ITMLST(4),IOSB(2)

	LOGICAL FLAG

	EXTERNAL SS$_NOSUCHNODE

	NLEN = LEN(NODE_NAME)

	CALL STR$UPCASE(NODE(1:NLEN),NODE_NAME)

	CALL ITEM_LIST(ITMLST,SYI$_CLUSTER_MEMBER,FLAG)

	STATUS = SYS$GETSYIW(,,NODE(1:NLEN),ITMLST,IOSB,,)

	IF (STATUS.EQ.%LOC(SS$_NOSUCHNODE) .OR.
	1			   IOSB(1).EQ.%LOC(SS$_NOSUCHNODE)) THEN

	    CLUSTER_MEMBER = .FALSE.

	ELSE IF (.NOT.STATUS) THEN

	    CALL LIB$STOP(%VAL(STATUS))

	ELSE IF (.NOT.IOSB(1)) THEN

	    CALL LIB$STOP(%VAL(IOSB(1)))

	ELSE

	    CLUSTER_MEMBER = FLAG

	ENDIF

	END
	INTEGER FUNCTION FILE_NAME_INFO(FILENAME,FLAGS)

**
*	INTEGER FUNCTION FILE_NAME_INFO( filename [ , flags ] )
*
*
*	Obtains various items of information about a file name.  The input
*	string  FILENAME  contains the name to be interrogated.  Wildcards
*	may be present, and parts  (even all)  of the name may be omitted.
*	The file  does not have to exist  (but any device,  directory,  or
*	node name specified  must exist, or you will  get an error status,
*	unless you use the FLAGS argument--see below).
*
*	The function result is the status returned by the RMS $PARSE oper-
*	ation.   The possible values are documented  under the description
*	of the $PARSE service in the VAX RMS Reference Manual. An error is
*	most likely to be a syntax error in a part of the name, or a node,
*	device, or directory which is unknown.
*
*	.INDEX FILE NAMES>>
*
*	The information about FILENAME is returned  in variables in common
*	block /FILE_NAME_INFO_/.  The definition of this block is:
*
*		INTEGER*4 FNB,FN_LEN
*		CHARACTER*256 FULLNAME
*		INTEGER*2 FIELDS(6,2)
*
*		COMMON /FILE_NAME_INFO_/ FNB,FN_LEN,FULLNAME,FIELDS
*
*	The information is:
*
*	  FNB -- a longword bit string giving status information about the
*		 file name.   The definitions of the bits are found in the
*		 VAX  RMS  Reference Manual,  in the discussion of the FNB
*		 field of the NAM block (section 6.13).  To get these def-
*		 initions in your Fortran program, use the statement:
*
*				INCLUDE '($NAMDEF)'
*
*		 An example of one of the bits is NAM$M_WILDCARD, which is
*		 set if FILENAME contains any wildcard characters.
*
*	  FULLNAME(1:FN_LEN) -- The  resultant file name  derived from the
*				input file name,  after application of de-
*				faults and translation of logical names.
*
*	  FIELDS -- An INTEGER*2 6-by-2 array,  giving the character posi-
*		    tions, in FULLNAME, of each of the file name's compon-
*		    ents.   FIELDS(n,1) has the start column,  FIELDS(n,2)
*		    the end column, of the n-th field, as follows:
*		   
*			1 node		4 file name
*			2 device	5 file type ("." if no type given)
*			3 directory	6 version   (";" if none given)
*-
*		    For fields  which are not present  (this could only be
*		    the node or file name),  FIELDS(n,2) will be  equal to
*		    FIELDS(n,1) minus one, indicating  a null string (For-
*		    tran accepts this without error).
*
*
*	If the optional FLAGS argument is provided, it can be used to mod-
*	ify the action of FILE_NAME_INFO.   Each bit in FLAGS controls one
*	function, and can be set in combination as desired.  The bits, and
*	their functions, are:
*
*	  Bit 0 -- Do not conceal concealed logical names in the resultant
*		   file name.
*
*	  Bit 1 -- Do not check to see  if any node,  device, or directory
*		   names used in FILENAME actually exist.
*
*
*
*	Alan L. Zirkle	   Naval Surface Weapons Center
*			   Code K53
*	19 Jan 1986	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) FILENAME

	INTEGER*4 FNB,FN_LEN
	CHARACTER*256 FULLNAME
	INTEGER*2 FIELDS(6,2)

	COMMON /FILE_NAME_INFO_/ FNB,FN_LEN,FULLNAME,FIELDS

	INCLUDE '($FABDEF)'
	INCLUDE '($NAMDEF)'

	RECORD /FABDEF/ FAB
	RECORD /NAMDEF/ NAM

	LOGICAL ARG_EXIST

	FLAGS_ = 0
	IF (ARG_EXIST(2)) FLAGS_ = FLAGS

	FAB.FAB$B_BID = FAB$C_BID
	FAB.FAB$B_BLN = FAB$C_BLN

	FAB.FAB$L_FNA = %LOC(FILENAME)
	FAB.FAB$B_FNS = LBYTE(LEN(FILENAME))

	FAB.FAB$L_NAM = %LOC(NAM)

	NAM.NAM$B_BID = NAM$C_BID
	NAM.NAM$B_BLN = NAM$C_BLN

	NAM.NAM$L_ESA = %LOC(FULLNAME)
	NAM.NAM$B_ESS = LBYTE(MIN(LEN(FULLNAME),255))

	NAM.NAM$B_NOP = 0
	IF (IAND(FLAGS_,1).NE.0) NAM.NAM$B_NOP = NAM$M_NOCONCEAL
	IF (IAND(FLAGS_,2).NE.0) NAM.NAM$B_NOP = NAM.NAM$B_NOP +
	1						    NAM$M_SYNCHK

	FILE_NAME_INFO = SYS$PARSE(FAB)

	FN_LEN = ZEXT(NAM.NAM$B_ESL)

	FNB = NAM.NAM$L_FNB

	FIELDS(1,1) = NAM.NAM$L_NODE - NAM.NAM$L_ESA + 1
	FIELDS(1,2) = FIELDS(1,1) + ZEXT(NAM.NAM$B_NODE) - 1

	FIELDS(2,1) = NAM.NAM$L_DEV - NAM.NAM$L_ESA + 1
	FIELDS(2,2) = FIELDS(2,1) + ZEXT(NAM.NAM$B_DEV) - 1

	FIELDS(3,1) = NAM.NAM$L_DIR - NAM.NAM$L_ESA + 1
	FIELDS(3,2) = FIELDS(3,1) + ZEXT(NAM.NAM$B_DIR) - 1

	FIELDS(4,1) = NAM.NAM$L_NAME - NAM.NAM$L_ESA + 1
	FIELDS(4,2) = FIELDS(4,1) + ZEXT(NAM.NAM$B_NAME) - 1

	FIELDS(5,1) = NAM.NAM$L_TYPE - NAM.NAM$L_ESA + 1
	FIELDS(5,2) = FIELDS(5,1) + ZEXT(NAM.NAM$B_TYPE) - 1

	FIELDS(6,1) = NAM.NAM$L_VER - NAM.NAM$L_ESA + 1
	FIELDS(6,2) = FIELDS(6,1) + ZEXT(NAM.NAM$B_VER) - 1

	END
	INTEGER FUNCTION SD_(PARAM,PRIV)

**
*	INTEGER FUNCTION SD_( param [,priv] )
*
*
*	Accepts a parameter string containing one or more  'SD' type oper-
*	ations, and computes the resultant device and directory.   The op-
*	erations in the parameter string must be in upper case and must be
*	separated by one or more blanks.   The legal operations are:
*
*	  ^	 Use directory one subdirectory level up
*
*	  ^^	 Use master directory at or above current directory
*
*	  .	 Use login default directory and disk
*
*	  <n	 Use n'th directory in the SD stack (default for n is 1)
*
*	  >X	 Use directory [z.X] when currently in [z.y]
*
*	  .X	 Use directory [current.X]
*
*	  X.Y.Z	 Use directory [X.Y.Z]
*
*	  n	 Use n'th predefined directory (n=0,1,2,...,9)
*
*	  >	 Traverse horizontally (i.e. from [A.A1] to [A.A2]
*
*	  \	 Traverse to next node in directory tree (preorder traver-
*								      sal)
*	Example:
*
*	  If in USER:[A.B], '^ .C' or '>C' or '^^ .C' selects USER:[A.C]
*
*	.INDEX ENVIRONMENT>>
*	The resultant device and directory must exist.
*
*	The  function result will be one of the following VMS error status
*	values:
*
*	  SS$_NORMAL   '00000001'X  Success
*
*	  RMS$_DIR     '000184CC'X  Error in directory name  (syntax error
*				    or undefined value of n or <n)
*
*	  RMS$_DNF     '0001C04A'X  Directory not found
*
*	  SS$_NOPRIV   '0024'X  No privilege for attempted operation (user
*				has no privilege to read directory)
*
*	  SS$_NOSUCHDEV  '0908'X  No such device available
*
*	  SS$_NOMOREFILES  '0930'X  No more files (An \ or > traversal has
*				    exhausted all possibilities)
*-
*	The resultant device and directory are placed in character strings
*	DEVICE and DIRECTORY, respectively.  The valid lengths of the str-
*	ings are in the INTEGER*4 variables DEVLEN and DIRLEN, respective-
*	ly.  These are all in common /SD_LOC/, defined as follows:
*
*		CHARACTER*128 DEVICE,DIRECTORY
*
*		COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY
*
*
*	If the logical name SD_TRANS exists,  it contains a list of device
*	names which the system manager wishes the users to use  instead of
*	physical names.   If the user does use a physical name correspond-
*	ing to one of the logical names, SD_ will substitute the preferred
*	name.  An example of SD_TRANS is:
*
*		DEFINE SD_TRANS "SYS$SYSDEVICE USER1 USER2"
*
*	The '<n' form of operand requires that the DCL symbols  SD_SP  and
*	SD_SLOTn  (n=0,1,2,...,7)  exist; these are defined by the SD com-
*	mand  (SYS$SYSDEVICE:[K105UTIL]SD.COM).   The 'n'  form of operand
*	requires  that the DCL symbol SD__n exist for each value of 'n' to
*	be used; see the installation document for SD.
*
*	The second (optional) argument PRIV is a logical quantity (the de-
*	fault is .FALSE.).  If true, then certain SD operations work diff-
*	erently:
*
*	    SD ^  from DEV:[A] will go to DEV:[000000]  (normally it stays
*								   at [A])
*
*	    SD ^  from ROOT:[A] will go to F$TRNLNM(ROOT)  (same as above)
*
*	    SD >  from ROOT:[A] will go to [B]             (same as above)
*
*
*	17 Mar 86	Complete rewrite.
*
*	 5 Jun 86	Don't let SD >  go from ROOT:[A] to [B] unless the
*			user is privileged.
*			Allow wildcard characters in directory parameters;
*			SD will go the FIRST matching directory.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	19 Oct 1984	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) PARAM

	CHARACTER*128 STRING,WORK

	COMMON /SD_WORK/ VALUE,EXPDEV,SLEN,STRING,WORK

	CHARACTER*128 DEVICE,DIRECTORY

	COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY

	CHARACTER*256 FULLNAME

	INTEGER*2 FIELDS(6,2)

	COMMON /FILE_NAME_INFO_/ FNB,FN_LEN,FULLNAME,FIELDS

	LOGICAL NUMBER,OTS$CVT_TI_L,LIB$GET_SYMBOL,SD_LASTDOT
	LOGICAL EXPDEV,ARG_EXIST,PRIV_

	DATA SLEN / 0 /

*	The following is a statement function:

	NUMBER(X) = OTS$CVT_TI_L(X,VALUE)     ! Convert string X to INT*4 VALUE

	SD_ = '184CC'X	    ! Default status is 'Error in Directory Name'

	PRIV_ = .FALSE.
	IF (ARG_EXIST(2)) PRIV_ = PRIV

*	If SLEN > 0, the calling program has already put the current
*	default device and directory (or the desired baseline point)
*	into STRING(1:SLEN).  We assume it is valid.

	IF (SLEN.EQ.0) THEN
	    CALL SD_SPLIT(' ')			! Current default:  SYS$DISK:[]
	ELSE
	    CALL SD_SPLIT(STRING(1:SLEN))	! User-specified starting point
	ENDIF

	EXPDEV = .FALSE.    			! No device in any SD operands

	PLEN = LEN(PARAM)

	PCOL = 1

10	IF (PCOL.GT.PLEN) THEN
	    CALL SD_TRANSLATE
	    SD_ =  SD_EXIST()
	    GO TO 100
	ENDIF

	PCOL2 = SUBINDEX(PARAM,PCOL,' ')

	IF (PCOL2.EQ.0) THEN
	    PCOL2 = PLEN + 1
	ELSE IF (PCOL2.EQ.PCOL) THEN
	    PCOL = PCOL + 1
	    GO TO 10
	ENDIF

	SLEN = PCOL2 - PCOL

	STRING(1:SLEN+1) = PARAM(PCOL:PCOL2-1) // ' '

20	IF (STRING(1:SLEN).EQ.'.') THEN

	    CALL SD_SPLIT('SYS$LOGIN:')

	ELSE IF (STRING(1:2).EQ.'..') THEN

	    CALL SD_SPLIT('SYS$LOGIN:')
	    DIRECTORY(DIRLEN:DIRLEN+SLEN-1) = STRING(2:SLEN) // ']'
	    DIRLEN = DIRLEN + SLEN - 1

	ELSE IF (STRING(1:1).EQ.'.') THEN

	    DIRECTORY(DIRLEN:DIRLEN+SLEN) = STRING(1:SLEN) // ']'
	    DIRLEN = DIRLEN + SLEN

	ELSE IF (STRING(1:2).EQ.'[.') THEN

	    DIRECTORY(DIRLEN:DIRLEN+SLEN-2) = STRING(2:SLEN)
	    DIRLEN = DIRLEN + SLEN - 2

	ELSE IF (STRING(1:SLEN).EQ.'^^') THEN

	    COL = INDEX(DIRECTORY(1:DIRLEN),'.')

	    IF (COL.NE.0) THEN
		DIRLEN = COL
		DIRECTORY(DIRLEN:DIRLEN) = ']'
	    ENDIF

	ELSE IF (STRING(1:SLEN).EQ.'^') THEN

	    IF (PRIV_) THEN
		CALL SD_PARENT(DEVICE(1:DEVLEN)//DIRECTORY(1:DIRLEN),1)
	    ELSE IF (SD_LASTDOT()) THEN
		DIRLEN = VALUE
		DIRECTORY(DIRLEN:DIRLEN) = ']'
	    ENDIF

	ELSE IF (STRING(1:SLEN).EQ.'>' .OR. STRING(1:SLEN).EQ.'\') THEN

	    IF (.NOT.SD_TRAVERSE(STRING(1:1),PRIV_)) THEN
		SD_ = '00000930'X
		RETURN
	    ENDIF

	ELSE IF (STRING(1:1).EQ.'>') THEN

	    IF (SD_LASTDOT()) THEN
		DIRECTORY(VALUE+1:VALUE+SLEN) = STRING(2:SLEN) // ']'
		DIRLEN = VALUE + SLEN
	    ELSE
		DIRECTORY(1:SLEN+1) = '[' // STRING(2:SLEN) // ']'
		DIRLEN = SLEN + 1
	    ENDIF

	ELSE IF (STRING(1:1).EQ.'<') THEN

	    IF (SLEN.EQ.1) THEN
		VALUE = 1
	    ELSE IF (.NOT.NUMBER(STRING(2:SLEN))) THEN
		GO TO 100
	    ENDIF

	    VALUE2 = VALUE

	    IF (.NOT.LIB$GET_SYMBOL('SD_SP',WORK,WLEN)) GO TO 100
	    IF (.NOT.NUMBER(WORK(1:WLEN))) GO TO 100

	    VALUE = IAND(VALUE-VALUE2,7)

	    IF (.NOT.LIB$GET_SYMBOL('SD_SLOT'//
	1		  CHAR(VALUE+ICHAR('0')),WORK,WLEN)) GO TO 100

	    CALL SD_SPLIT(WORK(1:WLEN))	    ! Assume this is full dev:[dir]

	ELSE IF (SLEN.EQ.1 .AND. NUMBER(STRING(1:1))) THEN

	    IF (.NOT.LIB$GET_SYMBOL('SD__'//
	1		  CHAR(VALUE+ICHAR('0')),STRING,SLEN)) GO TO 100

	    GO TO 20

	ELSE

	    CALL SD_NEW_DIRECTORY(STRING(1:SLEN),*100)

	ENDIF

	PCOL = PCOL2 + 1
	GO TO 10

100	SLEN = 0

	END
	SUBROUTINE SD_NEW_DIRECTORY(STRING,*)

**
*	SUBROUTINE SD_NEW_DIRECTORY( string , * )
*
*
*	This  routine is not called by the user;  it is called by function
*	SD_ to parse a parameter  which appears to be a device name and/or
*	directory name.
*
*
*	17 Jul 85	Save first logical name (if any) used in the input
*			string, so it can be used later in the result out-
*			put string.
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	19 Oct 1984	   Dahlgren, Virginia  22448
*

*	STRING is  LOG:[DIR]  or  LOG:  or  LOG  or  [DIR]  or  DIR
*
*	LOG could be  DEV  or  DEV:[DIR]  (or even DEV:[DIR]FIL.TYP)

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( NAM$M_ROOT_DIR = '00002000'X )

	CHARACTER*(*) STRING

	CHARACTER*128 DEVICE,DIRECTORY

	COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY

	CHARACTER*256 FULLNAME

	INTEGER*2 FIELDS(6,2)

	COMMON /FILE_NAME_INFO_/ FNB,FN_LEN,FULLNAME,FIELDS

	CHARACTER*128 WORK,WORK2
	LOGICAL TRNLOG

*	The following is a statement function:

	TRNLOG() = LIB$SYS_TRNLOG(WORK(1:WLEN),WLEN2,WORK2) .EQ. 1

	WLEN = LEN(STRING)
	WORK(1:WLEN) = STRING

10	COL = INDEX(WORK(1:WLEN),':')

	IF (COL.NE.0) THEN			! There is a colon

	    IF (COL.EQ.1) RETURN 1

	    CALL SD_SPLIT(WORK(1:COL))

	    IF (COL.EQ.WLEN) RETURN

	    WORK(1:WLEN-COL) = WORK(COL+1:WLEN)
	    WLEN = WLEN - COL

	ENDIF

	IF (WORK(1:1).EQ.'[') THEN

	    WLEN = WLEN - 1
	    IF (WLEN.EQ.0) RETURN 1
	    WORK(1:WLEN) = WORK(2:WLEN+1)

	ELSE IF (TRNLOG()) THEN

	    STATUS = FILE_NAME_INFO(WORK(1:WLEN),2)

	    WLEN = FIELDS(3,2) - FIELDS(2,1) + 1
	    WORK(1:WLEN) = FULLNAME(FIELDS(2,1):FIELDS(3,2))
	    GO TO 10

	ENDIF

	COL = INDEX(WORK(1:WLEN),']')

	IF (COL.NE.0) THEN

	    WLEN = COL - 1
	    IF (WLEN.EQ.0) RETURN 1

	ENDIF

	IF (WORK(1:1).EQ.'-') THEN
	    CALL SD_PARENT(DEVICE(1:DEVLEN)//DIRECTORY(1:DIRLEN),1)
	    IF (WLEN.EQ.1) RETURN
	    WLEN = WLEN - 1
	    WORK(1:WLEN) = WORK(2:WLEN+1)
	    GO TO 10
	ENDIF

	IF (WORK(1:1).EQ.'.') THEN

	    DIRECTORY(DIRLEN:DIRLEN+WLEN) = WORK(1:WLEN) // ']'
	    DIRLEN = DIRLEN + WLEN
	    RETURN

	ELSE

	    DIRLEN = WLEN + 2
	    DIRECTORY(1:DIRLEN) = '[' // WORK(1:WLEN) // ']'

20	    IF (DIRECTORY(1:DIRLEN).EQ.'[000000]' .AND.
	1			     IAND(FNB,NAM$M_ROOT_DIR).NE.0) THEN

		CALL FILE_NAME_INFO(DEVICE(1:DEVLEN)//
	1					  DIRECTORY(1:DIRLEN),3)
		COL = INDEX(FULLNAME,'.]')
		FULLNAME(COL:COL) = ']'
		CALL SD_SPLIT(FULLNAME(1:COL))

	    ENDIF

	ENDIF

	END
	LOGICAL FUNCTION SD_LASTDOT()

**
*	LOGICAL FUNCTION SD_LASTDOT( )
*
*
*	This  routine is not called by the user;  it is called by function
*	SD_ to remove the last  subdirectory from a character  string con-
*	taining a directory tree specification.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	19 Oct 1984	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	COMMON /SD_WORK/ VALUE

	CHARACTER*128 DEVICE,DIRECTORY

	COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY

	SD_LASTDOT = .FALSE.

	VALUE = INDEX(DIRECTORY(1:DIRLEN),'.')

	IF (VALUE.EQ.0) RETURN

	DO I=VALUE+1,DIRLEN

	    IF (DIRECTORY(I:I).EQ.'.') VALUE = I

	ENDDO

	SD_LASTDOT = .TRUE.

	END
	SUBROUTINE SD_SPLIT(FILENAME)

**
*	SUBROUTINE SD_SPLIT(FILENAME)
*
*
*	This  routine is not called by the user;  it is called by function
*	SD_ to split a device/directory specification into separate device
*	and directory parts.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	19 Oct 1984	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( NAM$M_EXP_DEV     = '00000080'X )
	PARAMETER ( NAM$M_EXP_DIR     = '00000040'X )

	CHARACTER*(*) FILENAME

	LOGICAL EXPDEV

	COMMON /SD_WORK/ VALUE,EXPDEV

	CHARACTER*256 FULLNAME

	INTEGER*2 FIELDS(6,2)

	COMMON /FILE_NAME_INFO_/ FNB,FN_LEN,FULLNAME,FIELDS

	CHARACTER*128 DEVICE,DIRECTORY

	COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY

	STATUS = FILE_NAME_INFO(FILENAME,2)

	DEVLEN = FIELDS(2,2) - FIELDS(2,1) + 1

	DEVICE(1:DEVLEN) = FULLNAME(FIELDS(2,1):FIELDS(2,2))

	DIRLEN = FIELDS(3,2) - FIELDS(3,1) + 1

	DIRECTORY(1:DIRLEN) = FULLNAME(FIELDS(3,1):FIELDS(3,2))

	IF (IAND(FNB,NAM$M_EXP_DEV).NE.0 .OR.
	1    IAND(FNB,NAM$M_EXP_DEV+NAM$M_EXP_DIR).EQ.0) EXPDEV = .TRUE.

	END
	SUBROUTINE SD_TRANSLATE

**
*	SUBROUTINE SD_TRANSLATE
*
*
*	This  routine is not called by the user;  it is called by function
*	SD_ to attempt to translate any  physical device  names  to  site-
*	specific logical names.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	19 Oct 1984	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( NAM$M_CNCL_DEV    = '00001000'X )

	CHARACTER*256 STRING

	COMMON /SD_WORK/ VALUE,EXPDEV,SLEN,STRING

	CHARACTER*128 DEVICE,DIRECTORY

	COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY

	CHARACTER*256 FULLNAME

	INTEGER*2 FIELDS(6,2)

	COMMON /FILE_NAME_INFO_/ FNB,FN_LEN,FULLNAME,FIELDS

	IF (IAND(FNB,NAM$M_CNCL_DEV).NE.0) RETURN

	IF (LIB$SYS_TRNLOG('SD_TRANS',SLEN,STRING).NE.1) RETURN

	COL = 1

10	COL2 = SUBINDEX(STRING(1:SLEN),COL,' ') - 1

	IF (COL2.LT.0) COL2 = SLEN

	IF (LIB$SYS_TRNLOG(STRING(COL:COL2),FN_LEN,FULLNAME).EQ.1) THEN

	    COL3 = 1
	    COL4 = 1

	    IF (DEVICE(1:1)  .EQ.'_') COL3 = 2
	    IF (FULLNAME(1:1).EQ.'_') COL4 = 2

	    IF (DEVICE(COL3:DEVLEN).EQ.FULLNAME(COL4:FN_LEN)) THEN

		DEVLEN = COL2 - COL + 2
		DEVICE(1:DEVLEN) = STRING(COL:COL2) // ':'

		RETURN

	    ENDIF

	ENDIF

	COL = COL2 + 2

	IF (COL.LE.SLEN) GO TO 10

	END
	INTEGER FUNCTION SD_EXIST()

**
*	INTEGER FUNCTION SD_EXIST( )
*
*
*	This  routine is not called by the user;  it is called by function
*	SD_ to verify that the resultant device and directory actually ex-
*	ist.
*
*
*	 5 Jun 86	Handle wildcards in directory specifications.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	19 Oct 1984	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( NAM$M_WILDCARD = '100'X )		!WILD

	CHARACTER*256 STRING

	COMMON /SD_WORK/ VALUE,EXPDEV,SLEN,STRING

	CHARACTER*128 DEVICE,DIRECTORY

	COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY

	CHARACTER*256 FULLNAME

	INTEGER*2 FIELDS(6,2)

	COMMON /FILE_NAME_INFO_/ FNB,FN_LEN,FULLNAME,FIELDS

	LOGICAL SD_WILDCARD				!WILD

10	SD_EXIST = SD_PARENT(DEVICE(1:DEVLEN)//DIRECTORY(1:DIRLEN))

	IF (IAND(FNB,NAM$M_WILDCARD).NE.0) THEN		!WILD
	    IF (SD_WILDCARD()) GO TO 10			!WILD
	ENDIF						!WILD

	IF (.NOT.SD_EXIST) THEN

	    IF (SD_EXIST.EQ.'1C04A'X) THEN
20		IF ((.NOT.EXPDEV) .AND.
	1		(DEVICE(1:DEVLEN).EQ.'SYS$SYSROOT:' .OR.
	2			DEVICE(1:DEVLEN).EQ.'SYS$COMMON:')) THEN
		    DEVLEN = 14
		    DEVICE(1:DEVLEN) = 'SYS$SYSDEVICE:'
		    GO TO 10
		ENDIF
	    ENDIF
!**	    IF (SD_EXIST.EQ.'186D4'X) SD_EXIST = '184CC'X
	    IF (SD_EXIST.EQ.'184C4'X) SD_EXIST = '908'X
	    RETURN

	ENDIF

*	Check that this process has read permission in the resultant
*	directory.

	SD_EXIST = AZ_OPEN(FULLNAME(1:FIELDS(6,2)))

	IF (SD_EXIST) THEN
	    CALL AZ_CLOSE
30	    IF (DIRECTORY(1:8).EQ.'[000000.') THEN
		DIRLEN = DIRLEN - 7
		DIRECTORY(1:DIRLEN) = '[' // DIRECTORY(9:DIRLEN+7)
		GO TO 30
	    ENDIF
	ELSE  IF (SD_EXIST.EQ.'1829A'X) THEN
	    SD_EXIST = '00024'X
	ELSE IF (SD_EXIST.EQ.'18292'X .OR. SD_EXIST.EQ.'18744'X) THEN	!WILD
	    SD_EXIST = '1C04A'X
	    GO TO 20
	ENDIF

	END
	INTEGER FUNCTION SD_PARENT(FILENAME,OPTION)

**
*	INTEGER FUNCTION SD_PARENT( filename [, option] )
*
*
*	Computes the directory name of the file whose name is in the char-
*	acter  string argument FILENAME.   Information about the directory
*	name is returned  in variables in common block  /FILE_NAME_INFO_/,
*	which is described in the documentation of routine FILE_NAME_INFO.
*
*	Examples:  After  SD_PARENT('UDISK2:[AA.BB]') is called, character
*		   variable FULLNAME contains 'UDISK2:[AA]BB.DIR;1'.
*
*		   After SD_PARENT('UDISK2:[A]') is called,  FULLNAME con-
*		   tains 'UDISK2:[000000]A.DIR;1'.
*
*		   After SD_PARENT('SYS$MANAGER') is called, FULLNAME con-
*		   tains  (for example)  'DUA0:[SYS0]SYSMGR.DIR;1'.   Note
*		   that device  name is always translated  to physical  in
*		   this case.
*
*	SD_PARENT calls FILE_NAME_INFO (and SYS$PARSE) two or three times.
*	The function result  returned from SD_PARENT is the result it gets
*	from FILE_NAME_INFO for the parent directory name.
*	
*	If the optional second argument OPTION is present,  SD_PARENT also
*	performs the function of  routine SD_SPLIT on the parent directory
*	name.
*
*	.INDEX FILE NAMES>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	14 March 1986	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( NAM$M_DIR_LVLS = '00E00000'X )
	PARAMETER ( NAM$M_ROOT_DIR = '00002000'X )
	PARAMETER ( NAM$V_DIR_LVLS = 21 )

	CHARACTER*(*) FILENAME

	CHARACTER*256 FULLNAME

	INTEGER*2 FIELDS(6,2)

	COMMON /FILE_NAME_INFO_/ FNB,FN_LEN,FULLNAME,FIELDS

	CHARACTER*128 DEVICE,DIRECTORY

	COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY

	LOGICAL ARG_EXIST

	SD_PARENT = FILE_NAME_INFO(FILENAME,2)

	IF (.NOT.SD_PARENT) GO TO 100

	SUB_LVLS = ISHFT( IAND(FNB,NAM$M_DIR_LVLS) , -NAM$V_DIR_LVLS)

	IF (SUB_LVLS.GT.0) THEN
							! Case 1: DEV:[A.B...]
	    COL = FIELDS(3,1)
	    DO I=1,SUB_LVLS
		COL = SUBINDEX(FULLNAME,COL+1,'.')
	    ENDDO

	    FULLNAME(COL:) = ']' // FULLNAME(COL+1:FIELDS(3,2)-1) //
	1							'.DIR;1'

	ELSE IF (IAND(FNB,NAM$M_ROOT_DIR).NE.0) THEN
							! Case 2: ROOT:[A]
	    SD_PARENT = FILE_NAME_INFO(FILENAME,3)
	    IF (.NOT.SD_PARENT) GO TO 100

	    COL = INDEX(FULLNAME,'.]')

	    FULLNAME(COL:) = ']' // FULLNAME(COL+3:FIELDS(3,2)-1) //
	1							'.DIR;1'

	ELSE
							! Case 3: DEV:[A]
	    COL = FIELDS(2,2) + 2

	    FULLNAME(COL:) = '000000]' // FULLNAME(COL:FIELDS(3,2)-1)
	1						     // '.DIR;1'

	ENDIF

	SD_PARENT = FILE_NAME_INFO(FULLNAME(1:255))

100	IF (SD_PARENT.EQ.'186D4'X) SD_PARENT = '184CC'X

	IF (.NOT.ARG_EXIST(2)) RETURN

	DEVLEN = FIELDS(2,2) - FIELDS(2,1) + 1

	DEVICE(1:DEVLEN) = FULLNAME(FIELDS(2,1):FIELDS(2,2))

	DIRLEN = FIELDS(3,2) - FIELDS(3,1) + 1

	DIRECTORY(1:DIRLEN) = FULLNAME(FIELDS(3,1):FIELDS(3,2))

	END
	INTEGER FUNCTION SD_TRAVERSE(TYPE,PRIV)

**
*	INTEGER FUNCTION SD_TRAVERSE( type , priv )
*
*
*	This  routine is not called by the user;  it is called by function
*	SD_ to perform a traversal operation (i.e. SD > or SD \).  Charac-
*	ter string TYPE must be either '>' or '\').
*
*	See routine SD_ for a definition of the PRIV argument.
*
*
*	 5 Jun 86	Don't let SD >  go from ROOT:[A] to [B] unless the
*			user is privileged.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	17 Mar 1986	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( NAM$M_ROOT_DIR = '00002000'X )
	PARAMETER ( NAM$M_DIR_LVLS = '00E00000'X )
	PARAMETER ( NAM$V_DIR_LVLS = 21 )

	CHARACTER*(*) TYPE
	LOGICAL PRIV_

	CHARACTER*128 DEVICE,DIRECTORY

	COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY

	CHARACTER*256 FULLNAME

	INTEGER*2 FIELDS(6,2)

	COMMON /FILE_NAME_INFO_/ FNB,FN_LEN,FULLNAME,FIELDS

	CHARACTER*255 WORK

	IF (TYPE.EQ.'>' .AND. .NOT.PRIV) THEN

	   SUB_LVLS = ISHFT( IAND(FNB,NAM$M_DIR_LVLS) , -NAM$V_DIR_LVLS)

	   IF (SUB_LVLS.EQ.0 .AND. IAND(FNB,NAM$M_ROOT_DIR).EQ.0) THEN
		SD_TRAVERSE = 0
		RETURN
	   ENDIF

	ELSE IF (TYPE.EQ.'\') THEN	! Try going down one level first

	    CONTEXT = 0

	    SD_TRAVERSE = LIB$FIND_FILE(DEVICE(1:DEVLEN)//
	1		    DIRECTORY(1:DIRLEN)//'*.DIR;1',WORK,CONTEXT)

	    IF (SD_TRAVERSE) GO TO 20	! Yes, there is a subdirectory here

	    IF (.NOT.SD_LASTDOT()) GO TO 30	! If no subs under [A], don't
						!  go to [B]
	ENDIF

	SD_TRAVERSE = SD_PARENT(DEVICE(1:DEVLEN)//DIRECTORY(1:DIRLEN))

	IF (.NOT. SD_TRAVERSE) RETURN

	CONTEXT = 0

10	SD_TRAVERSE = LIB$FIND_FILE(FULLNAME(1:FIELDS(3,2))//'*.DIR;1',
	1						   WORK,CONTEXT)

	IF (.NOT.SD_TRAVERSE) GO TO 30

	IF (WORK.NE.FULLNAME(1:FIELDS(6,2))) GO TO 10

	SD_TRAVERSE = LIB$FIND_FILE(FULLNAME(1:FIELDS(3,2))//'*.DIR;1',
	1						   WORK,CONTEXT)

	IF (.NOT.SD_TRAVERSE) THEN
	    IF (TYPE.EQ.'>') GO TO 30
	    CALL SD_PARENT(DEVICE(1:DEVLEN)//DIRECTORY(1:DIRLEN),1)
	    IF (DIRECTORY(1:DIRLEN).EQ.'[000000]') GO TO 30
	    GO TO 10
	ENDIF

20	COL1 = INDEX(WORK,'[') + 1
	IF (WORK(COL1:COL1+5).EQ.'000000') COL1 = COL1 + 7

	COL2 = INDEX(WORK,']')
	COL3 = INDEX(WORK,'.DIR;1') - 1

	WORK(COL2:COL2) = '.'

	DIRLEN = COL3 - COL1 + 3

	DIRECTORY(1:DIRLEN) = '[' // WORK(COL1:COL3) // ']'

30	CALL LIB$FIND_FILE_END(CONTEXT)

	END
	SUBROUTINE DEFAULT_DIRECTORY(DIR_STRING,LENGTH)

**
*	SUBROUTINE DEFAULT_DIRECTORY( dir_string , [ length ] )
*
*
*	Returns, in the character string DIR_STRING, the name of the  cur-
*	rent  default device and directory.  The string DIR_STRING must be
*	long enough to contain the name, or this routine will abort.
*
*	If the optional integer*4 argument LENGTH  is  supplied,  then the
*	length of the name is returned there.
*
*	.INDEX ENVIRONMENT>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	9 Nov 1983	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) DIR_STRING

	LOGICAL ARG_EXIST

	STATUS = SYS$TRNLOG('SYS$DISK',LEN1,DIR_STRING,,,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	STATUS = SYS$SETDDIR(,LEN2,DIR_STRING(LEN1+1:))

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	LEN1 = LEN1 + LEN2

	IF (LEN1.LT.LEN(DIR_STRING)) DIR_STRING(LEN1+1:) = ' '

	IF (ARG_EXIST(2)) LENGTH = LEN1

	END
	INTEGER FUNCTION FPRINT_2(STRING)

**
*	INTEGER FUNCTION FPRINT_2 ( string )
*
*
*	This routine is not normally called by the user.   It is called by
*	routine  FPRINT  to print a line  after the line has been built by
*	the $FAO system service.
*
*	You can  provide your own FPRINT_2 routine to replace this one, if
*	necessary; see the notes for routine FPRINT for details.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	10 Aug 1984	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) STRING

	PRINT 1000,STRING

	FPRINT_2 = 1

1000	FORMAT (A)

	END
	LOGICAL FUNCTION SD_WILDCARD()

**
*	LOGICAL FUNCTION SD_WILDCARD( )
*
*
*	This  routine is not called by the user;  it is called by function
*	SD_ to attempt to remove wildcards from a directory specification.
*	The function result is .TRUE. if a directory exists  which matches
*	the wildcard specification.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	 5 Jun 1986	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*128 DEVICE,DIRECTORY

	COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY

	CHARACTER*256 FULLNAME

	INTEGER*2 FIELDS(6,2)

	COMMON /FILE_NAME_INFO_/ FNB,FN_LEN,FULLNAME,FIELDS

	CHARACTER*255 WORK

	CONTEXT = 0

	SD_WILDCARD = LIB$FIND_FILE(FULLNAME(1:FN_LEN),WORK,CONTEXT)

	IF (SD_WILDCARD) THEN

	    COL1 = INDEX(WORK,'[')
	    COL2 = INDEX(WORK,']')
	    COL3 = INDEX(WORK,'.DIR;1')

	    DIRLEN = COL3 - COL1 + 1

	    WORK(COL2:COL2) = '.'
	    WORK(COL3:COL3) = ']'

	    DIRECTORY(1:DIRLEN) = WORK(COL1:COL3)

	ENDIF

	CALL LIB$FIND_FILE_END(CONTEXT)

	END
	SUBROUTINE CONTROL_Y(ROUTINE)

**
*	SUBROUTINE CONTROL_Y( routine )
*
*
*	Sets up linkage for subroutine ROUTINE to get control  when  ASCII
*	<control-Y>  or  <control-C>  is entered to abort this image.  The
*	argument ROUTINE must be declared EXTERNAL in the calling program.
*	This routine disables CLI interpretation of <ctrl-Y> and <ctrl-C>,
*	and sets up an exit handler to re-enable them when the image exits
*	(this is in case the caller does not do it in ROUTINE,  by calling
*	LIB$ENABLE_CTRL.  The exit handler is the separate  routine  named
*	CONTROL_Y_EXIT.
*
*	If called with a null argument, the default action of  <control-Y>
*	and <control-C> are restored.
*
*	22 Feb 85	Added restoration option.
*
*	.INDEX TERMINAL I/O>>
*	.INDEX PROCESS CONTROL>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	4 Feb 1983	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( IO$_SETMODE  = '23'X )
	PARAMETER ( IO$M_CTRLYAST = '80'X )
	PARAMETER ( IO$M_CTRLCAST = '100'X )

	INTEGER*2 CHAN,IOSB(4)
	EXTERNAL ROUTINE,CONTROL_Y_EXIT

	COMMON /TT_CHAN_TT/ CHAN

	DATA CHAN / 0 /

	IF (CHAN.EQ.0) THEN

	    STATUS = SYS$ASSIGN('TT',CHAN,,)

	    IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	ENDIF

	STATUS = SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE+IO$M_CTRLYAST),
	1						IOSB,,,ROUTINE,,,,,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))
	IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1)))

	STATUS = SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE+IO$M_CTRLCAST),
	1						IOSB,,,ROUTINE,,,,,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))
	IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1)))

	IF (%LOC(ROUTINE).NE.0) THEN

	    CALL DECLARE_EXIT_HANDLER(CONTROL_Y_EXIT)

	    STATUS = LIB$DISABLE_CTRL('02000000'X)

	ELSE

	    CALL CANCEL_EXIT_HANDLER(CONTROL_Y_EXIT)

	    STATUS = LIB$ENABLE_CTRL('02000000'X)

	ENDIF

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	END
	SUBROUTINE CONTROL_Y_EXIT

**
*	SUBROUTINE CONTROL_Y_EXIT
*
*
*	This routine is not normally called by the user.   It  is  an exit
*	handler  set  up by routine CONTROL_Y to re-enable CLI interpreta-
*	tion of <ctrl-Y> and <ctrl-C>.  See routine CONTROL_Y for details.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	4 Feb 1983	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	STATUS = LIB$ENABLE_CTRL('02000000'X)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	END
	SUBROUTINE SET_INPUT_ALARM

**
*	SUBROUTINE SET_INPUT_ALARM
*
*
*	Sets things up so that when a character is entered at the caller's
*	VT100 terminal keyboard, the following things happen:
*
*		* The LOGICAL variable INPUT_READY is set .TRUE.
*
*		* The  value of the character entered is put into variable
*		  INPUT_CHAR
*
*		* The variable INPUT_FLAG  is set to  ' '  (blank)  if the
*		  character is a printable character, '*' if it is a  con-
*		  trol character, or '.' if it indicates an escape sequen-
*		  ce (i.e. an arrow key or keypad key was hit).   In  this
*		  last case, INPUT_CHAR contains the last character of the
*		  sequence  (for example,  if the  'up arrow'  key is hit,
*		  INPUT_FLAG is '*' and INPUT_CHAR is 'A').
*
*		* If the program is hibernating (i.e.  it  called  routine
*		  GO_HIBERNATE) it is wakened up.
*
*	The definition of these variables is:
*
*		LOGICAL*1 INPUT_READY
*		CHARACTER*1 INPUT_CHAR,INPUT_FLAG
*
*		COMMON /TTIN_/ INPUT_CHAR,INPUT_FLAG,INPUT_READY
*
*	The typed characters are not echoed on the screen; it is up to the
*	calling program to do this if desired.
*
*	This routine enables a program to be doing useful work at the same
*	time an input is expected, and, by testing INPUT_READY,  the input
*	can be processed as soon as it occurs.
*
*	When using this routine and the DELETE key  is  hit,  it  does  not
*	delete the last character;  its ASCII value is placed in INPUT_CHAR
*	just like any other key.
*
*	This is a one-time enable.   After you process the input character,
*	you must call SET_INPUT_ALARM again to get more input.
*
*	.INDEX TERMINAL I/O>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	30 Apr 1983	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	EXTERNAL INPUT_ALARM

	INTEGER*2 CHAN,IOSB(4)
	BYTE BUFFER(16)

	INTEGER*4 MASK(6) / 16,0,4*'FFFFFFFF'X /

	LOGICAL*1 INPUT_READY
	CHARACTER*1 INPUT_CHAR,INPUT_FLAG

	COMMON /TTIN_/ INPUT_CHAR,INPUT_FLAG,INPUT_READY
	COMMON /TT_CHAN_TT/ CHAN
	COMMON /ALARM_IOSB/ IOSB,BUFFER

	DATA CHAN,INPUT_READY / 0,.FALSE. /

	PARAMETER ( IO$_READVBLK = '31'X )
	PARAMETER ( IO$M_NOECHO  = '40'X )
	PARAMETER ( IO$M_NOFILTR = '200'X )
	PARAMETER ( IO$M_ESCAPE  = '4000'X )
	PARAMETER ( FUNCTION     = IO$_READVBLK + IO$M_NOECHO +
	1				IO$M_NOFILTR + IO$M_ESCAPE )

	INPUT_READY = .FALSE.

	IF (CHAN.EQ.0) THEN
	    STATUS=SYS$ASSIGN('TT',CHAN,,)
	    IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))
	ENDIF

	MASK(2)=%LOC(MASK(3))

*	NOTE FOLLOWING IS QIO, NOT QIOW!

	STATUS=SYS$QIO(,%VAL(CHAN),%VAL(FUNCTION),IOSB,INPUT_ALARM,,
	1					BUFFER,%VAL(16),,MASK,,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	END
	SUBROUTINE INPUT_ALARM

**
*	SUBROUTINE INPUT_ALARM
*
*
*	This routine is not called by the user.   Routine  SET_INPUT_ALARM
*	sets up this routine as the I/O completion AST routine for reading
*	from the terminal.  This routine checks  the status  of the  read,
*	and parses the input (to set variable INPUT_FLAG).
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	30 Apr 1983	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	EXTERNAL SS$_BADESCAPE

	INTEGER*2 IOSB(4)
	BYTE BUFFER(16)

	LOGICAL*1 INPUT_READY
	CHARACTER*1 INPUT_CHAR,INPUT_FLAG

	COMMON /TTIN_/ INPUT_CHAR,INPUT_FLAG,INPUT_READY
	COMMON /ALARM_IOSB/ IOSB,BUFFER
	COMMON /HIBER_/ HIBERNATING

	IF (.NOT.IOSB(1)) THEN

	    IF (IOSB(1).NE.%LOC(SS$_BADESCAPE))
	1				CALL LIB$STOP(%VAL(IOSB(1)))

	ENDIF

	INPUT_CHAR = CHAR(BUFFER(IOSB(4)))

	INPUT_READY = .TRUE.

	IF (IOSB(3).EQ.'033'O) THEN

	    INPUT_FLAG = '.'

	ELSE IF (IOSB(3).LT.'040'O.OR.IOSB(3).EQ.'177'O) THEN

	    INPUT_FLAG = '*'

	ELSE

	    INPUT_FLAG = ' '

	ENDIF

	IF (HIBERNATING) CALL GO_WAKE_UP

	END
	SUBROUTINE GO_HIBERNATE

**
*	Subroutines GO_HIBERNATE and GO_WAKE_UP
*
*
*	Places the calling process into and out of  hibernation.   See the
*	VAX/VMS  System  Services Reference Manual,  Chapter 7 (pages 7-10
*	through 7-13) for a discussion of hibernation.
*
*	Note that after the process has been  placed  in hibernation,  the
*	only ways it can wake up are:
*
*		* If the process receives an AST and the AST routine calls
*		  GO_WAKE_UP (or calls the SYS$WAKE System Service,  which
*		  is equivalent)
*
*		* If this process called the SYS$SCHDWK System Service be-
*		  fore it hibernated, to schedule a wake-up call.
*
*		* If another process calls SYS$WAKE or SYS$SCHDWK  on  be-
*		  half of this process
*
*	.INDEX PROCESS CONTROL>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	2 Apr 1983	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	LOGICAL HIBERNATING

	COMMON /HIBER_/ HIBERNATING

	DATA HIBERNATING / .FALSE. /

	HIBERNATING = .TRUE.

	STATUS = SYS$HIBER()

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	HIBERNATING = .FALSE.

	RETURN



	ENTRY GO_WAKE_UP


	STATUS = SYS$WAKE(,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	END
	SUBROUTINE SET_KEYPAD_MODE

**
*	Subroutines SET_KEYPAD_MODE and RESET_KEYPAD_MODE
*
*
*	Places the VT100 keypad keys  into or  out of  Keypad  Application
*	Mode.   Normally, the keys are not in application mode; the keypad
*	'7' for instance, is the same as the keyboard '7', and the 'Enter'
*	key is the same as 'Return'.  When in application mode, the keypad
*	keys return unique escape sequences, described in the VT100 manual
*	and reference card.
*
*	The calling program should reset keypad mode before it exits.
*
*	.INDEX TERMINAL I/O>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	2 Apr 1983	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	BYTE BUFFER(2) / 27,0 /
	INTEGER*2 CHAN,IOSB(4)

	COMMON /TT_CHAN_TT/ CHAN

	PARAMETER ( IO$_WRITEVBLK = '30'X )
	PARAMETER ( FUNCTION      = IO$_WRITEVBLK )

	BUFFER(2) = ICHAR('=')

10	IF (CHAN.EQ.0) THEN
	    STATUS=SYS$ASSIGN('TT',CHAN,,)
	    IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))
	ENDIF

	STATUS=SYS$QIOW(,%VAL(CHAN),%VAL(FUNCTION),IOSB,,,
	1					BUFFER,%VAL(2),,,,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1)))

	RETURN



	ENTRY RESET_KEYPAD_MODE


	BUFFER(2)=ICHAR('>')

	GO TO 10

	END
	SUBROUTINE SMGL_GET_TERMINAL_SETTINGS

**
*	SUBROUTINE SMGL_GET_TERMINAL_SETTINGS
*
*
*	Gets the current settings  of the terminal characteristics for the
*	device SYS$OUTPUT. This routine is used by other library routines,
*	so direct calls by the user should obey the following rule:
*
*	This routine should only be called once.  It should only be called
*	if CHARBUF.DEVICE_CLASS is zero; if it is not zero, it has already
*	been called.  Structure  CHARBUF  contains the current settings of
*	the terminal characteristics, and structure  CHARBUF_DEFAULT  con-
*	tains the initial settings when this image started.  The structure
*	CHARBUF_DEFAULT should NOT be modified!
*
*	The definitions of CHARBUF and CHARBUF_DEFAULT are:
*
*		STRUCTURE /CHARBUF/
*		  BYTE DEVICE_CLASS	/ 0 /	! DC$_TERM
*		  BYTE DEVICE_TYPE	/ 0 /	! DT$_VT100, etc.
*		  INTEGER*2 PAGE_WIDTH  / 0 /	! 80 or 132
*		  union
*		    map
*		      INTEGER*4 BASIC_CHAR	! First 3 bytes ($TTDEF)
*		    end map
*		    map
*		      BYTE %FILL (3)
*		      BYTE PAGE_LENGTH		! Usually 24
*		    end map
*		  end union
*		  INTEGER*4 EXT_CHAR		! ($TT2DEF)
*		END STRUCTURE
*
*		RECORD /CHARBUF/ CHARBUF,CHARBUF_DEFAULT
*
*		COMMON /SMGL_CHAR/ CHARBUF,CHARBUF_DEFAULT
*
*	See "VAX/VMS I/O User's Reference Manual:  Part I" (for VMS V4.0),
*	Figure 8-8, on page 8-38.
*
*	.INDEX TERMINAL I/O>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	19 May 1985	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( IO$_SENSEMODE =   '27'X )

	LOGICAL*1 HANDLER_ON
	INTEGER*2 CHAN,IOSB(4)

	STRUCTURE /CHARBUF/
	  BYTE DEVICE_CLASS	/ 0 /		! DC$_TERM
	  BYTE DEVICE_TYPE	/ 0 /		! DT$_VT100, etc.
	  INTEGER*2 PAGE_WIDTH  / 0 /		! 80 or 132
	  union
	    map
	      INTEGER*4 BASIC_CHAR		! Actually 3 bytes ($TTDEF)
	    end map
	    map
	      BYTE %FILL (3)
	      BYTE PAGE_LENGTH			! Usually 24
	    end map
	  end union
	  INTEGER*4 EXT_CHAR			! ($TT2DEF)
	END STRUCTURE

	RECORD /CHARBUF/ CHARBUF,CHARBUF_DEFAULT

	COMMON /SMGL_CHAR/ CHARBUF,CHARBUF_DEFAULT,CHAN,IOSB,HANDLER_ON

	IF (CHAN.EQ.0) THEN

	    STATUS = SYS$ASSIGN('SYS$OUTPUT',CHAN,,)

	    IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	ENDIF

	STATUS = SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SENSEMODE),
	1				    IOSB,,,CHARBUF,%VAL(12),,,,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1)))

	CHARBUF_DEFAULT = CHARBUF

	END
	INTEGER FUNCTION SEND_MESSAGE(USERNAME,MESSAGE,FLAGS)

**
*	INTEGER FUNCTION SEND_MESSAGE ( username , message [,flags] )
*
*
*	Sends a message to a given terminal, to a given logged-in user, or
*	to all connected terminals.  This routine requires OPER privilege,
*	and works cluster-wide on VAXclusters.
*
*	The  first  two arguments are required, and are character strings.
*
*	If the first argument contains a colon, it is assumed  to  be  the
*	name of a terminal, and the message is sent there.  For example:
*
*		CALL SEND_MESSAGE('TTA0:',' Hello ')
*
*	If the first argument is blank, the message is sent to all termin-
*	als connected  to the system, whether users are  logged in at them
*	or not.
*
*	Otherwise, the first argument is assumed to be someone's Username.
*	The message is sent to all terminals  (if any)  at which the named
*	user is logged in.  For example:
*
*		INTEGER SEND_MESSAGE
*
*		N = SEND_MESSAGE('JONES','  Goodbye  ')
*
*	In this case, the calling process needs OPER privilege,  and GROUP
*	privilege  if the user is in the same group, or WORLD privilege if
*	privilege if the user is not in the same group.  The function res-
*	ult is the number of terminals to which the message was sent.
*
*	The message must not be over 256 characters long.
*
*	The optional integer argument FLAGS controls the formatting of the
*	message.  Each bit controls one formatting function:
*
*		Bit 0 -- Ring the recieving terminal's bell four times
*
*		Bit 1 -- Display the message on the recieving terminal  in
*			 bold  reverse  video  (valid  for VTxxx terminals
*			 only).  For best readability, the message  should
*			 be  surrounded by blanks, like in the above exam-
*			 ples.
*
*		Bit 2 -- Do not send this message cluster-wide.   This bit
*			 only has effect on a VAXcluster,  and only if the
*			 message is  being sent to a user or to  all users
*			 (messages sent  to terminal names  are never sent
*			 cluster-wide).
*
*	.INDEX MESSAGES>>
*-
*	If FLAGS  is omitted,  the default value of 3 is used  (ring bell,
*	display in reverse video, send cluster-wide).
*
*
*	1 Aug 85	Add carriage return at  beginning of message,  add
*			option to send to all users, upgrade to VMS 4.0.
*
*	31 Aug 85	Change meaning of blank first argument from  "send
*			to all logged-in users" to  "send to all connected
*			terminals".
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	20 Nov 1983	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( BRK$C_ALLUSERS = '3'X )	! Not used
	PARAMETER ( BRK$C_ALLTERMS = '4'X )
	PARAMETER ( BRK$C_DEVICE   = '1'X )
	PARAMETER ( BRK$C_USERNAME = '2'X )
	PARAMETER ( BRK$M_CLUSTER  = '800'X )

	CHARACTER*(*) USERNAME,MESSAGE

	INTEGER*2 IOSB(4)
	LOGICAL*1 FIRST_CALL / .TRUE. /

	CHARACTER*280 BUFFER

	CHARACTER*1 ESC,BEL,CR
	CHARACTER*6 FRT
	CHARACTER*3 BCK
	CHARACTER*4 BELS

	PARAMETER ( CR   = CHAR(13) )
	PARAMETER ( ESC  = CHAR(27) )
	PARAMETER ( BEL  = CHAR(7) )
	PARAMETER ( FRT  = ESC//'[1;7m' )
	PARAMETER ( BCK  = ESC//'[m' )
	PARAMETER ( BELS = BEL//BEL//BEL//BEL )

	LOGICAL ARG_EXIST

	EXTERNAL SS$_DEVOFFLINE

	FLAGS_ = DEFAULT_ARG(3,'3'X)

	MLEN = LEN(MESSAGE) + 1
	BUFFER(1:MLEN) = CR // MESSAGE

	IF (IAND(FLAGS_,1).NE.0) THEN
	    BUFFER(MLEN+1:MLEN+4) = BELS
	    MLEN = MLEN + 4
	ENDIF

	IF (IAND(FLAGS_,2).NE.0) THEN
	    BUFFER(1:MLEN+9) = CR // FRT // BUFFER(2:MLEN) // BCK
	    MLEN = MLEN + 9
	ENDIF

	BFLAGS = 0

	IF ( INDEX(USERNAME,':') .NE. 0 ) THEN	       ! Send to given terminal

	    SNDTYP = BRK$C_DEVICE

	ELSE IF (USERNAME.EQ.' ') THEN

	    SNDTYP = BRK$C_ALLTERMS
	    IF (IAND(FLAGS_,4).EQ.0) BFLAGS = BRK$M_CLUSTER

	ELSE

	    SNDTYP = BRK$C_USERNAME
	    IF (IAND(FLAGS_,4).EQ.0) BFLAGS = BRK$M_CLUSTER

	ENDIF

	IF (FIRST_CALL) THEN
	    FIRST_CALL = .FALSE.
	    STATUS = LIB$GET_EF(EF)
	    IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))
	ENDIF

	STATUS = SYS$BRKTHRUW(%VAL(EF),BUFFER(1:MLEN),USERNAME,
	1		     %VAL(SNDTYP),IOSB,,%VAL(BFLAGS),,%VAL(5),,)

	SEND_MESSAGE = IOSB(2)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	IF (IOSB(1).EQ.%LOC(SS$_DEVOFFLINE)) RETURN

	IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1)))

	END
	SUBROUTINE GO_WAIT(SECONDS)

**
*	SUBROUTINE GO_WAIT ( seconds )
*
*
*	Places the process in a wait state for  the  specified  number  of
*	seconds.   The  process  will show up as being in HIB state in the
*	SHOW SYSTEM and MONITOR displays.  The program will become  active
*	prematurely if an AST occurs.
*
*	 4 Jan 86	Hibernate,  instead of waiting for event flag,  so
*			it is easier to cancel.
*
*	.INDEX PROCESS CONTROL>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	14 Nov 1983	   Dahlgren, Virginia  22448
*
*

	IMPLICIT INTEGER (A-Z)

	INTEGER*4 DAYTIME(2)

	CALL LIB$EMUL(-SECONDS,10000000,0,DAYTIME)

	STATUS = SYS$SCHDWK(,,DAYTIME,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	CALL GO_HIBERNATE

	END
	SUBROUTINE FILE_ERROR(UNIT)

**
*	SUBROUTINE FILE_ERROR( [unit] )
*
*
*	Displays one or more  error messages associated with the last For-
*	tran I/O statement executed.   This routine should be called after
*	taking an ERR= branch from an I/O statement.  Examples:
*
*		OPEN (1 , ... , ERR=100)
*		 . . .
*	    100 CALL FILE_ERROR
*
*
*		WRITE (1, ... , ERR=200) ...
*		 . . .
*	    200 CALL FILE_ERROR(8)
*
*	If the optional argument  UNIT  is omitted, the error messages are
*	written to the file SYS$OUTPUT; it may also write  the messages to
*	the file  SYS$ERROR  if  SYS$ERROR is assigned to a different file
*	than SYS$OUTPUT (they normally are the same file) and the error is
*	severe enough.
*
*	If the optional argument UNIT is specified, it is the Fortran unit
*	number to which the messages  are to be written.  The messages are
*	then written to this file instead of  SYS$OUTPUT.   NOTE THAT THIS
*	UNIT NUMBER IS WHERE THE MESSAGES ARE TO BE WRITTEN; IT IS NOT THE
*	UNIT NUMBER OF THE FILE WHERE THE ERROR OCCURRED.
*
*	In either of the above cases,  a blank line is written to the file
*	before the first line of messages and after the last line.
*
*	.INDEX DISK I/O>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	21 Feb 1985	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	INTEGER*4 MSGVEC(4) / 3,0,0,0 /

	LOGICAL ARG_EXIST

	EXTERNAL FILE_ERROR_1

	CALL ERRSNS(,MSGVEC(2),MSGVEC(4),)

	IF (ARG_EXIST(1)) THEN

	    WRITE (UNIT,1000)

	    CALL SYS$PUTMSG(MSGVEC,FILE_ERROR_1,,UNIT)

	    WRITE (UNIT,1000)

	ELSE

	    PRINT 1000

	    CALL SYS$PUTMSG(MSGVEC,,,)

	    PRINT 1000

	ENDIF

1000	FORMAT (' ')

	END
	LOGICAL FUNCTION LOGICAL_NAME(NAME,EXEC)

**
*	LOGICAL FUNCTION LOGICAL_NAME( name [ ,exec ] )
*
*
*	Returns a result of .TRUE. if and only if the logical name  in the
*	character string NAME exists.  The translation of the name is  NOT
*	returned.
*
*	If the optional second argument EXEC is supplied,  then the result
*	will be .TRUE. if and only if the logical name exists as an Execu-
*	tive Mode logical name.
*
*	.INDEX LOGICAL NAMES>>
*
*	26 Jun 85	Added capability to test for Executive Mode names.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	14 Nov 1983	   Dahlgren, Virginia  22448
*
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( LNM$_CASE_BLIND = '02000000'X )
	PARAMETER ( LNM$_ACMODE     = '6'X        )
	PARAMETER ( PSL$C_EXEC      = '1'X        )

	CHARACTER*(*) NAME

	INTEGER ITMLST(4)

	LOGICAL ARG_EXIST

	EXTERNAL SS$_NOLOGNAM

	CALL ITEM_LIST(ITMLST,LNM$_ACMODE,ACMODE)

	STATUS = SYS$TRNLNM(LNM$_CASE_BLIND,'LNM$DCL_LOGICAL',NAME,,
	1							 ITMLST)

	LOGICAL_NAME = STATUS

	IF (.NOT.STATUS) THEN

	   IF (STATUS.NE.%LOC(SS$_NOLOGNAM)) CALL LIB$STOP(%VAL(STATUS))

	ELSE IF (ARG_EXIST(2)) THEN

	   LOGICAL_NAME = ACMODE .EQ. PSL$C_EXEC

	ENDIF

	END
	SUBROUTINE MAILBOX(NAME,MB_DATA,INPUT,OUTPUT,PERM,PROT)

**
*	SUBROUTINE MAILBOX ( name , mb_data , [ input ] ,
*
*+					    [ output ] , [perm] , [prot] )
*
*
*	(Part of the NSWC K53 Mailbox-Handling package.)
*
*	Opens  a  mailbox.   The  mailbox may already exist; if not, it is
*	created.  If we create it, the mailbox will be a 'Temporary' mail-
*	box unless the optional argument PERM is included; then it will be
*	a 'Permanent' mailbox. Note that you must have TMPMBX privilege to
*	create a temporary mailbox, and PRMMBX privilege to create a perm-
*	anent mailbox.   See below for more information  on temporary  and
*	permanent mailboxes.
*
*	The character string argument NAME is the desired logical name  of
*	the mailbox.   This logical name must not already be in use by you
*	(or any other process which will use this mailbox)  for any  other
*	purpose.
*
*	The argument MB_DATA must be a four-longword array which  is  used
*	by  the  mailbox  routines to store information about the mailbox;
*	each call to MAILBOX to open a different mailbox must use  a  dif-
*	ferent MB_DATA array.   This array is always passed as an argument
*	to routines MAILBOX_READ, MAILBOX_WRITE, and MAILBOX_WRITE_EOF, so
*	they know which mailbox to use.
*
*	.INDEX MAILBOXES>>
*	.INDEX INTER-PROCESS COMMUNICATION>>
*
*	The optional argument INPUT is the name of a routine,  provided by
*	you the caller, which will be CALLed when another process which is
*	using  the mailbox  writes data to the mailbox.   Thus you  do not
*	need to keep testing whether there is anything in the mailbox  for
*	you to read.  Remember to declare INPUT as EXTERNAL in the routine
*	which calls MAILBOX.
*
*	Similarly, the optional argument OUTPUT is the name of a  routine,
*	provided by you the caller, which will be CALLed when another pro-
*	cess which is using the mailbox attempts to  read  data  from  the
*	mailbox.  Thus you do not need to write anything until you know it
*	is likely to be read.   Remember  to declare OUTPUT as EXTERNAL in
*	the routine which calls MAILBOX.
*
*	If you use either or both of these arguments, and you  later  want
*	to disable their functions,  call MAILBOX again with the same NAME
*	and  MB_DATA  arguments,  but  without  the relevent routine name.
*	Similarly, you can add their functions later after  initially  not
*	using them.
*
*	If the mailbox is a 'Temporary' mailbox, it is deleted  automatic-
*	ally  by the system when nobody has it open.  When the image call-
*	ing MAILBOX exits, the mailbox is be closed for this process.
*-
*	If the mailbox is 'Permanent', the mailbox will stay in  existance
*	until either the system is shut down, or a process explicitly del-
*	etes it.  Routine MAILBOX_DELETE can be used to delete it.
*
*	If the optional argument PROT is not included, or is zero,  anyone
*	can access  the mailbox.   The mailbox can be protected by setting
*	bits in PROT:
*					R - If bit clear, can READ
*	   bit 15       8    4    0	W - If bit clear, can WRITE
*		Wrld Grp  Ownr Sys	L - If bit clear, LOGICAL ACCESS
*		RWLP RWLP RWLP RWLP	P - If bit clear, PHYSICAL ACCESS
*
*	('P'  is apparently not used;  LOGICAL ACCESS  is necessary to use
*	INPUT or OUTPUT routines.)
*
*	To  actually  perform  I/O  to  the  mailbox, you use the routines
*	MAILBOX_READ, MAILBOX_WRITE, and MAILBOX_WRITE_EOF.   See them for
*	details.
*
*	Any message sent must not be longer than 256 bytes. The World (for
*	a permanent mailbox) or Group (for a temporary mailbox) is permit-
*	ted to access the mailbox, subject to the PROT argument.
*
*	By default, all mailbox I/O is done in the 'Now' mode; when we  do
*	a WRITE, we do not wait until someone reads what we wrote; when we
*	do a READ,  we get an immediate EOF indication if there is nothing
*	currently in the mailbox to read.
*
*	If  you  want to use the opposite 'Wait' mode, you must set bit 31
*	of MB_DATA(1) anytime after calling MAILBOX.  For example:
*
*		MB_DATA(1) = IOR ( MBDATA(1) , '80000000'X )
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	5 Nov 1983	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) NAME
	INTEGER*4 MB_DATA(4)
	LOGICAL ARG_EXIST
	EXTERNAL INPUT,OUTPUT

*	MB_DATA(1) = channel assigned to this mailbox, bit 31 on to wait
*	MB_DATA(2) = routine to call when read is necessary (or zero)
*	MB_DATA(3) = routine to call when write is necessary (or zero)
*	MB_DATA(4) = currently unused

	CHARACTER*32 NAME_,DUMMY
	INTEGER*2 IOSB(4)
	LOGICAL LOGICAL_NAME

	MB_DATA(1) = 0

	PRM = 0							! Temporary
	IF (ARG_EXIST(5)) PRM = 1				! Permanent

	PRT = 0							! Protection
	IF (ARG_EXIST(6)) PRT = PROT

	L = LEN(NAME)

	CALL STR$UPCASE(NAME_(1:L),NAME)	! Make sure NAME is uppercase

	IF (.NOT.LOGICAL_NAME(NAME_(1:L))) THEN

	    STATUS = SYS$CREMBX(%VAL(PRM),MB_DATA(1),%VAL(256)
	1			       ,%VAL(512),%VAL(PRT),,NAME_(1:L))

	    IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	ELSE

	    STATUS = SYS$ASSIGN(NAME_(1:L),MB_DATA(1),,)

	    IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	ENDIF

	MB_DATA(2) = 0
	MB_DATA(3) = 0

	IF (ARG_EXIST(3)) THEN

	    MB_DATA(2) = %LOC(INPUT)

	    CALL MAILBOX_NOTIFY_READ(MB_DATA)

	ENDIF

	IF (ARG_EXIST(4)) THEN

	    MB_DATA(3) = %LOC(OUTPUT)

	    CALL MAILBOX_NOTIFY_WRITE(MB_DATA)

	ENDIF

	END
	SUBROUTINE MAILBOX_READ(MB_DATA,BUFFER,LENGTH)

**
*	SUBROUTINE MAILBOX_READ ( mb_data , buffer , length )
*
*
*	(Part of the NSWC K53 Mailbox-Handling package.)
*
*	Reads  the  next record from a mailbox which was opened by calling
*	Subroutine MAILBOX.   See routine MAILBOX for general information.
*
*	The  argument  MB_DATA  is the four-longword array for the mailbox
*	you desire to read.  BUFFER is the character string into which the
*	record is read.   It must not be shorter than the record,  or  the
*	program  will abort.  The actual  length  of the record, in bytes,
*	will be returned in the integer LENGTH;  note that it may be zero.
*
*	If an End-of-file is read,  LENGTH  will be set to minus one (-1).
*
*	See routine MAILBOX for information on the 'Now' and 'Wait' modes.
*
*	.INDEX MAILBOXES>>
*	.INDEX INTER-PROCESS COMMUNICATION>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	5 Nov 1983	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( IO$_READVBLK  = '31'X )
	PARAMETER ( IO$M_NOW      = '40'X )

	INTEGER*4 MB_DATA(4)
	CHARACTER*(*) BUFFER
	INTEGER*4 LENGTH

	INTEGER*2 IOSB(4)

	EXTERNAL SS$_ENDOFFILE

	FUNC = IO$_READVBLK

	IF (MB_DATA(1).GT.0) FUNC = FUNC + IO$M_NOW

	STATUS=SYS$QIOW(,%VAL(MB_DATA(1)),%VAL(FUNC),IOSB,,,
	1				%REF(BUFFER),%VAL(256),,,,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	IF (.NOT.IOSB(1)) THEN

	    IF (IOSB(1).EQ.%LOC(SS$_ENDOFFILE)) THEN

		LENGTH = -1
	
	    ELSE

		CALL LIB$STOP(%VAL(IOSB(1)))

	    ENDIF

	ELSE

	    LENGTH = IOSB(2)

	ENDIF

	IF (MB_DATA(2).NE.0) CALL MAILBOX_NOTIFY_READ(MB_DATA)

	END
	SUBROUTINE MAILBOX_WRITE(MB_DATA,BUFFER)

**
*	SUBROUTINE MAILBOX_WRITE ( mb_data , buffer )
*
*
*	(Part of the NSWC K53 Mailbox-Handling package.)
*
*	Writes a record to a mailbox which was opened by  calling  Subrou-
*	tine MAILBOX.  See routine MAILBOX for general information.
*
*	The argument MB_DATA is the four-longword array for the mailbox to
*	which you desire to write. BUFFER is the character string contain-
*	ing the data to be written.
*
*	See routine MAILBOX for information on the 'Now' and 'Wait' modes.
*
*	.INDEX MAILBOXES>>
*	.INDEX INTER-PROCESS COMMUNICATION>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	5 Nov 1983	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( IO$_WRITEVBLK = '30'X )
	PARAMETER ( IO$M_NOW      = '40'X )

	INTEGER*4 MB_DATA(4)
	CHARACTER*(*) BUFFER
	INTEGER*4 LENGTH

	INTEGER*2 IOSB(4)

	LENGTH = LEN(BUFFER)

	FUNC = IO$_WRITEVBLK

	IF (MB_DATA(1).GT.0) FUNC = FUNC + IO$M_NOW

	STATUS=SYS$QIOW(,%VAL(MB_DATA(1)),%VAL(FUNC),IOSB,,,
	1				%REF(BUFFER),%VAL(LENGTH),,,,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1)))

	IF (MB_DATA(3).NE.0) CALL MAILBOX_NOTIFY_WRITE(MB_DATA)

	END
	LOGICAL FUNCTION FILE_ERROR_1(MESSAGE,UNIT)

**
*	LOGICAL FUNCTION FILE_ERROR_1( message , unit )
*
*
*	This routine is used by subroutine FILE_ERROR and is not called by
*	user code.
*
*	FILE_ERROR_1 is called by  SYS$PUTMSG  once for each line of error
*	message.   This routine writes the line to the Fortran unit number
*	passed as the second argument, and returns a .FALSE. result, which
*	tells SYS$PUTMSG not to write the line on SYS$OUTPUT or SYS$ERROR.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	21 Feb 1985	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) MESSAGE

	WRITE (UNIT,1000) MESSAGE

	FILE_ERROR_1 = .FALSE.

1000	FORMAT (1X,A)

	END	
	LOGICAL FUNCTION FILE_BUSY()

**
*	LOGICAL FUNCTION FILE_BUSY ()
*
*
*	When this logical function is called after an unsuccessful attempt
*	to do a Fortran OPEN on a file, a determination  is  made  whether
*	the OPEN failed because another user has the file open.  If so, we
*	wait two seconds and return a .TRUE. result, and the calling prog-
*	ram can retry the OPEN.  Otherwise, .FALSE. is returned.
*
*	Usage:
*			LOGICAL FILE_BUSY
*			. . .
*		     10	OPEN (1 , . . . , ERR=100)
*			. . .
*			<file is open>
*			. . .
*		    100 IF (FILE_BUSY()) GO TO 10
*			. . .
*			<file is not busy, cannot be opened>
*			. . .
*
*	.INDEX DISK I/O>>
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	14 Nov 1983	   Dahlgren, Virginia  22448
*
*

	IMPLICIT INTEGER (A-Z)

	CALL ERRSNS(,STATUS,,,)

	FILE_BUSY = STATUS .EQ. '1828A'X

	IF (FILE_BUSY) CALL GO_WAIT(2)

	END
	SUBROUTINE MAILBOX_NOTIFY_READ(MB_DATA)

**
*	SUBROUTINE MAILBOX_NOTIFY_READ ( mb_data )
*
*
*	(Part of the NSWC K53 Mailbox-Handling package.)
*
*	This routine is not normally called  by the user;  it is called by
*	other  mailbox routines.   See routine MAILBOX for general inform-
*	ation.
*
*	Sets up a 'Write attention AST' for a mailbox which was opened  by
*	calling Subroutine MAILBOX. This is done when the mailbox is open-
*	ed,  and after every read,  if and only if  the INPUT argument was
*	specified on the call to MAILBOX.
*
*	This sets up the linkage for the INPUT routine to be  called  when
*	a process  puts  a  record into the mailbox.  This is a 'one time' 
*	AST, so it must be done after every read on the mailbox.
*
*	This allows us to know when someone has written to the mailbox, so
*	we can read the record.
*
*	The argument MB_DATA is the four-longword array for the mailbox of
*	interest.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	5 Nov 1983	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( IO$_SETMODE   = '23'X )
	PARAMETER ( IO$M_READATTN = '80'X )
	PARAMETER ( IO$M_WRTATTN  = '100'X )

	INTEGER*4 MB_DATA(4)	

	INTEGER*2 IOSB(4)

	FUNC = IO$_SETMODE + IO$M_WRTATTN

	STATUS = SYS$QIOW(,%VAL(MB_DATA(1)),%VAL(FUNC),IOSB,,,
	1				   %VAL(MB_DATA(2)),MB_DATA,,,,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1)))

	RETURN




	ENTRY MAILBOX_NOTIFY_WRITE(MB_DATA)

**
*	SUBROUTINE MAILBOX_NOTIFY_WRITE ( mb_data )
*
*
*	(Part of the NSWC K53 Mailbox-Handling package.)
*
*	This  routine is not normally called by the user;  it is called by
*	other mailbox routines.   See routine MAILBOX for general informa-
*	tion.
*
*	Sets up a  'Read attention AST'  for a mailbox which was opened by
*	calling Subroutine MAILBOX. This is done when the mailbox is open-
*	ed, and after every write,  if and only if the OUTPUT argument was
*	specified on the call to MAILBOX.
*
*	This  sets up the linkage for the OUTPUT routine to be called when
*	a process attempts to read a record from  the mailbox.   This is a
*	'one time'  AST, so it must be done after every write on the mail-
*	box.
*
*	This allows us to know whenever someone is reading the mailbox, so
*	we can provide a record for them to read.
*
*	The argument MB_DATA is the four-longword array for the mailbox of
*	interest.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	5 Nov 1983	   Dahlgren, Virginia  22448
*

	FUNC = IO$_SETMODE + IO$M_READATTN

	STATUS = SYS$QIOW(,%VAL(MB_DATA(1)),%VAL(FUNC),IOSB,,,
	1				   %VAL(MB_DATA(3)),MB_DATA,,,,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1)))

	END
