
  	INTEGER FUNCTION SD_(PARAMS,PRIV)

**
*	INTEGER FUNCTION SD_( PARAMS [,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)
*
*
*	17 Mar 86	Complete rewrite.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	19 Oct 1984	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) PARAMS
	LOGICAL PRIV, AtStat

	Include 'SD_Common.Dat'

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


*	The following is a statement function:

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

C-----------------------------------------------------------------------

	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.


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


	PCOL = 1

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

	PCOL2 = SUBINDEX(PARAMS,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) = PARAMS(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))) 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


		Value = SD_SP_Number - Value2
106		If (Value .LT. 0) then
			Value = Value + Stack_Depth
                        GoTo 106
		End If
		Value = MOD(Value, Stack_Depth)


	    Write (SD_SLOTn(8:9),108) Value
108		Format (I2.2)

	    IF (.NOT.LIB$GET_SYMBOL(SD_SLOTn,WORK,WLEN)) GO TO 100

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

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

C 		Pick one of the following two: UAF to use SYSUAF.DAT, or
C 		LIST to use SYSUAF.LIS (LIST can be made available to
C 		users by protection, but is a pain to keep updated.  UAF
C		is always up-to-date, but only available to managers)
C 
	    Call SD_UserName_UAF (AtStat)
C	    Call SD_UserName_List (AtStat)
	    If (.NOT. AtStat) Go To 100
	    CALL SD_NEW_DIRECTORY(STRING(1:SLEN),*100)

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

	    Write (SD__n(5:6),108) Value
	    IF (.NOT.LIB$GET_SYMBOL(SD__n,STRING,SLEN)) GO TO 100

	    GO TO 20

C 		The following bug-fix contributed by Steve Gabelnick, Argonne
	ELSE IF (SLEN.EQ.2 .AND. NUMBER(STRING(1:2))) THEN

	    Write (SD__n(5:6),108) Value
	    IF (.NOT.LIB$GET_SYMBOL(SD__n,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

	Return 
	END

C------------------------------------------------------------
	SUBROUTINE SD_NEW_DIRECTORY(STRINGX,*)

**
*	SUBROUTINE SD_NEW_DIRECTORY( stringx , * )
*                  
*
*	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*(*) STRINGX


	Include 'SD_Common.Dat'

	Character*128 Work2

	LOGICAL TRNLOG

C-------------------------------------------------------------------
*	The following is a statement function:

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

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

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

	Return
	END

C-------------------------------------------------------------------
	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)


	Include 'SD_Common.Dat'

C-------------------------------------------------------------------
	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.

	Return
	END

C-------------------------------------------------------------------
	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

	Include 'SD_Common.Dat'

C------------------------------------------------------------------------

	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.

	Return
	END

C-----------------------------------------------------------------------
	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 )

	Integer*2 FN_LenX

	Include 'SD_Common.Dat'
                    
C-----------------------------------------------------------------------

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

CZ	IF (LIB$SYS_TRNLOG('SD_TRANS',SLEN,STRING).NE.1) RETURN
C		Changed to a "Common" Parameter
	Call STR$Trim(%Descr(SD_Tran),%Descr(SD_Tran),%Ref(TLen))
	If (TLen .LE. 1) Return
	COL = 1

10	COL2 = SUBINDEX(SD_Tran(1:TLen),COL,' ') - 1

	IF (COL2.LE.0) COL2 = TLen

	IF (LIB$SYS_TRNLOG(SD_Tran(COL:COL2),FN_LENX,FULLNAME).EQ.1) THEN

	    Fn_Len = FN_LENX
	    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_LENX)) THEN

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

		RETURN

	    ENDIF

	ENDIF

	COL = COL2 + 2

	IF (COL.LE.TLen) GO TO 10

	Return
	END

C-----------------------------------------------------------------------
	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.
*
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	19 Oct 1984	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)


	Include 'SD_Common.Dat'
	External Is_Dir
C-----------------------------------------------------------------------

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

	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.

C	 	  Assign a channel to "Channel";
C
  	Status = Sys$Assign (%Descr(FULLNAME(Fields(2,1):Fields(2,2))),       
	1		%Ref(Channel),,)
C			NOTE THAT THE TRAILING COMMAS ARE REQUIRED

C		Open with all parameters of a "real" .DIR, so that
C		an error will probably indicate an invalid .dir file
        Open(Unit=1, File= FULLNAME(1:Fields(6,2)),
	1	Access = 'SEQUENTIAL', Carriagecontrol = 'NONE',
	2	Recl = 512, RecordType = 'VARIABLE',
	3	NoSpanBlocks, Status='OLD', READONLY, Shared, 
	4	IOSTAT = IOX, UserOpen = Is_Dir, ERR=31)  
C
C --NOTE-- Opening SHARED seems to crash on CLOSE with V4.4, if we read
C  to end of file - but this is just an open and close.
C

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

C		FILE OPEN SUCCEEDED...
C 		Deassign the channel (note use of %Val);
	Status = Sys$Dassgn (%Val(Channel))
	Channel = -9999

CZ	IF (SD_EXIST) THEN
	SD_EXIST = '00001'X
	Close (Unit=1)
30	    IF (DIRECTORY(1:8).EQ.'[000000.') THEN
		DIRLEN = DIRLEN - 7
		DIRECTORY(1:DIRLEN) = '[' // DIRECTORY(9:DIRLEN+7)
		GO TO 30
	    ENDIF
	GoTo 9999

C		COULD NOT OPEN THE FILE...
C 		Deassign the channel (note use of %Val);
31	Status = Sys$Dassgn (%Val(Channel))
	Channel = -9999
	
	If (IOX .NE. 43) then  
	    SD_EXIST = '1C04A'X
	    GoTo 20	
	Else
	    SD_EXIST = '00024'X
        End If

CZ  	ELSE  IF (SD_EXIST.EQ.'1829A'X) THEN
CZ	    SD_EXIST = '00024'X
CZ	ELSE IF (SD_EXIST.EQ.'18292'X) THEN
CZ	    SD_EXIST = '1C04A'X
CZ	    GO TO 20
CZ	ENDIF

9999 	CONTINUE
	Return
	END


C-----------------------------------------------------------------------
	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:[A.B]')  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


	Include 'SD_Common.Dat'

	LOGICAL ARG_EXIST

C-----------------------------------------------------------------------

	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))

	Return
	END


C-----------------------------------------------------------------------
	INTEGER FUNCTION SD_TRAVERSE(TYPE)

**
*	SUBROUTINE SD_TRAVERSE( type )
*
*
*	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 '\').
*
*                                  
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K53
*	17 Mar 1986	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) TYPE


	Include 'SD_Common.Dat'

	CHARACTER*255 WORKX

C-----------------------------------------------------------------------

	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',WORKX,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						   WORKX,CONTEXT)

	IF (.NOT.SD_TRAVERSE) GO TO 30

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

	SD_TRAVERSE = LIB$FIND_FILE(FULLNAME(1:FIELDS(3,2))//'*.DIR;1',
	1						   WORKX,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(WORKX,'[') + 1
	IF (WORKX(COL1:COL1+5).EQ.'000000') COL1 = COL1 + 7

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

	WORKX(COL2:COL2) = '.'

	DIRLEN = COL3 - COL1 + 3

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

30	CALL LIB$FIND_FILE_END(CONTEXT)

	Return
	END

C-----------------------------------------------------------------------
	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


	Include 'SD_Common.Dat'

	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'/

C-----------------------------------------------------------------------

	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.

	Return
	END

C-----------------------------------------------------------------------
	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

C-----------------------------------------------------------------------

	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

	Return
	END

C-----------------------------------------------------------------------
	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


	Include 'SD_Common.Dat'

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

	RECORD /FABDEF/ FAB
	RECORD /NAMDEF/ NAM

	LOGICAL ARG_EXIST

C-----------------------------------------------------------------------

	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

	Return
	END

C------------------------------------------------------------------
	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

	Return
	END


C ---------------------------------------------------------------------
	Subroutine SD_UserName_List (AtStat)
C 
C 		Dale E. Coy
C 		19-DEC-1987 
C 
C 	String(:Slen) = '@Username'
C 	Returns with String(:Slen) = Login Directory for this user
C 	(AtStat = .false. and error message written if unknown or
C 		no privilege to access sys$system:sysuaf.lis)
C 
C 	NOTE: This routine assumes that SYS$SYSTEM:SYSUAF.LIS exists, 
C 	and was created using LIST/BRIEF from Authorize.  It is specific
C 	to the format created by LIST/BRIEF in VMS 4.6, and the routine
C 	must be edited if the format of this listing changes with future
C 	versions of VMS.  If I have guessed right, only the parameter
C 	statements will have to be edited.
	
	IMPLICIT INTEGER (A-Z)
	Logical AtStat
	Parameter (DirPosn  = 70)
	Parameter (UserPosn = 22)
	Parameter (UserName_Length = 12)
	Character*(UserName_Length) This_UserName, Requested_UserName
	
	Include 'SD_Common.Dat'

	AtStat = .FALSE.	! Assume failure
	If (Slen .LT. 2) Return
	If (Slen .GT. (UserName_Length + 1)) Return
	Requested_UserName = String (2:Slen)
	String (1:Slen) = String (2:Slen)
	Slen = Slen - 1
	
        Open(Unit=1, File= 'SYS$SYSTEM:SYSUAF.LIS',
	1	Access = 'SEQUENTIAL', 
	2	RecordType = 'VARIABLE',
	3	Status='OLD', READONLY, Shared, 
	4	IOSTAT = IOX, ERR= 100)  

C 		First two lines are headers
	Read (1,50,End=200,Err=200)
	Read (1,50,End=200,Err=200)
50	Format (T<UserPosn>,A<UserName_Length>,T<DirPosn>,Q,A)
	
60	Continue	! Do Forever	
	Read (1,50,End=200,Err=200) This_UserName, ChgLen, Change
	If (This_UserName .EQ. Requested_UserName) Go To 300
	GoTo 60
	
100	Continue	! Error on Open IOX=30 open fail, 29 file not found
	CALL LIB$PUT_LINE(' ')
	CALL LIB$PUT_LINE(
	1	'  No Privilege For This Operation  (File Not Found) ',2,3)
	CALL EXIT('10000004'X)		! ABORT, WITHOUT A MESSAGE
	
200	Continue	! End or Error
	CALL LIB$PUT_LINE(' ')
	CALL LIB$PUT_LINE(
	1	'  Account '//String(:Slen)//' Was Not Found  ',2,3)
	Close (Unit=1)
	CALL EXIT('10000004'X)		! ABORT, WITHOUT A MESSAGE
	
300	Continue	! Success
	String = Change
	SLen = ChgLen
	AtStat = .TRUE.
	Go To 9998	
	
9998	Close (Unit=1)
9999	Return
	
	End

C ---------------------------------------------------------------------
	Subroutine SD_UserName_UAF (AtStat)
C 
C 	Get default (login) directory for a user, directly from UAF
C 
C 		Dale E. Coy
C 		20-FEB-1988 
C 
C 	String(:Slen) = '@Username'
C 	Returns with String(:Slen) = Login Directory for this user
C 	(AtStat = .false. and error message written if unknown or
C 		no privilege to access sys$system:sysuaf.dat)
C 
	
	IMPLICIT INTEGER (A-Z)
	Logical AtStat
	
	Parameter (UserName_Length = 64)
	Character*(UserName_Length) Requested_UserName
	
	Include 'SD_Common.Dat'
	include	'($UAIDEF)'

	Parameter (Uaf_Device_Length = 64)
	Byte	Uaf_dev(Uaf_Device_Length +1), 
	1	Uaf_device(Uaf_Device_Length), Uaf_dev_Len

	Parameter (Uaf_Directory_Length = 256)
	Byte	Uaf_Dir(Uaf_Directory_Length +1), 
	1	Uaf_Directory(Uaf_Directory_Length), Uaf_Dir_Len
	
	Integer*2 	Dvlen,Drlen
	
	Equivalence 	(Uaf_dev(2),Uaf_device(1))
	Equivalence 	(Uaf_dev(1),Uaf_dev_Len)
	Equivalence 	(Uaf_Dir(2),Uaf_Directory(1))
	Equivalence 	(Uaf_Dir(1),Uaf_Dir_Len)
                                                
	structure /item_list/
	  integer*2 buflen,code
	  integer*4 address,retlen
	end structure

	record /item_list/ list(3)


C -------------------------------------------------------------------------
	
	AtStat = .FALSE.	! Assume failure
	If (Slen .LT. 2) Return
	If (Slen .GT. (UserName_Length + 1)) Return
	Requested_UserName = String (2:Slen)
	String (1:Slen) = String (2:Slen)
	Slen = Slen - 1
	
c
c	Get SYSTEM info
c

	list(1).buflen = Uaf_Device_Length 
	list(1).code = uai$_defdev
	list(1).address = %loc(Uaf_dev)
	list(1).retlen = %loc(Dvlen)

	list(2).buflen = Uaf_Directory_Length
	list(2).code = uai$_defdir
	list(2).address = %loc(Uaf_Dir)
	list(2).retlen = %loc(Drlen)

	list(3).buflen = 0
	list(3).code = 0


	status = sys$getuai(,,Requested_UserName,list,,,)
	if (.NOT. Status) Go To 10468		! Error
	
	Change = ' '
	
	Do 50 K = 1, Uaf_dev_Len
		Change(K:K) = Char(Uaf_device(K))
50	Continue
	
	ChgLen = Uaf_dev_Len
	Do 60 K = 1, Uaf_Dir_Len
		ChgLen = ChgLen + 1
		Change(ChgLen:ChgLen) = Char(Uaf_Directory(K))
60	Continue
	
300	Continue	! Success
	String = Change(:ChgLen)
	SLen = ChgLen
	AtStat = .TRUE.
	Go To 9999	
	
C ERROR Exits
10468	Continue
	If (Status .EQ. 10468) Go To 100	! No Priv
C 		10524 seems to be "same group but not same UIC"
C 		Act like it's "no priv"
	If (Status .EQ. 10524) Go To 100	! No Priv
C 		98994 is "does not exist", and is returned for any user.
C 		If you are concerned about the security implications, 
C 		change this to point to 100 instead of 200.
	If (Status .EQ. 98994) Go To 200	! User does not exist
	Go To 250				! Some other error
		
100	Continue	! Error on Access
	CALL LIB$PUT_LINE(' ')
	CALL LIB$PUT_LINE(
	1	'  No Privilege For This Operation  ',2,3)
	CALL EXIT('10000004'X)		! ABORT, WITHOUT A MESSAGE
	
200	Continue	! End or Error
	CALL LIB$PUT_LINE(' ')
	CALL LIB$PUT_LINE(
	1	'  Account '//String(:Slen)//' Was Not Found  ',2,3)
	CALL EXIT('10000004'X)		! ABORT, WITHOUT A MESSAGE
	
250	Continue	! End or Error
	CALL LIB$PUT_LINE(' ')
	CALL LIB$PUT_LINE(
	1	'  Error finding Account '//String(:Slen)//'  ',2,3)
	CALL EXIT('10000004'X)		! ABORT, WITHOUT A MESSAGE
	
	
9999	Return
	
	End
	
