C-------------------------------------------------------------------------
C	IS_DIR Function
C-------------------------------------------------------------------------
C	Determine if a file is actually directory-type
C	This is a "USEROPEN" Routine
C
C	To use this routine, do the following:
C
C 1.  In declarations, define;
C
C		External Is_Dir
C		Integer*2 Channel
C	        Common /Dir_Channel/ Channel
C	
C 2.  Assign a channel to "Channel";
C
C		Status = Sys$Assign (%Descr('DISK$CURRENT:'),%Ref(Channel),,)
C			NOTE THAT THE TRAILING COMMAS ARE REQUIRED
C
C 3.  Do the file open (using whatever is appropriate).  The ERR exit will
C		be used if the file is not a real Directory file (in addition
C		to the usual conditions)
C
C        Open(Unit=1, File= FileName,
C	1	Access = 'SEQUENTIAL', Carriagecontrol = 'NONE',
C	2	Recl = 512, RecordType = 'VARIABLE',
C	3	NoSpanBlocks, Status='OLD', ReadOnly, ERR=9999,
C	4	IOSTAT = IOX, Useropen = Is_Dir)
C	  (NOTE: IOX will be set to 43 if the file is not a directory)  

C		-- NOTE -- This used to be as below:
C	4	IOSTAT = IOX, Shared, Useropen = Is_Dir)
C		  However, at V4.4, opening it SHARED seems to cause
C		  a crash at CLOSE time (is this a bug??)
C 		VMS 4.5 with FORTRAN 4.6 does not have the problem.
C 		Must have been a bug.


C
C 4.  Optionally, deassign the channel (note use of %Val);
C		Status = Sys$Dassgn (%Val(Channel))
C
C
C
C-------------------------------------------------------------------------

	Integer Function Is_Dir (FAB, RAB, LUN)

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

	IMPLICIT INTEGER*4 (A-Z)

	INTEGER*4 Attributes
	INTEGER*2 IOSB(4)
	CHARACTER*10 FIB

	Parameter (FCH$M_DIRECTORY = '0000000D'X) ! Pos'n for .DIR bit.
	Parameter (RMS$_SYN        = '000186D4'X) ! File Spec Err.

	EXTERNAL IO$_ACCESS

	Include '($ATRDEF)'
	Include '($FABDEF)'

	Record /FABDEF/ FAB
	Record /ATRDEF/ ATR, LastAtr

	Integer*2 Channel
        Common /Dir_Channel/ Channel

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

	Is_Dir = 0

10	If (Channel .LE. 0) then  ! No channel assigned
		Print *, 'No Channel Assigned'
		STOP
	End If


C		Make sure we can open it
	Status = SYS$Open (FAB)
	If (Status) then
		Status = SYS$Connect (RAB)

		Is_Dir = Status
		If (Status) then
			GoTo 20
		Else
			Call Sys$Close (FAB)
		End If
	Else
		Is_Dir = Status
	End If

	Return		! Error in Open or Connect - just return


20 	Call Get_FIB (%Val(Fab.FAB$L_NAM),FIB)

	Atr.ATR$W_TYPE = ATR$C_UCHAR
	Atr.ATR$W_SIZE = ATR$S_UCHAR
	Atr.ATR$L_ADDR = %Loc(Attributes)
	LastAtr.ATR$W_TYPE = 0
	LastAtr.ATR$W_SIZE = 0
	LastAtr.ATR$L_ADDR = 0


C		The following is tempting, but........
C	      	Doing this causes 'no priv' error
C	Channel = Fab.FAB$L_STV

	STATUS=SYS$QIOW(,%VAL(CHANNEL),IO$_ACCESS,IOSB,,,FIB,,,,ATR,)

C	Print *,'Status of QIO ',Status
C	Print *, 'Attributes =',Attributes
C	Print *, BTest( Attributes, FCH$M_DIRECTORY)

	If (Status .AND. BTest( Attributes, FCH$M_DIRECTORY)) then
		Return
	Else
		Is_Dir = RMS$_SYN    ! Signal "Error" = Not a Directory
		Call Sys$Close (FAB)
		Fab.FAB$L_STS = RMS$_SYN
		Return
	End If

	End

C----------------------------------------------------------------------
C		Convert FID to Character FIB
C		(Moves data to Char-type variable)
C
C 	Call Get_FIB (%Val(Fab.FAB$L_NAM),FIB)
C		FAB$L_NAM contains the Address of the NAM 
C			(which contains the 6-byte FID)
C		FIB is a 10-character item to be passed to QIO
C----------------------------------------------------------------------

 	Subroutine Get_FIB (NAM, FIB)

C	Fib = Char(0)//Char(0)//Char(0)//Char(0)
C  	Len = 6
C	Call Lib$SCOPY_R_DX (Len,Nam.NAM$W_FID(1),FIB(5:))

	Integer*2 Len
	Character*10 FIB

	Include '($NAMDEF)'

	Record /NAMDEF/ NAM

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

	Fib = Char(0)//Char(0)//Char(0)//Char(0)
  	Len = 6
	Call Lib$SCOPY_R_DX (Len,Nam.NAM$W_FID(1),FIB(5:))

	Return
	End

