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 if they are non binary
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 (Max 510 byte records) 
C		List the directory of a library file
C		New library 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	* ARC is Copyright 1985,1986 by System Enhancements Associates
C
C	This program was in general based on the Turbo Pascal program 
C	DEARC that is in the public domain. Also referenced ARC sources
C	from System Enhancement Associates
C
C-----------------------------------------------------------------------------
C-----------------------------------------------------------------------------
C	Modification History:
C
C	Vers	Date		Who		Comments
C
C	V2.8	12 Dec 86	John Coburn	Fix problem when running
C						in a subprocess
C				Walt Lamia	Extraction of all members
C
C	V2.7	22 Nov 86	John Coburn	Add CRC checking for LBRs
C
C	V2.6	30 Oct 86	John Coburn	Add CRC checking for ARCs
C
C	V2.5	29 Oct 86	John Coburn	Fixed bug that occurred
C						when extracting unsqueezed
C						binary files. Also fixed
C						boundary condition problem 
C						in decompression table that
C						caused ARC extracts to fail.
C
C	V2.4	 6 Sep 1986	John Coburn	Change to allow single CR or LF
C				Glenn Everharts	to be a record terminator.
C		
C	V2.3	 1 Mar 1986	John Coburn	Removed unreliable CRC checking
C
C	V2.2	 ???		John Coburn	Enhance ARC functions
C
C	V2.1	 ???		John Coburn	Add ARC functionality
C
C	V2.0	 1 Feb 1986	John Coburn	First released version
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, FBuf(128)
	Integer*2	LBR_Recognize
	Integer		Max_Num_Members

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

	Character	File_Name*12, In_FILE_NAME*50, ANS*1, Lib_Type*1
	Character	Technique*10, Techs(10)*10, Actual_Len_Str*8
	Data	Techs 	/ 2*'    --', '  Packed', ' Squeezed', 
	1		  3*'Crunch(un)', ' Crunched', 
	2		 2*' 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), Act_Len(Max_Num_Members)
	Integer		Num_Bytes_Arr(Max_Num_Members)
	Integer*2	CRCS(Max_Num_Members)
	Integer*4 Inought

	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, Ivcr
	Integer		Ibinfrc

	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
	Integer	 	Out_Index, Out_Length, Out_Num
	Byte		In_Buf(4096), Out_Buf(512)
	Common	/Buffers/ First_In, Last_In, Buf_Index, Buf_Length, In_Buf,
	1		Out_Buf, Out_Index, Out_Length, Out_Num

	Logical*1	View_Cr, View_flg, Bin_flg, Extr_flg
	Logical*1	LBR_Flg, Cancel_Op, AST_On_Flg
	Integer		Remaining_Size
	Integer*2	CRC_Val
	Common	/Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 
	1		 LBR_Flg, Cancel_Op, AST_On_Flg, CRC_Val
	common/binfrc/ ibinfrc

	Integer*2	I2
	Integer		Q, I, J, K, M, N, DIR_SECTS, ISTAT, Ios
	INTEGER		N1,N2,NN

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



C	Start of Code

	Type *, ' '
	Type *, 'V M S   S w e e p   V2.8a'
	Type *, 'for .LBR and .ARC files'
	Type *, ' '

10	Continue
	Last_In = 0
	First_In = 0
	Out_Index = 1
	In_FILE_NAME = ' '
	View_Cr = .False.
	Type 1020,'$Enter "library": '
	Accept 1021, Q, In_FILE_NAME(1:Q) 
	If ( Q .eq. 0 ) GoTo 800
	Ibinfrc = 0

	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', ReadOnly, 
	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 )

	File_OK = .True.
	Do I=1,8
	  If ( Name(I) .ne. ' ' ) File_OK = .False.
	EndDo
	Do I=1,3
	  If ( EXTEN(I) .ne. ' ' ) File_OK = .False.
	EndDo

	If ( .Not. File_OK ) Then
	  Write( 6, * ) '+++ Requested file is not an LBR file +++'
	  Write( 6, * ) '+++ Invalid directory format for LBR  +++'
	  GoTo 700
	EndIf

	DIR_SECTS = NSECTS		! How many directory segments are there

	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 = 2, DIR_SECTS*4
	    Call Get_Byte_Knt( DIR_ENTRY, 32 )
	    	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
		    Act_Len(N) = Num_Bytes_ARR(N) 
		    Temp = Indx
		    First_Byte_arr(N) = Temp * 128 + 1
		    CRCS(N) = CRC
		    If ( Crea_Date .ne. 0 ) Then
			Call LBR_Date_Str( 78, Crea_Date, Mem_Date(N) )
		    Else
			Mem_Date(N) = '   --'
		    EndIf
		    If ( Crea_Time .ne. 0 ) Then
			Call Time_Str( Crea_Time, Mem_Time(N) )
		    Else
			Mem_Time(N) = '  -'
		    EndIf
	    EndIf
70	Continue

C	Now lets determine how many of the members are squeezed

	Do I = 1, N
	  Call Position_Lib( First_Byte_Arr(I) )
	  Call Get_Byte_KNT( I2, 2 )		! Read first 2 bytes
	  If ( I2 .eq. LBR_recognize ) Then
	    Hdr_Vers(I) = 4			! Squeezed 
	    Act_Len(I) = 0			! Unknown actual size
	    Call Get_Byte_Knt( I2, 2 )		! Get past the CRC
	    File_Name = ' ' 
	    Call Get_Byte( C )			! Get the member orig name
	    K = 1
	    Do While ( C .ne. 0 )
	      File_Name(K:K) = Char( C )
	      Call Get_Byte( C )
	      K = K + 1
	    EndDo
	    Member_Names(I) = File_Name
	  Else
	    Hdr_Vers(I) = 2			! Not squeezed
	  EndIf
	EndDo

	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)
	Type *, ' '

	Call Get_Byte( C )
	Inought = 0
	Do While ( C .ne. -1 )
	  If ( C .ne. ArcMark ) Then		! Not an ARC file
	    I = 0
	    Do While ( C .ne. ArcMark .and. I .lt. 10 )
	      Call Get_Byte( C )
	      I = I + 1
	    EndDo
	    If ( I .ge. 10 ) Then
	      Write( 6, * ) '+++ Requested file not an ARC file +++'
	      Write( 6, * ) '+++ Could not find the mark of ARC +++'
		If (Inought.gt.0) goto 100
	      Goto 700
	    Else
	      Write( 6, * ) '+++ Bad Header encountered +++'
	      Write( 6, 1030 ) '+++ Skipped ', I, ' bytes  +++'
	    EndIf
	  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
	  Inought = Inought + 1
	  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 ARC_Date_Str( Crea_Date, Mem_Date(N) )
	  Else
	    Mem_Date(N) = '   --'
	  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) = '  -'
	  EndIf
	  Call Get_Byte_Knt( CRCs(N), 2 )

	  If ( Hdr_Ver .gt. 1 ) Then
	    Call Get_Byte_Knt( Act_Len(N), 4 )		! expanded length
	  Else
	    Act_Len(N) = Num_Bytes_Arr(N)
	  EndIf

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

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

	  Call Get_Byte( C )

	EndDo

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
	  K = Index( Member_Names(I), '.' )		! Make sure that 
	  If ( K .eq. 0 ) Then				! that created files
	    K = 1					! don't get a .DAT
	    Do While ( Member_Names(I)(K:K) .ne. ' ' )	! extension when
	      K = K + 1					! extracting a member
	    EndDo					! that has no extension
	    Member_Names(I)(K:K) = '.'
	  EndIf
	  NBLKS = Num_Bytes_Arr(I) / 512
	  If ( NBLKS*512 .ne. Num_Bytes_ARR(I) ) Nblks = NBlks + 1
	  Technique = Techs( Hdr_Vers(I) )
	  Actual_Len_Str = '    ??'
	  If ( Act_Len(I) .ne. 0 ) Then
	    Write( Actual_Len_Str, 1001, Err=160 ) Act_Len(I)
	  EndIf
160	  Write( 6,1010 ) I, Member_NAMES(I), Num_Bytes_Arr(I), CRCS(I),
	1		  Mem_Date(I), Mem_Time(I)(1:5), Technique, 
	1		  Actual_Len_Str
	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.
	Ivcr = 0

	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 ( ANS .eq. 'i' .or. ANS .eq. 'I' ) ivcr=-1
   	If ( ANS .eq. 'k' .or. ANS .eq. 'K' ) ivcr=+1
	If ( ANS .eq. 'v' .or. ANS .eq. 'V' ) View_flg = .True.
	If ( ANS .eq. 'e' .or. ANS .eq. 'E' ) Extr_flg = .True.
	If ( ANS .eq. 'b' .or. ANS .eq. 'B' ) ibinfrc = 1
	If ( ANS .eq. 'a' .or. ANS .eq. 'A' ) ibinfrc = 0

c arrange that A and B don't flag illegal command on console.
	If (ANS.eq.'a'.or.ANS.eq.'b')goto 200
	IF (ans.EQ.'A'.OR.ans.EQ.'B')GOTO 200
	If ( View_flg .or. Extr_flg ) GoTo 250
c Allow K and I modes to set carriage control for terminal
c output...
	If(ivcr.eq.0)goto 207
	If(ivcr.eq.-1)View_cr=.false.
	If(ivcr.eq.1)View_cr=.True.
	Goto 200
207	Continue

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

230	Continue
	Type 1020, ' '
	Type 1020, ' Commands available:'
	Type 1020, ' '
	Type 1020, '   E - Extract a member to a file'
	Type 1020, '   L - List the directory again'
	Type 1020, '   N - Get a new library file'
	Type 1020, '   V - View member at terminal'
	Type 1020, '   K - Convert isolated CR or LF to CRLF'
	Type 1020, '   I - Leave isolated CR or LF alone (image)'
	Type 1020, '   X - No option wanted (exit)'
	Type 1020, '   A - Ascii/Binary recognition for extract'
	Type 1020, '   B - Ask if ascii or binary on extract'
	Type 1020, '   ? - Display this list'

	GoTo 200

250	Continue
	Type 1400
	Accept 1410, N

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

	IF (N .GT. NUM_MEMBERS) THEN
	   N1 = 1
	   N2 = NUM_MEMBERS
	ELSE
	   N1 = N
	   N2 = N
	ENDIF

	If ( .Not. LBR_Flg ) GoTo 500

C	Now handle selection from .LBR file

300	Continue

	DO N = N1, N2

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

	CRC_Val = 0

	If ( Hdr_Vers(N) .eq. 4 ) Then
	  Squeezed = .True.
	  Call LBR_Init_UnSq				! Init the decode tree
	Else
	  Squeezed = .False.
	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
	  Call Get_Char( I2 )
	  Do While (( I2 .ne. -1 ) .and. .Not. Cancel_op )
	    Call Put_Char_CRC( I2 )
	    Call Get_Char( I2 )
	  EnDDo
	EndIf

	If (Remaining_Size.gt.0) Then
	  Call Get_Char_Knt( FBuf, Remaining_Size)	! Finish CRC
	EndIf

	Call Close_Ext_File( CRCS(N) )

	ENDDO

	GoTo 200

C	This code is for the .ARC library format

500	Continue

	DO N = N1, N2

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

	CRC_Val = 0

	GoTo ( 510, 510, 520, 530, 590, 590, 590, 540 ), Hdr_Vers(N)
	Type *, '--- Illegal or Unknown ARC Header value: ', Hdr_Vers(N)
	GoTo 200

510	Continue 		! Extract member that has no compression
	Call Open_Ext_File( Member_Names(N) )

	Call Get_Char( I2 )
	Do While (( I2 .ne. -1 ) .and. .Not. Cancel_Op )
	  Call Put_Char_CRC( I2 )
	  Call Get_Char( I2 )
	EnDDo
	Goto 595

520	Continue		! Extract member that uses DLE compression
	Call Open_Ext_File( Member_Names(N) )       

	Call Get_Char( I2 )
	Do While (( I2 .ne. -1 ) .and. .Not. Cancel_Op )
	  Call Put_Char_UnComp( I2 )
	  Call Get_Char( I2 )
	EnDDo
	Goto 595

530	Continue		! Extract Member that uses Huffman squeeze
	Call Open_Ext_File( Member_Names(N) )

	Type *, ' '
	Type *, '--- Warning --- File may not extract properly ---'
	Type *, ' '

	Call Init_Unsq
	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
	Goto 595

540	Continue
	Call Open_Ext_File( Member_Names(N) )
	Call DeComp_LZW_Var
	Goto 595

590	Continue
	Type *, 'Not implemented yet, Need a newer version'
	Type *, '(Also, old crunch options not supported.)'
	GoTo 200

595	Continue
	Call Close_Ext_File( CRCS(N) )

	ENDDO

	GoTo 200

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 )
1001	Format( I8 )
1008	Format( '   #  Member Name   # Bytes  CRC     Date    Time   ',
	1	'Stor. Type  Actual Len' )
1009	Format( ' ---- ------------  -------  ----  --------  -----  ',
	1	'----------  ----------' )
1010	Format( ' ', I3, '. ', a, '  ', I7, '  ', Z4.4, 4( '  ', 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 (9999 for all) : ' )
1410	Format( I3 )

	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, Record_Length

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

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

	Character	For_IOS(68)*30
	Common	/ForIOS/ For_IOS
	Integer Ibinfrc
	common/binfrc/ Ibinfrc

	Out_Num = 0
	Bin_Flg = .True.
	K = Index( File_Name, '.' )
c force question about ASCII/BINARY to be asked if B command was given
	If (Ibinfrc.ne.0)K=0
	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+3)
	  Do K = 1, 3			! Upcase the extension
	    If ( File_Ext(K:K) .ge. 'a' .and. File_Ext(K:K) .le. 'z' ) Then
	      File_Ext(K:K) = Char( Ichar( File_Ext(K:K) ) - '40'o )
	    EndIf
	  EndDo
          K = Index( ' LBR ARC COM EXE REL CMD COM OVR BIN', File_Ext )
	  Bin_Flg = .False. 
	  If ( K .ne. 0 ) Bin_Flg = .True.
	EndIf

	If ( .Not. Bin_Flg ) Then
	  Type *, '++ Member being treated as Text (Bit 8 cleared) ++'
	EndIf

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

	If ( Bin_Flg ) Then
	  Out_Length = 128
	  Carriage = 'NONE'
	Else
	  Out_Length = 510
	  Carriage = 'LIST'
	EndIf

	Cancel_op = .False.

	If ( View_flg ) Then
	  Open_Name = 'Sys$OutPut'
	Else
	  OPen_Name = File_Name
	  Do I = 1, 11
	    If ( Open_Name(I:I) .eq. '-' ) Open_Name(I:I) = '_'
	  EndDo
	  Write( 6, * ) 'Extracting to ', Open_Name, '...'
	EndIf

	If ( .Not. AST_On_Flg ) Then
	  Call Cancel_AST_Start
	  AST_On_Flg = .True.
	EndIf

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

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

	Return

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

1100	Format( A )

	End




C------------------------------------------------------------------------
C	Subroutine used to close the open LUN used for extract and View
C	commands. Insures that the last partial buffer is written.
C
C	Inputs:
C		Uses info in buffer common to empty the output buffer
C		If needed.
C
C	Outputs:
C		The last buffer is emptied before closing the LUN
C
C------------------------------------------------------------------------

	Subroutine Close_Ext_File( Mem_CRC )

	Implicit None

	Byte		B(2)
	Integer*2	Mem_CRC, Loc_CRC, KeepCRC

	Equivalence	( Loc_CRC, B(1) )

	Integer 	K

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

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

c	Start of routine code

	Loc_CRC = Mem_CRC           

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

	If ( Cancel_Op ) Then
	  Close( Unit=1, Disp='DELETE' )
	Else
	  Close( Unit=1 )
	  KeepCRC = CRC_Val
	  If ( .Not. LBR_Flg ) Then
	    Call ARC_CRC( CRC_Val, B(1) )
	    Call ARC_CRC( CRC_Val, B(2) )
	  Else
	    Call LBR_CRC( CRC_Val, B(2) )
	    Call LBR_CRC( CRC_Val, B(1) )
	  EndIf
	  If ( Mem_CRC .ne. 0 ) Then		! Zero CRC means no check
	    If ( CRC_Val .ne. 0 ) Then
	      Type *,'--- Warning --- CRC Error ---'
	      Type 2000, Mem_CRC, KeepCRC, Crc_Val
2000	      Format( ' Member CRC: ', Z4.4, ', Calc''d CRC: ', Z4.4, 
	1		', Final value CRC: ', Z4.4 )
	    EndIf
	  EndIf
	EndIf

	If ( .Not. View_Flg .and. .Not. Cancel_Op ) Then
	  If ( Bin_Flg )Then
	    Type 1000, Out_Num
	  Else
	    Type 1001, Out_Num
	  EndIf
	EndIf

	Return
1000	Format( //' --> ', I6, ' Records written' )
1001	Format( //' --> ', I6, ' Lines written' )
1100	Format( 510A1 )

	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
	Integer	 	Out_Index, Out_Length, Out_Num
	Byte		In_Buf(4096), Out_Buf(512)
	Common	/Buffers/ First_In, Last_In, Buf_Index, Buf_Length, In_Buf,
	1		Out_Buf, Out_Index, Out_Length, Out_Num

	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

	Integer*4	Knt

	Equivalence	( W, C )

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

	W = 0
	If ( remaining_Size .gt. 0 ) Then
	    Call Get_Byte( C )
	    Remaining_Size = Remaining_Size - 1
	    If ( LBR_Flg ) Then
		Knt = Knt + 1
		Call LBR_CRC( CRC_Val, C )
c		Type 10, 'Knt: ', Knt, ', Char: ', C, ', CRC: ', CRC_Val
c10		Format( x, A, I5, A, Z2, A, Z4.4 )
	    EndIf
	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 used to get KNT bytes from input
C	Call the Get_Char 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_Char_Knt( Buf, Knt )

	Implicit None

	Integer		Knt, I

	Byte		Buf(KNT)

	Do I = 1, KNT
	    Call Get_Char( 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
c	  Type *, 'Special End of File found'
	  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_Cr, View_flg, Bin_flg, Extr_flg
	Logical*1	LBR_Flg, Cancel_Op, AST_On_Flg
	Integer		Remaining_Size
	Integer*2	CRC_Val
	Common	/Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 
	1		 LBR_Flg, Cancel_Op, AST_On_Flg, CRC_Val

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

	Data	CR_Flg /.False./

	If ( .Not. Bin_Flg ) Then
	  C = C .and. '7F'x
	  If ( C .eq. '1a'x ) Then		! If ^z don't put in file
c	    Remaining_Size = 0
	    Return
	  EndIf

	  If ((C.eq.LF.or.C.eq.CR).and.View_cr)Then
c Write out line if CR or LF up to what's saved alread.
c View_Cr mode only...
	    Write(1, 1100) (Out_Buf(K), K=1,Out_Index-1)
	    Out_Index=1
	    Out_Num = Out_Num+1
	    CR_FLG = .False.
	    Return
	  Endif
	  If ( CR_Flg ) Then
	    If ( C .eq. LF ) Then
	      Write( 1, 1100 ) (Out_Buf(K), K=1,Out_Index-1)
	      Out_Index = 1
	      Out_Num = Out_Num + 1
	      CR_Flg = .False.
	      Return
	    Else
	      Out_Buf( Out_Index ) = CR
	      Out_Index = Out_Index + 1
	      If ( Out_Index .gt. Out_Length ) Then
	       Write( 1, 1100 ) (Out_Buf(K), K=1,Out_Length )
	       Out_Index = 1
	       Out_Num = Out_Num + 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. Out_Length ) Then
	  Write( 1, 1100 ) (Out_Buf(K), K=1,Out_Length )
	  Out_Index = 1
	  Out_Num = Out_Num + 1
	EndIf

	Return

1100	Format( 510A1 )

	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_Cr, View_flg, Bin_flg, Extr_flg
	Logical*1	LBR_Flg, Cancel_Op, AST_On_Flg
	Integer		Remaining_Size
	Integer*2	CRC_Val
	Common	/Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 
	1		 LBR_Flg, Cancel_Op, AST_On_Flg, CRC_Val

	Integer*2	W, Wc, Knt

	Byte		C

	Equivalence	( Wc, C )

	Wc = W
	Call Put_Byte( C )

	If ( .Not. Lbr_Flg ) Then
	  Call ARC_CRC( CRC_Val, C )
c	  Type 10, 'Rem: ', Remaining_size, ', Char: ', C, ', CRC: ', CRC_Val
c10	  Format( x, A, I5, A, Z2, A, Z4.4 )
	EndIf

	Return
	End




C------------------------------------------------------------------------
C	Subroutine that process the header of a squeezed member of a 
C	LBR file. 
C
C------------------------------------------------------------------------

	Subroutine LBR_Init_UnSq

	Implicit None

	Integer*2	I2, K

	Byte		C

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

	Call Get_Char_KNT( I2, 2 )		! Read first 2 bytes
	Call Get_Char_Knt( I2, 2 )		! Get past the CRC
	Call Get_Char( C )			! Get the member orig name
	Do While ( C .ne. 0 )			!  Read all of it
	  Call Get_Char( C )			!  until we point to the
	EndDo					!  decode tree

	Call Init_UnSq				! Read the decode tree

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

	Subroutine Init_UnSq

	Implicit None

	Integer*2	SpEOF
	Parameter	( SPEOF = 256 )

	Integer*2	I, NumNodes

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

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

	Call Get_Char_Knt( NumNodes, 2 )

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

	NumNodes = NumNodes - 1

	Do I = 0, NumNodes
	  Call Get_Char_Knt( DNode( I, 0 ), 2 )
	  Call Get_Char_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
	Integer	 	Out_Index, Out_Length, Out_Num
	Byte		In_Buf(4096), Out_Buf(512)
	Common	/Buffers/ First_In, Last_In, Buf_Index, Buf_Length, In_Buf,
	1		Out_Buf, Out_Index, Out_Length, Out_Num

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( ':', I2.2 ) )

	End




C-------------------------------------------------------------------------------
C	Subroutine used to convert a date in MSDOS File date format into
C	a year, month and day. 
C
C	This routine uses VMS FORTRAN intrinsic function for shifting
C
C	Inputs:
C		D	2 byte value containing the date 
C
C	Outputs:
C		D_Str	in form: mm/dd/yy
C
C-------------------------------------------------------------------------------

	Subroutine ARC_Date_Str( D, D_Str )
                  
	Implicit None

	Integer*2	D, Work
	Integer		Yr, Mo, Dy

	Character	D_Str*(*)

	Integer*2	Y_Mask, M_Mask, D_Mask
	Parameter	( Y_Mask = 'FE00'x, 
	1		  M_Mask = '01E0'x, 
	1		  D_Mask = '001F'x )

	Work = D .and. D_Mask
	Dy = Work

	Work = D .and. M_Mask
	Work = IShft( Work, -5 )		! Shift right 5 !!!VMS!!!
	Mo = Work

	Work = D .and. Y_Mask
	Work = IShft( Work, -9 )		! Shift right 9 !!!VMS!!!
	Yr = Work

	Write( D_Str, 1000, err = 100 ) Mo, Dy, Yr+80

	Return

100	Continue

	D_Str = 'UnKnown'

	Return

1000	Format( I2, 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 LBR_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( '/', 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 ) )

	If ( TT_Name .eq. ' ' ) Then
	  TT_Name = 'TT:'
	  TT_Len = 3
	EndIf

	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_Cr, View_flg, Bin_flg, Extr_flg
	Logical*1	LBR_Flg, Cancel_Op, AST_On_Flg
	Integer		Remaining_Size
	Integer*2	CRC_Val
	Common	/Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 
	1		 LBR_Flg, Cancel_Op, AST_On_Flg, CRC_Val

	Cancel_OP = .True.
	AST_On_Flg = .False.

	Type *, '+++ Operation Cancelled +++'
	Type *, ' '

	Return
	End




C-----------------------------------------------------------------------------
C	Subroutine used to Decompress a file that uses Lempel-Zev crunching
C	with adaptive reset of the string table
C
C	Inputs:
C		Uses Common
C
C	Output:
C		A character code in I*2 variable
C
C-----------------------------------------------------------------------------

	Subroutine GetCode( C )

	Implicit None

	Integer*2	R_Off, Bits, Code, C, Temp
	Integer*2	MaxCodeVal

c	Common and declarations for Lempel-Zev Crunching 
                         
	Integer         Max_bits, H_Size, Init_Bits
	Integer*2	First_Entry, Clear_Ind, Eof_Mark
	Parameter	( Max_Bits = 12 )
	Parameter	( Init_Bits = 9 )
	Parameter	( First_Entry = 257 )
	Parameter	( Clear_Ind = 256 )
	Parameter	( EOF_Mark = -1 )
	Parameter	( H_Size = 5003 )

	Logical*1	Clear_Flg
	Byte	   	Suffix(0:H_Size), Stack(0:H_Size)
	Byte		R_Mask(0:9), L_Mask(0:9)
	Integer*2	MaxCode, Max_MaxCode, Free_Ent, N_Bits
	Integer*2  	Buf(0:Max_Bits), Buf_Inx, Offset, Size
	Integer*2	Prefix(0:H_Size)

	Common	/LZWV/	Clear_Flg, MaxCode, Max_MaxCode, Free_Ent, N_Bits,
	1		Buf, Buf_Inx, R_Mask, L_Mask, Prefix, Suffix, Stack,
	1		Offset, Size

c	Start code

	If ( Clear_Flg .or. ( Offset .ge. Size ) .or. 
	1  ( Free_ent .gt. Maxcode ) ) Then

c 	  if the next entry will be too big for current code size 
c	  then we must increase the size and get a new buffer

	  If ( Free_ent .gt. Maxcode ) Then
	    N_Bits = N_Bits + 1
	    If ( N_Bits .eq. Max_Bits ) Then
	      Maxcode = Max_Maxcode
	    Else
	      Maxcode = MaxcodeVal( N_Bits )
	    EndIf
	  EndIf

	  If ( Clear_Flg ) Then
	    N_Bits = Init_Bits
	    Maxcode = MaxcodeVal( N_Bits )
	    Clear_Flg = .False.
	  EndIf

	  Do Size = 0, N_Bits-1
	    Call Get_Char( Code )
	    If ( Code .eq. EOF_Mark ) Goto 100
	    Buf( Size ) = Code
	  EndDo

100	  Continue
	  If ( Size .le. 0 ) Then
	    C = -1
	    Return
	  EndIf
	  Offset = 0

c	  Round size down to integral number of codes

	  Size = Ishft( Size, 3 ) - ( N_bits - 1 )
	EndIf

	R_Off = Offset
	Bits = N_Bits

c	Get the first byte

	Buf_Inx = Ishft( R_Off, -3 )
	R_Off = R_Off .and. 7

	Temp = Buf(Buf_Inx)
	Buf_Inx = Buf_Inx + 1

c	get the first part of the code

	Code = Ishft( Temp, -R_Off )
	Bits = Bits - ( 8 - R_Off )
	R_Off = 8 - R_Off 

c	get any 8 bit parts in the middle ( <= 1 for up to 16 bits )

	If ( Bits .ge. 8 ) Then
	  Temp = Buf( Buf_Inx )
	  Buf_Inx = Buf_Inx + 1
	  Code = Code .or. ( IShft( Temp, R_Off ) )
	  R_Off = R_Off + 8
	  Bits = Bits - 8
	EndIf

c	High order bits

	Temp = Buf( Buf_Inx ) .and. R_Mask( Bits )
	Code = Code .or. ( Ishft( Temp, R_Off ) )
	Offset = Offset + N_Bits

	C = Code
	Return
	End




C-----------------------------------------------------------------------------
C	Main Subroutine to decompress a Lempel Zev crunched file using
C	adaptive reset of string buffer when full - Based on ARC V5.0
C
C	Inputs:
C		None
C
C	Outputs:
C		Decompresses a member of an ARC file
C
C-----------------------------------------------------------------------------

	Subroutine DeComp_LZW_Var

	Implicit None

	Byte		BCode, BFinChar, BTemp
	Integer*2	FinChar, OldCode, InCode, Code, St_Inx, MaxCodeVal
	Integer*2	Temp
	Equivalence	( Temp, BTemp )
	Equivalence	( Code, BCode )
	Equivalence	( FinChar, BFinChar )

c	Common and declarations for Lempel-Zev Crunching 

	Integer         Max_bits, H_Size, Init_Bits
	Integer*2	First_Entry, Clear_Ind, Eof_Mark
	Parameter	( Max_Bits = 12 )
	Parameter	( Init_Bits = 9 )
	Parameter	( First_Entry = 257 )
	Parameter	( Clear_Ind = 256 )
	Parameter  	( EOF_Mark = -1 )
	Parameter	( H_Size = 5003 )

	Logical*1	Clear_Flg
	Byte		Suffix(0:H_Size), Stack(0:H_Size)
	Byte		R_Mask(0:9), L_Mask(0:9)
	Integer*2	MaxCode, Max_MaxCode, Free_Ent, N_Bits
	Integer*2	Buf(0:Max_Bits), Buf_Inx, Offset, Size
	Integer*2	Prefix(0:H_Size)

	Common	/LZWV/	Clear_Flg, MaxCode, Max_MaxCode, Free_Ent, N_Bits,
	1		Buf, Buf_Inx, R_Mask, L_Mask, Prefix, Suffix, Stack,
	1		Offset, Size

	Data	R_Mask	/ '00'x, '01'x, '03'x, '07'x, '0f'x, 
	1		  '1f'x, '3f'x, '7f'x, 'ff'x, '00'x /

	Data	L_Mask	/ 'ff'x, 'fe'x, 'fc'x, 'f8'x, 'f0'x, 
	1		  'e0'x, 'c0'x, '80'x, '00'x, '00'x /

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

c	Start of code

c	Check maximum number of bits used in code

	Call Get_Char( Code )
	If ( Code .ne. Max_Bits ) Then
	  Type *, '--- Cannot handle bit count of Crunch ---'
	  Return
	EndIf

	N_Bits = Init_Bits
	Clear_Flg = .False.

	CRC_Val = 0				! Reset some variables
	Offset = 0				!  for the new member
	Size = 0

	MaxCode = MaxcodeVal( N_Bits )
	Max_MaxCode = MaxcodeVal( Max_Bits )+1	! Adjust so full table works

c	Initialize the first 256 entries in the table

	Do Code = 255, 0, -1
	  Prefix(Code) = 0
	  Suffix(Code) = BCode
	EndDo

	Free_Ent = First_Entry

c	First code must be the actual character

	Call GetCode( OldCode )
	FinChar = OldCode

	If ( OldCode .eq. -1 ) Return

	Call Put_Char_UnComp( FinChar )

	St_Inx = 1

c	Now loop getting codes unyil all done

	Call GetCode( Code )
	Do While ( ( Code .gt. -1 ) .and. .Not. Cancel_Op )

c	Clear the table?

	  If ( Code .eq. Clear_Ind ) Then
	    Do Code = 255, 0, -1
	      Prefix(Code) = 0
	    EndDo         
	    Clear_Flg = .True.
	    Free_Ent = First_Entry - 1
	    Call GetCode( Code )
	    If ( Code  .eq. -1 ) Return
	  EndIf

	  InCode = Code

c	Special case for KwKwK string

	  If ( Code .ge. Free_Ent ) Then
	    Stack( St_Inx ) = BFinChar
	    St_Inx = St_Inx + 1
	    Code = OldCode
	  EndIf

c	Generate output chars in reverse order

	  Do While ( Code .ge. 256 )
	    Stack( St_Inx ) = Suffix( Code )
	    St_Inx = St_Inx + 1
	    Code = Prefix( Code )
	  EndDO

	  Stack( St_Inx ) = Suffix( Code )
	  St_Inx = St_Inx + 1
	  FinChar = Suffix( Code )

c	Output them in correct order

100	  Continue
	  St_Inx = St_Inx - 1
	  Temp = 0
	  BTemp = Stack( St_Inx ) 
	  Call Put_Char_UnComp( TEMP )

	  If ( St_Inx .gt. 1 ) GoTo 100

C	Setup for next code

	  Code = Free_ent 
	  If ( Code .lt. Max_MaxCode ) Then
	    Prefix( Code ) = OldCode
	    Suffix( Code ) = BFinChar
	    Free_Ent = Code + 1
	  EndIf

	  OldCode = InCode

	  Call GetCode( Code )
	EndDo

	Return
	End




C-----------------------------------------------------------------------------
C	Integer function used to calculate a maximum value based on the
C	number of bits to be used
C
C	Input:
C		The number of bits to use (I)
C	Output:
C		The maximum (unsigned) value that can be stored in I bits
C
C-----------------------------------------------------------------------------

	Integer*2 Function MaxCodeVal( I )

	Integer*2	I, J

	J = 1
	MaxCodeVal = ( Ishft( J, I ) - 1 )

	Return
	End




C-----------------------------------------------------------------------------
C	Subroutine used to calculate a CRC value based on the
C	character (byte) passed to it.
C
C	Input:
C		The current CRC value and the byte to add into it
C	Output:
C		The updated CRC value
C
C-----------------------------------------------------------------------------

	Subroutine ARC_CRC( CRCVal, Val )

	Implicit None

	Integer*2	CRCTab(0:255), Temp, I, CRCVal

	Byte	Val, IVal

	Equivalence	( I, IVal )

	Data	CRCTab	/
	1	'0000'x, 'C0C1'x, 'C181'x, '0140'x, 
	1	'C301'x, '03C0'x, '0280'x, 'C241'x,
	1	'C601'x, '06C0'x, '0780'x, 'C741'x, 
	1	'0500'x, 'C5C1'x, 'C481'x, '0440'x,
	1	'CC01'x, '0CC0'x, '0D80'x, 'CD41'x, 
	1	'0F00'x, 'CFC1'x, 'CE81'x, '0E40'x,
	1	'0A00'x, 'CAC1'x, 'CB81'x, '0B40'x, 
	1	'C901'x, '09C0'x, '0880'x, 'C841'x,
	1	'D801'x, '18C0'x, '1980'x, 'D941'x, 
	1	'1B00'x, 'DBC1'x, 'DA81'x, '1A40'x,
	1	'1E00'x, 'DEC1'x, 'DF81'x, '1F40'x, 
	1	'DD01'x, '1DC0'x, '1C80'x, 'DC41'x,
	1	'1400'x, 'D4C1'x, 'D581'x, '1540'x, 
	1	'D701'x, '17C0'x, '1680'x, 'D641'x,
	1	'D201'x, '12C0'x, '1380'x, 'D341'x, 
	1	'1100'x, 'D1C1'x, 'D081'x, '1040'x,
	1	'F001'x, '30C0'x, '3180'x, 'F141'x, 
	1	'3300'x, 'F3C1'x, 'F281'x, '3240'x,
	1	'3600'x, 'F6C1'x, 'F781'x, '3740'x, 
	1	'F501'x, '35C0'x, '3480'x, 'F441'x,
	1	'3C00'x, 'FCC1'x, 'FD81'x, '3D40'x, 
	1	'FF01'x, '3FC0'x, '3E80'x, 'FE41'x,
	1	'FA01'x, '3AC0'x, '3B80'x, 'FB41'x, 
	1	'3900'x, 'F9C1'x, 'F881'x, '3840'x,
	1	'2800'x, 'E8C1'x, 'E981'x, '2940'x, 
	1	'EB01'x, '2BC0'x, '2A80'x, 'EA41'x,
	1	'EE01'x, '2EC0'x, '2F80'x, 'EF41'x, 
	1	'2D00'x, 'EDC1'x, 'EC81'x, '2C40'x,
	1	'E401'x, '24C0'x, '2580'x, 'E541'x, 
	1	'2700'x, 'E7C1'x, 'E681'x, '2640'x,
	1	'2200'x, 'E2C1'x, 'E381'x, '2340'x, 
	1	'E101'x, '21C0'x, '2080'x, 'E041'x,
	1	'A001'x, '60C0'x, '6180'x, 'A141'x, 
	1	'6300'x, 'A3C1'x, 'A281'x, '6240'x,
	1	'6600'x, 'A6C1'x, 'A781'x, '6740'x, 
	1	'A501'x, '65C0'x, '6480'x, 'A441'x,
	1	'6C00'x, 'ACC1'x, 'AD81'x, '6D40'x, 
	1	'AF01'x, '6FC0'x, '6E80'x, 'AE41'x,
	1	'AA01'x, '6AC0'x, '6B80'x, 'AB41'x, 
	1	'6900'x, 'A9C1'x, 'A881'x, '6840'x,
	1	'7800'x, 'B8C1'x, 'B981'x, '7940'x, 
	1	'BB01'x, '7BC0'x, '7A80'x, 'BA41'x,
	1	'BE01'x, '7EC0'x, '7F80'x, 'BF41'x, 
	1	'7D00'x, 'BDC1'x, 'BC81'x, '7C40'x,
	1	'B401'x, '74C0'x, '7580'x, 'B541'x, 
	1	'7700'x, 'B7C1'x, 'B681'x, '7640'x,
	1	'7200'x, 'B2C1'x, 'B381'x, '7340'x, 
	1	'B101'x, '71C0'x, '7080'x, 'B041'x,
	1	'5000'x, '90C1'x, '9181'x, '5140'x, 
	1	'9301'x, '53C0'x, '5280'x, '9241'x,
	1	'9601'x, '56C0'x, '5780'x, '9741'x, 
	1	'5500'x, '95C1'x, '9481'x, '5440'x,
	1	'9C01'x, '5CC0'x, '5D80'x, '9D41'x, 
	1	'5F00'x, '9FC1'x, '9E81'x, '5E40'x,
	1	'5A00'x, '9AC1'x, '9B81'x, '5B40'x, 
	1	'9901'x, '59C0'x, '5880'x, '9841'x,
	1	'8801'x, '48C0'x, '4980'x, '8941'x, 
	1	'4B00'x, '8BC1'x, '8A81'x, '4A40'x,
	1	'4E00'x, '8EC1'x, '8F81'x, '4F40'x, 
	1	'8D01'x, '4DC0'x, '4C80'x, '8C41'x,
	1	'4400'x, '84C1'x, '8581'x, '4540'x, 
	1	'8701'x, '47C0'x, '4680'x, '8641'x,
	1	'8201'x, '42C0'x, '4380'x, '8341'x, 
	1	'4100'x, '81C1'x, '8081'x, '4040'x
	1	/

	I = 0
	IVal = Val

	Temp = Ishft( CRCVal, -8 ) .and. '00ff'x
	Temp = Temp .xor. CRCTab( ( (CRCVal .Xor. I) .and. '00ff'x ) )
	CRCVal = Temp

	Return
	End




C------------------------------------------------------------------------------
C	Subroutine used to calculate the CRC for .LBR files
C
C	Input:
C		Current CRC value
C		New byte to include 
C
C	Output:
C		Updated CRC value
C
C------------------------------------------------------------------------------

	Subroutine LBR_CRC( CRCVal, Val )

	Implicit None

	Byte		Val, V

	Integer*2	CRCVal, Temp, I, BitC, BitH, Mask_Bit, Poly

	Data		Mask_Bit /15/, Poly /'1021'x/

	Integer*4	Long, K

	Equivalence	( Long, Temp )
	Equivalence	( I, V )

	I = 0
	V = Val

	Do K = 1, 8
	Bitc = IBits( I, 7, 1 )
	BitH = IBits( CrcVal, Mask_Bit, 1 )
	Temp = Ishft( I, 1 ) 
	I = Temp .and. 'FF'x

	Long = 0
	Temp = Ishft( CrcVal, 1 ) + BitC

	If ( BitH .eq. 1 ) Then
	Temp = Temp .Xor. Poly
	EndIf

	CrcVal = Temp
	EndDo

	Return
	End