🚀 go-pugleaf

Submitted-by: munroe@dmc.com (Dick Munroe)
Posting-number: Volume 3, Issue 120
Archive-name: ubbs/part12
-+-+-+-+-+-+-+-+ START OF PART 12 -+-+-+-+-+-+-+-+
X`09Integer`09`09Remaining_Size
X`09Integer*2`09CRC_Val
X`09Common`09/Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg,`2
V0
X`091`09`09 LBR_Flg, Cancel_Op, AST_On_Flg, CRC_Val
X
X`09Cancel_OP = .True.
X`09AST_On_Flg = .False.
X
X`09Type *, '+++ Operation Cancelled +++'
X`09Type *, ' '
X
X`09Return
X`09End
X`0C`0A
XC---------------------------------------------------------------------------
V--
XC`09Subroutine used to Decompress a file that uses Lempel-Zev crunching
XC`09with adaptive reset of the string table
XC
XC`09Inputs:
XC`09`09Uses Common
XC
XC`09Output:
XC`09`09A character code in I*2 variable
XC
XC---------------------------------------------------------------------------
V--
X
X`09Subroutine GetCode( C )
X
X`09Implicit None
X
X`09Integer*2`09R_Off, Bits, Code, C, Temp
X`09Integer*2`09MaxCodeVal
X
Xc`09Common and declarations for Lempel-Zev Crunching`20
X                        `20
X`09Integer         Max_bits, H_Size, Init_Bits
X`09Integer*2`09First_Entry, Clear_Ind, Eof_Mark
X`09Parameter`09( Max_Bits = 12 )
X`09Parameter`09( Init_Bits = 9 )
X`09Parameter`09( First_Entry = 257 )
X`09Parameter`09( Clear_Ind = 256 )
X`09Parameter`09( EOF_Mark = -1 )
X`09Parameter`09( H_Size = 5003 )
X
X`09Logical*1`09Clear_Flg
X`09Byte`09   `09Suffix(0:H_Size), Stack(0:H_Size)
X`09Byte`09`09R_Mask(0:9), L_Mask(0:9)
X`09Integer*2`09MaxCode, Max_MaxCode, Free_Ent, N_Bits
X`09Integer*2  `09Buf(0:Max_Bits), Buf_Inx, Offset, Size
X`09Integer*2`09Prefix(0:H_Size)
X
X`09Common`09/LZWV/`09Clear_Flg, MaxCode, Max_MaxCode, Free_Ent, N_Bits,
X`091`09`09Buf, Buf_Inx, R_Mask, L_Mask, Prefix, Suffix, Stack,
X`091`09`09Offset, Size
X
Xc`09Start code
X
X`09If ( Clear_Flg .or. ( Offset .ge. Size ) .or.`20
X`091  ( Free_ent .gt. Maxcode ) ) Then
X
Xc `09  if the next entry will be too big for current code size`20
Xc`09  then we must increase the size and get a new buffer
X
X`09  If ( Free_ent .gt. Maxcode ) Then
X`09    N_Bits = N_Bits + 1
X`09    If ( N_Bits .eq. Max_Bits ) Then
X`09      Maxcode = Max_Maxcode
X`09    Else
X`09      Maxcode = MaxcodeVal( N_Bits )
X`09    EndIf
X`09  EndIf
X
X`09  If ( Clear_Flg ) Then
X`09    N_Bits = Init_Bits
X`09    Maxcode = MaxcodeVal( N_Bits )
X`09    Clear_Flg = .False.
X`09  EndIf
X
X`09  Do Size = 0, N_Bits-1
X`09    Call Get_Char( Code )
X`09    If ( Code .eq. EOF_Mark ) Goto 100
X`09    Buf( Size ) = Code
X`09  EndDo
X
X100`09  Continue
X`09  If ( Size .le. 0 ) Then
X`09    C = -1
X`09    Return
X`09  EndIf
X`09  Offset = 0
X
Xc`09  Round size down to integral number of codes
X
X`09  Size = Ishft( Size, 3 ) - ( N_bits - 1 )
X`09EndIf
X
X`09R_Off = Offset
X`09Bits = N_Bits
X
Xc`09Get the first byte
X
X`09Buf_Inx = Ishft( R_Off, -3 )
X`09R_Off = R_Off .and. 7
X
X`09Temp = Buf(Buf_Inx)
X`09Buf_Inx = Buf_Inx + 1
X
Xc`09get the first part of the code
X
X`09Code = Ishft( Temp, -R_Off )
X`09Bits = Bits - ( 8 - R_Off )
X`09R_Off = 8 - R_Off`20
X
Xc`09get any 8 bit parts in the middle ( <= 1 for up to 16 bits )
X
X`09If ( Bits .ge. 8 ) Then
X`09  Temp = Buf( Buf_Inx )
X`09  Buf_Inx = Buf_Inx + 1
X`09  Code = Code .or. ( IShft( Temp, R_Off ) )
X`09  R_Off = R_Off + 8
X`09  Bits = Bits - 8
X`09EndIf
X
Xc`09High order bits
X
X`09Temp = Buf( Buf_Inx ) .and. R_Mask( Bits )
X`09Code = Code .or. ( Ishft( Temp, R_Off ) )
X`09Offset = Offset + N_Bits
X
X`09C = Code
X`09Return
X`09End
X`0C`0A
XC---------------------------------------------------------------------------
V--
XC`09Main Subroutine to decompress a Lempel Zev crunched file using
XC`09adaptive reset of string buffer when full - Based on ARC V5.0
XC
XC`09Inputs:
XC`09`09None
XC
XC`09Outputs:
XC`09`09Decompresses a member of an ARC file
XC
XC---------------------------------------------------------------------------
V--
X
X`09Subroutine DeComp_LZW_Var
X
X`09Implicit None
X
X`09Byte`09`09BCode, BFinChar, BTemp
X`09Integer*2`09FinChar, OldCode, InCode, Code, St_Inx, MaxCodeVal
X`09Integer*2`09Temp
X`09Equivalence`09( Temp, BTemp )
X`09Equivalence`09( Code, BCode )
X`09Equivalence`09( FinChar, BFinChar )
X
Xc`09Common and declarations for Lempel-Zev Crunching`20
X
X`09Integer         Max_bits, H_Size, Init_Bits
X`09Integer*2`09First_Entry, Clear_Ind, Eof_Mark
X`09Parameter`09( Max_Bits = 12 )
X`09Parameter`09( Init_Bits = 9 )
X`09Parameter`09( First_Entry = 257 )
X`09Parameter`09( Clear_Ind = 256 )
X`09Parameter  `09( EOF_Mark = -1 )
X`09Parameter`09( H_Size = 5003 )
X
X`09Logical*1`09Clear_Flg
X`09Byte`09`09Suffix(0:H_Size), Stack(0:H_Size)
X`09Byte`09`09R_Mask(0:9), L_Mask(0:9)
X`09Integer*2`09MaxCode, Max_MaxCode, Free_Ent, N_Bits
X`09Integer*2`09Buf(0:Max_Bits), Buf_Inx, Offset, Size
X`09Integer*2`09Prefix(0:H_Size)
X
X`09Common`09/LZWV/`09Clear_Flg, MaxCode, Max_MaxCode, Free_Ent, N_Bits,
X`091`09`09Buf, Buf_Inx, R_Mask, L_Mask, Prefix, Suffix, Stack,
X`091`09`09Offset, Size
X
X`09Data`09R_Mask`09/ '00'x, '01'x, '03'x, '07'x, '0f'x,`20
X`091`09`09  '1f'x, '3f'x, '7f'x, 'ff'x, '00'x /
X
X`09Data`09L_Mask`09/ 'ff'x, 'fe'x, 'fc'x, 'f8'x, 'f0'x,`20
X`091`09`09  'e0'x, 'c0'x, '80'x, '00'x, '00'x /
X
X`09Logical*1`09View_Cr, View_flg, Bin_flg, Extr_flg
X`09Logical*1`09LBR_Flg, Cancel_Op, AST_On_Flg
X`09Integer`09`09Remaining_Size
X`09Integer*2`09CRC_Val
X`09Common`09/Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg,`2
V0
X`091`09`09 LBR_Flg, Cancel_Op, AST_On_Flg, CRC_Val
X
Xc`09Start of code
X
Xc`09Check maximum number of bits used in code
X
X`09Call Get_Char( Code )
X`09If ( Code .ne. Max_Bits ) Then
X`09  Type *, '--- Cannot handle bit count of Crunch ---'
X`09  Return
X`09EndIf
X
X`09N_Bits = Init_Bits
X`09Clear_Flg = .False.
X
X`09CRC_Val = 0`09`09`09`09! Reset some variables
X`09Offset = 0`09`09`09`09!  for the new member
X`09Size = 0
X
X`09MaxCode = MaxcodeVal( N_Bits )
X`09Max_MaxCode = MaxcodeVal( Max_Bits )+1`09! Adjust so full table works
X
Xc`09Initialize the first 256 entries in the table
X
X`09Do Code = 255, 0, -1
X`09  Prefix(Code) = 0
X`09  Suffix(Code) = BCode
X`09EndDo
X
X`09Free_Ent = First_Entry
X
Xc`09First code must be the actual character
X
X`09Call GetCode( OldCode )
X`09FinChar = OldCode
X
X`09If ( OldCode .eq. -1 ) Return
X
X`09Call Put_Char_UnComp( FinChar )
X
X`09St_Inx = 1
X
Xc`09Now loop getting codes unyil all done
X
X`09Call GetCode( Code )
X`09Do While ( ( Code .gt. -1 ) .and. .Not. Cancel_Op )
X
Xc`09Clear the table?
X
X`09  If ( Code .eq. Clear_Ind ) Then
X`09    Do Code = 255, 0, -1
X`09      Prefix(Code) = 0
X`09    EndDo        `20
X`09    Clear_Flg = .True.
X`09    Free_Ent = First_Entry - 1
X`09    Call GetCode( Code )
X`09    If ( Code  .eq. -1 ) Return
X`09  EndIf
X
X`09  InCode = Code
X
Xc`09Special case for KwKwK string
X
X`09  If ( Code .ge. Free_Ent ) Then
X`09    Stack( St_Inx ) = BFinChar
X`09    St_Inx = St_Inx + 1
X`09    Code = OldCode
X`09  EndIf
X
Xc`09Generate output chars in reverse order
X
X`09  Do While ( Code .ge. 256 )
X`09    Stack( St_Inx ) = Suffix( Code )
X`09    St_Inx = St_Inx + 1
X`09    Code = Prefix( Code )
X`09  EndDO
X
X`09  Stack( St_Inx ) = Suffix( Code )
X`09  St_Inx = St_Inx + 1
X`09  FinChar = Suffix( Code )
X
Xc`09Output them in correct order
X
X100`09  Continue
X`09  St_Inx = St_Inx - 1
X`09  Temp = 0
X`09  BTemp = Stack( St_Inx )`20
X`09  Call Put_Char_UnComp( TEMP )
X
X`09  If ( St_Inx .gt. 1 ) GoTo 100
X
XC`09Setup for next code
X
X`09  Code = Free_ent`20
X`09  If ( Code .lt. Max_MaxCode ) Then
X`09    Prefix( Code ) = OldCode
X`09    Suffix( Code ) = BFinChar
X`09    Free_Ent = Code + 1
X`09  EndIf
X
X`09  OldCode = InCode
X
X`09  Call GetCode( Code )
X`09EndDo
X
X`09Return
X`09End
X`0C`0A
XC---------------------------------------------------------------------------
V--
XC`09Integer function used to calculate a maximum value based on the
XC`09number of bits to be used
XC
XC`09Input:
XC`09`09The number of bits to use (I)
XC`09Output:
XC`09`09The maximum (unsigned) value that can be stored in I bits
XC
XC---------------------------------------------------------------------------
V--
X
X`09Integer*2 Function MaxCodeVal( I )
X
X`09Integer*2`09I, J
X
X`09J = 1
X`09MaxCodeVal = ( Ishft( J, I ) - 1 )
X
X`09Return
X`09End
X`0C`0A
XC---------------------------------------------------------------------------
V--
XC`09Subroutine used to calculate a CRC value based on the
XC`09character (byte) passed to it.
XC
XC`09Input:
XC`09`09The current CRC value and the byte to add into it
XC`09Output:
XC`09`09The updated CRC value
XC
XC---------------------------------------------------------------------------
V--
X
X`09Subroutine ARC_CRC( CRCVal, Val )
X
X`09Implicit None
X
X`09Integer*2`09CRCTab(0:255), Temp, I, CRCVal
X
X`09Byte`09Val, IVal
X
X`09Equivalence`09( I, IVal )
X
X`09Data`09CRCTab`09/
X`091`09'0000'x, 'C0C1'x, 'C181'x, '0140'x,`20
X`091`09'C301'x, '03C0'x, '0280'x, 'C241'x,
X`091`09'C601'x, '06C0'x, '0780'x, 'C741'x,`20
X`091`09'0500'x, 'C5C1'x, 'C481'x, '0440'x,
X`091`09'CC01'x, '0CC0'x, '0D80'x, 'CD41'x,`20
X`091`09'0F00'x, 'CFC1'x, 'CE81'x, '0E40'x,
X`091`09'0A00'x, 'CAC1'x, 'CB81'x, '0B40'x,`20
X`091`09'C901'x, '09C0'x, '0880'x, 'C841'x,
X`091`09'D801'x, '18C0'x, '1980'x, 'D941'x,`20
X`091`09'1B00'x, 'DBC1'x, 'DA81'x, '1A40'x,
X`091`09'1E00'x, 'DEC1'x, 'DF81'x, '1F40'x,`20
X`091`09'DD01'x, '1DC0'x, '1C80'x, 'DC41'x,
X`091`09'1400'x, 'D4C1'x, 'D581'x, '1540'x,`20
X`091`09'D701'x, '17C0'x, '1680'x, 'D641'x,
X`091`09'D201'x, '12C0'x, '1380'x, 'D341'x,`20
X`091`09'1100'x, 'D1C1'x, 'D081'x, '1040'x,
X`091`09'F001'x, '30C0'x, '3180'x, 'F141'x,`20
X`091`09'3300'x, 'F3C1'x, 'F281'x, '3240'x,
X`091`09'3600'x, 'F6C1'x, 'F781'x, '3740'x,`20
X`091`09'F501'x, '35C0'x, '3480'x, 'F441'x,
X`091`09'3C00'x, 'FCC1'x, 'FD81'x, '3D40'x,`20
X`091`09'FF01'x, '3FC0'x, '3E80'x, 'FE41'x,
X`091`09'FA01'x, '3AC0'x, '3B80'x, 'FB41'x,`20
X`091`09'3900'x, 'F9C1'x, 'F881'x, '3840'x,
X`091`09'2800'x, 'E8C1'x, 'E981'x, '2940'x,`20
X`091`09'EB01'x, '2BC0'x, '2A80'x, 'EA41'x,
X`091`09'EE01'x, '2EC0'x, '2F80'x, 'EF41'x,`20
X`091`09'2D00'x, 'EDC1'x, 'EC81'x, '2C40'x,
X`091`09'E401'x, '24C0'x, '2580'x, 'E541'x,`20
X`091`09'2700'x, 'E7C1'x, 'E681'x, '2640'x,
X`091`09'2200'x, 'E2C1'x, 'E381'x, '2340'x,`20
X`091`09'E101'x, '21C0'x, '2080'x, 'E041'x,
X`091`09'A001'x, '60C0'x, '6180'x, 'A141'x,`20
X`091`09'6300'x, 'A3C1'x, 'A281'x, '6240'x,
X`091`09'6600'x, 'A6C1'x, 'A781'x, '6740'x,`20
X`091`09'A501'x, '65C0'x, '6480'x, 'A441'x,
X`091`09'6C00'x, 'ACC1'x, 'AD81'x, '6D40'x,`20
X`091`09'AF01'x, '6FC0'x, '6E80'x, 'AE41'x,
X`091`09'AA01'x, '6AC0'x, '6B80'x, 'AB41'x,`20
X`091`09'6900'x, 'A9C1'x, 'A881'x, '6840'x,
X`091`09'7800'x, 'B8C1'x, 'B981'x, '7940'x,`20
X`091`09'BB01'x, '7BC0'x, '7A80'x, 'BA41'x,
X`091`09'BE01'x, '7EC0'x, '7F80'x, 'BF41'x,`20
X`091`09'7D00'x, 'BDC1'x, 'BC81'x, '7C40'x,
X`091`09'B401'x, '74C0'x, '7580'x, 'B541'x,`20
X`091`09'7700'x, 'B7C1'x, 'B681'x, '7640'x,
X`091`09'7200'x, 'B2C1'x, 'B381'x, '7340'x,`20
X`091`09'B101'x, '71C0'x, '7080'x, 'B041'x,
X`091`09'5000'x, '90C1'x, '9181'x, '5140'x,`20
X`091`09'9301'x, '53C0'x, '5280'x, '9241'x,
X`091`09'9601'x, '56C0'x, '5780'x, '9741'x,`20
X`091`09'5500'x, '95C1'x, '9481'x, '5440'x,
X`091`09'9C01'x, '5CC0'x, '5D80'x, '9D41'x,`20
X`091`09'5F00'x, '9FC1'x, '9E81'x, '5E40'x,
X`091`09'5A00'x, '9AC1'x, '9B81'x, '5B40'x,`20
X`091`09'9901'x, '59C0'x, '5880'x, '9841'x,
X`091`09'8801'x, '48C0'x, '4980'x, '8941'x,`20
X`091`09'4B00'x, '8BC1'x, '8A81'x, '4A40'x,
X`091`09'4E00'x, '8EC1'x, '8F81'x, '4F40'x,`20
X`091`09'8D01'x, '4DC0'x, '4C80'x, '8C41'x,
X`091`09'4400'x, '84C1'x, '8581'x, '4540'x,`20
X`091`09'8701'x, '47C0'x, '4680'x, '8641'x,
X`091`09'8201'x, '42C0'x, '4380'x, '8341'x,`20
X`091`09'4100'x, '81C1'x, '8081'x, '4040'x
X`091`09/
X
X`09I = 0
X`09IVal = Val
X
X`09Temp = Ishft( CRCVal, -8 ) .and. '00ff'x
X`09Temp = Temp .xor. CRCTab( ( (CRCVal .Xor. I) .and. '00ff'x ) )
X`09CRCVal = Temp
X
X`09Return
X`09End
X`0C`0A
XC---------------------------------------------------------------------------
V---
XC`09Subroutine used to calculate the CRC for .LBR files
XC
XC`09Input:
XC`09`09Current CRC value
XC`09`09New byte to include`20
XC
XC`09Output:
XC`09`09Updated CRC value
XC
XC---------------------------------------------------------------------------
V---
X
X`09Subroutine LBR_CRC( CRCVal, Val )
X
X`09Implicit None
X
X`09Byte`09`09Val, V
X
X`09Integer*2`09CRCVal, Temp, I, BitC, BitH, Mask_Bit, Poly
X
X`09Data`09`09Mask_Bit /15/, Poly /'1021'x/
X
X`09Integer*4`09Long, K
X
X`09Equivalence`09( Long, Temp )
X`09Equivalence`09( I, V )
X
X`09I = 0
X`09V = Val
X
X`09Do K = 1, 8
X`09Bitc = IBits( I, 7, 1 )
X`09BitH = IBits( CrcVal, Mask_Bit, 1 )
X`09Temp = Ishft( I, 1 )`20
X`09I = Temp .and. 'FF'x
X
X`09Long = 0
X`09Temp = Ishft( CrcVal, 1 ) + BitC
X
X`09If ( BitH .eq. 1 ) Then
X`09Temp = Temp .Xor. Poly
X`09EndIf
X
X`09CrcVal = Temp
X`09EndDo
X
X`09Return
X`09End
X`00`00`00
$ CALL UNPACK [.UTILITY]VMSARC.FOR;2 50478767
$ v=f$verify(v)
$ EXIT