C-----------------------------------------------------------------------------
C	Program	used to	provide	LSWEEP and some	ARC functionality on VMS
C
C	VMSsweep will handle .LBR and .ARC files and can be used to extract 
C	members	or just	display	them on	the terminal (No check is done to see 
C	that they are text files). 
C
C	Restrictions: 
C		The VMS	file must have a maximum record	length of 4096 bytes. 
C		The library file (.ARC or .LBR)	can only have 200 members
C
C	Functions provided:
C		View a member at the terminal -squeezed	or unsqueezed
C		Extract	a member to a file (128byte records) 
C		List the directory of the .LBR file
C		New .LBR file requested
C
C	Author:
C		John T.	Coburn		Digital	Equipment, Cleveland
C		Copyright (c) 1986
C
C	Please feel free to distribute this program by any noncommercial
C	means to anyone	who can	use it.
C
C	This program was in general based on the Turbo Pascal program 
C	DEARC that is in the public domain. Author unknown by me.
C
C-----------------------------------------------------------------------------
	Program	VAX_ARC_LBR

	Implicit None

	Character	For_IOS(68)*30
	Common	/ForIOS/ For_IOS

! 
!	Define FORTRAN error numbers for use with IOSTAT and ERRSNS
! 
	Data For_IOS /68*' '/
	Data FOR_IOS ('00000011'X ) /' syntax error in NAMELIST	input'/
	Data FOR_IOS ('00000012'X ) /' too many	values for NAMELIST variable'/
	Data FOR_IOS ('00000013'X ) /' invalid reference to variable'/
	Data FOR_IOS ('00000014'X ) /' REWIND error '/
	Data FOR_IOS ('00000015'X ) /' duplicate file specifications '/
	Data FOR_IOS ('00000016'X ) /' input record too	long '/
	Data FOR_IOS ('00000017'X ) /' BACKSPACE error '/
	Data FOR_IOS ('00000018'X ) /' end-of-file during read '/
	Data FOR_IOS ('00000019'X ) /' record number outside range '/
	Data FOR_IOS ('0000001A'X ) /' OPEN or DEFINE FILE required'/
	Data FOR_IOS ('0000001B'X ) /' too many	records	in I/O statement'/
	Data FOR_IOS ('0000001C'X ) /' CLOSE error '/
	Data FOR_IOS ('0000001D'X ) /' file not	found '/
	Data FOR_IOS ('0000001E'X ) /' open failure '/
	Data FOR_IOS ('0000001F'X ) /' mixed file access modes '/
	Data FOR_IOS ('00000020'X ) /' invalid logical unit number '/
	Data FOR_IOS ('00000021'X ) /' ENDFILE error '/
	Data FOR_IOS ('00000022'X ) /' unit already open '/
	Data FOR_IOS ('00000023'X ) /' segmented record	format error '/
	Data FOR_IOS ('00000024'X ) /' attempt to access non-existent record'/
	Data FOR_IOS ('00000025'X ) /' inconsistent record length '/
	Data FOR_IOS ('00000026'X ) /' error during write '/
	Data FOR_IOS ('00000027'X ) /' error during read '/
	Data FOR_IOS ('00000028'X ) /' recursive I/O operation '/
	Data FOR_IOS ('00000029'X ) /' insufficient virtual memory '/
	Data FOR_IOS ('0000002A'X ) /' no such device '/
	Data FOR_IOS ('0000002B'X ) /' file name specification error '/
	Data FOR_IOS ('0000002C'X ) /' inconsistent record type'/
	Data FOR_IOS ('0000002D'X ) /' keyword value error in OPEN statement '/
	Data FOR_IOS ('0000002E'X ) /' inconsistent OPEN/CLOSE parameters'/
	Data FOR_IOS ('0000002F'X ) /' write to	READONLY file '/
	Data FOR_IOS ('00000030'X ) /' invalid arg to FORTRAN RTL'/
	Data FOR_IOS ('00000031'X ) /' invalid key specification'/
	Data FOR_IOS ('00000032'X ) /' inconsistent key	change,	duplicate key'/
	Data FOR_IOS ('00000033'X ) /' inconsistent file organization'/
	Data FOR_IOS ('00000034'X ) /' specified record	locked'/
	Data FOR_IOS ('00000035'X ) /' no current record'/
	Data FOR_IOS ('00000036'X ) /' REWRITE error'/
	Data FOR_IOS ('00000037'X ) /' DELETE error'/
	Data FOR_IOS ('00000038'X ) /' UNLOCK error'/
	Data FOR_IOS ('00000039'X ) /' FIND error'/
	Data FOR_IOS ('0000003B'X ) /' list-directed I/O syntax	error '/
	Data FOR_IOS ('0000003C'X ) /' infinite	format loop '/
	Data FOR_IOS ('0000003D'X ) /' format/variable-type mismatch '/
	Data FOR_IOS ('0000003E'X ) /' syntax error in format '/
	Data FOR_IOS ('0000003F'X ) /' output conversion error '/
	Data FOR_IOS ('00000040'X ) /' input conversion	error '/
	Data FOR_IOS ('00000042'X ) /' output statement	overflows record '/
	Data FOR_IOS ('00000043'X ) /' input requires too much data '/
	Data FOR_IOS ('00000044'X ) /' variable	format expression error	'/

	Byte		ArcMark
	Integer*2	LBR_Recognize
	Integer		Max_Num_Members

	Parameter ( ArcMark = 26 )
	Parameter ( LBR_recognize = 'FF76'x )
	Parameter ( Max_Num_Members = 200 )

	Character	File_Name*12, In_FILE_NAME*50, ANS*1, Lib_Type*1
	Character	Technique*14, Techs(10)*14
	Data	Techs	/'No compression', 'No compression', 'DLE compressn', 
	1		 'Huffman, DLE', 'LZW Comp', 'LZW, DLE comp',
	2		 3*'Unknown', '	' /

	Character	Member_NAMES(Max_Num_Members)*12
	Character	Mem_Date(Max_Num_Members)*8
	Character	Mem_Time(Max_Num_Members)*8

	Integer		First_Byte_Arr(Max_Num_Members)
	Integer		HDR_Vers(Max_Num_Members)
	Integer		Num_Bytes_Arr(Max_Num_Members),	CRCS(Max_Num_Members)

	Integer		Temp

	Byte		DIR_ENTRY(32)

	Byte		STATUS,	NAME(8), EXTEN(3), LBR_Filler(6), F1, F2
	Integer*2	INDX, NSECTS, CRC, Frec, Crea_Date, Upd_Date
	Integer*2	Crea_Time, Upd_Time
	Integer		Num_Members, NBlks

	Common	/LBR_Dire/ STATUS, NAME, EXTEN,	INDX, NSECTS, CRC, 
	1		   Crea_Date, Upd_Date,	Crea_Time, Upd_Time, 
	1		   LBR_Filler, F1, F2

	Equivalence	( DIR_ENTRY(1),	STATUS )
	Equivalence	( Frec,	F1 )

	Integer		First_In, Last_In, Buf_Index, Buf_Length, Out_Index
	Byte		In_Buf(4096), Out_Buf(128)
	Common	/Buffers/ First_In, Last_In, Buf_Index,	Buf_Length, In_Buf,
	1		Out_Buf, Out_Index

	Logical*1	View_flg, Bin_flg, Extr_flg, LBR_Flg, Cancel_Op
	Integer		Remaining_Size
	Common	/Global/ Remaining_Size, View_Flg, Bin_Flg, Extr_Flg, 
	1		 LBR_Flg, Cancel_Op

	Integer*2	I2
	Integer		Q, I, J, K, M, N, DIR_SECTS, ISTAT, Ios

	Logical*1	Squeezed
	Byte		Tbytes(13), C, HDR_Ver

	Type *,	' '
	Type *,	'V M S	 S w e e p   V1.0'
	Type *,	'for .LBR and .ARC files'
	Type *,	' '

10	Continue
	Last_In	= 0
	First_In = 0
	Out_Index = 1
	In_FILE_NAME = ' '
	Type 1020,'$Enter "library": '
	Accept 1021, Q,	In_FILE_NAME(1:Q) 

	K = Index( In_File_Name(1:Q), '.' )
	If ( K .eq. 0 )	Then
	  Lib_Type = ' '
	Else
	  Lib_Type = In_File_Name(K+1:K+1)
	EndIf

	If ( Lib_Type .eq. 'l' ) Lib_Type = 'L'
	If ( Lib_Type .eq. 'a' ) Lib_Type = 'A'

20	Continue
	If ( Lib_Type .ne. 'A' .and. Lib_Type .ne. 'L' ) Then
	  Type 1020, '$ARC or LBR file [L]: '
	  Accept 1021, I, Lib_Type
	  If ( I .eq. 0	) Lib_Type = 'L'
	  If ( Lib_Type	.eq. 'l' ) Lib_Type = 'L'
	  If ( Lib_Type	.eq. 'a' ) Lib_Type = 'A'
	  If ( Lib_Type	.ne. 'A' .and. Lib_Type	.ne. 'L' ) Then
	    Type *, '--- Invalid File type entered: ', Lib_Type
	    GoTo 20
	  EndIf
	  If ( k .eq. 0	) Then
	    If ( Lib_Type .eq. 'A' )In_File_Name(Q+1:) = '.ARC'
	    If ( Lib_Type .eq. 'L' )In_File_Name(Q+1:) = '.LBR'
	  EndIf
	EndIf

	Lbr_Flg	= .True.
	If ( Lib_Type .eq. 'A' ) LBR_Flg = .False.

	Open( Unit=2, File=In_File_Name, Status='OLD', RecL=4096, 
	1	DefaultFile='.', Err=900, IoStat=IoS )

	Call Position_Lib( 1 )
	N = 0

	If ( .Not. Lbr_Flg ) GoTo 75

C	Handle the .LBR	file Specified

50	Continue

	Call Get_Byte_Knt( DIR_ENTRY, 32 )

	DIR_SECTS = NSECTS		! How many directory segments are there

	Call Position_Lib( 1 )		! Back to the first buffer

	If ( DIR_SECTS .GT. 1 )	Then
	   Write( 6, 1030 ) '++	There are ', DIR_SECTS,	
	1	' directory segments in	' // In_File_name(1:Q) // ' ++'
	Else
	   Write( 6, 1030 ) '++	There is ', DIR_SECTS, 
	1	' directory segment in ' // In_File_name(1:Q) // ' ++'
	EndIf

	Do 70 I	= 1, DIR_SECTS*4
	    Call Get_Byte_Knt( DIR_ENTRY, 32 )
	    If ( I .ne.	1 ) Then
		If ( STATUS .eq. 0 ) Then
		    If ( N .eq.	max_num_members	) goto 100
		    N =	N + 1
		    Member_Names(N) = '	'
		    M =	1
		    Do While ( M .le. 8	.and. Name(M) .ne. ' ' )
			    Member_Names(N)(M:M) = Char( Name(M) )
			    M =	M + 1
		    EndDo
		    Member_Names(N)(M:M) = '.'
		    Hdr_Vers(N)	= 10			! Special blank
		    Do K=1,3
			    Member_NAMES(N)(M+K:M+K) = Char( EXTEN(K) )
		    EndDo
		    Temp = NSECTS
		    Num_Bytes_ARR(N) = Temp * 128
		    Temp = Indx
		    First_Byte_arr(N) =	Temp * 128 + 1
		    CRCS(N) = CRC
		    If ( Crea_Date .ne.	0 ) Then
			Call Date_Str( 78, Crea_Date, Mem_Date(N) )
		    Else
			Mem_Date(N) = '	 None'
		    EndIf
		    If ( Crea_Time .ne.	0 ) Then
			Call Time_Str( Crea_Time, Mem_Time(N) )
		    Else
			Mem_Time(N) = '	 None'
		    EndIf


		EndIf
	    EndIf
70	Continue
	Goto 100

C	Read the .ARC file to get 'directory' type info

75	Continue		! Get info for .ARC file

	Type *,	'Gathering "directory" information for ', In_File_Name(1:Q)

	Call Get_Byte( C )

	Do While ( C .ne. -1 )
	  If ( C .ne. ArcMark )	Then		! Not an ARC file
	    Write( 6, *	) '+++ Requested file not an .ARC file +++'
	    Goto 700
	  EndIf

	  Call Get_Byte( Hdr_Ver )
	  If ( Hdr_Ver .lt. 0 )	Then		! invalid header
	   Type	*, 'Cannot handle this version of .ARC file:', Hdr_ver
	   goto	700
	  EndIf
	  If ( Hdr_Ver .eq. 0 )	Then		! special endoffile
	    GoTo 100
	  EndIf

	  If ( N .eq. max_num_members )	goto 100
	  N = N	+ 1

	  Call Get_Byte_Knt( TBytes, 13	)

	  Member_NAMES(N) = ' '
	  M = 1
	  Do While ( TBytes(M) .ne. 0 )
	    Member_NAMES(N)(M:M) = Char( TBytes(M) )
	    M =	M + 1
	  EndDo

	  Call Get_Byte_Knt( Num_Bytes_Arr(N), 4 )
	  Call Get_Byte_Knt( Crea_Date,	2 )
	  If ( Crea_Date .ne. 0	) Then
	    Call Date_Str( 78, Crea_Date, Mem_Date(N) )
	  Else
	    Mem_Date(N)	= '  None'
	  EndIf
	  Call Get_Byte_Knt( Crea_Time,	2 )		! Discard time 
	  If ( Crea_Time .ne. 0	) Then
	    Call Time_Str( Crea_Time, Mem_Time(N) )
	  Else
	    Mem_Time(N)	= '  None'
	  EndIf
	  Call Get_Byte_Knt( CRCs(N), 2	)

	  If ( Hdr_Ver .gt. 1 )	Then
	    Call Get_Byte_Knt( Tbytes, 4 )		! Discard expanded length
	  EndIf

	  Hdr_Vers(N) =	Hdr_Ver
	  First_Byte_arr(N) = Buf_Index	+ First_In

d	  Write( 6, 1110 ) N, Member_NAMES(N), First_Byte_Arr(N), 
d	1		  Num_Bytes_Arr(N)

	  Call Position_Lib( Num_Bytes_Arr(N) +	First_Byte_Arr(N) - 1 )

d	  Write( 6, 1111 ) 'Positioned to byte:	', 
d	1		Num_Bytes_Arr(N) + First_Byte_Arr(N) - 1

	  Call Get_Byte( C )

	EndDo

d	Write( 6, * ) 'All members are found...'

C	Now display the	directory for this library

100	Continue
	Num_Members = N

150	Continue
	If ( Num_Members .GT. 1	) Then
	   Write( 6, 1030 ) '++	There are ', Num_Members, 
	1			' members ++'
	Else
	   Write( 6, 1030 ) '++	There is ', Num_Members, ' member ++'
	EndIf

	Write( 6, 1020 ) ' '
	Write( 6, 1008 )
	Write( 6, 1009 )
	Do I = 1, Num_Members
	  NBLKS	= Num_Bytes_Arr(I) / 512
	  If ( NBLKS*512 .ne. Num_Bytes_ARR(I) ) Nblks = NBlks + 1
	  Technique = Techs( Hdr_Vers(I) )

	  Write( 6,1010	) I, Member_NAMES(I), Num_Bytes_Arr(I),	
	1		  Mem_Date(I), Mem_Time(I), Technique
	EndDo

c	Now lets see if	the user wants to extract any members

200	Continue
	Type 1020, ' '
	Type 1020, '$Enter command (? for list)	[X]: '
	Accept 1020, ANS
	If ( ANS .eq. '	' ) ANS	= 'X'
	If ( ANS .eq. 'x' .or. ANS .eq.	'X' ) Goto 800

	View_flg = .False.
	Extr_flg = .False.
	Bin_flg	 = .False.

	If ( ANS .eq. '?' ) Goto 230
	If ( ANS .eq. 'l' .or. ANS .eq.	'L' ) GoTo 150
	If ( ANS .eq. 'n' .or. ANS .eq.	'N' ) GoTo 700
	If ( .Not. LBR_Flg ) GoTo 210
	If ( ANS .eq. 'v' .or. ANS .eq.	'V' ) View_flg = .True.
	If ( ANS .eq. 'e' .or. ANS .eq.	'E' ) Extr_flg = .True.

	If ( View_flg .or. Extr_flg ) GoTo 250

210	Type *,	'-- Illegal Command --'

230	Continue
	Type 1020, ' '
	Type 1020, ' Commands available:'
	Type 1020, ' '
	If ( Lbr_Flg ) Then
	Type 1020, '   E - Extract a member to a file'
	EndIf
	Type 1020, '   L - List	the directory again'
	Type 1020, '   N - Get a new library file'
	If ( Lbr_Flg ) Then
	Type 1020, '   V - View	member at terminal (squeezed or	unsqueezed)'
	Type 1020, '	   No check on whether member is viewable'
	EndIf
	Type 1020, '   X - No option wanted (exit)'
	Type 1020, '   ? - Display this	list'

	GoTo 200

250	Continue
	Type 1400
	Accept 1410, N

	If (( N	.le. 0 ) .or. (	N .gt. Num_Members )) Then
	  Type *, '-- Illegal member number --'
	  Goto 250
	EndIf

	Call Position_Lib( First_Byte_Arr(N) )
	Remaining_Size = Num_Bytes_Arr(N)

	If ( Lib_Type .eq. 'A' ) GoTo 500

C	Now handle selection from .LBR file

300	Continue
	Call Get_Byte_Knt( Frec, 2 )
	Squeezed = .False.
	If ( Frec .eq. LBR_recognize ) Then
	  Remaining_Size = Remaining_Size - 5	! Keep track of	member size
	  Squeezed = .True.
	  Call Get_Byte_Knt( I2, 2 )		! Get past the CRC
	  File_Name = '	' 
	  Call Get_Byte( C )			! Get the member orig name
	  I = 0
	  Do While ( C .ne. 0 )
	    I =	I + 1
	    File_Name(I:I) = Char( C )
	    Call Get_Byte( C )
	    Remaining_Size = Remaining_Size - 1
	  EndDo
	  Call Init_UnSq			! Init the decode tree
	Else
	  File_Name = Member_Names(N)
	EndIf

	Call Open_Ext_File( File_Name )		! Open the output LUN

	If ( Squeezed )	Then
	  Call Get_Char_Sq( I2 )
	  Do While (( I2 .ne. -1 ) .and. .Not. Cancel_Op )
	    Call Put_Char_UnComp( I2 )
	    Call Get_Char_Sq( I2 )
	  EnDDo
	Else
	  I2 = F1				! Save the characters
	  Call Put_Char_UnComp(	I2 )		! that i checked for 
	  I2 = F2				! the recognition value
	  Call Put_Char_UnComp(	I2 )
	  Call Get_Char( I2 )
	  Do While (( I2 .ne. -1 ) .and. .Not. Cancel_op )
	    Call Put_Char_UnComp( I2 )
	    Call Get_Char( I2 )
	  EnDDo
	EndIf

	Call Close_Ext_File

	GoTo 200

C	This code is for the .ARC library format

500	Continue

	Type *,	'Not implemented yet'

c	Now lets setup for another lib file 

700	Continue
	Close( Unit=2 )	
	Goto 10

800	Continue

	Call Exit

900	Continue
	If ( IOS .gt. 68 ) Then
	  Type *,'Unkown error on OPEN:', IOS
	Else
	  Type *, 'Error on OPEN: ', For_IOS( IOS )
	EndIf

	Call Exit

1000	Format(	' ', a,	'     ', i4 )
1008	Format(	'   #  Member Name   # Bytes	Date	  Time')
1009	Format(	' ---- ------------  -------  --------	--------')
1010	Format(	' ', I3, '. ', a, '  ',	I7, 3( '  ', A ) )
1011	Format(	' Extracting: ', a, '.', a, ', First Byte: ', I7, 
	1	', # Bytes: ', I7 )
1020	Format(	a )
1021	Format(	q, a )
1030	Format(	' ', a,	I4, a )
1110	Format(	' Member#', I3,	'. ', a, 
	1	', First: ', i7, ', Number: ', i7  )
1111	Format(	' ', A,	I7 )
1400	Format(	'$Enter	member number: ' )
1410	Format(	I3 )
1450	Format(	128A1 )

	End

C------------------------------------------------------------------------
C	Subroutine called to open an output LUN	for processing a member
C	of library (eitrher .LBR or .ARC)
C
C	Inputs:
C		File_Name	Member filename
C
C	Outputs:
C		The Bin_Flg will be set	if the extension of the	file is
C		.EXE, .BIN, .COM, .CMD,	.OVR etc...
C
C------------------------------------------------------------------------

	Subroutine Open_Ext_File( File_Name )

	Implicit None

	Logical*1	File_Flg, Squeezed, Ctrlz_Flg

	Character	File_Name*(*), Carriage*4, ANS,	File_Ext*3
	Character	Open_Name*12

	Integer		K, I, IOS

	Logical*1	View_flg, Bin_flg, Extr_flg, LBR_Flg, Cancel_Op
	Integer		Remaining_Size
	Common	/Global/ Remaining_Size, View_Flg, Bin_Flg, Extr_Flg, 
	1		 LBR_Flg, Cancel_Op

	Character	For_IOS(68)*30
	Common	/ForIOS/ For_IOS

	Bin_Flg	= .True.
	K = Index( File_Name, '.' )
	If ( K.	eq. 0 )Then
	  Type *, 'Is ', File_Name, ' a	text file? '
	  Accept 1100, Ans
	  If ( Ans .eq.	'y' .or. Ans .eq. 'Y' )	Bin_Flg	= .False.
	Else
	  File_Ext = File_Name(K+1:)
	  K = Index( 'COM EXE REL CMD COM OVR BIN', File_Ext )
	  Bin_Flg = .False. 
	  If ( K .ne. 0	) Bin_Flg = .True.
	EndIf

	If ( View_flg .and. Bin_Flg ) Then
	  Type *, '--->	Can''t view a binary file, extracting...'
	  View_Flg = .False.
	EndIf

	If ( View_Flg .or. Bin_Flg ) Then
	  Carriage = 'NONE'
	Else
	  Carriage = 'LIST'
	EndIf

	Cancel_op = .False.

	If ( View_flg )	Then
	  Open_Name = 'Sys$OutPut'
	Else
	  OPen_Name = File_Name
	  Write( 6, * )	'Extracting to ', File_Name, '...'
	EndIf

	Call Cancel_AST_Start
	Type *,	'+++ To	cancel operation type Ctrl-C +++'
	Type *,	' '

	Open( Unit=1, File=Open_Name, Status='NEW', RecL=128, 
	1     IoStat=IOS, CarriageControl=Carriage, Err=900 )

	Return

900	Continue
	Type *,	'Error opening file: ',	FOR_IOS( IOS )
	Return

1100	Format(	A )

	End

	Subroutine Close_Ext_File

	Implicit None

	Integer		K

	Integer		First_In, Last_In, Buf_Index, Buf_Length, Out_Index
	Byte		In_Buf(4096), Out_Buf(128)
	Common	/Buffers/ First_In, Last_In, Buf_Index,	Buf_Length, In_Buf,
	1		Out_Buf, Out_Index

	If ( Out_Index .gt. 1 )	Then
	  Write( 1, 1100 ) (Out_Buf(K),	K=1,Out_Index)
	  Out_Index = 1
	EndIf

	Close( Unit=1 )

	Return

1100	Format(	128A1 )

	End

C------------------------------------------------------------------------
C	Subroutine used	to get the next	byte from the input buffer
C	If the input buffer is empty the next record will be read 
C
C	Inputs:
C		Common containing information about the	buffers
C
C	OutPut:
C		C is the next byte value from the input	buffer
C
C------------------------------------------------------------------------

	Subroutine Get_Byte( C )

	Implicit None

	Byte		C

	Integer		First_In, Last_In, Buf_Index, Buf_Length, Out_Index
	Byte		In_Buf(4096), Out_Buf(128)
	Common	/Buffers/ First_In, Last_In, Buf_Index,	Buf_Length, In_Buf,
	1		Out_Buf, Out_Index

	If ( Buf_Index .gt. Buf_Length ) Then
	    Call Position_Lib( Last_In + 1 )
	EndIf

	C = In_Buf( Buf_Index )
	Buf_Index = Buf_Index +	1

	Return
	End

C------------------------------------------------------------------------
C	Subroutine used	to get the next	byte from the input buffer
C	Call Get_Byte after checking remaining size of member
C
C	Inputs:
C		Common containing information about the	member
C
C	OutPut:
C		I is the next byte value from the input	buffer in I*2
C
C------------------------------------------------------------------------

	Subroutine Get_Char( I )

	Implicit None

	Integer*2	I, W
	Byte		C

	Equivalence	( W, C )

	Logical*1	View_flg, Bin_flg, Extr_flg, LBR_Flg, Cancel_Op
	Integer		Remaining_Size
	Common	/Global/ Remaining_Size, View_Flg, Bin_Flg, Extr_Flg, 
	1		 LBR_Flg, Cancel_Op

	W = 0
	If ( remaining_Size .gt. 0 ) Then
	    Call Get_Byte( C )
	    Remaining_Size = Remaining_Size - 1
	Else
	    W =	-1
	EndIf

	I = W

	Return
	End

C------------------------------------------------------------------------
C	Subroutine used	to get KNT bytes from input
C	Call the Get_Byte subroutine to	minimize buffer	manipulation
C
C	Input:
C		Buffer address to fill
C		KNT number of bytes to fill
C
C	Output:
C		Fills parameter	buffer with KNT	bytes
C
C------------------------------------------------------------------------

	Subroutine Get_Byte_Knt( Buf, Knt )

	Implicit None

	Integer		Knt, I

	Byte		Buf(KNT)

	Do I = 1, KNT
	    Call Get_Byte( Buf(I) )
	EndDo

	Return
	End

C------------------------------------------------------------------------
C	Subroutine that	translates a byte to ASCII
C
C	Input:
C		Will call Get_Char to get a bytes needed for translation
C
C	Output:
C		The translated value (unsqueezed) in I*2 format
C
C------------------------------------------------------------------------

	Subroutine Get_Char_Sq(	W )

	Implicit None

	Integer*2	SpEOF
	Parameter	( SPEOF	= 256 )

	Integer*2	W
	Integer*2	I, K, CurIn

	Integer*2	DNode(0:255,0:1), BPos
	Common	/UnSq/	DNode, BPos

	I = 0
	Do While ( I .ge. 0 )
	  BPos = BPos +	1
	  If ( BPos .gt. 7 ) Then
	    BPos = 0
	    Call Get_Char( CurIN )
	    If ( Curin .eq. -1 ) Then
	      W	= -1
	      Return
	    EndIf
	  Else
	    Curin = Ishft( Curin, -1 )		!!!VMS!!! VAX intrinsic	function
	  EndIf
	  K = Curin .and. 1
	  I = DNode( I,	K )
	EndDo

	I = -( I + 1 )
	If ( I .eq. SPEOF ) Then
	  W = -1
	Else
	  W = I
	EndIf
	Return
	End			   

C------------------------------------------------------------------------
C	Subroutine used	to put a byte into outbut buffer and will check
C	for compression	using the DLE technique
C
C	Input:
C		W	I*2 value holding the char to output
C
C	Output:		
C		Places data into the output buffer
C
C------------------------------------------------------------------------

	Subroutine Put_Char_UnComp( W )

	Implicit None

	Integer*2	DLE
	Parameter	( DLE =	'90'x )

	Integer*2	W, WC, RepCt, LastC

	Byte		C

	Equivalence	( WC, C	)

	Data	RepCt	/0/

	If ( Repct .gt.	0 ) Then		! Are we repeating a char?
	  If ( W .eq. 0	) Then
	    Call Put_Char_Crc( DLE )		! DLE was a real one
	  Else					! Count	is what	we have
	    RepCt = W				! Set the count	right
	    repct = repct - 1			! Now put the proper
	    Do While ( repCt .gt. 0 )		!  number of characters
	      Call Put_Char_Crc( LastC )	!  into	the buffer
	      repct = repct - 1
	    EndDo
	  EndIf
	  repct	= 0				! All done with	this repeat
	Else					! Not repeating	yet
	  If ( W .eq. DLE ) Then		! Repeat introducer?
	    RepCt = 1				! Yes, flag the	repeat
	  Else					! No, just put the char
	    Call Put_Char_Crc( W )		! Always save last sent
	    LastC = W
	  EndIf
	EndIf

	Return
	End

C------------------------------------------------------------------------
C	Subroutine that	places a byte into the output buffer
C
C	Input:
C		A byte value
C
C	OutPut:
C		The byte will be placed	into the output	buffer.	When the
C		buffer is full then it will be written.
C
C------------------------------------------------------------------------

	Subroutine Put_Byte( C )

	Implicit None

	Byte		CR, LF
	Parameter	( LF = '12'o )
	Parameter	( CR = '15'o )

	Byte		C

	Logical*1	CR_Flg

	Integer		K

	Logical*1	View_flg, Bin_flg, Extr_flg, LBR_Flg, Cancel_Op
	Integer		Remaining_Size
	Common	/Global/ Remaining_Size, View_Flg, Bin_Flg, Extr_Flg, 
	1		 LBR_Flg, Cancel_Op

	Integer		First_In, Last_In, Buf_Index, Buf_Length, Out_Index
	Byte		In_Buf(4096), Out_Buf(128)
	Common	/Buffers/ First_In, Last_In, Buf_Index,	Buf_Length, In_Buf,
	1		Out_Buf, Out_Index

	Data	CR_Flg /.False./

	If ( .Not. ( View_flg .or. Bin_Flg )) Then
	  If ( CR_Flg )	Then
	    If ( C .eq.	LF ) Then
	      Write( 1,	1100 ) (Out_Buf(K), K=1,Out_Index-1)
	      Out_Index	= 1
	      CR_Flg = .False.
	      Return
	    Else
	      Out_Buf( Out_Index ) = CR
	      Out_Index	= Out_Index + 1
	      If ( Out_Index .gt. 128 )	Then
	       Write( 1, 1100 )	(Out_Buf(K), K=1,128 )
	       Out_Index = 1
	      EndIf
	    EndIf
	  EndIf
	  If ( C .eq. CR ) Then
	    CR_Flg = .True.
	    Return
	  EndIf
	  Cr_Flg = .False.
	EndIf

	Out_Buf( Out_Index ) = C
	Out_Index = Out_Index +	1

	If ( Out_Index .gt. 128	) Then
	  Write( 1, 1100 ) (Out_Buf(K),	K=1,128	)
	  Out_Index = 1
	EndIf

	Return

1100	Format(	128A1 )

	End

C------------------------------------------------------------------------
C	Subroutine that	is used	to calc	a CRC 
C
C	Input:
C		I*2 with the character to add to the CRC
C
C	Output:
C		Call Put_Byte to add the byte to the output buffer
C
C------------------------------------------------------------------------

	Subroutine Put_Char_Crc( W )

	Implicit None

	Logical*1	View_flg, Bin_flg, Extr_flg, LBR_Flg, Cancel_Op
	Integer		Remaining_Size
	Common	/Global/ Remaining_Size, View_Flg, Bin_Flg, Extr_Flg, 
	1		 LBR_Flg, Cancel_Op

	Integer*2	W, Wc, T1, T2, CRCVal
	Integer*2	CRCTab(0:255)

	Byte		C

	Equivalence	( Wc, C	)

	Wc = W
	Call Put_Byte( C )

	If ( .Not. Lbr_Flg ) Then
	  T1 = ( 'FF'X .and. Ishft( CrcVal, -8 ) )		!!!VMS!!!
	  T2 = CrcTab((	CrcVal .xor. W ) .and. 'ff'X )
	  CrcVal = T1 .Xor. T2
	EndIf
	Return
	End

C------------------------------------------------------------------------
C	Subroutine that	sets up	the translation	array for the specified	
C	member 
C
C	Input:
C
C	Output:
C		The translation	node array is filled in	if 
C		The original name of the member	file.
C
C------------------------------------------------------------------------

	Subroutine Init_UnSq

	Implicit None

	Integer*2	SpEOF
	Parameter	( SPEOF	= 256 )

	Integer*2	I, NumNodes

	Logical*1	View_flg, Bin_flg, Extr_flg, LBR_Flg, Cancel_Op
	Integer		Remaining_Size
	Common	/Global/ Remaining_Size, View_Flg, Bin_Flg, Extr_Flg, 
	1		 LBR_Flg, Cancel_Op

	Integer*2	DNode(0:255,0:1), BPos
	Common	/UnSq/	DNode, BPos

	Call Get_Byte_Knt( NumNodes, 2 )

	BPos = 100
	Dnode(0,0) = -(SPEOF+1)
	Dnode(0,1) = -(SPEOF+1)

	NumNodes = NumNodes - 1

	Do I = 0, NumNodes
	  Call Get_Byte_Knt( DNode( I, 0 ), 2 )
	  Call Get_Byte_Knt( DNode( I, 1 ), 2 )
	EndDo

d	  Write( 6, * )	'Translation arrays:'
d	  Do I = 0, NumNodes
d	    Write( 6, 1000 ) I,	Dnode(I,0), Dnode(I,1)
d1000	    Format( ' #', I3, 2( ' ', Z4.4 ) )
d	  EndDo

	Return
	End

C------------------------------------------------------------------------
C	Subroutine called to position to a specified byte of a library 
C	file opened on LUN 2
C
C	Inputs:
C		Byte_Lk		The first byte wanted
C
C	Outputs:
C		Will put the requested byte in the buffer
C
C------------------------------------------------------------------------

	Subroutine Position_Lib( Byte_Lk )

	Implicit None

	Character	For_IOS(68)*30
	Common	/ForIOS/ For_IOS

	Integer		I, J, K, L, Q, Byte_Lk,	IoS

	Integer		First_In, Last_In, Buf_Index, Buf_Length, Out_Index
	Byte		In_Buf(4096), Out_Buf(128)
	Common	/Buffers/ First_In, Last_In, Buf_Index,	Buf_Length, In_Buf,
	1		Out_Buf, Out_Index

C	Check the starting byte	that is	requested

100	Continue
	If ( Byte_Lk .lt. First_In ) Goto 150		! Need to REWIND file
	If ( Byte_Lk .gt. Last_In ) Goto 200		! Read the next	buffer

C	Otherwise byte is in the current buffer

	Buf_Index = Byte_Lk - First_In + 1

	Return

C	Needed to start	over in	the file

150	Continue	      

	Rewind	2
	Last_In	= 0

C	Read the next buffer

200	Continue
	Do I = 1, 4096
	  In_Buf(I) = 0
	EndDo
	Read( 2, 1010, End=500,	Err=800, IoStat=IOS ) Q, ( In_Buf(K),K=1,Q )

d	Write( 6, 1111 ) ( In_Buf(K),K=1,128 )
d1111	Format(	8(/' ',	16( z2.2, ' ' )	) )

	Buf_Length = Q
	First_In = Last_In + 1
	Last_In	= First_In + Buf_Length	- 1

	Goto 100

C	End of File Encountered	while attempting to find a sector

500	Continue
	Rewind 2
	First_In = 0
	Last_In	= 0

	Return

C	Error occurred on read

800	Continue
	If ( IOS .gt. 68 ) Then
	  Type *, 'Unknown error on READ: ', IOS
	Else
	  Type *, 'Error on READ: ', For_IOS( IOS )
	EndIf

	Return

1010	Format(	Q, 4096A1 )

	End

C-------------------------------------------------------------------------------
C	Subroutine used	to convert a time in MSDOS I*2 format to a string
C	This routine calls a VMS FORTRAN shift routine (ISHFT).
C
C	Inputs:
C		T	2 byte value containing	time 
C			Format:	Bits 0-4 is number of 2	sec intervals
C				Bits 5-10 is number of minutes
C				Bits 11-15 is the number of hours
C	Outputs:
C		T_Str	in form: hh:mm:ss
C
C-------------------------------------------------------------------------------

	Subroutine Time_Str( T,	T_Str )

	Implicit None

	Integer*2	T, Work
	Integer		Sec, Hr, Min

	Character	T_Str*(*)

	Integer*2	H_Mask,	M_Mask,	S_Mask
	Parameter	( H_Mask = 'F800'x, 
	1		  M_Mask = '07E0'x, 
	1		  S_Mask = '001F'x )

	Work = T .and. S_Mask
	Sec = Work

	Work = T .and. M_Mask
	Work = IShft( Work, -5 )		! Shift	right 5	!!!VMS!!!
	Min = Work

	Work = T .and. H_Mask
	Work = IShft( Work, -11	)		! Shift	right 11 !!!VMS!!!
	Hr = Work

	Write( T_Str, 1000, err	= 100 )	Hr, Min, Sec*2

	Return

100	Continue

	T_Str =	'UnKnown'

	Return

1000	Format(	I2.2, 2( ':', I2.2 ) )

	End

C-------------------------------------------------------------------------------
C	Subroutines used to convert a count of days from a base	date to
C	a year,	month and day. The base	date can be selected.
C	This routine uses VMS RTL routines for date and	time manipulation.
C
C	Inputs:
C		BY	Base year (ie. 80 is 1-Jan-1980	is day 1)
C		D	2 byte value containing	the date that is the number
C			of days	since a	base date
C
C	Outputs:
C		D_Str	in form: mm/dd/yy
C
C-------------------------------------------------------------------------------

	Subroutine Date_Str( BY, D, D_Str )

	Implicit None

	Integer*2	D, Num_Time(7)

	Integer		BY, Work, Delta(2), Base(2), Act_Date(2)

	Integer		Lib$SubX, Sys$BinTim, Sys$NumTim, Stat	!!!VMS!!!

	Character	D_Str*(*), Temp_Str*23,	Err

	Err = 'T'
	If ( D .gt. 9999 ) Goto	100

	Err = 'B'
	Write( Temp_Str, 1001, Err=100 ) BY-1
	Stat = Sys$BinTim( Temp_Str, Base )		!!!VMS!!!
	If ( .Not. Stat	) GoTo 100

	Err = 'D'
	Write( Temp_Str, 1000, Err=100 ) D
	Stat = Sys$BinTim( Temp_Str, Delta )		!!!VMS!!!
	If ( .Not. Stat	) GoTo 100

	Err = 'S'
	Stat = Lib$SubX( Base, Delta, Act_Date,	2 )	!!!VMS!!!
	If ( .Not. Stat	) GoTo 100

	Err = 'N'
	Stat = Sys$NumTim( Num_Time, Act_Date )		!!!VMS!!!
	If ( .Not. Stat	) GoTo 100

	Err = 'W'
	Write( D_Str, 1002, Err=100 ) Num_Time(2), Num_Time(3),	
	1		Num_Time(1)-1900

	Return

100	Continue
	D_Str =	'Cnv Err' // Err		! Can't	convert
	Return

1000	Format(	I4.4, '	00:00:00.00' )
1001	Format(	'31-DEC-19', I2.2, ' 00:00:00.00' )	
1002	Format(	I2.2, 2( '/', I2.2 ) )

	End

C-------------------------------------------------------------------------------
C	Subroutine used	to enable the control C	trap used as a cancel signal
C	for View and Extract functions.
C
C	This routine is	very VMS specific!
C-------------------------------------------------------------------------------

	Subroutine Cancel_AST_Start

	Implicit None

	Integer		JPI_ITEM, IO_Func, K, L, IOS, TT_LEN
	Integer		Lib$GetJPI, Sys$Assign,	Sys$QioW

	Integer*2	TT_Chan

	Character	TT_Name*7

	Include		'($IODEF)'
	Include		'($JPIDEF)'

	External	Cancel_AST

	JPI_Item = JPI$_Terminal
	IOS = Lib$GetJPI( JPI_ITEM,,,, TT_Name,	TT_Len )
	If ( .Not. IOS ) Call Lib$Stop(	%Val( IOS ) )

	IOS = Sys$Assign( TT_Name(1:TT_Len), TT_Chan,, )
	If ( .Not. IOS ) Call Lib$Stop(	%Val( IOS ) )

	IO_Func	= IO$_SetMode .or. IO$M_CtrlCAST

	IOS = Sys$QioW(	, %Val(TT_Chan), %Val(IO_Func),,,, Cancel_AST,,,,, )
	If ( .Not. IOS ) Call Lib$Stop(	%Val( IOS ) )

	Return
	End

C-------------------------------------------------------------------------------
C	Subroutine to set Cancel AST for View and extract functions
C
C	This routine is	VMS specific
C-------------------------------------------------------------------------------

	Subroutine Cancel_AST

	Implicit None

	Logical*1	View_flg, Bin_flg, Extr_flg, LBR_Flg, Cancel_Op
	Integer		Remaining_Size
	Common	/Global/ Remaining_Size, View_Flg, Bin_Flg, Extr_Flg, 
	1		 LBR_Flg, Cancel_Op

	Cancel_OP = .True.
	Type *,	'+++ Operation Cancelled +++'
	Type *,	' '

	Return
	End
