C..Finger.For				Callable finger routine
C..					R. Garland / C.U.Chemistry

	Integer Function Finger(Command_line,Finger_Out_Routine)

C	Function-
C		o To provide detailed information about users on system.
C		o To provide additional information about an individual.
C		o To request out-bound, or to answer in-bound network
C		  requests to/from other hosts supporting finger.
C
C	Author-
C		Dr. Richard Garland
C		Department of Chemistry
C		Box 351 Havemeyer Hall
C		Columbia University
C		New York, NY, 10027
C		(212) 280-3183
C
C	Disclaimer/rights-
C		This software is in the public domain and is
C		provided free though DECUS or other channels.
C
C	Environment-
C		VAX/VMS V4.x
C		Must be installed with CMKRNL,SYSPRV, and WORLD privileges.
C			CMKRNL - to get the idle times from the UCB's.
C			SYSPRV - so it can read SYSUAF.DAT
C			WORLD - so it can do GETJPI's on processes.
C
C	Routines required, installation:
c		read FINGER.DOC and use the procedure INSTALL_FINGER.COM
c		and BUILD_FINGER.COM

C
C	Edition/changes-
C
c	Note:	Early update history is at the end of this source.
c
c	V5.63	Adapt for uVAX. (VMS V4.0 changes)		5-Nov-1984
c			CPU type: add uVAX I
c			Imagename: multiple brakets [ ][ ] etc.
c			Default Dir from SYSUAF
c			PID format
c	V5.64	real V4.0 came					12-Jan-1985
c			Get DCL parse kludge from BJJ @ PSUVMS1
c			GET_ID from CRW @PSUVMS1 (Mail stuff)
c			New IDLE.MAR (BJJ @ PSUVMS1) to use EPIDs
c
c	New version format: Vx.y.z - 	x = VMS version
c					y = major finger version
c					z = finger revision
c	V5.64 => V40.0.7					12-Jan-1984
c	V40.0.8	-	new V4.0 QUENAME (PJO @ PSUVMS1)	14-Jan-1985
c	V40.0.9	-	disable DECNET node name for now	14-Jan-1985
c	V40.0.10 -	Use LIB$DAY_OF_WEEK			17-Jan-1985
c	V40.0.11 -	Put in new CPU types			17-Jan-1985
c	V40.0.12 -	Put in last login time			17-Jan-1985
c	V40.0.13 -	Integrate Mark London (MIT) changes 
c			into IDLE.MAR				24-Jan-1985
c	V40.0.13	Add filter for printing control chars.	29-Jan-1985
c	V40.0.14	Rewrite and rename Idle --> TT_UCB.  Now it
c			also gets physcial terminal name.	31-Jan-1985
c	V40.0.15	Transform VT's into TT's in Get_Location 31-Jan-1985
c	V40.0.16	Allow local host name to be set other than
c			DECnet node name			6-Feb-1985
c	V40.0.17	Add "Organization name" to heading	7-Feb-1985
c	V40.0.18	Include Peter Lucas's TCP code untested	12-Feb-1985
c	V40.0.19	Search multiple nets for a node (ala PAL) 12-Feb-1985
c	V40.0.20	Default "router" stuff (ala PAL)	15-Feb-1985
c	This was sent out to some sites as a "beta test"	15-Feb-1985
c	----------------
c	V40.0.21	minor fixes to above			19-Feb-1985
c	V40.0.22	more of same				20-Feb-1985
c	V40.0.23	enable privs only when needed		25-Feb-1985
c	V40.0.24	require EXEC mode log name translation	27-Feb-1985
c	V40.0.25	jnet_Finger using global sec after getting
c			status that there wasn't one.		28-Feb-1985
c	V40.0.26	Fix TTUCB and Finger for RT DECnet nodes 8-Mar-1985
c	V40.0.26	Take EXEC mode out for FINGER$MESSAGE	25-Mar-1985
c	V40.0.27	Change Open of SYSUAF for VMS 4.1	25-Mar-1985
c	V40.0.28	make singular "user" in header		25-Mar-1985
c	V40.1.00	Call this VMS 4.0 "release version"	25-Mar-1985
c	----------------
c	V40.1.01	Put "%Val( )" in SYS$DASSGN: Get_DECnet_Node
c			turn off CMKRNL: Get_Idle_Times		3-Apr-1985
c	V40.1.02	Trim trailing space off ORGANIZATION	5-Apr-1985
c	V40.1.03	Make 7 chars default for Terminal names
c			to accomodate VTA's			16-Apr-1985
c	V40.1.04	Assign channel each time: Get_DEC_Node	17-Apr-1985
c	V40.1.05	fix for jnet V2X2 add SYS$CANEXH	21-Apr-1985
c	V40.1.06	Fix by Mike Cochran <Mike@Mecan1.BITnet>
c			for last users in UAF problem		22-Apr-1985
c	V41.1.07	Close with privilege files so opened	20-May-1985
c	V41.1.08	Move open of UAF inline. kill OPEN_UNITS 20-May-1985
c	V41.1.09	Change $TRNLOG to $TRNLNM 		20-May-1985
c	V41.1.10	Look for "::" if no "@" in command.	21-May-1985
c			above 3 changes from Dan Cottler of RCA

C	This routine can be called locally or via a network object.
c	In any case, the output is processed by an external routine
c	specified as an argument.  This makes it somewhat independent
c	of invocation.

	Include		'Fingercom'
	Include		'Fingerdef'

	Character VersionMsg*50
	1	/'VAX/VMS Finger: Version V41.1.10 of 21-May-1985'/
	Common	/Version_Common/ VersionMsg

	Integer		Privilege(2) /0,0/
	Integer		Btrim
	Logical		Wild, Wild_Match
	Character	Command_line*(*)
	Character	Expanded_Command*132
	Character	Node*12, Next_Node*12
	Character	Get_Node*12, Save_Node*12
	Character	Route*72, Node_Type*1
	Character	CR /13/,	LF /10/,	SP /' '/
	Character	Slash /'/'/,	Flush/255/

	Integer		
	1		OutboundLinkUnit /11/,
	2		UafUnit /12/,
	3		ScratchUnit /13/

	Common	/IO_Units/ 
	1		OutboundLinkUnit,
	2		UafUnit,
	3		ScratchUnit

	External	Finger_Out_Routine
	External	Fing_NoWild
	External	Fing_NoNode
	External	Fing_NoNet

	Integer		Local_Finger,
	1		Remote_Finger

c  Turn off privileges
	Privilege(1) = Prv$M_Cmkrnl .or. Prv$M_World .or. Prv$M_Sysprv
	Call Sys$Setprv(,Privilege,,)

c  start processing command
	l_com = Len(Command_line)

C  Strip CR//LF off Command_line
	i_CRLF = Index(Command_line,CR//LF)
	If ( i_CRLF .ne. 0 ) l_Com = i_CRLF - 1

C  Find node name: look for @-sign
10	Do ii=l_Com,1,-1
	    If ( Command_line(ii:ii) .eq. '@' ) Then
		i_At = ii
		GoTo 110
	    EndIf
	EndDo
c  check also for "::" if there are no @-signs
	i_cc = index(command_line,'::')
	If (i_cc.ne.0) then
	    do ii = i_cc,1,-1
	       if (command_line(ii:ii).eq.slash) goto 20
	       if (command_line(ii:ii).eq.sp   ) goto 20
	    end do
	    ii = 0
20	    node = command_line(ii+1:i_cc-1)
	    l_node = i_cc - ii - 1
	    Command_line(ii+1:i_cc+1) = '@'//node(:l_node)//' '
	    Go to 10
	End if
	
	Finger = Local_Finger(Command_line(:l_Com),Finger_Out_Routine) ! No node name:
								! local finger
	Return

110	Continue
	Node = Command_line(i_At+1:l_Com)		! This is the node name
	l_Node = l_Com - i_At
	Do ii = 2,l_Node
	    If ( Node(ii:ii) .eq. Slash ) GoTo 111
	    If ( Node(ii:ii) .eq. SP ) GoTo 111
	EndDo
	GoTo 112
111	l_Node = ii - 1
112	Continue
	Save_Node = Node
	l_Save_node = l_node

c  see if there are wildcards in node name
	ii_node = 1
	wild = .false.
	If ( (Index(Node(:l_Node),'*')+Index(Node(:l_Node),'%'))
	1	.gt. 0 ) then
		wild = .true.
		ii_node = Host$I_Last
		Finger = %Loc(Fing_NoWild)
	End if
c  loop though node names, or do just one.
	Do ii = 1,ii_node
	    If ( wild ) then
		l_host = Btrim(Host$C_Host(ii))
		if ( Wild_Match(Save_Node(:l_Save_Node),
	1	Host$C_Host(ii)(:l_host)) ) then
		    Node = Host$C_Host(ii)
		    l_node = l_host
		Else
		    Go to 200	
		End if
	    End if
c  Get routing information
	    Next_Node = Get_Node(Node(:l_Node),Node_Type,Route,.false.)
C  Format  command 
	    Expanded_Command = Command_line(:i_AT-1)//
	1	Route(:Btrim(Route))//
	2	Command_line(i_AT+l_Save_Node+1:l_Com)

C  send command out to appropriate network/node

	    Finger = Remote_Finger(Next_Node(:Btrim(Next_Node)), 
	1	Expanded_Command(:Btrim(Expanded_Command)),
	2	Finger_Out_Routine, Node_Type)

c  If a wild card net and node not found, see if there is a default router
	    If ( Node_Type.eq.'*' .and. Finger.eq.%Loc(Fing_NoNode) ) then
c	Get routing information for Router
		Next_Node = Get_Node(Node(:l_Node),
	1	    Node_Type,Route,.true.)
		If ( Next_Node .eq. ' ' ) then		! no router: give up.
		    Call Finger_Out_Routine(': link failed]'//CR//LF)
		    Call Lib$Signal(Fing_NoNode)
		    Return
		End if
C	Format  command 
		Expanded_Command = Command_line(:i_AT-1)//
	1	    Route(:Btrim(Route))//
	2	    Command_line(i_AT+l_Save_Node+1:l_Com)

c	notify user we are rerouting
		Call Finger_Out_Routine(': rerouting link via '//
	1	    Next_Node(:Btrim(Next_Node))//']'//CR//LF)

C	send command out to appropriate network/node

		Finger = Remote_Finger(Next_Node(:Btrim(Next_Node)), 
	1	    Expanded_Command(:Btrim(Expanded_Command)),
	2	    Finger_Out_Routine, Node_Type)

	    End if
200	    Continue
	End do

C Done
	Return

	End

c------------------------------------------------------------------------
	Integer Function Remote_Finger(Next_Node, Command,
	1			Finger_Out_Routine, Node_Type)


	Character	Command*(*)
	Character	Next_Node*(*)
	Character	Node_Type*1
	Character	Flush/255/

	External	Finger_Out_Routine
	External	Fing_Nonode, Fing_NoNet

	Integer		Local_Finger,
	1		DECnet_Finger,
	3		jnet_Finger,
	4		TCP_Finger

	Logical		WildNet, NoNode

	NoNode = .false.
	If ( Node_Type .eq. '*' ) then
	    WildNet = .true.
	Else
	    WildNet = .false.
	End if

c  see if it's really local
	If ( Node_Type .eq. 'L' ) Then				! Local
	    Remote_Finger = Local_Finger(Command,Finger_Out_Routine)
	    Return
	End if

c  Notify requester trying to open link
	Call Finger_Out_Routine('['//Next_Node//Flush)

c  dispatch by network type

	If ( WildNet .or. (Node_Type.eq.'D') ) then	! DECnet
	    Remote_Finger = DECnet_Finger(Next_Node,Command,
	1   Finger_Out_Routine)
	    If ( WildNet .and. (Remote_Finger.eq.%Loc(Fing_NoNode)) )
	1	NoNode = .true.
	    If ( .not. WildNet ) Return 
	    If ( .not.(	Remote_Finger.eq.%Loc(Fing_NoNode) .or.
	1		Remote_Finger.eq.%Loc(Fing_NoNet) ) ) Return
	End if

	If ( WildNet .or. 
	1	(Node_Type.eq.'J') .or. (Node_Type.eq.'I') ) then ! jnet
	    Remote_Finger = jnet_Finger(Next_Node,Command,
	1   Finger_Out_Routine,Node_Type)
	    If ( WildNet .and. (Remote_Finger.eq.%Loc(Fing_NoNode)) )
	1	NoNode = .true.
	    If ( .not. WildNet ) Return 
	    If ( .not.(	Remote_Finger.eq.%Loc(Fing_NoNode) .or.
	1		Remote_Finger.eq.%Loc(Fing_NoNet) ) ) Return
	End if

	If ( WildNet .or. (Node_Type.eq.'T') ) then	! TCP
	    Remote_Finger = TCP_Finger(Next_Node,Command,
	1   Finger_Out_Routine)
	    If ( WildNet .and. (Remote_Finger.eq.%Loc(Fing_NoNode)) )
	1	NoNode = .true.
	    If ( .not. WildNet ) Return 
	    If ( .not.(	Remote_Finger.eq.%Loc(Fing_NoNode) .or.
	1		Remote_Finger.eq.%Loc(Fing_NoNet) ) ) Return
	End if
	
	If ( WildNet .and. NoNode ) then
	    Remote_Finger = %Loc(Fing_NoNode)
	Else
	    Remote_Finger = %Loc(Fing_NoNet)
	End if

	Return
	End

c------------------------------------------------------------------------
	Character*12 Function Get_Node(Node,Node_Type,Route,Router)

	Include		'FingerCom.For'

	Character	Node*(*), Node_Type*1, Route*72
	Logical		Router


c  see if we want the default router node
	If ( Router ) then
	    Get_Node = Net$C_Router_Host
	    If ( Get_Node .eq. ' ' ) Return
	    Route = '@'//Node//Net$C_Router_Route
	    Node_Type = Net$C_Router_Type
	    Return
	End if

c  otherwise do a regular look up
	Do ii = 1,Host$I_Last
	    If ( Node .eq. Host$C_Host(ii) ) then
		Get_Node = Host$C_Link(ii)
		If ( Get_Node .eq. ' ' ) Get_Node = Node
		Node_Type = Host$C_Type(ii)
		Route = Host$C_Route(ii)
		Return
	    End if
	End do

c  not found: default to Wild card
	Get_Node = Node
	Node_Type = '*'
	Route = ' '
	Return

	End

c------------------------------------------------------------------------
	Character*20 Function Get_Network(Net_Type)

	Include		'FingerCom.For'

c  look up name of network in database.

	Character	Net_Type*1
	Integer		length

c  in case we don't find it, some defaults
	Get_Network = 'Net'
	If ( Net_Type .eq. 'D' ) Get_Network = 'DECnet'
	If ( Net_Type .eq. 'J' ) Get_Network = 'jnet'
	If ( Net_Type .eq. 'I' ) Get_Network = 'jnet'
	If ( Net_Type .eq. 'T' ) Get_Network = 'TCP'

	Do ii = 1,Net$I_Last
	    If ( Net_Type .eq. Net$C_Type(ii) ) then
		Get_Network = Net$C_Name(ii)
	    End if
	End do

	Return
	End

c------------------------------------------------------------------------
	Integer Function DECnet_Finger(Next_Node,Net_Command,
	1			Finger_Out_Routine)

c  Do a Finger of a remote DECnet node.  Establish the link, send
c  the command, and relay the output back to the requestor.

	Include		'($SSDEF)'
	Include		'($RMSDEF)'

	Character	Next_Node*(*), Net_Command*(*)

	Integer		Btrim
	Character	Line*32000,	NUL/0/
	Character	CR /13/,	LF /10/,	SP /' '/
	Character	Flush /255/
	Character	OpenMsg*80
	Character	Network*20,	Get_Network*20

	Integer		
	1		OutboundLinkUnit, 
	2		UafUnit,
	3		ScratchUnit

	Common	/IO_Units/ 
	1		OutboundLinkUnit,
	2		UafUnit,
	3		ScratchUnit

	Integer		OutLinkOpenStatus, OutLinkRMSStatus
	Common		/OutLinkOpen_Common/ OutLinkOpenStatus,
	1			OutLinkRMSStatus

	External	Finger_Out_Routine
	External	Fing_Complete,	Fing_Abort
	External	Fing_NoNode, Fing_NoNet
	External	OutLink_UserOpen

c  Default return status
	DECnet_Finger = %Loc(Fing_Complete)
c  Establish DECnet link
	Open(	Unit=OutboundLinkUnit,
	1	File=Next_Node//'::"117="',
	2	Type='UNKNOWN',
	3	CarriageControl='NONE',
	4	Err=145,
	5	UserOpen=OutLink_UserOpen,
	6	Recl=32000,
	7	BlockSize=32000)
c  Get network name
	Network = Get_Network('D')
c  Finish message
	Call Finger_Out_Routine('.'//Network(:Btrim(Network))//']'//CR//LF)
	GoTo 150

c  Error establishing link
145	Continue
	If ( OutLinkOpenStatus .eq. SS$_NOSUCHNODE ) then
	    DECnet_Finger = %Loc(Fing_NoNode)
	    Return
	End if
	If ( OutLinkRMSStatus .eq. RMS$_NOD ) then	! Bad node name for
	    DECnet_Finger = %Loc(Fing_NoNode)		! DECnet may be OK
	    Return					! on another net.
	End if
	If ( OutLinkOpenStatus .eq. SS$_DEVNOTMOUNT ) then
	    DECnet_Finger = %Loc(Fing_NoNet)
	    Return
	End if
	Call Finger_Out_Routine(': link failed]'//CR//LF)
	Call Lib$Signal(%Val(OutLinkOpenStatus.or.2**27)) !turn on customer bit
	DECnet_Finger = %Loc(Fing_Abort)
	Return

c  Send command over link
150	Write(OutboundLinkUnit,1002)
	1	Net_Command//CR//LF

C  Read response from network
	DoWhile(.true.)
	    Read(OutboundLinkUnit,1001,End=200) il,Line
	    nl = il/80
	    Do ii = 1,nl
		Call Finger_Out_Routine(Line((ii-1)*80+1:ii*80))
	    EndDo
	    Call Finger_Out_Routine(Line(nl*80+1:il))
	EndDo
200	Continue

c  Make sure link is closed
	Close( Unit=OutboundLinkUnit, Err=201)
201	Continue

	Return

1001	Format(Q,A)
1002	Format(A)

	End

c------------------------------------------------------------------------
	Integer Function jnet_Finger(Next_Node,Net_Command,
	1			Finger_Out_Routine,Node_Type)

c  Do a Finger of a remote jnet node.  Establish the link, send
c  the command, and relay the output back to the requestor.

c  The routine calls to the jnet network are based on interfaces
c  to jnet (tm), a software product available from Joiner Associates
c  of Madison Wisconsin.  This software allows a VAX/VMS system to
c  emulate a full VM (IBM) RSCS node.  jnet is a trademark of
c  Joiner Associates.  BITnet is a network of Universities pri-
c  marily using IBM systems and RSCS protocols.

	Character	Next_Node*(*), Net_Command*(*), Node_Type*1
	External	Finger_Out_Routine

	Include		'FingerDef'
	Include		'GETJPIDEF'

	Integer		Btrim
	Integer		IDaemon /.false./
	Common		/jnet_Daemon/ IDaemon
	Logical		TimedOut
	Common		/jnet_Common/ TimedOut
	Integer		Status, Sys$Trnlnm, Lib$Movtc, Create_Hook
	Integer		Route_Msg, Get_Msg
        Character	Line*255, Line2*255
	Character	Str$Upcase*255
        Character       Remote_Node*8,	PID_String*8
	Character	Local_Node*8
	Character	InitialTimeout*13 /'0 00:00:30.00'/
	Character	Timeout*13 /'0 00:00:10.00'/
	Integer		InitialTime(2)
	Integer		DeltaTime(2)
        Integer*4       Etoa_Desc(2), Atoe_Desc(2)
	Character	CR /13/, LF /10/, Flush/255/
        Character*1	E_Fill, A_Fill
	Logical		started
	Character	Network*20,	Get_Network*20

	Integer		TRN_ItemList(4)
	Integer*2	TRN_ItemList2(8)
	Equivalence	(TRN_ItemList,TRN_ItemList2)
	Integer		TRN$_String /Z00000002/
	Integer		SS$_NoLog /Z000001BC/
     
        External        Rou$C_Stat_Connect, Rou$C_Stat_Inactive
	External	Fing_Complete,	Fing_Abort,  Fing_Multj
	External	Rou_NoNode
	External	Fing_jNA, Fing_NoNode, Fing_NoNet
        External        Etoa, Atoe
	External	jnet_Timer_AST
	External 	jnet_Exit_Handler
	Integer 	Exhblk (4)
	Integer		Privilege(2) /0,0/
     
c  Set default return status
	jnet_Finger = %Loc(Fing_Complete)
c  check for (reentrant) call from DAE
	If ( IDaemon ) then
	    If ( Node_Type .eq. '*' ) then
		jnet_Finger = %Loc(Fing_NoNode)
	    Else
		jnet_Finger = %Loc(Fing_Multj)
	    End if
	    Return
	End if
     
c  Get our RSCS node name for return jnet adress
c    Set up the item list for call to TRNLNM
	TRN_ItemList2(1) = 8
	TRN_ItemList2(2) = TRN$_String
	TRN_ItemList(2) = %Loc(Local_Node)
	TRN_ItemList(3) = %Loc(L_node)
	TRN_ItemList2(7) = 0
	TRN_ItemList2(8) = 0

	Status = Sys$TrnLnm(,'LNM$SYSTEM_TABLE',
	1	'SYS$RSCS_NODE',,
	2	TRN_ItemList)
        If (Status .eq. SS$_NoLog) then
	    jnet_Finger = %Loc(Fing_NoNet)
	    Return
	End if

c  set up stuff for translate instructions
        Etoa_Desc(1) = 256                        ! Conversion Table Descriptor
        Etoa_Desc(2) = %Loc(Etoa)
        Atoe_Desc(1) = 256                        ! Conversion Table Descriptor
        Atoe_Desc(2) = %Loc(Atoe)
        A_Fill = ' '
        E_Fill = Char('100'O)
c  Get our PID for Hook name
	I = 1
	II = 1
	ITEM_LIST2(II+IC) =	JPI$_PID
	ITEM_LIST2(II+BL) =	L_PID
	ITEM_LIST(I+BA)  =	%LOC(PID)
	ITEM_LIST(I+RL)  =	%LOC(RL_PID)
	ITEM_LIST(I+3) = 0		! End of list
	Call Sys$Getjpi(,,,Item_List,,,)
	Call Sys$Waitfr()
	Write(PID_String,1001) PID
	Do ii = 1,8
	    If ( PID_String(ii:ii) .eq. ' ' ) PID_String(ii:ii) = '0'
	End do

c  Remote node
        Remote_Node = Next_Node

c  Turn on SYSPRV privilege
	Privilege(1) =  Prv$M_Sysprv
	Call Sys$Setprv(%Val(1),Privilege,,)
c  Create jnet HOOK
        Status = Create_Hook(PID_String)
c  Turn off SYSPRV privilege
	Call Sys$Setprv(,Privilege,,)
        If (.Not.Status) then
	    If ( Status .eq. %Loc(Fing_jNA)) then
		jnet_Finger = %Loc(Fing_NoNet)
		Return
	    Else
		Call Lib$Signal(%Val(Status))
		jnet_Finger = %Loc(Fing_Abort)
		Return
	    End if
	End if
c  declare exit handler (to remove hook just in case)
	Exhblk(2) = %Loc(jnet_Exit_Handler)    ! Exit Handler
	Exhblk(3) = 1                     ! Two Arguments
	Exhblk(4) = %Loc(Reason)
	Call Sys$Dclexh (Exhblk)
c  set hook connected
	Call Set_Status(Rou$C_Stat_Connect)
c  Format the timeout times
	Call Sys$BinTim(InitialTimeout,InitialTime)
	Call Sys$BinTim(Timeout,DeltaTime)
c  Format the line
        Line(1:1) = Char(3)
        Line(3:10) = Remote_Node
	Line(19:26) = Local_Node
	Line(27:34) = PID_String
	Line(35:80) = Net_Command
	Len1 = 34 + Len(Net_Command)
	If ( Node_Type .eq. 'J' .or. Node_Type .eq. '*' ) then	! jnet and unix
	    Line(2:2) = Char('260'O)
            Line(11:18) = ' '
	Else if ( Node_Type .eq. 'I' ) then		! IBM types a'la Vace
	    Line(2:2) = Char('262'O)
            Line(11:18) = 'FINGER'
	    Line(35:40) = ' '	 	! get rid of "FINGER"
	    If ( Line(41:80) .eq. ' ' ) Line(35:35) = '*'
	    Line(Len1+1:Len1+4) = ' MSG' ! this so we get whole output
	    Len1 = Len1 + 4
        End if
c translate to EBCDIC
	Call Lib$Movtc (Line(3:Len1), E_Fill, Atoe_Desc, Line(3:Len1) )

c and send it out
c  Turn on WORLD privilege
	Privilege(1) =  Prv$M_World
	Call Sys$Setprv(%Val(1),Privilege,,)
        Status = Route_Msg(Line(1:Len1))
c  Turn off WORLD privilege
	Call Sys$Setprv(,Privilege,,)
        If (.Not.Status) then
	    If ( Status .eq. %Loc(Rou_NoNode) ) then
		jnet_Finger = %Loc(Fing_NoNode)
		Goto 101
	    End if
	    Call Finger_Out_Routine(': link failed]'//CR//LF)
	    Call Lib$Signal(%Val(Status))
	    jnet_Finger = %Loc(Fing_Abort)
	    GoTo 101
	End if
     
c  clear timer flags
	Started = .false.
	TimedOut = .false.
c  Start the initial timeout
	Call Sys$SeTimr(,InitialTime,jnet_Timer_Ast,)
c  get the return messages
10      If ( If_Msg() ) GoTo 20
15	    If (started) Call Sys$SeTimr(,DeltaTime,jnet_Timer_Ast,)
	    Call Sys$Hiber()
	    Call Sys$CanTim(,)
	    If ( TimedOut ) GoTo 100
	    Goto 10
20	Len2 = Get_Msg(Line2)
        If (Len2 .eq. 0) Go to 15
c  translate to ASCII
	Call Lib$Movtc(Line2(19:len2),A_Fill,Etoa_Desc,Line2(19:len2))
c  See if an intermediate node responded
	If ( Line2(19:26) .ne. Remote_Node ) then
	    If ( .not. started ) 
	1   Call Finger_Out_Routine(': link failed]'//CR//LF)
	    Call Finger_Out_Routine(LF//'?Finger: Error from node '//
	1	Line2(19:26)//' - '//Line2(35:Len2)//CR)
	    jnet_Finger = %Loc(Fing_Abort)
	    GoTo 101
	End if
c  Notify requester that link is open
	If ( .not. started ) then
c         Get network name
	    Network = Get_Network('J')
c         finish connection message
	    Call Finger_Out_Routine('.'//
	1	Network(:Btrim(Network))//']'//CR//LF)
	    started = .true.
	Endif
c  Output the line     
	Call Finger_Out_Routine(LF//Line2(35:Len2)//CR)
c  Check for end of command
	If ( Index(Str$UpCase(Line2(35:Len2)),
	1	'COMMAND COMPLETE').ne.0) 
	2	GoTo 100
c back for next line     
        Goto 10
     
c Here when done
100	Continue
	If ( .not. started ) then
	    Call Finger_Out_Routine(': link failed]'//CR//LF)
	    Call Finger_Out_Routine(LF//'?Finger: For node '//
	2		Next_Node//' - Timeout'//CR)
	    jnet_Finger = %Loc(Fing_Abort)
	End if
	Call Finger_Out_Routine(LF)
c  some last minute clean up
101	Call Sys$CanTim(,)
	Call Set_Status (Rou$C_Stat_Inactive)
	Call Remove_Hook
	Call Sys$CanExh(Exhblk)
	Return

1001	Format(Z8)

        End

c------------------------------------------------------------------------------
	Integer Function jnet_Timer_Ast

	Logical	TimedOut
	Common	/jnet_Common/ TimedOut

	TimedOut = .True.
	jnet_Timer_Ast = 1
	Call Sys$Wake(,)

	Return

	End

c------------------------------------------------------------------------
	Subroutine jnet_Exit_Handler

	External Rou$C_Stat_Inactive
     
	Call Set_Status (Rou$C_Stat_Inactive)
	Call Remove_Hook

	Return

	End

c------------------------------------------------------------------------
	Integer Function Local_Finger(Command,Finger_Out_Routine)

	Character VersionMsg*50
	Common	/Version_Common/ VersionMsg

	External	Finger_Out_Routine

	Character	Command*(*)
	Character*50	Directory
	Character	Name*25,	Get_PersonalName*25
	Character	Make_Pretty*25
	Character	ComName*12, Get_Username*12, TComName*12
	Character	CR /13/, LF /10/, NUL/0/, Flush/255/
	Integer		SS$_Status, Sys$Waitfr, Btrim
	Integer*2	NewMes
	Integer		LastLogin(2)
	Integer		TestOutput,	FlagProcess
	Logical		ValidID,	TestName
	Logical		Get_ID,		Check_Name,	Check_Process
	Logical		LoggedIn,	HeaderWritten
	Integer		Lbr$Ini_Control,Lbr$Open,	Lbr$Get_Help
	Integer		LbrIndex,	LbrFunc,	Lbr$C_Read/1/
	External	Fing_Complete,	Fing_Abort
	External	Do_Help
	Character	CCC*8
	Integer		Privilege(2) /0,0/

C  Include all GETJPI and flag definitions
	Include		'GETJPIDEF.FOR'
	Include		'FingerFlg.For'
	Include		'Fingerdef.For'


c  Set default return status
	Local_Finger = %Loc(Fing_Complete)
c  initialize a few things
	l_Com = Len(Command)

C  Parse command
	Call Parse_Command(Command(:l_Com),ComName,
	1		TestName,TestOutput)

c  Print version if required
	If ( (TestOutput.and.FlagVersion) .ne. 0 ) Then
	    Call Finger_Out_Routine(LF//VersionMsg//CR)
	EndIf

c Output HELP if required
	If ( (TestOutput.and.FlagHelp) .ne. 0 ) Then
	    Call Header_Brief(Finger_Out_Routine)
	    LbrFunc = Lbr$C_Read
	    ii = Lbr$Ini_Control(LbrIndex,LbrFunc)
	    If ( .not. ii ) then
		Call Lib$Signal(%Val(ii_stat1))
		Local_Finger = %Loc(Fing_Abort)
		Return
	    End if
	    ii = Lbr$Open(LbrIndex,'SYS$HELP:HELPLIB.HLB')	
	    If ( .not. ii ) then
		Call Lib$Signal(%Val(ii_stat2))
		Call Lbr$Close(LbrIndex)
		Local_Finger = %Loc(Fing_Abort)
		Return
	    End if
	    ii = Lbr$Get_Help(LbrIndex,,Do_Help,
	1	Finger_Out_Routine,'FINGER...') 
	    If ( .not. ii ) then
		Call Lib$Signal(%Val(ii_stat3))
		Call Lbr$Close(LbrIndex)
		Local_Finger = %Loc(Fing_Abort)
		Return
	    End if
	    Call Finger_Out_Routine(LF)
	    Call Lbr$Close(LbrIndex)
	    Return
	EndIf

	LoggedIn = .False.
	If ( (Testoutput.and.FlagIdleTime) .ne. 0 )
	1	Call Get_Idle_Times

C  Set up item list
	I = 1					! 1st item - process name
	II = 1
	ITEM_LIST2(II+IC) =	JPI$_PRCNAM
	ITEM_LIST2(II+BL) =	L_PRCNAM
	ITEM_LIST(I+BA)  =	%LOC(PRCNAM)
	ITEM_LIST(I+RL)  =	%LOC(RL_PRCNAM)
	I = I + 3				! 2nd item - status flags
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_STS
	ITEM_LIST2(II+BL) =	L_STS
	ITEM_LIST(I+BA)  =	%LOC(STS)
	ITEM_LIST(I+RL)  =	%LOC(RL_STS)
	I = I + 3				! 3rd item - terminal name
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_TERMINAL
	ITEM_LIST2(II+BL) =	L_TERMINAL
	ITEM_LIST(I+BA)  =	%LOC(TERMINAL)
	ITEM_LIST(I+RL)  =	%LOC(RL_TERMINAL)
	I = I + 3				! 4th item - username
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_USERNAME
	ITEM_LIST2(II+BL) =	L_USERNAME
	ITEM_LIST(I+BA)  =	%LOC(USERNAME)
	ITEM_LIST(I+RL)  =	%LOC(RL_USERNAME)
	I = I + 3				! 5th item - PID
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_PID
	ITEM_LIST2(II+BL) =	L_PID
	ITEM_LIST(I+BA)  =	%LOC(PID)
	ITEM_LIST(I+RL)  =	%LOC(RL_PID)
	I = I + 3				! 6th item - GRP
	II = II + 6
	ITEM_LIST2(ii+IC) = 	JPI$_GRP
	ITEM_LIST2(ii+BL) =	L_PID
	ITEM_LIST(i+BA)  =	%LOC(GRP)
	ITEM_LIST(i+RL)  =	%LOC(RL_GRP)
	I = I + 3				! 7th item - OWNER
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_OWNER
	ITEM_LIST2(II+BL) = 	L_OWNER
	ITEM_LIST(I+BA)  =	%LOC(OWNER)
	ITEM_LIST(I+RL)  = 	%LOC(RL_OWNER)
	I = I + 3				! 8th item - STATE
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_STATE
	ITEM_LIST2(II+BL) =	L_STATE
	ITEM_LIST(I+BA) =	%LOC(STATE)
	ITEM_LIST(I+RL) =	%LOC(RL_STATE)
	I = I + 3				! 9th item - Global pages
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_GPGCNT
	ITEM_LIST2(II+BL) =	L_GPGCNT
	ITEM_LIST(I+BA) =	%LOC(GPGCNT)
	ITEM_LIST(I+RL) =	%LOC(RL_GPGCNT)
	I = I + 3				! 10th item - process pages
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_PPGCNT
	ITEM_LIST2(II+BL) =	L_PPGCNT
	ITEM_LIST(I+BA) =	%LOC(PPGCNT)
	ITEM_LIST(I+RL) =	%LOC(RL_PPGCNT)

	I = I + 3				! End of list
	ITEM_LIST(I) = 0

C  Print header
	If ( TestName ) Then
		Call Header_Brief(Finger_Out_Routine)
	Else
		Call Header_Full(TestOutput,Finger_Out_Routine)
	EndIf

C  Call $GetJpi service in loop
	PIDinput = PID_Wildcard
	HeaderWritten = .false.

c  Turn on WORLD privilege
	Privilege(1) = Prv$M_World
	Call Sys$Setprv(%Val(1),Privilege,,)

	DoWhile(Sys$Getjpi(,PIDinput,,Item_List,,,)) ! assume only failure
	    Call Sys$Waitfr()				 ! is SS$_NoMoreProc
	    If ( Check_Process(TestOutput,FlagProcess,
	1	STS,GRP,Owner,Terminal) )
	1   Then
		If (.not. TestName .or.
	1	Check_Name(Username(:Btrim(Username)),
	2		ComName(:Btrim(ComName)) ) ) Then
		    LoggedIn = .true.
		    Call User_Info(PID,STS,Prcnam,Username,Terminal,
	1		State, GPgCnt+PPgCnt, HeaderWritten,
	2		TestOutput,FlagProcess,Finger_Out_Routine)
		EndIf
	    EndIf
	EndDo

c  Turn off WORLD privilege
	Call Sys$Setprv(,Privilege,,)

	If ( .not. TestName .and. .not. LoggedIn )
	1   Call Finger_Out_Routine(LF//' no such jobs.')

200	Continue

C  Check if personal information is requested
	ValidID = Get_ID(ComName, Directory, NewMes, Name, LastLogin)
	If ( TestName .and. .not. LoggedIn ) Then
	    If ( ValidID ) Then
		Name = Make_Pretty(Name)
		Call Finger_Out_Routine(LF//
	1	    ComName(1:btrim(ComName))//
	2	    ' ('//Name(1:btrim(Name))//')'//
	3	    ' is not logged in.'//CR)
	    Else 
		TComName = Get_Username(ComName(:btrim(ComName)),
	1	    NMatches,.true.,Finger_Out_Routine)
		If ( NMatches .eq. 1 )
	1	    ValidID = 
	2	    Get_ID(TComName,Directory,NewMes,Name,LastLogin)
		If ( NMatches .eq. 0 )
	1	    Call Finger_Out_Routine(LF//
	2		ComName(1:btrim(ComName))//
	3		': no such user.'//CR)
	    EndIf
	EndIf

C  Print out Mail info and Plan if user is valid
	IF (TestName .and. ValidID ) Then
	    Call Personal_Info(ComName, Directory, NewMes, LastLogin,
	1	LOggedIn, TestOutput,Finger_Out_Routine)
	EndIf

C  1 last line-feed at end
	Call Finger_Out_Routine(LF)

	Return

1000	Format(A)

	END


c---------------------------------------------------------------------------
	Subroutine Parse_Command(Command,ComName,
	1		TestName,TestOutput)

c  Note: this routine uses a command definition table which is created
c  by the SET COMMAND command from the file FINGERCLI.CLD.  Changes
c  to qualifiers etc. should be reflected both here and in that file.

	Include		'GETJPIDEF.FOR'
	Include		'FingerFlg.For'

	Character	Command*(*),	ComName*12
	Character	CR /13/, LF /10/, NUL/0/

	Logical		TestName 
	Integer		TestOutput

	External	FingerCli_Table
	Integer		Cli$Dcl_Parse,	Cli$Get_Value,	Cli$Present
	Integer		Kludge_Cli$Dcl_Parse
	Character	CCC*8

	TestName = .true.
	TestOutput = 0

	l_Com = Len(Command)
c  In V4.0 the next line would corrupt the stack
c  the Kludge... routine pads the stack first for protection
c	Call Cli$Dcl_Parse(Command(:l_Com),FingerCli_Table)
	Call Kludge_Cli$Dcl_Parse(Command(:l_Com),FingerCli_Table)
	ComName = ' '
	Call Cli$Get_Value('FINGERNAME',ComName)
	If ( ComName .eq. ' ' ) TestName = .false.
	If ( ComName .eq. '.' ) then
	    I = 1
	    II = 1
	    ITEM_LIST2(II+IC) =	JPI$_USERNAME
	    ITEM_LIST2(II+BL) =	L_USERNAME
	    ITEM_LIST(I+BA)  =	%LOC(USERNAME)
	    ITEM_LIST(I+RL)  =	%LOC(RL_USERNAME)
	    ITEM_LIST(I+3) = 0		! End of list
	    Call Sys$Getjpi(,,,Item_List,,,)
	    Call Sys$Waitfr()
	    ComName = Username
	End if

c  Set flags from command qualifiers
	If ( Cli$Present('INTERACTIVE') ) 
	1	TestOutput = TestOutput .or. FlagInteractive
	If ( Cli$Present('BATCH') )
	1	TestOutput = TestOutput .or. FlagBatch
	If ( Cli$Present('SUBPROCESS') )
	1	TestOutput = TestOutput .or. FlagSubprocess
	If ( Cli$Present('NETWORK') )
	1	TestOutput = TestOutput .or. FlagNetwork
	If ( Cli$Present('SYSTEM') )
	1	TestOutput = TestOutput .or. FlagSystem
	If ( Cli$Present('ALL') )
	1	TestOutput = TestOutput .or. FlagAll
	If ( Cli$Present('HELP') )
	1	TestOutput = TestOutput .or. FlagHelp

c  If nothing else on, turn on FlagInteractive
	If ( TestOutput .eq. 0 ) TestOutput = FlagInteractive

c  Miscellaneous stuff
	If ( Cli$Present('SORT') )
	1	TestOutput = TestOutput .or. FlagSort
	If ( Cli$Present('VERSION') )
	1	TestOutput = TestOutput .or. FlagVersion
	If ( Cli$Present('MESSAGE') )
	1	TestOutput = TestOutput .or. FlagMessage

c  individual's stuff
	If ( Cli$Present('PLAN') )
	1	TestOutput = TestOutput .or. FlagPlan
	If ( Cli$Present('MAIL') )
	1	TestOutput = TestOutput .or. FlagMail

c  display qualifiers
	If ( Cli$Present('PID') )
	1	TestOutput = TestOutput .or. FlagPid
	If ( Cli$Present('PROCESSNAME') )
	1	TestOutput = TestOutput .or. FlagProcessname
	If ( Cli$Present('USERNAME') )
	1	TestOutput = TestOutput .or. FlagUsername
	If ( Cli$Present('PERSONALNAME') )
	1	TestOutput = TestOutput .or. FlagPersonalName
	If ( Cli$Present('IMAGENAME') )
	1	TestOutput = TestOutput .or. FlagImagename
	If ( Cli$Present('TERMINAL') )
	1	TestOutput = TestOutput .or. FlagTerminal
	If ( Cli$Present('LOGINTIME') )
	1	TestOutput = TestOutput .or. FlagLoginTime
	If ( Cli$Present('CPUTIME') )
	1	TestOutput = TestOutput .or. FlagCpuTime
	If ( Cli$Present('STATE') )
	1	TestOutput = TestOutput .or. FlagState
	If ( Cli$Present('SIZE') )
	1	TestOutput = TestOutput .or. FlagSize
	If ( Cli$Present('IDLETIME') )
	1	TestOutput = TestOutput .or. FlagIdleTime
	If ( Cli$Present('LOCATION') )
	1	TestOutput = TestOutput .or. FlagLocation
	If ( Cli$Present('TTTYPE') )
	1	TestOutput = TestOutput .or. FlagTTType
	If ( Cli$Present('SWAPPED') )
	1	TestOutput = TestOutput .or. FlagSwapped
c  lastly test for /FULL : it turns all displays on
	If ( Cli$Present('FULL') )
	1	TestOutput = TestOutput .or. FlagFull

	Return
	End

c---------------------------------------------------------------------------
	Logical Function Do_Help(Line,HelpFlags,Out_Routine,Level)

	External	Out_Routine

	Character	CR /13/, LF /10/, NUL/0/
	Character	Line*(*),	Space*80/' '/
	Integer		HelpFlags,	Level

	l_Line = Len(Line)

	Call Out_Routine(LF//
	1	Space(:5*(Level-1)+1)//Line(:l_Line)//CR)

	Do_Help = .true.
	Return

	End

c---------------------------------------------------------------------------
	Logical Function Check_Process(TestOutput,FlagProcess,
	1				STS,GRP,Owner,Terminal)

	Character	Terminal*7
	Character	NUL/0/

	Integer		STS,	GRP,	Owner
	Integer		Pcb$m_Batch/Z00004000/
	Integer		Pcb$m_Netwrk/Z00200000/

	Integer		FlagProcess
	Integer		TestOutput

	Include		'FingerFlg.For'

	Parameter	SysGRP = 8

	FlagProcess = 0
	Check_Process = .true.

c  set process flags
	If ( Terminal(1:1) .ne. NUL ) Then
	    FlagProcess = FlagProcess .or. FlagInteractive
	ElseIf ( (STS.and.Pcb$m_Batch) .ne. 0 ) Then
	    FlagProcess = FlagProcess .or. FlagBatch
	ElseIf ( (STS.and.Pcb$m_Netwrk) .ne. 0 ) Then
	    FlagProcess = FlagProcess .or. FlagNetwork
	ElseIf ( Owner .ne. 0 ) Then
	    FlagProcess = FlagProcess .or. FlagSubprocess
	ElseIf ( GRP .le. SysGRP ) then
	    FlagProcess = FlagProcess .or. FlagSystem
	Else
	EndIf

c  First check for "/ALL"
	If ( (TestOutput.and.FlagAll) .ne. 0 ) Return

c Check process against flags
	If ( (TestOutput.and.FlagProcess) .eq. 0 ) 
	1	Check_Process = .false.

	Return
	End

c---------------------------------------------------------------------------
	Subroutine Header_Full(TestOutput,Finger_Out_Routine)

	Include		'FingerCom.For'
	Include		'FingerFlg.For'
	Integer		TestOutput

	External	Finger_Out_Routine

	Integer		
	1		OutboundLinkUnit, 
	2		UafUnit,
	3		ScratchUnit

	Common	/IO_Units/ 
	1		OutboundLinkUnit,
	2		UafUnit,
	3		ScratchUnit


c  Site-specific: load pseudodevice gives load averages.
	Parameter	LoadDevice = 'LAV0:'
c	Parameter	LoadDevice = '$$VMS_LOAD_AVERAGE:'	! alternate

	Integer		SS$_Status, SS$_NoLog/Z000001BC/
	Integer		Sys$AscTim, Sys$GetTim, Sys$TrnLnm, Sys$GetSYI
	Integer		Btrim
	Integer		SYI_ItemList(7),TRN_ItemList(4)
	Integer*2	SYI_ItemList2(14),TRN_ItemList2(8)
	Equivalence	(TRN_ItemList,TRN_ItemList2)
	Equivalence	(SYI_ItemList,SYI_ItemList2)
	Integer		TRN$_String /Z00000002/
	Integer		SYI$_CPU /Z00000200/
	Integer		SYI$_Version /Z00000100/
	Integer		CPU_Type
	Integer		l_CPU, l_Vrsn
	Character	System_Version*8
	Character*10	CPU_Types(8) /
	1			'VAX 11/780',
	2			'VAX 11/750',
	3			'VAX 11/730',
	4			'VAX 8600',
	5			'Scorpio',
	6			'Nautilus',
	7			'uVAX I',
	8			'uVAX II'/
	Character	Node$Lognam*8 /'SYS$NODE'/,	Node*12
	Character	AscTime*23, AscSince*23, Make_Pretty*23
	Character	Day_OfTheWeek*9, Today*9, Upday*9
	Character	MsgLine*132
	Real		Load1,	load5,	load15

	External	Sys$gw_IJobCnt
	External	Sys$gw_BJobCnt
	External	Exe$gl_AbsTim
	External	Priv_UserOpen
	Integer*2	Get_w_Val
	Integer		Get_l_Val
	Integer		Ijobs, Bjobs 
	Integer		UpTime(2), SysTime(2), UpSince(2)

	Character	NUL/0/, LF/10/, CR /13/, SP /' '/
	Character	Temp*23
	Logical		LoadAvailable	/.false./
	Logical		WroteSomething	/.false./

C  Get node name, system stuff, time, load averages etc., print header

c   Set up item list for GetSYI
	SYI_ItemList2(1) = 4		! 4 bytes for CPU type
	SYI_ItemList2(2) = SYI$_CPU	! CPU type
	SYI_ItemList(2) = %Loc(CPU_Type)
	SYI_Itemlist(3) = %Loc(l_CPU)	! returned length
	SYI_ItemList2(7) = 8		! 8 bytes
	SYI_ItemList2(8) = SYI$_Version	! System version
	SYI_ItemList(5) = %Loc(System_Version)
	SYI_ItemList(6) = %Loc(l_Vrsn)	! returned length
	SYI_ItemList(7) = 0	! no more items
	Call Sys$GetSYI(,,,SYI_ItemList,,,)
	Call Sys$Waitfr()

	If ( Net$C_Local_Host_Name .eq. ' ' ) then
	    TRN_ItemList2(1) = 8
	    TRN_ItemList2(2) = TRN$_String
	    TRN_ItemList(2) = %Loc(node)
	    TRN_ItemList(3) = %Loc(L_node)
	    TRN_ItemList2(7) = 0
	    TRN_ItemList2(8) = 0

	    SS$_Status = Sys$TrnLnm(,'LNM$FILE_DEV',
	1	Node$Lognam,,
	3	TRN_ItemList)
	    If ( SS$_Status .eq. SS$_NoLog ) Then
		Node = 'Finger'
	    Else
		Node = Node(2:l_Node-2)
	    EndIf
	Else
	    Node = Net$C_Local_Host_Name		! use set value
	End if
	l_Node = Btrim(Node)
	Call Sys$AscTim(,AscTime,,)				! Time now
	AscTime = Make_Pretty(AscTime)
	Today = Day_OfTheWeek(%Val(0))
	UpTime(1) = Get_l_Val(Exe$gl_AbsTim)			! up time (sec)
	Call Lib$EMul(10000000,UpTime,0,UpTime)			! 64 bit format
	Call Sys$GetTim(SysTime)
	Call Lib$Subx(SysTime,UpTime,UpSince)
	Call Sys$AscTim(,AscSince,UpSince,)			! Up since
	AscSince = Make_Pretty(AscSince)
	Upday = Day_OfTheWeek(UpSince)
	Ijobs = Get_w_Val(Sys$gw_IJobCnt)			! # users
	Bjobs = Get_w_Val(Sys$gw_BJobCnt)			! # batch

c  ! Site-specific: This is the load average pseudo-device.  If not
c  available, omit this section.  Or leave it and it will still be OK.
	Open(Unit=ScratchUnit,
	1	File=LoadDevice,
	2	Type='NEW',
	3	RecordSize=12,
	4	Err=101)
	Read(ScratchUnit,2000,Err=101) Load1, Load5, Load15
	Close(Unit=ScratchUnit)
	LoadAvailable = .true.
101	Continue

C  Print full header
C		Organization name if defined
	If ( Net$C_Organization .ne. ' ' )
	1	Call Finger_Out_Routine(
	2	LF//
	3	Net$C_Organization(:BTrim(Net$C_Organization))//
	4	CR)
C		1st full line
	Call Finger_Out_Routine(LF//
	1			Node(:l_Node)//' '//
	2			CPU_Types(Cpu_Type)
	3				(:Btrim(CPU_Types(CPU_Type)))//', '//
	4			'VMS '//
	5		 	System_Version(:Btrim(System_Version))//
	6			'. '//
	7			Today(:Btrim(Today))//', '//
	8			AscTime(:17)//', ')
	If ( Ijobs .eq. 1 ) then
	    Write(Temp,1001)	Ijobs, ' User, '
	Else
	    Write(Temp,1001)	Ijobs, ' Users, '
	End if
	Call Finger_Out_Routine(Temp(:10))
	Write(Temp,1001)	Bjobs, ' Batch.'
	Call Finger_Out_Routine(Temp(:9))
	Call Finger_Out_Routine(CR)
c		2nd line
	Call Finger_Out_Routine(LF//
	1			' Up since '//
	2			Upday(:Btrim(Upday))//', '//
	3			AscSince(:17))
	If ( LoadAvailable ) Then
	    Write(Temp,1002) 	', Load: '	! Site-specific
	1			,Load1 		! Site-specific
	    Call Finger_Out_Routine(Temp(:13))
c	2    			,Load5		! Site-specific
c	3    			,Load15		! Site-specific
c	    Call Finger_Out_Routine(Temp)
	EndIf
	Call Finger_Out_Routine(CR//LF)

C  Print message if any
	If ( (TestOutput.and.FlagMessage) .ne. 0 ) then
	    Open	(Unit=ScratchUnit,
	1	File='FINGER$MESSAGE:',
c	2	UserOpen = Priv_UserOpen, ! Uncomment this to prevent
c					! redirection of message lognamm
	2	Type='OLD',
	3	ReadOnly,
	4	Shared,
	5	Err=201)
	    DoWhile(.True.)		! Loop through message file
		Read(ScratchUnit,3000,Err=201,End=200) l_Msg, MsgLine
		Call Finger_Out_Routine(LF//MsgLine(:l_Msg)//CR)
		WroteSomething = .True.
	    EndDo
200	    Call Priv_Close(ScratchUnit)
201	    Continue
C	    1 blank line if there was any message
	    If ( WroteSomething ) Call Finger_Out_Routine(LF//CR)
	EndIf

	Return

1001	Format(I2,A)
1002	Format(A,3F5.2)

2000	Format(3A4)

3000	Format(Q,A)	

	End

c---------------------------------------------------------------------------
	Subroutine Header_Brief(Finger_Out_Routine)

	Include		'Fingercom.for'

	External	Finger_Out_Routine

	Integer		TRN$_String /Z00000002/
	Integer		TRN_ItemList(4)
	Integer*2	TRN_ItemList2(8)
	Equivalence	(TRN_ItemList,TRN_ItemList2)

	Integer		SS$_Status, SS$_NoLog/Z000001BC/
	Integer		Sys$AscTim, Sys$GetTim, Sys$TrnLnm
	Integer		Btrim
	Character	Node$Lognam*8 /'SYS$NODE'/,	Node*9
	Character	Day_OfTheWeek*9,	Today*9
	Character	AscTime*23, Make_Pretty*23

	Character	NUL/0/, LF/10/, CR /13/, SP /' '/

C  Get node name, system time
	If ( Net$C_Local_Host_Name .eq. ' ' ) then
	    TRN_ItemList2(1) = 8
	    TRN_ItemList2(2) = TRN$_String
	    TRN_ItemList(2) = %Loc(node)
	    TRN_ItemList(3) = %Loc(L_node)
	    TRN_ItemList2(7) = 0
	    TRN_ItemList2(8) = 0

	    SS$_Status = Sys$TrnLnm(,'LNM$FILE_DEV',
	1	Node$Lognam,,
	2	TRN_ItemList)
	    If ( SS$_Status .eq. SS$_NoLog ) Then
		Node = 'Finger'
	    Else
		Node = Node(2:l_Node-2)
	    EndIf
	Else
	    Node = Net$C_Local_Host_Name		! use set value
	End if
	l_Node = Btrim(Node)
	Call Sys$AscTim(,AscTime,,)			! Time now
	AscTime = Make_Pretty(AscTime)
	Today = Day_OfTheWeek(%Val(0))

C  Print brief header
	Call Finger_Out_Routine(LF//
	1			Node(:l_node)//
	2			' VAX/VMS, '//
	3			Today(:Btrim(Today))//', '//
	4			AscTime(:17)//
	5			CR//LF)

	Return
	End

c---------------------------------------------------------------------------
	Logical	Function Check_Name(Username,ComName)

c  Check if the Username of a process matches the name from the
c  input command.

	Logical		Wild_Match
	Character	Username*(*), ComName*(*)

	Check_Name = .false.

	If ( Username .eq. ComName ) Then
	    Check_Name = .true.
	    Return
	EndIf

c  Check for wild-card
	Check_Name = Wild_Match(ComName,Username)

	Return
	End


c-----------------------------------------------------------------------------
	Subroutine User_Info(PID,STS,Prcnam,Username,Terminal,
	1	State, PgCnt, HeaderWritten,
	2	TestOutput,FlagProcess,Finger_Out_Routine)

	External	Finger_Out_Routine

	Integer		
	1		OutboundLinkUnit, 
	2		UafUnit,
	3		ScratchUnit

	Common	/IO_Units/ 
	1		OutboundLinkUnit,
	2		UafUnit,
	3		ScratchUnit
	
	Include		'GETJPIDEF'
	Include		'FingerFlg'
	Include		'Fingerdef'

	Integer		TestOutput,	FlagProcess
	Integer		CPU_Min,	CPU_Sec
	Character	PID_String*8
	Character	Location*25,	Get_Location*25
	Character	Make_Pretty*20,	Filter_Control_Chars*15
	Character	Name*20,	Get_PersonalName*20
	Character	Image*9,	Get_Image*9
	Character	Time_String*11,	Login_Time*5
	Character	CPU_Time*6,	Idle_Time*5,	Get_Idle*5
	Character	TTType*25
	Character	Quename*18
	Character	CR /13/, LF /10/
	Integer		PgCnt
	Character*5	States(15) /
	1	'ColPg','MWait',' CEF ',' PFW ',' LEF ',' LEFO',' Hib ',
	1	' HibO',' Susp','SuspO',' FPg ',' Com ',' ComO',' Cur ',
	1	'     '/
	Integer		LEF_State /5/, Blank_State /15/
	Integer		State_COMO /13/, State_HIBO /8/
	Integer		State_LEFO /6/, State_SUSPO /10/
	Character*5	Size
	Logical		HeaderWritten 
	Integer		Privilege(2) /0,0/

c  ! site-specific
c  Note - this routine is set up so you can select the information
c  you desire printed.  Set the defaults for your site in the FINGERCLI.CLD
c  file.  The user can override these with explicit qualifiers to the
c  FINGER command. If all fields are selected the line is 135 characters long
c  (3 more for long terminal line number).  You could vary the size of certain 
c  fields (e.g. PERSONALNAME or LOCATION) if you wanted to customize things
c  further.  I use only 15 out of 25 characters of the location, and the TTType
c  may wrap.  The size of these could be varied.  I would never use certain 
c  combinations together, e.g. PROCESSNAME and USERNAME (they are practically
c  redundant) - but to each his own. (USERNAME is useful for MAIL and PHONE, 
c  PROCESSNAME is unique.) 		- Rg

c  first some petty preprocessing
	If ( (Testoutput.and.FlagPID) .ne. 0 ) then
	    Write(PID_String,1001) PID
	    Do II = 1,8
		If ( PID_String(II:II) .eq. ' ') PID_String(II:II) = '0'
	    End do
	End if
	Call NULToSP(Terminal,7)
	If ( (Testoutput.and.FlagProcessname) .ne. 0 ) then
	    Call NULToSP(Prcnam,15)
	    Prcnam = Filter_Control_Chars(Prcnam)
	End if
	If ( (Testoutput.and.FlagPersonalName) .ne. 0 )
	1   Name = Make_Pretty(Get_PersonalName(Username))
c  only get P1 stuff for inswapped processes unless asked otherwise
	If ( (Testoutput.and.FlagSwapped) .ne. 0 ) then
	    Image = Make_Pretty(Get_Image(PID,LoginTim,CPUTim))
	Else
           IF (	State .ne. State_COMO .and.
	1	State .ne. State_HIBO .and.
	2	State .ne. State_LEFO .and.
	3	State .ne. State_SUSPO) then
		Image = Make_Pretty(Get_Image(PID,LoginTim,CPUTim))
	    Else
		Image = '<swapped>'
		Logintim(1)= 0
		Logintim(2)= 0
		CPUTim=      0
	    End if
	End if
c  If in DCL and LEF state, don't print STATE. (keep picture cleaner)
	If (Image.eq.'$' .and. State.eq.LEF_State ) State = Blank_State
	Call Sys$Asctim(,Time_String,LoginTim,%Val(1))
	Login_Time = Time_String(1:5)
c  convert CPU time to min and sec
	CPU_Sec = CPUTim/100
	CPU_Min = CPU_Sec/60
	CPU_Sec = CPU_Sec - (60*CPU_Min)
	If ( CPU_Min .le. 999 ) then
	    Write(CPU_Time,1002) CPU_Min, CPU_Sec
	    If ( CPU_Time(5:5) .eq. ' ' ) CPU_Time(5:5) = '0'
	Else
c  if more than 999 min, omit seconds
	    Write(CPU_Time,10021) CPU_Min
	Endif
c  scratch Login and CPU time for outswapped processes
	If ( Image(1:1) .eq. '<' ) Login_Time = ' --- '
	If ( Image(1:1) .eq. '<' ) CPU_Time = '  --- '
	If ( (Testoutput.and.FlagIdleTime) .ne. 0 )
	1	Idle_Time = Get_Idle(PID)
	Write(Size,1003) PgCnt
	Location = Get_Location(Terminal,TTType,PID)
	If ( (FlagProcess.and.FlagSubprocess) .ne. 0 ) then
	    Location = '- Subprocess -'
	    TTType = ' '
	Else If ( (STS.and.Pcb$m_Batch) .ne. 0 ) Then
c  Turn on SYSPRV privilege
	    Privilege(1) =  Prv$M_Sysprv
	    Call Sys$Setprv(%Val(1),Privilege,,)
c  get job controller information
	    Call Get_Queue_Name(PID,Quename,ll)
c  Turn off SYSPRV privilege
	    Call Sys$Setprv(,Privilege,,)
	    Location = 'Q.'//Quename(:ll)
	    TTType = ' '
	End If
c  Column headings
	If ( .not. HeaderWritten ) Then
	    Call Finger_Out_Routine(LF)
	    If ( (Testoutput.and.FlagPID) .ne. 0 )
	1	Call Finger_Out_Routine('PID      ')
	    If ( (Testoutput.and.FlagProcessname) .ne. 0 )
	1	Call Finger_Out_Routine('Process         ')
	    If ( (Testoutput.and.FlagUsername) .ne. 0 )
	1	Call Finger_Out_Routine('Username     ')
	    If ( (Testoutput.and.FlagPersonalName) .ne. 0 )
	1	Call Finger_Out_Routine('Personal name        ')
	    If ( (Testoutput.and.FlagImagename) .ne. 0 )
	1	Call Finger_Out_Routine('Program   ')
	    If ( (Testoutput.and.FlagTerminal) .ne. 0 )
c	1	Call Finger_Out_Routine('Term ')	! short terminal name
	1	Call Finger_Out_Routine('Term    ')	! long terminal name
	    If ( (Testoutput.and.FlagLoginTime) .ne. 0 )
	1	Call Finger_Out_Routine('Login ')
	    If ( (Testoutput.and.FlagCPUTime) .ne. 0 )
	1	Call Finger_Out_Routine('  CPU  ')
	    If ( (Testoutput.and.FlagIdleTime) .ne. 0 )
	1	Call Finger_Out_Routine(' Idle ')
	    If ( (Testoutput.and.FlagState) .ne. 0)
	1	Call Finger_Out_Routine('State ')
	    If ( (Testoutput.and.FlagSize) .ne. 0)
	1	Call Finger_Out_Routine(' Size ')
	    If ( (Testoutput.and.FlagLocation) .ne. 0 )
	1	Call Finger_Out_Routine('Location        ')
	    If ( (Testoutput.and.FlagTTType) .ne. 0 )
	1	Call Finger_Out_Routine('TT Type')
	    Call Finger_Out_Routine(CR)
	    HeaderWritten = .true.
	EndIf

c  Write out line of user information

	Call Finger_Out_Routine(LF)
	If ( (Testoutput.and.FlagPID) .ne. 0 )
	1	Call Finger_Out_Routine(PID_String//' ')
	If ( (Testoutput.and.FlagProcessname) .ne. 0 )
	1	Call Finger_Out_Routine(Prcnam//' ')
	If ( (Testoutput.and.FlagUsername) .ne. 0 )
	1	Call Finger_Out_Routine(Username//' ')
	If ( (Testoutput.and.FlagPersonalName) .ne. 0 )
	1	Call Finger_Out_Routine(Name//' ')
	If ( (Testoutput.and.FlagImagename) .ne. 0 )
	1	Call Finger_Out_Routine(Image//' ')
	If ( (Testoutput.and.FlagTerminal) .ne. 0 )
c	1	Call Finger_Out_Routine(Terminal(1:4)//' ')	! short
	1	Call Finger_Out_Routine(Terminal(1:7)//' ')	! long
	If ( (Testoutput.and.FlagLoginTime) .ne. 0 )
	1	Call Finger_Out_Routine(Login_Time//' ')
	If ( (Testoutput.and.FlagCPUTime) .ne. 0 )
	1	Call Finger_Out_Routine(CPU_Time//' ')
	If ( (Testoutput.and.FlagIdleTime) .ne. 0 )
	1	Call Finger_Out_Routine(Idle_Time//' ')
	If ( (Testoutput.and.FlagState) .ne. 0)
	1	Call Finger_Out_Routine(States(State)//' ')
	If ( (Testoutput.and.FlagSize) .ne. 0)
	1	Call Finger_Out_Routine(Size//' ')
	If ( (Testoutput.and.FlagLocation) .ne. 0 )
	1	Call Finger_Out_Routine(Location(1:15)//' ')
	If ( (Testoutput.and.FlagTTType) .ne. 0 )
	1	Call Finger_Out_Routine(TTType)
	Call Finger_Out_Routine(CR)

	Return

1000	Format(A)
1001	Format(Z8)
1002	Format(I3,':',I2)
10021	Format(I6)
1003	Format(I5)

	End

c-----------------------------------------------------------------------------
	Character*5 Function Get_Idle(PID)

c  Call a kernel mode routine which makes a table of idle times
c  for allocated terminals

	Include		'Fingercom.for'

	Integer		I_Idle, I_hr, I_min
	Integer		PID

	Get_Idle = ' '

	Do ii = 1,max_units
	    If ( TT_UCB$I_PIDs(ii) .eq. 0 ) Return
	    If ( PID .eq. TT_UCB$I_PIDs(ii) ) then
		I_Idle = TT_UCB$I_Times(ii)
		Go to 200
	    End if
	End do
	Return

200	Continue
	I_min = I_Idle/60
	If ( I_Idle .le. 0 ) Return
	I_hr = I_Min/60
	I_Min = I_Min - (60*I_hr)
	Write (Get_Idle,1000,Err=300) I_hr, I_Min
	If ( I_hr .eq. 0 ) then
	    Get_Idle(1:3) = ' '
	    If ( I_Min .le. 0 ) Get_Idle = '    .'
	Else
	    If ( Get_Idle(4:4) .eq. ' ' ) Get_Idle(4:4) = '0'
	End if
300	Return

1000	Format(I2,':',I2)

	End

c-----------------------------------------------------------------------------
	Character*6 Function Get_DECnet_Node(PID)

c  Get the remote DECnet node name given a link found in the UCB
c  for the remote terminal.  Taken from Craig Leres (lbl) Ratfor routine.
c  His comments follow.

c	### rmtinfo - get remote terminal info
c	#
c	# synopsis
c	#
c	#    integer status, link, node
c	#    character site(7)
c	#    status = rmtinfo ( link, node, site )
c	#
c	#	link - rtt link number
c	#	node - returned DECnet node number
c	#	site - character string to receive site name
c	#	status - VMS return status
c	#
c	# Given the link number (as found in the ucb$w_rtt_link offset in the
c	# unit control block of a remote terminal), this routine consults NETACP
c	# to get the node number and site name of the DECnet host the remote
c	# terminal is attached to. The privilege NETMBX is required for use.
c	#
c	# Warning: This routine is chalked full of undocumented MAGIC.
c	#

	Include		'Fingercom.for'

	Parameter NFB$C_FC_SHOW = '00000022'X
	Parameter NFB$M_NOUPD	= '00000004'X
	Parameter NFB$C_DB_LLI	= '00000008'X
	Parameter NFB$C_OP_EQL	= '00000000'X
	Parameter NFB$C_LLI_LLN	= '08010012'X
	Parameter NFB$C_WILDCARD= '00000001'X
	Parameter NFB$C_LLI_PNA	= '08010014'X
	Parameter NFB$C_LLI_PNN	= '08020043'X
	Parameter NFB$C_ENDOFLIST= '00000000'X

	Parameter NFB_SIZE	= 28	!	# one gronk + 3 long
	Parameter BUF_SIZE	= 12	!	# long + word + 6 byte string
	Parameter SITE_SIZE	= 6	!	# number of characters in a hostname

	Integer		PID

	Integer i, status, chan, sys$assign, sys$qiow, enode
	integer net_dsc(2), nfb_dsc(2), key_dsc(2), key(2), buf_dsc(2)
	Character Net_str*4 /'NET:'/
	integer k1, k2, f1, f2, f3
	integer*2 c1, c2, iosb(4), elen
	logical init/.false./
	byte nfb(NFB_SIZE), buf(BUF_SIZE), esite(SITE_SIZE)
	equivalence (nfb(5), k1), (nfb(9), k2), (nfb(13), c1), (nfb(15), c2)
	equivalence (nfb(17), f1), (nfb(21), f2), (nfb(25), f3)
	equivalence (buf(1), enode), (buf(5), elen), (buf(7), esite)
	external ss$_normal, io$_acpcontrol

	Get_DECnet_Node = ' '
	Do ii = 1, SITE_SIZE
	    esite(ii) = ' '
	End do
	Do ii = 1,max_units
	    If ( TT_UCB$I_PIDs(ii) .eq. 0 ) Return
	    If ( PID .eq. TT_UCB$I_PIDs(ii) ) then
		link = TT_UCB$I_RTT_Link(ii)
		Go to 200
	    End if
	End do
	Return
200	Continue

	Net_dsc(1) = len(Net_Str)
	Net_dsc(2) = %loc(Net_Str)
	status = sys$assign ( Net_dsc, chan, , )
	if ( status .ne. %loc(ss$_normal) ) then
	    Call Lib$Signal(%Val(status))
	    Return
	End if

	nfb(1) = NFB$C_FC_SHOW
	nfb(2) = NFB$M_NOUPD	!	# don't update the database
	nfb(3) = NFB$C_DB_LLI	!	# logical link information database
	nfb(4) = NFB$C_OP_EQL	!	# match the key exactly
	k1 = NFB$C_LLI_LLN	!	# the key is a logical link number
	k2 = NFB$C_WILDCARD	!	# search the whole database
	c1 = 0			!	# must be zero
	c2 = 0			!	# let counted strings vary in length
	f1 = NFB$C_LLI_PNA	!	# partner's node address
	f2 = NFB$C_LLI_PNN	!	# partner's node name
	f3 = NFB$C_ENDOFLIST

	nfb_dsc(1) = NFB_SIZE
	nfb_dsc(2) = %loc(nfb)

	key_dsc(1) = 8
	key_dsc(2) = %loc(key)
	key(1) = 0
	key(2) = link

	buf_dsc(1) = BUF_SIZE
	buf_dsc(2) = %loc(buf)

	status = sys$qiow (,%val(chan),%val(%loc(io$_acpcontrol)),iosb,,,
	1    nfb_dsc,key_dsc,,buf_dsc,,)
	if ( status .ne. %loc(ss$_normal) ) then
	    Call Lib$Signal(%Val(status))
	    Call sys$dassgn (%Val(chan))
	    Return
	End if
	if ( iosb(1) .ne. %loc(ss$_normal) ) then
	    Call Lib$Signal(%Val(iosb(1)))
	    Call sys$dassgn (%Val(chan))
	    Return
	End if
	node = enode
	Do i = 1, SITE_SIZE
	    Get_DECnet_Node(i:i) = Char(esite(i))
	End do

	Call sys$dassgn (%Val(chan))
	return

	end

c-----------------------------------------------------------------------------
	Subroutine Get_Idle_Times

c  Call a kernel mode routine which makes a table of idle times,
c  and links from the UCB for finding the DECnet node name,
c  and PIDs for allocated terminals

	Include		'Fingercom.for'
	Include		'Fingerdef.for'

	Integer		TT_UCB
	Integer		Privilege(2) /0,0/

c  Turn on CMKRNL privileg
	Privilege(1) =  Prv$M_Cmkrnl
	Call Sys$Setprv(%Val(1),Privilege,,)
c  Call Kernel mode routine
	IStatus = TT_UCB(TT_UCB$I_Times,TT_UCB$I_PIDs,TT_UCB$I_Device,
	1		TT_UCB$I_Unit,TT_UCB$I_RTT_Link,max_units)
c  Turn off CMKRNL privilege
	Call Sys$Setprv(,Privilege,,)

	If ( .not. IStatus ) Call Lib$Signal(IStatus)


	Return

	End

c-----------------------------------------------------------------------------
	Character*8	Function Get_jnet_Node(Terminal)

c	This routine finds the jnet node name using a /SYSTEM
c	Logical name of the form JNET_PTYxxxx

	Integer		TRN$_String /Z00000002/
	Integer		TRN_ItemList(4)
	Integer*2	TRN_ItemList2(8)
	Equivalence	(TRN_ItemList,TRN_ItemList2)

	Character	Terminal*7

	Get_jnet_Node = '?'	! default
	If ( Index(Terminal,'PTY') .eq. 0 ) Return	! Wrong terminal type
	ii = Index(Terminal,':') - 1

	TRN_ItemList2(1) = 8
	TRN_ItemList2(2) = TRN$_String
	TRN_ItemList(2) = %Loc(Get_jnet_Node)
	TRN_ItemList(3) = %Loc(L_node)
	TRN_ItemList2(7) = 0
	TRN_ItemList2(8) = 0

	SS$_Status = Sys$TrnLnm(,'LNM$SYSTEM_TABLE',
	1	'JNET_'//Terminal(:ii),,
	3	TRN_ItemList)

	Return
	End	

c-----------------------------------------------------------------------------
	Character*25	Function Get_Location(Terminal,TTType,PID)

c  This routine returns the location and terminal type, giver the
c  terminal name.  It user the data in the shared common section.

c  ! site-specific
c  If the terminal begins with RT it is considered a DECnet terminal.
c  If it begins with PT is ia assumed to be a pseudoterminal.  We use
c  these to connect to a network called jnet.  These can be ignored
c  if you don't have them, otherwise change appropriately.
c  If the terminal begins with VT its considered a VMS V4.x virtual
c  terminal and the associated physical terminal is used.

c  In the normal situation, the 25 characters returned are
c  the location and 25 for the type.  Obviously these can be 
c  can be shortened for printing (I normally print 15 + 25)

	Include		'FingerCom.For'

	Character	Terminal*7, TTType*25
	Character	Network*20,	Get_Network*20
	Character	Node*12,	Get_Decnet_Node*6
	Character	Get_jnet_Node*8
	Integer		Btrim,		PID

	Integer		I_Device(4)
	Byte		B_Device(16), B_Device_Len
	Character	C_Device*15
	Equivalence	(I_Device, B_Device)
	Equivalence	(B_Device(1), B_Device_Len)
	Equivalence	(B_Device(2), C_Device)
	
	Get_Location = ' '	! If location can't be found
	TTType = ' '

c  first see if a VT (virtual terminal) is connected to a physical
c  terminal.
	If ( Terminal(1:2) .eq. 'VT' ) then
	    Do ii = 1, max_units
		If ( PID .eq. TT_UCB$I_PIDs(ii) ) GoTo 101
	    End do
	    Go to 102
101	    I_Device(1) = TT_UCB$I_Device(1,ii)
	    I_Device(2) = TT_UCB$I_Device(2,ii)
	    I_Device(3) = TT_UCB$I_Device(3,ii)
	    I_Device(4) = TT_UCB$I_Device(4,ii)
	    Terminal = C_Device(:B_Device_len)
	    If ( TT_UCB$I_Unit(ii) .eq. 0 ) then
		n = 1
	    Else
	        n = Log10(Float(TT_UCB$I_Unit(ii))+0.5) + 1
	    End if
	    Write(Terminal(B_Device_Len+1:B_Device_Len+1+n),1111)
	1	TT_UCB$I_Unit(ii)
1111		Format(I<n>,':')
	End if
102	Continue

	If ( Terminal(1:2) .eq. 'RT' ) Then
	    Node = Get_DECnet_Node(PID)
	    Network = Get_Network('D')
	    If ( Network .eq. '?' ) Network = 'DECnet'
	    Get_Location = Node(:Btrim(Node))//
	1	'.'//Network(:Btrim(Network))
	ElseIf ( Terminal(1:2) .eq. 'PT' ) Then	! Site-specific
	    Node = Get_jnet_Node(Terminal)
	    Network = Get_Network('J')
	    If ( Network .eq. '?' ) Network = 'jnet'
	    Get_Location = Node(:Btrim(Node))//
	1	'.'//Network(:Btrim(Network))
	ElseIf ( Terminal(1:2) .eq. 'VT' ) then
	    Get_Location = '<disconnected>'
	Else
c	  search for Terminal in shared common database
	    Do ii = 1,Loc$I_Last
		If ( Loc$C_Terminal(ii) .eq. Terminal ) then
		    Get_Location = Loc$C_Location(ii)
		    TTType = Loc$C_TTType(ii)
		    Return
	    	End if
	    End do
	EndIf
	Return

	End

c---------------------------------------------------------------------------
	Character*9	Function Get_Image(Input_PID,LOGINTIM,CPUTIM)

c  This routine does an additional GETJPI to get the image name, the Login
c  time, and the CPU time.  This is not done in the main loop in Local_Finger 
c  because this Getjpi may take a long time for low priority or swapped out
c  processes and these processes are typically not listed by finger anyway.  

c  ! Site-specific note: Only images from "public" directories are identified 
c  by finger for reasons of privacy (basically so "Joe" won't complain that
c  "Harry" is running Adventure all day.)  The several site-specific public 
c  directories are set as parameters here and should be changed for your site.
c  You could also, for example, just check the disk and decide all images on
c  a certain disk are public etc.  Or just eliminate the check altogether 
c  and all images, public or private, will be identified.
c					- Rg
c	Parameter	PublicDirectory1 = 'SYS$SYSROOT:[SYSEXE]'! obviously.
c	Parameter	PublicDirectory2 = 'CHEM$SYSROOT:[USER]'! These 2 for..
c	Parameter	PublicDirectory3 = 'WORK$:[SYS.USER]'	! my site -Rg
c	Parameter	PublicDirectory4 = 'DBA0:'		! an example
c	Parameter	PublicDirectory5 = 'DRA1:[LOCAL]'	! an example
c
c  ! Site-specific: end of note

	Integer		Input_PID

C  Include all GETJPI data and definitions
	Include		'GETJPIDEF.FOR'

	Get_Image = '<unavail>'

C  Set up item list for GETJPI
	I = 1
	II = 1
	ITEM_LIST2(II+IC) =	JPI$_IMAGNAME
	ITEM_LIST2(II+BL) =	L_IMAGNAME
	ITEM_LIST(I+BA)  =	%LOC(IMAGNAME)
	ITEM_LIST(I+RL)  =	%LOC(RL_IMAGNAME)
	I = I + 3
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_LOGINTIM
	ITEM_LIST2(II+BL) =	L_LOGINTIM
	ITEM_LIST(I+BA)  =	%LOC(LOGINTIM)
	ITEM_LIST(I+RL)  =	%LOC(RL_LOGINTIM)
	I = I + 3
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_CPUTIM
	ITEM_LIST2(II+BL) =	L_CPUTIM
	ITEM_LIST(I+BA)  =	%LOC(CPUTIM)
	ITEM_LIST(I+RL)  =	%LOC(RL_CPUTIM)

	ITEM_LIST(I+3) = 0		! End of list


c  Do Getjpi
	IStatus =  Sys$Getjpi(,Input_PID,,Item_List,,,)
	If ( .not. IStatus ) Return
	Call Sys$Waitfr()

c  Check for no image (DCL)
	If ( Imagname(:Rl_Imagname) .eq. ' ' ) Then
	    Get_Image = '$'	! DCL
	    Return
	EndIf

c  Check for public directory
c  ! Site-specific: If you want all images printed, delete this whole block.
c	i_Dir1 = Index(Imagname,PublicDirectory1)	!
c	i_Dir2 = Index(Imagname,PublicDirectory2)	! to be set
c	i_Dir3 = Index(Imagname,PublicDirectory3)	! above for
cc	i_Dir4 = Index(Imagname,PublicDirectory4)	! each site. 
cc	i_Dir5 = Index(Imagname,PublicDirectory5)	! 
c	If ( 
c	1		i_Dir1 .eq. 0 	! one of 
c	2	.and. 	i_Dir2 .eq. 0 	! these for 
c	3	.and. 	i_Dir3 .eq. 0 	! each public 
cc	4	.and. 	i_Dir4 .eq. 0 	! directory
cc	5	.and. 	i_Dir5 .eq. 0 	! at your site.
c	6   ) Then
c	    Get_Image = '<user>' ! default for image in private directory
c	    Return		 ! (for privacy)
c	EndIf
c  ! Site-specific - end of block

c  Image good.  Just get file name.

	Do i = Rl_Imagname,0,-1
	    If ( Imagname(i:i) .eq. ']' ) Goto 101
	    If ( Imagname(i:i) .eq. '>' ) Goto 101
	    If ( Imagname(i:i) .eq. ':' ) Goto 101
	End do

101	ii = i + 1
	iii = Index(Imagname(ii:Rl_Imagname),'.') + ii - 2
	Get_Image = Imagname(ii:iii)

	Return
	End

c---------------------------------------------------------------------------
	Character*20	Function Get_PersonalName(Username)

	Include		'FingerCom.For'

	Character*12	UserName		! User's login name
	Character*25	Owner, Fix_Name*25

	Call NULToSP(Username,12)
	Owner = ' '		! default if name not found

c  search for Userame in shared common database
	Do ii = 1,Usr$I_Last
	    If ( Usr$C_Username(ii) .eq. Username ) then
		Owner = Usr$C_PersonalName(ii)
		Go to 122
	    End if
	End do

122	Continue
	Get_PersonalName = Fix_Name(Owner)

	Return
	End

c---------------------------------------------------------------------------
	Character*12	Function Get_Username(PersonalName,
	1			NMatches,OutFlag,Out_Routine)
c
c  This routine searches the username <--> Personalname database
c  for a match in part (or all) with the personal name and returns
c  the Username.  If there is more than 1 match the last match is
c  returned.  "minimum_match_length" requires at least that many
c  characters for the compare (to avoid matching all kinds of small
c  strings).  The routine also returns the number of matches and will
c  output the match on option.

c  ! site-specific:	set minimum match length or omit. (see below)
c	Parameter	minimum_match_length = 3

	Include		'FingerCom.For'

	Integer		NMatches, Btrim
	Logical		OutFlag, ExactMatch, Match
	Logical		Wild, Wild_Match
	External	Out_Routine
	Character	C_Temp*25, Str$UpCase*25
	Character	Fix_Name*25, Make_Pretty*25
	Character*(*)	PersonalName
	Character*1	LF/10/, CR/13/

	Get_Username = ' '
	NMatches = 0
c  ! site-specific: use following code for minimum match length
c	If ( Len(PersonalName) .lt. minimum_match_length ) then
c	    ExactMatch = .true.
c	Else
	    ExactMatch = .false.
c	End if
c  check if wildcards (a bit useless considering...)
	If ((Index(PersonalName,'*') + Index(PersonalName,'%')).gt.0)
	1	Wild = .true.
c  search for PersonalName in shared common database
	Do ii = 1,Usr$I_Last
	    Match = .false.
	    If ( ExactMatch ) then
		If ( Str$UpCase(Usr$C_Personalname(ii))
	1		 .eq. Personalname ) Match = .true.
	    Else if ( Wild ) then
		iii = Btrim(Usr$C_Personalname(ii))
		C_Temp = Str$Upcase(Usr$C_Personalname(ii))
		Match = Wild_Match('*'//PersonalName//'*',	! add wild
	1		C_Temp(:iii))				! front & back
	    Else
		If ( Index(Str$UpCase(Usr$C_PersonalName(ii)),
	1	    PersonalName) .ne. 0 ) Match = .true.
	    End if
	    If ( Match ) then
		NMatches = NMatches + 1
		Get_Username = Usr$C_Username(ii)
		If ( OutFlag ) then
		    Call Out_Routine(LF//Usr$C_Username(ii)//' - '//
	1		Make_Pretty(Fix_Name(Usr$C_PersonalName(ii)))
	2		//CR)
		End if
	    End if
	End do

	Return
	End

c---------------------------------------------------------------------------
	Character*9	Function Day_OfTheWeek(BinTime)

	Character*9	Day(7) /
	1		'Monday',
	2		'Tuesday',
	3		'Wednesday',
	4		'Thursday',
	5		'Friday',
	6		'Saturday',
	7		'Sunday'/

	Integer		BinTime(2), DayNumber

	Call Lib$Day_of_Week(BinTime,DayNumber)
	Day_OfTheWeek = Day(DayNumber)

	Return
	End

c---------------------------------------------------------------------------
	Subroutine	NULToSP(String,Length)

	Character	String*(*)
	Character	NUL/0/, SP/' '/

	Do ii=1,Length
	    If ( String(ii:ii) .eq. NUL ) String(ii:ii) = SP
	EndDo

	Return
	End

c------------------------------------------------------------------------
	Character*25 Function Fix_Name(Name)

	Character	Name*25, First_Name*25, Last_Name*25
	Character	SP /' '/

	Fix_Name = Name
	If ( Name .eq. ' ' ) Return

	If ( Name(1:1) .eq. '(' ) GoTo 200
	i_Comma = Index(Name,',')
	If ( i_Comma .eq. 0 ) GoTo 200

	i_Last = i_Comma-1
	If ( i_Last .le. 0 ) Then
	    Last_Name = ' '
	    i_Last = 1
	EndIf
	Last_Name = Name(:i_Last)

	First_Name = Name(i_Comma+1:)
	i_First = 25 - i_Comma
	Do ii=i_First,2,-1
	    If ( First_Name(ii:ii) .ne. SP ) GoTo 110
	EndDo

110	i_First = ii
	Do ii = 1,i_First
	    If ( First_Name(ii:ii) .ne. SP ) GoTo 120
	EndDo

120	First_Name = First_Name(ii:i_First)
	i_First = i_First - ii + 1

	Fix_Name = First_name(:i_First)//SP//Last_name(:i_Last)

200	Return

	END


c------------------------------------------------------------
	Character*(*) Function Make_Pretty(String)

c	! Site-specific note
c  This implements one person's idea of what constitutes "pretty"
c  text: all words capitalized, with other letters lower case.  If
c  you like all UPPER-CASE (like VMS) or all lower-case (like unix)
c  feel free to change this as per comments below.		- Rg

	Character*(*)	String
	Character	Item
	Character	Down_Case, Str$UpCase	! May have to specify length
	Logical		NewWord, Alpha

	NewWord = .true.
	Make_Pretty = ' '

	Do i = 1, Len(String)
	    Item = String(i:i)
	    Alpha = (Item .ge. 'A' .and. Item .le. 'Z') .or.
	1	    (Item .ge. 'a' .and. Item .le. 'z')
	    Item = Down_Case(Item)
	    If ( NewWord ) Item = Str$UpCase(Item)
	    NewWord = .not. Alpha
	    Make_Pretty(i:i) = Item
	EndDo

c  Following are alternate possibilities.	! Site-specific
c  Must give "Down_Case" and "Str$UpCase" correct length specification above.
c	Make_Pretty = Down_Case(String)		! For all lower case
c	Make_Pretty = Str$UpCase(String)	! For all UPPER CASE

	Return
	End

c------------------------------------------------------------
	Character*(*) Function Filter_Control_Chars(String)

c	This routine can be used to filter control characters
c	from the output stream and put a period (".") in their
c	place to prevent wierd process names etc. from messing 
c	up the terminal screen.

	Character*(*)	String

	Character*256	FilterTable 

	    Parameter ( FilterTable =
	1	'................................' //
	2	' !"#$%&''()*+,-./0123456789:;<=>?'//
	3	'@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_' //
	4	'`abcdefghijklmnopqrstuvwxyz{|}~.' //
	5	'................................' //
	6	'................................' //
	7	'................................' //
	8	'................................' )

	Call Lib$Movtc(String,' ',FilterTable,Filter_Control_Chars)

	Return
	End

c------------------------------------------------------------
	Character*(*) Function Down_Case(Item)

	Character*(*)	Item

	Do i = 1,Len(Item)
	    Down_Case(i:i) = Item(i:i)
	    If ( Item(i:i) .ge. 'A' .and. Item(i:i) .le. 'Z' ) 
	1	Down_case(i:i) = Char(Ichar(Item(i:i)) + 32)
	EndDo

	Return
	End

c------------------------------------------------------------
	Integer Function OutLink_UserOpen(FAB,RAB,Unit)

	Integer		FAB(30), RAB(30)
	Integer		Rab$L_Rop/2/, Rab$M_Loc/Z00010000/
	Integer		Sys$Create, Sys$Connect
	Integer		Unit, OutLinkOpenStatus, OutLinkRMSStatus

	Common	/OutLinkOpen_Common/ OutLinkOpenStatus, OutLinkRMSStatus

	iii = Sys$Create(FAB)
	OutLinkRMSStatus = iii		! RMS Status
	OutLinkOpenStatus = FAB(4)	! This is the Fab$l_STS field: status

	If ( .not. iii ) Then
	    IF ( OutLinkOpenStatus .eq. 0 ) OutLinkOpenStatus = iii
	    OutLink_UserOpen = iii
	    Return
	EndIf

	RAB(Rab$L_Rop) = RAB(Rab$L_Rop) .or. Rab$M_Loc	! Locate option
	OutLink_UserOpen = Sys$Connect(RAB)

	Return
	End

c---------------------------------------------------------------------
	Subroutine Personal_Info(UserName, Directory, NewMes, LastLogin,
	1	LoggedIn, TestOutput,Finger_Out_Routine)

c   Routine to type a user's Mail info and PLAN file, given his name.
c   Adapted from routine "Type_Plan" written at CMU PSYA::

c  ! Site-specific note:  If you want different names for plan files,
c  change or add to the following list

	Include		'Fingerdef'
	Include		'FingerFlg'

	Parameter PlanFileName1 = 'FINGER.PLN'
	Parameter PlanFileName2 = 'PLAN.'	! compatible with EUNICE
c	Parameter PlanFileName3 = 'anything'	! your choice

	External	Finger_Out_Routine

	Integer		
	1		OutboundLinkUnit, 
	2		UafUnit,
	3		ScratchUnit

	Common	/IO_Units/ 
	1		OutboundLinkUnit,
	2		UafUnit,
	3		ScratchUnit

	Integer*2	NewMes
	Logical		LoggedIn
	Integer		LastLogin(2)
	Integer		SS$_Status,	Sys$Crmpsc
	Integer		MailOpenStatus,	MailFileChan
	Common		/MailOpen_Common/  MailOpenStatus, MailFileChan
	External	MailFile_UserOpen
	Integer		MailTextDescr(2)
	Integer		Inadr(2)/0,0/,	Retadr(2)
	Integer		Flags/z00020000/

	Character	Temp*25
	Character*50	MailFile, PlanFile, Directory
	Character*12	UserName
	Character*9	Day_oftheWeek, LastLogin_Day
	Character*23	LastLogin_Time, Make_Pretty
	Character*132	Line
	Character*1	LF/10/, CR/13/
	Integer		Btrim
	Integer		TestOutput
	External	Priv_UserOpen

C  Last Login info
	If ( .not. (LastLogin(1).eq.0 .and. LastLogin(2).eq.0) ) then
	    LastLogin_Day = Day_oftheWeek(LastLogin)
	    Call Sys$AscTim(,LastLogin_Time,LastLogin,)
	    LastLogin_Time = Make_Pretty(LastLogin_Time)
	    If ( LoggedIn ) then
		Call Finger_Out_Routine(LF//' Logged in since: ')
	    Else
		Call Finger_Out_Routine(LF//' Last logged in: ')
	    End if
	    Call Finger_Out_Routine(
	1	LastLogin_Day(:Btrim(LastLogin_Day))//', '//
	2	LastLogin_Time(:17)//CR)
	End if
C  Mail information
	If ( (TestOutput.and.FlagMail) .ne. 0 ) then
	  Call Finger_Out_Routine(LF//' Mail: ')
	  If (NewMes .gt. 0) then
	    Temp = ' '
	    If ( NewMes .eq. 1 ) then
		Call Finger_Out_Routine('1 new message.'//CR)
	    ElseIf ( NewMes .gt. 1 .and. NewMes .lt. 10 ) then
		Write(Temp,1001)NewMes,' new messages.'//CR
		Call Finger_Out_Routine(Temp(:16))
	    ElseIf ( NewMes .ge. 10 ) then
		Write(Temp,1002)NewMes,' new messages.'//CR
		Call Finger_Out_Routine(Temp(:18))
	    EndIf
c  ! Site-specific note:
c  If you do not wish the mail "From: so-and-so" information printed
c  omit the next section of code.
c	    MailFile = Directory(1:Btrim(Directory))//'MAIL.MAI'
c	    Open(	Unit=ScratchUnit,
c	1		File=MailFile,
c	2		Type='Old',
c	3		Shared,
c	4		ReadOnly,
c	5		Err=101,
c	6		UserOpen=MailFile_UserOpen)
c	    SS$_Status = Sys$Crmpsc(Inadr,Retadr,,%Val(Flags),
c	1		,,,%Val(MailFileChan),,,,)
c	    If ( .not. SS$_Status ) GoTo 100
c	    MailTextDescr(1) = Retadr(2) - Retadr(1)
c	    MailTextDescr(2) = Retadr(1)
c	    If ( MailTextDescr(1) .ge. 32768 ) Then
c		MailTextDescr(1) = 32767
c		MailTextDescr(2) = Retadr(2) - 32767
c	    Endif
c	    Call MailTextInfo(MailTextDescr,Finger_Out_Routine)
c	    Call Sys$Deltva(Retadr,,)
c	    Call Sys$Dassgn(%Val(MailFileChan))
c100	    Close(Unit=ScratchUnit,Err=101)
c101	    Continue		! No Mail file (Open failure)
cc  ! Site-specific - end of section
	  Else
	    Call Finger_Out_Routine('(no new mail)'//CR)
	  Endif
c
C  1 blank line
c	  Call Finger_Out_Routine(LF//CR)
	EndIf

C  Plan information
c  ! Site-specific note:
c  You may opt for another standard name for the plan file, see above.

	If ( (TestOutput.and.FlagPlan) .ne. 0 ) then
	  Call Finger_Out_Routine(LF//' Plan: ')

	  PlanFile = Directory(1:Btrim(Directory))//PlanFileName1
	  Open (	Unit=ScratchUnit,
	1	File=PlanFile,
	2	User Open = Priv_UserOpen,
	2	Status='old',
	3	Err=201,
	4	Shared,
	5	Readonly)

	  GoTo 250

c  Error opening Plan File - look for an alternate.
201	  Continue
	  PlanFile = Directory(1:Btrim(Directory))//PlanFileName2
	  Open (	Unit=ScratchUnit,
	1	File=PlanFile,
	2	User Open = Priv_UserOpen,
	2	Status='old',
	3	Err=202,
	4	Shared,
	5	Readonly)

	  GoTo 250

c  look for another - or give up ! Site-specific
202	  Continue
c	  PlanFile = Directory(1:Btrim(Directory))//PlanFileName3
c	  Open (	Unit=ScratchUnit,
c	1	File=PlanFile,
c	2	User Open = Priv_UserOpen,
c	2	Status='old',
c	3	Err=301,
c	4	Shared,
c	5	Readonly)
c	  GoTo 250
	  GoTo 301

c  Found the file - list it.
250	  Call Finger_Out_Routine(CR)
	  DoWhile(.True.)
	    Read(ScratchUnit,2000,End=300) l_line, Line
	    Call Finger_Out_Routine(LF//Line(1:l_line)//CR)
	  EndDo
300	  Call Priv_Close(ScratchUnit)
	  Return

C  Here if no plan file
301	  Continue

	  Call Finger_Out_Routine('(no plan file)'//CR)
	EndIf

	Return

1001	Format(I1,A)
1002	Format(I3,A)
2000	Format(Q,A)

	End

c------------------------------------------------------------
	Integer Function MailFile_UserOpen(Fab,Rab,Unit)

c  Set the UFO bit on in the FOP field so file can be mapped
c  The 2nd word of the FAB is Fab$l_FOP

	Integer		Fab(30), Rab(30)
	Integer		Fab$m_UFO/Z00020000/
	Integer		Sys$Open
	Integer		Unit, MailOpenStatus, MailFileChan

	Common	/MailOpen_Common/ MailOpenStatus, MailFileChan

	Fab(2) = Fab(2) .or. Fab$M_UFO	! 2nd longword is FOP field
	MailOpenStatus = Sys$Open(FAB)
	MailFileChan = Fab(4)

	MailFile_UserOpen = MailOpenStatus
	Return
	End

c-----------------------------------------------------------------------
      Subroutine MailTextInfo(FileString,Out_Routine)
     
c  ! VMS-specific V3.0 - check in future releases of MAIL.
c  Search for unread messages in VMS type MAIL file.  The
c  file is mapped to the string "FileString".  Finding the
c  message depends on the assumption that the file is a VMS
c  variable length record file with the length in a word
c  preceding the line.  VMS MAIL also puts a "*" at the end
c  of the "From:" line for unread messages.
     
c  Modified by Craig R. Watkins 23-Oct-1983
c  To check for end of file
     
      External  Out_Routine
     
      Integer           Unit
      Character*(*)     FileString
      Character*1       LF/10/, CR/13/
     
      i = 1
      ilen = Len(FileString)
      j = ilen - 512                                    ! Last block in file
      If ( j .gt. 0) Then
          jj = Index(FileString(j:), Char(255)//Char(255))! EOF marker
          If ( jj .ne. 0 ) ilen = ilen - 512 + jj       ! Mark it there
      EndIf
      DoWhile(.true.)
          ii = Index(FileString(i:),'From:')
          If ( ii .eq. 0 ) Return
          i = i+ii
          If ( Ichar(FileString(i-2:)) .eq. 0 ) Then
        iii = Ichar(FileString(i-3:))           ! length of line
        If ( i+iii-2 .gt. ilen ) Return
        If ( FileString(i+iii-2:i+iii-2) .eq. '*' )
     1  Call Out_Routine(LF//'       '//
     2                  FileString(i-1:i+iii-2)//
     3                  CR)
          EndIf
      EndDo
     
1000  Format(A)
      End

c--------------------------------------------------------------------------
	integer function btrim (string)

c   Integer function to determine the length of a character string with
c   trailing blanks and tabs removed.
c   Routine written at CMU PSYA::

	implicit integer*4 (a-z)
	integer countr
	character*(*) string
	character*1 tab, NUL, space
	
	NUL = char(0)
	tab = char(9)
	space = char(32)

	do 10 countr = len (string), 1, -1
		if (string (countr : countr) .ne. NUL .and.
     *			string (countr:countr) .ne. space .and.
     *			string (countr:countr) .ne. tab) then
			btrim = countr
			return
		endif
10	continue

	btrim = 1
	return
	end


c--------------------------------------------------------------------------
	Logical	Function Get_ID(UserName, Directory, 
	1			NewMes, Name, LastLogin)

c   Function to return the default login device and directory and
c   also determine if the user has new mail. 

	Include		'Fingerdef'

	Integer		
	1		OutboundLinkUnit, 
	2		UafUnit,
	3		ScratchUnit

	Common	/IO_Units/ 
	1		OutboundLinkUnit,
	2		UafUnit,
	3		ScratchUnit

c	Byte		UAF_Record(0:UAF$K_Length)
	Byte		UAF_Record(1:UAF$K_Length)

	Byte		UAF_L_DefDev
	Equivalence	(UAF_L_DefDev,UAF_Record(Uaf$K_DefDev))
	Character	UAF_DefDev*(UAF$S_DefDev)
	Equivalence	(UAF_DefDev,UAF_Record(Uaf$T_DefDev))
	Byte		UAF_L_DefDir
	Equivalence	(UAF_L_DefDir,UAF_Record(Uaf$K_DefDir))
	Character	UAF_DefDir*(UAF$S_DefDir)
	Equivalence	(UAF_DefDir,UAF_Record(Uaf$T_DefDir))
	Integer		LastLogin(2), UAF_LastLogin(2)
	Equivalence	(UAF_LastLogin,UAF_Record(UAF$Q_LastLogin_I))

	Integer*2 	NewMes, MAIL_Newmes
	Byte		MAIL_Record(272)
	Equivalence	(MAIL_NewMes, MAIL_Record(34))

	Character*50	Directory
	Character*12	UserName
	Character*20	Name, Get_Personalname, Fix_Name

	Integer		Btrim
	Integer		Privilege(2) /0,0/

	External	Priv_UserOpen

	Get_ID = .true.

c  Fix_name: LAST,FIRST --> First Last
	Name = Get_Personalname(Username)

c First get stuff from UAF
c  open the UAF

	Open(Unit=UafUnit,
	1	File = 'SYSUAF',
	2	Default File = 'SYS$SYSTEM:.DAT',
	3	User Open = Priv_UserOpen,
	4	Status = 'Old',
	5	Organization = 'Indexed',
	6	Access = 'Keyed',
	7	Form = 'Formatted',
	8	Readonly, 
	9	Shared)

c  read it
	Read(UafUnit,1000,KeyEq=UserName,Err=999) UAF_Record

c close it
	Call Priv_Close(UafUnit)

c   Concatenate the DEFDEV and DEFDIR into one string Directory.
	Directory = UAF_DefDev(:UAF_L_DefDev) //
	1		UAF_DefDir(:UAF_L_DefDir)
c  set up the last login stuff
	LastLogin(1) = UAF_LastLogin(1)
	LastLogin(2) = UAF_LastLogin(2)
cc	Write(6,*) 'Get_ID: LastLogin ', LastLogin

c Now get MAIL stuff
	OPEN (Unit = ScratchUnit, File = 'VMSMAIL',
	1	Default File = 'SYS$SYSTEM:.DAT',
	2	User Open = Priv_UserOpen,
	2	Status = 'OLD', Organization = 'INDEXED',
	3	Access = 'KEYED', Read Only, Record Type = 'VARIABLE',
	4	Form = 'UnFORMATTED', Shared)
c

	READ(Unit = ScratchUnit, KeyEQ = UserName,
	1	KeyID=0, IOStat=IOS) MAIL_Record

	Call Priv_CLOSE (ScratchUnit)

	NewMes = MAIL_NewMes

	Return

999	Continue
	Get_ID = .false.
	Return

1000	Format(<UAF$K_Length>A1)
	End

c------------------------------------------------------------
	Integer Function Priv_UserOpen(FAB$B,RAB,Unit)

c  open a system file with privilege.

c  set bits in the FAB to require EXEC mode logical name
c  translation to be used when opening the file and turn
c  SYSPRV on for the open.

	Include		'Fingerdef'

	Integer		Privilege(2) /0,0/
	Byte		FAB$B(0:119)
	Integer		RAB(30)
	Integer		Sys$Open, Sys$Connect
	Integer		Unit

c  set Logical name access to EXEC mode
	FAB$B(FAB$B_ACMODES) = FAB$B(FAB$B_ACMODES) .or.
	1	( (1) * 2**FAB$V_LNM_MODE)		! require EXEC mode

c  Turn on SYSPRV privilege
	Privilege(1) =  Prv$M_Sysprv
	Call Sys$Setprv(%Val(1),Privilege,,)

c  open file
	iii = Sys$Open(FAB$B)

c  Turn off SYSPRV privilege
	Call Sys$Setprv(,Privilege,,)

	If ( .not. iii ) Then
	    Priv_UserOpen = iii
	    Return
	EndIf

c  connect
	Priv_UserOpen = Sys$Connect(RAB)

	Return
	End

c------------------------------------------------------------
	Integer Function Priv_Close(Unit)

c  Close a system file with privilege.  Needed for Files opened with
c  privilege in VMS V4.2 (it is rumored)

	Include		'Fingerdef'
	Integer		Privilege(2) /0,0/
	Integer		Unit

c  Turn on SYSPRV privilege
	Privilege(1) =  Prv$M_Sysprv
	Call Sys$Setprv(%Val(1),Privilege,,)

c  Close file
	Close( Unit = Unit )

c  Turn off SYSPRV privilege
	Call Sys$Setprv(,Privilege,,)

	Return
	End

c-------------------------------------------------------------
	Integer*2 Function Get_w_Val(I2)

	Integer*2	I2

	Get_w_Val = I2

	Return

	End

c-------------------------------------------------------------
	Integer Function Get_l_Val(I)

	Integer	I

	Get_l_Val = I

	Return

	End

c------------------------------------------------------------------
c	Update history / implementation notes -
c
C	V1.00	Base version Working with DEC-20	June 1982
C	V1.01	Index of nodes with routing		June 1982
C	V1.02	Return open error message on failure
C		to establish link to next node		July 1982
C	V1.03	Slight change in task spec for VMS V3.0	July 1982
C	V1.04	Add image name information		July 1982
C
C	V2.00	Start looking for individuals		July 1982
C	V2.01	Clean up IO units			July 1982
C	V2.02	Clean up LOCATION, NAME & IMAGE		July 1982
C	V2.03	Fix individual finger w. wildcards	Aug. 1982
C	V2.04	Put GETJPI stuff in include file	Aug. 1982
C
C	V3.00	Combine local and network invocation	Aug. 1982
C	V3.01	Consolidate IO units into COMMON	Aug. 1982
C	unspec	Added terminal display -- PSYA::LUCAS	Sep. 1982
C	V3.02	Added typing of <username>.PLN files	
C		when fingering a specific user, as well
C		as telling if user has any new mail
C		messages. -- PSYA::OHLUND		Sep. 1982
C	V3.03	Change <username>.PLN to FINGER.PLN Rg	Sep. 1982
C	V3.04	Fix a few bugs. Rg			Sep. 1982
C	V3.10	Get personal name from UAF		Nov. 1982
C	V3.20	Get load averages			Nov. 1982
C	V3.25	Get node name from SYS$NODE		Nov. 1982
C	V3.30	Get current Mail messages		Nov. 1982
C	V3.35	Get day of the week			Nov. 1982
C	V4.00	Complete cleanup and rationalization		15-Nov-1982
c	V4.01	Fix bug in Get_Image scanning for image name	16-Nov-1982
c	V4.02	"Make_Pretty" the image name. Put all "Make_Pretty"'s
c		in Output routines.				18-Nov-1982
c	V4.03	Remove all Str$UpCase calls but the 1st
c		in routine Finger and in Make_Pretty.		18-Nov-1982
c	V4.04	Make load device a parameter			22-Nov-1982
c	V4.05	Fix mail-messages > 99 bug.			23-Nov-1982
c	V4.06	Put in handler to catch signalled errors
c		and route messages back to requesting node	17-Dec-1982
c	V4.07	Fix bug in MailTextInfo "From:" message.	 6-Jan-1983
c	V4.08	Slight mod in load average output statement.	17-Mar-1983
c	V4.09	Put in BITnet for location for PTys		24-Apr-1983
c
c	V5.00	Restructure program to use callable output
c		routine.  This is in anticipation of other
c		network support.				19-May-1983
c	V5.01	Allow terminal names to 6 char (7 including the
c		":"). This allows 3 digit numbers, e.g. TTC123	19-May-1983
c	V5.02	Put in limits to the number of messages output
c		by the signal_handlers to catch runaway error
c		loops						19-May-1983
c	V5.03	Add CPU type and VMS version to header.		20-May-1983
c	V5.04	Add display qualifiers to .CLD file		4-Jun-1983
c		In anticipation of having all display options
c		selectable by the user.
c	V5.05	add "no such jobs." message.			4-Jun-1983
c	V5.06	Change Flag integers to parameters		6-Jun-1983
c	V5.06	Check for NET, SUBPROCESS, and SYSTEM jobs	6-Jun-1983
c	V5.07	Move flag definitions to include file.		7-Jun-1983
c	V5.08	Fix wrong mask PCB$M_NETWRK			9-Jun-1983
c	V5.09	Change OPEN statement for load average due
c		to aparent VMS change in V3.2			18-Aug-1983
c	V5.10	Use Fortran IO instead of LIB$PUT_SCREEN locally
c		to avoid screw ups on hard copy devices. Consolidate
c		DECnet and local output routine: RMS_Out_Routine.
c		Similarly consolidate Signal handlers.		3-Sep-1983
c	V5.11	Add [NO]Message qualifier to suppress message
c		of the day.					3-Sep-1983
c	V5.12	Get LOGIN time and CPU time for processes.	22-Sep-1983
c	V5.13	Change NAME qualifier to PERSONALNAME,
c		change TTNAME qualifier to TERMINAL,
c		change PRCNAME qualifier to PROCESSNAME.	22-Sep-1983
c	V5.14	Break User_Info according to qualifiers		21-Sep-1983
c	V5.15	Take out space in front of PLAN lines.		22-Sep-1983
c	V5.16	Map "." into self.				22-Sep-1983
c	V5.17	Put "- Subprocess -" into Location		22-Sep-1983
c	V5.18	Move Username <--> Name to Shared COMMON	5-Oct-1983
c	V5.19	Put in personal name matching			6-Oct-1983
c	V5.20	Implement Idle time				6-Oct-1983
c	V5.21	Put terminal data-base into common section	7-Oct-1983
c	V5.22	Put node data into shared common section	10-Oct-1983
c	V5.23	Change idle-time from mm:ss to hh:mm		15-Oct-1983
c	V5.24	change local output open to type='NEW' to fix
c		bug when assigning sys$output to a file.	15-Oct-1983
c	V5.25	Fix typo in JPI item list for OWNER		17-Oct-1983
c	V5.26	Add /FULL (all display qualifiers on)		18-Oct-1983
c	V5.27	Fix load average output bug.			18-Oct-1983
c	V5.28	Fix MailTextInfo multiple message bug (CRW)	29-Oct-1983
c	V5.29	Use Wild_Match routine in Check_Name		4-Nov-1983
c	V5.30	Put in wild cards for node names		4-Nov-1983
c	V5.31	Put in wild cards for personalname match	5-Nov-1983
c	V5.32	Separate the FingerMain file from Finger	5-Nov-1983
c	V5.33	Fix personalname wild cards a bit		7-Nov-1983
c	V5.34	Add STATE & SIZE from BJJ@PSUVMS1		25-Nov-1983
c	V5.35	Include outgoing BITnet linking			25-Nov-1983
c	V5.36	Put in checks for reentrant BITnet call		28-Nov-1983
c	V5.37	Fix several bugs in BITnet stuff		29-Nov-1983
c	V5.38	Put FAO arguments for signal handler		1-Dec-1983
c	V5.39	Close channels (Out-link, and Mail)		2-Dec-1983
c	V5.40	Signal (rather than Exit) on Help error		3-Dec-1983
c	V5.41	Have Finger and subFingers return status. -1
c		means abort.  					5-Dec-1983
c	V5.42	Put in messages and return codes for exits.	7-Dec-1983
c	V5.43	Take out "ERR=" in DECnet read			13-Dec-1983
c	V5.44	Put in error return for Node wild card failure	15-Dec-1983
c	V5.45	Allow "<>" as directory delimitors in Get_Image	15-Dec-1983
c	V5.46	Fix CPU time for overflow.			22-May-1984
c	V5.47	clear a flag before first timeout so wild card
c		node timeouts won't give spurious timeouts	22-Jun-1984
c	V5.48	Change "BITnet" to "jnet" throughout.		17-Jul-1984
c	V5.49	Add network names in Fingershr and on output	17-Jul-1984
c	V5.50	Put Que name in for Batch jobs			19-Jul-1984
c	V5.51	Avoid doing extra GETJPI on outswapped procs.
c		and fix output for same (Ed Miller @SLAC)	9-Aug-1984
c	V5.52	Get remote DECnet node for location		10-Aug-1984
c	V5.53	Work on multile jnet link situation		31-Aug-1984
c	V5.54	Send to IBM nodes a'la Vace (MSG vs CMD)	31-Aug-1984
c	V5.55	Make "Command complete" check case-insensitive	19-Sep-1984
c	V5.56	Buffer RMS output line at a time		19-Sep-1984
c	V5.57	Supply the command "FINGER" if missing on
c		jnet invocations.				20-Sep-1984
c	V5.58	put in ' MSG' at end of command to IBM hosts	26-Sep-1984
c	V5.59	change definition of "system" process slightly	19-Oct-1984
c	V5.60	Fix bug in clearing DECnet site name		23-Oct-1984
c	V5.61	Deassign NET: channel after use:Get_DECnet_Node	24-Oct-1984
c	V5.62	Add routine to get jnet node: Get_jnet_Node	27-Oct-1984