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