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 C Functions provided: C View a member at the terminal - Crunched, squeezed or normal C Extract a member to a file (Max 510 byte records) (expanded) C Raw Extract a member to a file 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 The Crunch code that supports CRUNCH V2.x was translated from Frank C Prindle's UNCR231.C source. C C----------------------------------------------------------------------------- C----------------------------------------------------------------------------- C Modification History: C C Vers Date Who Comments C C V3.0 30 Jan 87 John Coburn Support Crunch2.x members C for LBR files. Many thanks C to Frank Prindle for UNCR231 C sources. C Change default command to ? C Add Version and VersDate vars C Add function to extract a member C without expansion. ARC members C will create a single entry ARC C file, LBR members will create C standalone files. C Also, fixed bug with CtrlC code C Glenn Everharts Add 8 bit only mode that will C not strip bit 7 on text files C C V2.8 24 Dec 86 Walt Lamia Extend EXTRACT and VIEW C functions to process all C members of a library C C Strip 8th bit off of member C file names so they are legal 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 '/ Character Version*5 /'V3.1'/ Character VersDate*11 /'31 Jan 1987'/ Byte ArcMark, FBuf(128) Integer*2 LBR_Recognize, Cr_Recognize Integer Max_Num_Members Parameter ( ArcMark = 26 ) Parameter ( LBR_recognize = 'FF76'x ) Parameter ( Cr_recognize = 'FE76'x ) Parameter ( Max_Num_Members = 200 ) 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 Orig_NAMES(Max_Num_Members)*12 Character Member_NAMES(Max_Num_Members)*12 Character Mem_Date(Max_Num_Members)*8 Character Mem_Time(Max_Num_Members)*8 Integer Start_Mem_Arr(Max_Num_Members) 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 Temp, Start_Pos 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 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, Raw_Flg Logical*1 LBR_Flg, Cancel_Op, AST_On_Flg, Eight_Flg Integer Remaining_Size Integer*2 CRC_Val Common /Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Raw_Flg, Cancel_Op, AST_On_Flg, CRC_Val, 1 Eight_Flg Integer*2 I2 Integer Q, I, J, K, M, N, DIR_SECTS, ISTAT, Ios, Force INTEGER N1,N2,NN Logical*1 Crunched, Squeezed, File_OK Byte Tbytes(13), C, HDR_Ver, Info, Sig, ErrD Character BitStr*11, ImageStr*9 C Start of Code Type *, ' ' Type *, 'V M S S w e e p ' // Version Type *, 'for .LBR and .ARC files' Type *, ' ' Force = 0 10 Continue Last_In = 0 First_In = 0 Out_Index = 1 In_FILE_NAME = ' ' View_Cr = .False. Eight_Flg = .False. Call Lib$Get_Foreign( In_File_Name, 'Enter "library": ', Q, Force ) c Type 1020,'$Enter "library": ' c Accept 1021, Q, In_FILE_NAME(1:Q) If ( Q .eq. 0 ) GoTo 800 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 Orig_Names(N) = Member_NAMES(N) Temp = NSECTS Num_Bytes_ARR(N) = Temp * 128 Act_Len(N) = Num_Bytes_ARR(N) Temp = Indx Start_Mem_arr(N) = Temp * 128 + 1 First_Byte_arr(N) = Start_Mem_arr(N) 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 or crunched 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 ) .or. ( I2 .eq. Cr_Recognize )) Then If ( I2 .eq. LBR_recognize ) Then Hdr_Vers(I) = 4 ! Squeezed Call Get_Byte_Knt( I2, 2 ) ! Get past the CRC Else Hdr_Vers(I) = 8 ! Crunched EndIf Act_Len(I) = 0 ! Unknown actual size File_Name = ' ' K = 1 Call Get_Byte( C ) ! Get the member orig name Do While ( C .ne. 0 ) File_Name(K:K) = Char( C .and. '7F'x ) Call Get_Byte( C ) K = K + 1 EndDo If ( I2 .eq. Cr_Recognize ) Then K = Index( File_Name, '.' ) + 4 File_Name(K:) = ' ' Call Get_Byte( Info ) ! Now read the 4 info bytes Call Get_Byte( Sig ) ! to determnine if we support Call Get_Byte( ErrD ) ! this version of crunch Call Get_Byte( C ) ! (Spare byte) If ( Sig .lt. '20'x .or. Sig .gt. '2f'x ) Hdr_Vers(I) = 7 EndIf 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 ) Do While ( C .ne. -1 ) Start_Pos = Buf_Index + First_In - 2 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 +++' 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 If ( N .eq. max_num_members ) goto 100 N = N + 1 Start_Mem_Arr(N) = Start_Pos 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 Orig_Names(N) = Member_Names(N) 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 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 [?]: ' Accept 1020, ANS If ( ANS .eq. ' ' ) Goto 230 If ( ANS .eq. '?' ) Goto 230 If ( ANS .eq. 'x' .or. ANS .eq. 'X' ) Goto 800 View_flg = .False. Extr_flg = .False. Bin_flg = .False. Ivcr = 0 If ( ANS .eq. 'l' .or. ANS .eq. 'L' ) GoTo 150 If ( ANS .eq. 'n' .or. ANS .eq. 'N' ) GoTo 700 c Allow K and I modes to set carriage control for terminal c output... If ( ANS .eq. 'i' .or. ANS .eq. 'I' ) Then View_Cr = .False. Goto 200 EndIf If ( ANS .eq. 'k' .or. ANS .eq. 'K' ) Then View_Cr = .True. Goto 200 EndIf If ( ANS .eq. 'a' .or. ANS .eq. 'A' ) Then Eight_flg = .False. Goto 200 EndIf If ( ANS .eq. '8' ) Then Eight_flg = .True. Goto 200 EndIf 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. 'r' .or. ANS .eq. 'R' ) Raw_flg = .True. If ( Raw_flg .or. View_flg .or. Extr_flg ) GoTo 250 210 Type *, '-- Illegal Command --' 230 Continue Type 1020, ' ' Type 1020, ' VMSSweep ' // Version // ' [' // VersDate // ']' BitStr = 'Auto 7 or 8' If ( Eight_Flg ) BitStr = 'Eight Bit' ImageStr = 'Image' If ( View_Cr ) ImageStr = 'Single CR' Type 1020, ' Modes active - ' // BitStr // ', ' // ImageStr Type 1020, ' ' Type 1020, ' Commands available:' Type 1020, ' ' Type 1020, ' A - Automatically determine 7 or 8 bit mode' Type 1020, ' 8 - Eight bit only mode' 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, ' R - Raw extract of a member (no expansion)' Type 1020, ' X - No option wanted (exit)' Type 1020, ' ? - Display this list' GoTo 200 250 Continue Type 1400 Accept 1410, N If ( N .le. 0 ) 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 ( Raw_Flg ) GoTo 400 If ( .Not. LBR_Flg ) GoTo 500 C Now handle selection from .LBR file 300 Continue DO N = N1, N2 If ( Hdr_Vers(N) .eq. 7 ) Then Type *, '--- Unsuported Crunch algorithm ---' Goto 200 EndIf Call Position_Lib( First_Byte_Arr(N) ) Remaining_Size = Num_Bytes_Arr(N) CRC_Val = 0 Squeezed = .False. Crunched = .False. If ( Hdr_Vers(N) .eq. 4 ) Then Squeezed = .True. Call LBR_Init_UnSq ! Init the decode tree EndIf If ( Hdr_Vers(N) .eq. 8 ) Then Crunched = .True. Call LBR_Init_Crun ! Init stuff EndIf Call Open_Ext_File( Member_Names(N) ) If ( .not. ( Squeezed .or. Crunched )) Then Call Get_Char( I2 ) Do While (( I2 .ne. -1 ) .and. .Not. Cancel_op ) Call Put_Char_CRC( I2 ) Call Get_Char( I2 ) EnDDo Else 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 EndIf If ( Crunched ) Then Call LBR_Crunch EndIf EndIf If ((Remaining_Size.gt.0) .and. .Not. Cancel_Op ) Then Call Get_Char_Knt( FBuf, Remaining_Size) ! Finish CRC EndIf Call Close_Ext_File( CRCS(N) ) ENDDO GoTo 200 C Code to extract in Raw format 400 Continue Extr_FLg = .True. Do N = N1, N2 Call Position_Lib( Start_Mem_Arr(N) ) Remaining_Size = Num_Bytes_Arr(N) File_Name = Orig_Names(N) If ( .Not. LBR_Flg ) Then ! An ARC file K = Index( File_Name, '.' ) ! Set the output name If ( K .eq. 0 ) K = 9 File_Name(K:) = '.ARC' Remaining_Size = Remaining_Size + 29 ! Count the header EndIf Call Open_Ext_File( File_Name ) Call Get_Char( I2 ) Do While (( I2 .ne. -1 ) .and. .Not. Cancel_op ) Call Put_Char_CRC( I2 ) Call Get_Char( I2 ) EnDDo If ( .Not. LBR_Flg ) Then ! An ARC file Call Put_Char_Crc( '1a'x ) ! so mark the end Call Put_Char_Crc( 0 ) ! of the archive EndIf Call Close_Ext_File( 0 ) ! No CRC checking 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) ) 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 *, '--- Older Crunch versions not supported ---' GoTo 200 595 Continue Call Close_Ext_File( CRCS(N) ) 596 Continue 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, BinNames*200 Integer K, I, IOS, Record_Length Logical*1 View_Cr, View_flg, Bin_flg, Extr_flg, Raw_Flg Logical*1 LBR_Flg, Cancel_Op, AST_On_Flg, Eight_Flg Integer Remaining_Size Integer*2 CRC_Val Common /Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Raw_Flg, Cancel_Op, AST_On_Flg, CRC_Val, 1 Eight_Flg 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 BinNames = ' LBR ARK ARC COM EXE REL CMD COM OVR BIN' Out_Num = 0 Bin_Flg = .True. K = Index( File_Name, '.' ) If ( K. eq. 0 )Then Type *, 'Is ', File_Name, ' a text file? ' Accept 1100, Ans If ( Ans .eq. 'y' .or. Ans .eq. 'Y' ) Bin_Flg = .False. Else File_Ext = File_Name(K+1:K+3) Do K = 1, 3 ! Upcase the extension If ( File_Ext(K:K) .ge. 'a' .and. 1 File_Ext(K:K) .le. 'z' ) Then File_Ext(K:K) = Char( Ichar( File_Ext(K:K) ) - '40'o ) EndIf EndDo K = Index( BinNames, File_Ext ) Bin_Flg = .False. If ( K .ne. 0 ) Bin_Flg = .True. EndIf If ( Raw_Flg ) Bin_Flg = .True. If ( .Not. ( Eight_Flg .or. Bin_Flg )) Then Type *, '++ Member being treated as 7 bit data ++' Else Type *, '++ Member being treated as 8 bit data ++' 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 = 510 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, Raw_Flg Logical*1 LBR_Flg, Cancel_Op, AST_On_Flg, Eight_Flg Integer Remaining_Size Integer*2 CRC_Val Common /Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Raw_Flg, Cancel_Op, AST_On_Flg, CRC_Val, 1 Eight_Flg 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_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 2000,' --- Warning --- CRC Error ---' 2000 Format( A ) Type 2001, Mem_CRC, KeepCRC, Crc_Val 2001 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 Type 1000, Out_Num EndIf Return 1000 Format( //' --> ', I7, ' bytes 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, Raw_Flg Logical*1 LBR_Flg, Cancel_Op, AST_On_Flg, Eight_Flg Integer Remaining_Size Integer*2 CRC_Val Common /Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Raw_Flg, Cancel_Op, AST_On_Flg, CRC_Val, 1 Eight_Flg 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 ) 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 Byte Buf(1) Integer Knt, I Integer*2 In Byte C Equivalence ( In, C ) Do I = 1, KNT Call Get_Char( In ) Buf( I ) = C 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/ Bpos, DNode 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, Raw_Flg Logical*1 LBR_Flg, Cancel_Op, AST_On_Flg, Eight_Flg Integer Remaining_Size Integer*2 CRC_Val Common /Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Raw_Flg, Cancel_Op, AST_On_Flg, CRC_Val, 1 Eight_Flg 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./ Out_Num = Out_Num+1 ! How many bytes output If ( .Not. Bin_Flg ) Then If ( .not. Eight_Flg ) Then C = C .and. '7F'x If ( C .eq. '1a'x ) 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 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 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 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 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, Raw_Flg Logical*1 LBR_Flg, Cancel_Op, AST_On_Flg, Eight_Flg Integer Remaining_Size Integer*2 CRC_Val Common /Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Raw_Flg, Cancel_Op, AST_On_Flg, CRC_Val, 1 Eight_Flg 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, Raw_Flg Logical*1 LBR_Flg, Cancel_Op, AST_On_Flg, Eight_Flg Integer Remaining_Size Integer*2 CRC_Val Common /Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Raw_Flg, Cancel_Op, AST_On_Flg, CRC_Val, 1 Eight_Flg 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, Raw_Flg Logical*1 LBR_Flg, Cancel_Op, AST_On_Flg, Eight_Flg Integer Remaining_Size Integer*2 CRC_Val Common /Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Raw_Flg, Cancel_Op, AST_On_Flg, CRC_Val, 1 Eight_Flg Integer*2 DNode(0:255,0:1), BPos Common /UnSq/ Bpos, DNode 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 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 ) 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)' External Cancel_AST IOS = Sys$Assign( 'Sys$Input', 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, Raw_Flg Logical*1 LBR_Flg, Cancel_Op, AST_On_Flg, Eight_Flg Integer Remaining_Size Integer*2 CRC_Val Common /Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Raw_Flg, Cancel_Op, AST_On_Flg, CRC_Val, 1 Eight_Flg 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, Raw_Flg Logical*1 LBR_Flg, Cancel_Op, AST_On_Flg, Eight_Flg Integer Remaining_Size Integer*2 CRC_Val Common /Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Raw_Flg, Cancel_Op, AST_On_Flg, CRC_Val, 1 Eight_Flg 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 C--------------------------------------------------------------------------- C Subroutine to handle the uncrunching (V2.0 only) of a LBR member C C Input: C LBR_Crun COMMON C C Output: C COMMON variables initialized C C------------------------------------------------------------------------------ Subroutine LBR_Crunch Implicit None C Parameters used by the UnCrunch routines Integer*2 NoPred, Empty, Referenced, Impossible Parameter ( NoPred = '6fff'x ) Parameter ( Empty = '8000'x ) Parameter ( Referenced = '2000'x ) Parameter ( Impossible = '7fff'x ) Integer*2 EOF_Code, Reset_Code, Null_Code, Spare_Code Parameter ( Eof_Code = '100'x ) Parameter ( Reset_Code = '101'x ) Parameter ( Null_Code = '102'x ) Parameter ( Spare_Code = '103'x ) Integer*4 Tab_Size, XTab_Size Parameter ( Tab_Size = 4096, XTab_Size = 5003 ) C Common and variables used by the UnCrunch routines Byte Suffix(0:Tab_Size), CodeLen Byte FullFlg, EntFlg Integer*2 Predecessor(0:Tab_Size), XLate(0:XTab_Size) Integer*2 TargMask, Entry, GetBit, FinChar, LastPred Integer*4 GetBuf, ChkSum Common /LBR_Crun/ Suffix, Predecessor, Xlate, CodeLen, 1 FullFlg, EntFlg, TargMask, Entry, GetBit, FinChar, 2 LastPred, GetBuf, ChkSum Logical*1 View_Cr, View_flg, Bin_flg, Extr_flg, Raw_Flg Logical*1 LBR_Flg, Cancel_Op, AST_On_Flg, Eight_Flg Integer Remaining_Size Integer*2 CRC_Val Common /Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Raw_Flg, Cancel_Op, AST_On_Flg, CRC_Val, 1 Eight_Flg C Local variables Byte Flag Integer*2 Pred, C C Start of Code Pred = NoPred Call GetCode_Crun( C ) Do While (( C .ne. EOF_Code ) .and. ( .Not. Cancel_Op )) LastPred = Pred Pred = C If ( C .eq. Reset_Code ) Then Pred = NoPred Call Init_Var_Crun Call Init_Tab_Crun Goto 100 EndIf If ( C .eq. Null_Code ) Goto 100 ! Ignore null and spare If ( C .eq. Spare_Code ) Goto 100 If ( FullFlg .ne. 2 ) Then ! Table not full. Call Decode_Crun( Pred, Flag ) If ( Flag .eq. 0 ) Then Call EnterX( LastPred, FinChar ) Else EntFlg = 0 EndIf Else ! Table full! Call Decode_Crun( Pred, Flag ) Call EntFil( LastPred, FinChar ) EndIf 100 Continue Call GetCode_Crun( C ) EndDo C All done - Check checksum if wanted Return End C--------------------------------------------------------------------------- C Subroutine to Position input byte stream and to initialize the C data tables and other Common variables C C Input: C LBR_Crun COMMON C C Output: C COMMON variables initialized C C------------------------------------------------------------------------------ Subroutine LBR_Init_Crun Implicit None C Parameters used by the UnCrunch routines Integer*4 Tab_Size, XTab_Size Parameter ( Tab_Size = 4096, XTab_Size = 5003 ) C Common and variables used by the UnCrunch routines Byte Suffix(0:Tab_Size), CodeLen Byte FullFlg, EntFlg Integer*2 Predecessor(0:Tab_Size), XLate(0:XTab_Size) Integer*2 TargMask, Entry, GetBit, FinChar, LastPred Integer*4 GetBuf, ChkSum Common /LBR_Crun/ Suffix, Predecessor, Xlate, CodeLen, 1 FullFlg, EntFlg, TargMask, Entry, GetBit, FinChar, 2 LastPred, GetBuf, ChkSum C Local Variables Integer*4 I Integer*2 I2 Byte C C Start Code C Position input to start of crunched code Call Get_Char_Knt( I2, 2 ) ! Skip recognizer Call Get_Char( C ) Do While( C .ne. 0 ) Call Get_Char( C ) ! Skip filename EndDo Call Get_Char_Knt( I, 4 ) ! Skip ID bytes C Initialize the data structures to uncrunch ChkSum = 0 GetBit = 0 ! In buffer empty Call Init_Var_Crun Call Init_Tab_Crun Return End C--------------------------------------------------------------------------- C Subroutine to initialize COMMON Variables C C Input: C LBR_Crun COMMON C C Output: C COMMON variables initialized C C------------------------------------------------------------------------------ Subroutine Init_Var_Crun Implicit None C Parameters used by the UnCrunch routines Integer*4 Tab_Size, XTab_Size Parameter ( Tab_Size = 4096, XTab_Size = 5003 ) C Common and variables used by the UnCrunch routines Byte Suffix(0:Tab_Size), CodeLen Byte FullFlg, EntFlg Integer*2 Predecessor(0:Tab_Size), XLate(0:XTab_Size) Integer*2 TargMask, Entry, GetBit, FinChar, LastPred Integer*4 GetBuf, ChkSum Common /LBR_Crun/ Suffix, Predecessor, Xlate, CodeLen, 1 FullFlg, EntFlg, TargMask, Entry, GetBit, FinChar, 2 LastPred, GetBuf, ChkSum C Start Code TargMask = '1ff'x ! Start at 9 bits CodeLen = 9 FullFlg = 0 ! Table empty Entry = 0 EntFlg = 1 ! First code always atomic Return End C--------------------------------------------------------------------------- C Subroutine to initialize COMMON Variables C C Input: C LBR_Crun COMMON C C Output: C COMMON variables initialized C C------------------------------------------------------------------------------ Subroutine Init_Tab_Crun Implicit None C Parameters used by the UnCrunch routines Integer*2 NoPred, Empty, Referenced, Impossible Parameter ( NoPred = '6fff'x ) Parameter ( Empty = '8000'x ) Parameter ( Referenced = '2000'x ) Parameter ( Impossible = '7fff'x ) Integer*2 EOF_Code, Reset_Code, Null_Code, Spare_Code Parameter ( Eof_Code = '100'x ) Parameter ( Reset_Code = '101'x ) Parameter ( Null_Code = '102'x ) Parameter ( Spare_Code = '103'x ) Integer*4 Tab_Size, XTab_Size Parameter ( Tab_Size = 4096, XTab_Size = 5003 ) C Common and variables used by the UnCrunch routines Byte Suffix(0:Tab_Size), CodeLen Byte FullFlg, EntFlg Integer*2 Predecessor(0:Tab_Size), XLate(0:XTab_Size) Integer*2 TargMask, Entry, GetBit, FinChar, LastPred Integer*4 GetBuf, ChkSum Common /LBR_Crun/ Suffix, Predecessor, Xlate, CodeLen, 1 FullFlg, EntFlg, TargMask, Entry, GetBit, FinChar, 2 LastPred, GetBuf, ChkSum C Local variables Integer*2 I C Start Code Do I = 0, XTab_Size ! Show XTab as empty XLate(I) = Empty EndDo Do I = 0, 255 ! First 256 atomic codes Call EnterX( NoPred, I ) EndDo Do I = 0, 3 ! Reserved codes Call EnterX( Impossible, 0 ) EndDo Return End C--------------------------------------------------------------------------- C Subroutine to enter the next code into the tables C C Input: C Pred - Predecessor code C Suff - Suffix code C LBR_Crun COMMON C C Output: C C------------------------------------------------------------------------------ Subroutine EnterX( Pred, Suff ) Implicit None C Parameters used by the UnCrunch routines Integer*4 Tab_Size, XTab_Size Parameter ( Tab_Size = 4096, XTab_Size = 5003 ) C Common and variables used by the UnCrunch routines Byte Suffix(0:Tab_Size), CodeLen Byte FullFlg, EntFlg Integer*2 Predecessor(0:Tab_Size), XLate(0:XTab_Size) Integer*2 TargMask, Entry, GetBit, FinChar, LastPred Integer*4 GetBuf, ChkSum Common /LBR_Crun/ Suffix, Predecessor, Xlate, CodeLen, 1 FullFlg, EntFlg, TargMask, Entry, GetBit, FinChar, 2 LastPred, GetBuf, ChkSum C Local variables Byte S Integer*2 Pred, Suff, Save, BSuff, I Equivalence ( BSuff, S ) C Start Code Save = Entry Call Figure( Pred, Suff ) Predecessor(Save) = Pred BSuff = Suff Suffix(Save) = S Entry = Entry + 1 If ( Entry .ge. TargMask ) Then If ( CodeLen .lt. 12 ) Then CodeLen = CodeLen + 1 TargMAsk = Ishft( TargMask, 1 ) .or. 1 Else FullFlg = FullFlg + 1 EndIf EndIf Return End C--------------------------------------------------------------------------- C Subroutine to find an empty entry in XLate that hashes from the C Pred/Suff pair and store the index of the next avail. table entry C in it C C Input: C Pred - Predecessor code C Suff - Suffix code C LBR_Crun COMMON C C Output: C C------------------------------------------------------------------------------ Subroutine Figure( Pred, Suff ) Implicit None C Parameters used by the UnCrunch routines Integer*2 NoPred, Empty, Referenced, Impossible Parameter ( NoPred = '6fff'x ) Parameter ( Empty = '8000'x ) Parameter ( Referenced = '2000'x ) Parameter ( Impossible = '7fff'x ) Integer*4 Tab_Size, XTab_Size Parameter ( Tab_Size = 4096, XTab_Size = 5003 ) C Common and variables used by the UnCrunch routines Byte Suffix(0:Tab_Size), CodeLen Byte FullFlg, EntFlg Integer*2 Predecessor(0:Tab_Size), XLate(0:XTab_Size) Integer*2 TargMask, Entry, GetBit, FinChar, LastPred Integer*4 GetBuf, ChkSum Common /LBR_Crun/ Suffix, Predecessor, Xlate, CodeLen, 1 FullFlg, EntFlg, TargMask, Entry, GetBit, FinChar, 2 LastPred, GetBuf, ChkSum C Local variables Integer*2 Pred, Suff, Save, Hash, Inx, Disp C Start Code Inx = Hash( Pred, Suff, Disp ) Do While( (XLate(Inx) .and. 'ffff'x) .ne. Empty ) Inx = Inx + Disp If ( Inx .lt. 0 ) Inx = Inx + XTab_Size EndDo Xlate(Inx) = Entry Return End C--------------------------------------------------------------------------- C Integer Function to get the hash value using Crunch 2.x algorithm C C Input: C Pred - Predecessor code C Suff - Suffix code C Disp - C LBR_Crun COMMON C C Output: C C------------------------------------------------------------------------------ Integer*2 Function Hash( Pred, Suff, Disp ) Implicit None C Parameters used by the UnCrunch routines Integer*4 Tab_Size, XTab_Size Parameter ( Tab_Size = 4096, XTab_Size = 5003 ) C Local variables Integer*2 Pred, Suff, Save, HashVal, Disp C Start Code HashVal = Ishft( Pred, -4) .xor. Suff HashVal = HashVal .or. Ishft( (Pred.and.'f'x), 8 ) HashVal = ( HashVal + 1 ) Disp = HashVal - XTab_Size Hash = HashVal Return End C--------------------------------------------------------------------------- C Subroutine to get a code from the input stream (get codeLen bits) C C Input: C LBR_Crun COMMON C C Output: C C------------------------------------------------------------------------------ Subroutine GetCode_Crun( Code ) Implicit None C Parameters used by the UnCrunch routines Integer*2 EOF_Code, Reset_Code, Null_Code, Spare_Code Parameter ( Eof_Code = '100'x ) Parameter ( Reset_Code = '101'x ) Parameter ( Null_Code = '102'x ) Parameter ( Spare_Code = '103'x ) Integer*4 Tab_Size, XTab_Size Parameter ( Tab_Size = 4096, XTab_Size = 5003 ) C Common and variables used by the UnCrunch routines Byte Suffix(0:Tab_Size), CodeLen Byte FullFlg, EntFlg Integer*2 Predecessor(0:Tab_Size), XLate(0:XTab_Size) Integer*2 TargMask, Entry, GetBit, FinChar, LastPred Integer*4 GetBuf, ChkSum Common /LBR_Crun/ Suffix, Predecessor, Xlate, CodeLen, 1 FullFlg, EntFlg, TargMask, Entry, GetBit, FinChar, 2 LastPred, GetBuf, ChkSum C Local variables Integer*2 Code, I Integer*4 Shifter, Hole, J Character Str*12 Equivalence ( Shifter, I ) C Start Code J = CodeLen Shifter = 0 Hole = CodeLen - GetBit Call Get_Char( I ) If ( I .eq. -1 ) Goto 200 Shifter = Ishft( Shifter, Hole ) GetBuf = Ishft( GetBuf, J ) .or. Shifter GetBit = 8 - Hole C See if we got enough bits to supply a code If ( GetBit .lt. 0 ) Then Shifter = 0 Call Get_Char( I ) If ( I .eq. -1 ) Goto 200 GetBuf = GetBuf .or. Ishft( Shifter, (Hole-8) ) GetBit = GetBit + 8 EndIf Code = Ishft( GetBuf, -8 ) .and. TargMask ! Return the code Return 200 Continue Code = EOF_Code Return End C--------------------------------------------------------------------------- C Subroutine to decode a Crunched code C C Input: C LBR_Crun COMMON C C Output: C C------------------------------------------------------------------------------ Subroutine DeCode_Crun( InCode, Flag ) Implicit None C Parameters used by the UnCrunch routines Integer*2 NoPred, Empty, Referenced, Impossible Parameter ( NoPred = '6fff'x ) Parameter ( Empty = '8000'x ) Parameter ( Referenced = '2000'x ) Parameter ( Impossible = '7fff'x ) Integer*2 EOF_Code, Reset_Code, Null_Code, Spare_Code Parameter ( Eof_Code = '100'x ) Parameter ( Reset_Code = '101'x ) Parameter ( Null_Code = '102'x ) Parameter ( Spare_Code = '103'x ) Integer*4 Tab_Size, XTab_Size Parameter ( Tab_Size = 4096, XTab_Size = 5003 ) C Common and variables used by the UnCrunch routines Byte Suffix(0:Tab_Size), CodeLen Byte FullFlg, EntFlg Integer*2 Predecessor(0:Tab_Size), XLate(0:XTab_Size) Integer*2 TargMask, Entry, GetBit, FinChar, LastPred Integer*4 GetBuf, ChkSum Common /LBR_Crun/ Suffix, Predecessor, Xlate, CodeLen, 1 FullFlg, EntFlg, TargMask, Entry, GetBit, FinChar, 2 LastPred, GetBuf, ChkSum C Local variables Byte Flag, S Integer*2 Stack(0:Tab_Size), InCode, I, StInx, S2, Code Character Str*9 Equivalence ( S2, S ) C Start Code Code = InCode If ( Code .ge. Entry ) Then ! The 'UwUwU' exception EntFlg = 1 Call EnterX( LastPred, FinChar ) EndIf Predecessor( Code ) = Predecessor( Code ) .or. Referenced StInx = 0 Do While( Code .gt. 255 ) ! Not atomic StInx = StInx + 1 S2 = 0 S = Suffix( Code ) .and. 'ff'x Stack( StInx ) = S2 Code = Predecessor( Code ) .and. 'fff'x EndDo C Now lets output all bytes for this code S2 = 0 S = Suffix( Code ) .and. 'ff'x ! First char of string FinChar = S2 Call Put_Char_UnComp( FinChar ) Do While ( StInx .gt. 0 ) Call Put_Char_UnComp( Stack(StInx) ) StInx = StInx - 1 EndDo Flag = EntFlg Return End C--------------------------------------------------------------------------- C Subroutine to attempt to reassignm an existing code C C Input: C LBR_Crun COMMON C C Output: C COMMON variables initialized C C------------------------------------------------------------------------------ Subroutine EntFil( Pred, Suff ) Implicit None C Parameters used by the UnCrunch routines Integer*2 NoPred, Empty, Referenced, Impossible Parameter ( NoPred = '6fff'x ) Parameter ( Empty = '8000'x ) Parameter ( Referenced = '2000'x ) Parameter ( Impossible = '7fff'x ) Integer*2 EOF_Code, Reset_Code, Null_Code, Spare_Code Parameter ( Eof_Code = '100'x ) Parameter ( Reset_Code = '101'x ) Parameter ( Null_Code = '102'x ) Parameter ( Spare_Code = '103'x ) Integer*4 Tab_Size, XTab_Size Parameter ( Tab_Size = 4096, XTab_Size = 5003 ) C Common and variables used by the UnCrunch routines Byte Suffix(0:Tab_Size), CodeLen Byte FullFlg, EntFlg Integer*2 Predecessor(0:Tab_Size), XLate(0:XTab_Size) Integer*2 TargMask, Entry, GetBit, FinChar, LastPred Integer*4 GetBuf, ChkSum Common /LBR_Crun/ Suffix, Predecessor, Xlate, CodeLen, 1 FullFlg, EntFlg, TargMask, Entry, GetBit, FinChar, 2 LastPred, GetBuf, ChkSum C Local variables Byte S Integer*2 Pred, Suff, Inx, Tab, Disp, Hash, BSuff Equivalence ( BSuff, S ) C Start of Code Inx = Hash( Pred, Suff, Disp ) Do While( Xlate(Inx) .ne. Empty ) Tab = Xlate( Inx ) If (( Predecessor(Tab) .and. Referenced ) .eq. 0 ) Then Predecessor(Tab) = Pred BSuff = Suff Suffix(Tab) = S Goto 100 EndIf Inx = Inx + Disp If ( Inx .lt. 0 ) Inx = Inx + XTab_Size EndDo 100 Return End