C----------------------------------------------------------------------------- C Program used to provide LSWEEP and some ARC functionality on VMS C C VMSsweep will handle .LBR and .ARC files and can be used to extract C members or just display them on the terminal (No check is done to see C that they are text files). C C Restrictions: C The VMS file must have a maximum record length of 4096 bytes. C The library file (.ARC or .LBR) can only have 200 members C C Functions provided: C View a member at the terminal -squeezed or unsqueezed C Extract a member to a file (128byte records) C List the directory of the .LBR file C New .LBR file requested C C Author: C John T. Coburn Digital Equipment, Cleveland C Copyright (c) 1986 C C Please feel free to distribute this program by any noncommercial C means to anyone who can use it. C C This program was in general based on the Turbo Pascal program C DEARC that is in the public domain. Author unknown by me. C C----------------------------------------------------------------------------- Program VAX_ARC_LBR Implicit None Character For_IOS(68)*30 Common /ForIOS/ For_IOS ! ! Define FORTRAN error numbers for use with IOSTAT and ERRSNS ! Data For_IOS /68*' '/ Data FOR_IOS ('00000011'X ) /' syntax error in NAMELIST input'/ Data FOR_IOS ('00000012'X ) /' too many values for NAMELIST variable'/ Data FOR_IOS ('00000013'X ) /' invalid reference to variable'/ Data FOR_IOS ('00000014'X ) /' REWIND error '/ Data FOR_IOS ('00000015'X ) /' duplicate file specifications '/ Data FOR_IOS ('00000016'X ) /' input record too long '/ Data FOR_IOS ('00000017'X ) /' BACKSPACE error '/ Data FOR_IOS ('00000018'X ) /' end-of-file during read '/ Data FOR_IOS ('00000019'X ) /' record number outside range '/ Data FOR_IOS ('0000001A'X ) /' OPEN or DEFINE FILE required'/ Data FOR_IOS ('0000001B'X ) /' too many records in I/O statement'/ Data FOR_IOS ('0000001C'X ) /' CLOSE error '/ Data FOR_IOS ('0000001D'X ) /' file not found '/ Data FOR_IOS ('0000001E'X ) /' open failure '/ Data FOR_IOS ('0000001F'X ) /' mixed file access modes '/ Data FOR_IOS ('00000020'X ) /' invalid logical unit number '/ Data FOR_IOS ('00000021'X ) /' ENDFILE error '/ Data FOR_IOS ('00000022'X ) /' unit already open '/ Data FOR_IOS ('00000023'X ) /' segmented record format error '/ Data FOR_IOS ('00000024'X ) /' attempt to access non-existent record'/ Data FOR_IOS ('00000025'X ) /' inconsistent record length '/ Data FOR_IOS ('00000026'X ) /' error during write '/ Data FOR_IOS ('00000027'X ) /' error during read '/ Data FOR_IOS ('00000028'X ) /' recursive I/O operation '/ Data FOR_IOS ('00000029'X ) /' insufficient virtual memory '/ Data FOR_IOS ('0000002A'X ) /' no such device '/ Data FOR_IOS ('0000002B'X ) /' file name specification error '/ Data FOR_IOS ('0000002C'X ) /' inconsistent record type'/ Data FOR_IOS ('0000002D'X ) /' keyword value error in OPEN statement '/ Data FOR_IOS ('0000002E'X ) /' inconsistent OPEN/CLOSE parameters'/ Data FOR_IOS ('0000002F'X ) /' write to READONLY file '/ Data FOR_IOS ('00000030'X ) /' invalid arg to FORTRAN RTL'/ Data FOR_IOS ('00000031'X ) /' invalid key specification'/ Data FOR_IOS ('00000032'X ) /' inconsistent key change, duplicate key'/ Data FOR_IOS ('00000033'X ) /' inconsistent file organization'/ Data FOR_IOS ('00000034'X ) /' specified record locked'/ Data FOR_IOS ('00000035'X ) /' no current record'/ Data FOR_IOS ('00000036'X ) /' REWRITE error'/ Data FOR_IOS ('00000037'X ) /' DELETE error'/ Data FOR_IOS ('00000038'X ) /' UNLOCK error'/ Data FOR_IOS ('00000039'X ) /' FIND error'/ Data FOR_IOS ('0000003B'X ) /' list-directed I/O syntax error '/ Data FOR_IOS ('0000003C'X ) /' infinite format loop '/ Data FOR_IOS ('0000003D'X ) /' format/variable-type mismatch '/ Data FOR_IOS ('0000003E'X ) /' syntax error in format '/ Data FOR_IOS ('0000003F'X ) /' output conversion error '/ Data FOR_IOS ('00000040'X ) /' input conversion error '/ Data FOR_IOS ('00000042'X ) /' output statement overflows record '/ Data FOR_IOS ('00000043'X ) /' input requires too much data '/ Data FOR_IOS ('00000044'X ) /' variable format expression error '/ Byte ArcMark Integer*2 LBR_Recognize Integer Max_Num_Members Parameter ( ArcMark = 26 ) Parameter ( LBR_recognize = 'FF76'x ) Parameter ( Max_Num_Members = 200 ) Character File_Name*12, In_FILE_NAME*50, ANS*1, Lib_Type*1 Character Technique*14, Techs(10)*14 Data Techs /'No compression', 'No compression', 'DLE compressn', 1 'Huffman, DLE', 'LZW Comp', 'LZW, DLE comp', 2 3*'Unknown', ' ' / Character Member_NAMES(Max_Num_Members)*12 Character Mem_Date(Max_Num_Members)*8 Character Mem_Time(Max_Num_Members)*8 Integer First_Byte_Arr(Max_Num_Members) Integer HDR_Vers(Max_Num_Members) Integer Num_Bytes_Arr(Max_Num_Members), CRCS(Max_Num_Members) Integer Temp Byte DIR_ENTRY(32) Byte STATUS, NAME(8), EXTEN(3), LBR_Filler(6), F1, F2 Integer*2 INDX, NSECTS, CRC, Frec, Crea_Date, Upd_Date Integer*2 Crea_Time, Upd_Time Integer Num_Members, NBlks Common /LBR_Dire/ STATUS, NAME, EXTEN, INDX, NSECTS, CRC, 1 Crea_Date, Upd_Date, Crea_Time, Upd_Time, 1 LBR_Filler, F1, F2 Equivalence ( DIR_ENTRY(1), STATUS ) Equivalence ( Frec, F1 ) Integer First_In, Last_In, Buf_Index, Buf_Length, Out_Index Byte In_Buf(4096), Out_Buf(128) Common /Buffers/ First_In, Last_In, Buf_Index, Buf_Length, In_Buf, 1 Out_Buf, Out_Index Logical*1 View_flg, Bin_flg, Extr_flg, LBR_Flg, Cancel_Op Integer Remaining_Size Common /Global/ Remaining_Size, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Cancel_Op Integer*2 I2 Integer Q, I, J, K, M, N, DIR_SECTS, ISTAT, Ios Logical*1 Squeezed Byte Tbytes(13), C, HDR_Ver Type *, ' ' Type *, 'V M S S w e e p V1.0' Type *, 'for .LBR and .ARC files' Type *, ' ' 10 Continue Last_In = 0 First_In = 0 Out_Index = 1 In_FILE_NAME = ' ' Type 1020,'$Enter "library": ' Accept 1021, Q, In_FILE_NAME(1:Q) K = Index( In_File_Name(1:Q), '.' ) If ( K .eq. 0 ) Then Lib_Type = ' ' Else Lib_Type = In_File_Name(K+1:K+1) EndIf If ( Lib_Type .eq. 'l' ) Lib_Type = 'L' If ( Lib_Type .eq. 'a' ) Lib_Type = 'A' 20 Continue If ( Lib_Type .ne. 'A' .and. Lib_Type .ne. 'L' ) Then Type 1020, '$ARC or LBR file [L]: ' Accept 1021, I, Lib_Type If ( I .eq. 0 ) Lib_Type = 'L' If ( Lib_Type .eq. 'l' ) Lib_Type = 'L' If ( Lib_Type .eq. 'a' ) Lib_Type = 'A' If ( Lib_Type .ne. 'A' .and. Lib_Type .ne. 'L' ) Then Type *, '--- Invalid File type entered: ', Lib_Type GoTo 20 EndIf If ( k .eq. 0 ) Then If ( Lib_Type .eq. 'A' )In_File_Name(Q+1:) = '.ARC' If ( Lib_Type .eq. 'L' )In_File_Name(Q+1:) = '.LBR' EndIf EndIf Lbr_Flg = .True. If ( Lib_Type .eq. 'A' ) LBR_Flg = .False. Open( Unit=2, File=In_File_Name, Status='OLD', RecL=4096, 1 DefaultFile='.', Err=900, IoStat=IoS ) Call Position_Lib( 1 ) N = 0 If ( .Not. Lbr_Flg ) GoTo 75 C Handle the .LBR file Specified 50 Continue Call Get_Byte_Knt( DIR_ENTRY, 32 ) DIR_SECTS = NSECTS ! How many directory segments are there Call Position_Lib( 1 ) ! Back to the first buffer If ( DIR_SECTS .GT. 1 ) Then Write( 6, 1030 ) '++ There are ', DIR_SECTS, 1 ' directory segments in ' // In_File_name(1:Q) // ' ++' Else Write( 6, 1030 ) '++ There is ', DIR_SECTS, 1 ' directory segment in ' // In_File_name(1:Q) // ' ++' EndIf Do 70 I = 1, DIR_SECTS*4 Call Get_Byte_Knt( DIR_ENTRY, 32 ) If ( I .ne. 1 ) Then If ( STATUS .eq. 0 ) Then If ( N .eq. max_num_members ) goto 100 N = N + 1 Member_Names(N) = ' ' M = 1 Do While ( M .le. 8 .and. Name(M) .ne. ' ' ) Member_Names(N)(M:M) = Char( Name(M) ) M = M + 1 EndDo Member_Names(N)(M:M) = '.' Hdr_Vers(N) = 10 ! Special blank Do K=1,3 Member_NAMES(N)(M+K:M+K) = Char( EXTEN(K) ) EndDo Temp = NSECTS Num_Bytes_ARR(N) = Temp * 128 Temp = Indx First_Byte_arr(N) = Temp * 128 + 1 CRCS(N) = CRC If ( Crea_Date .ne. 0 ) Then Call Date_Str( 78, Crea_Date, Mem_Date(N) ) Else Mem_Date(N) = ' None' EndIf If ( Crea_Time .ne. 0 ) Then Call Time_Str( Crea_Time, Mem_Time(N) ) Else Mem_Time(N) = ' None' EndIf EndIf EndIf 70 Continue Goto 100 C Read the .ARC file to get 'directory' type info 75 Continue ! Get info for .ARC file Type *, 'Gathering "directory" information for ', In_File_Name(1:Q) Call Get_Byte( C ) Do While ( C .ne. -1 ) If ( C .ne. ArcMark ) Then ! Not an ARC file Write( 6, * ) '+++ Requested file not an .ARC file +++' Goto 700 EndIf Call Get_Byte( Hdr_Ver ) If ( Hdr_Ver .lt. 0 ) Then ! invalid header Type *, 'Cannot handle this version of .ARC file:', Hdr_ver goto 700 EndIf If ( Hdr_Ver .eq. 0 ) Then ! special endoffile GoTo 100 EndIf If ( N .eq. max_num_members ) goto 100 N = N + 1 Call Get_Byte_Knt( TBytes, 13 ) Member_NAMES(N) = ' ' M = 1 Do While ( TBytes(M) .ne. 0 ) Member_NAMES(N)(M:M) = Char( TBytes(M) ) M = M + 1 EndDo Call Get_Byte_Knt( Num_Bytes_Arr(N), 4 ) Call Get_Byte_Knt( Crea_Date, 2 ) If ( Crea_Date .ne. 0 ) Then Call Date_Str( 78, Crea_Date, Mem_Date(N) ) Else Mem_Date(N) = ' None' EndIf Call Get_Byte_Knt( Crea_Time, 2 ) ! Discard time If ( Crea_Time .ne. 0 ) Then Call Time_Str( Crea_Time, Mem_Time(N) ) Else Mem_Time(N) = ' None' EndIf Call Get_Byte_Knt( CRCs(N), 2 ) If ( Hdr_Ver .gt. 1 ) Then Call Get_Byte_Knt( Tbytes, 4 ) ! Discard expanded length EndIf Hdr_Vers(N) = Hdr_Ver First_Byte_arr(N) = Buf_Index + First_In d Write( 6, 1110 ) N, Member_NAMES(N), First_Byte_Arr(N), d 1 Num_Bytes_Arr(N) Call Position_Lib( Num_Bytes_Arr(N) + First_Byte_Arr(N) - 1 ) d Write( 6, 1111 ) 'Positioned to byte: ', d 1 Num_Bytes_Arr(N) + First_Byte_Arr(N) - 1 Call Get_Byte( C ) EndDo d Write( 6, * ) 'All members are found...' C Now display the directory for this library 100 Continue Num_Members = N 150 Continue If ( Num_Members .GT. 1 ) Then Write( 6, 1030 ) '++ There are ', Num_Members, 1 ' members ++' Else Write( 6, 1030 ) '++ There is ', Num_Members, ' member ++' EndIf Write( 6, 1020 ) ' ' Write( 6, 1008 ) Write( 6, 1009 ) Do I = 1, Num_Members NBLKS = Num_Bytes_Arr(I) / 512 If ( NBLKS*512 .ne. Num_Bytes_ARR(I) ) Nblks = NBlks + 1 Technique = Techs( Hdr_Vers(I) ) Write( 6,1010 ) I, Member_NAMES(I), Num_Bytes_Arr(I), 1 Mem_Date(I), Mem_Time(I), Technique EndDo c Now lets see if the user wants to extract any members 200 Continue Type 1020, ' ' Type 1020, '$Enter command (? for list) [X]: ' Accept 1020, ANS If ( ANS .eq. ' ' ) ANS = 'X' If ( ANS .eq. 'x' .or. ANS .eq. 'X' ) Goto 800 View_flg = .False. Extr_flg = .False. Bin_flg = .False. If ( ANS .eq. '?' ) Goto 230 If ( ANS .eq. 'l' .or. ANS .eq. 'L' ) GoTo 150 If ( ANS .eq. 'n' .or. ANS .eq. 'N' ) GoTo 700 If ( .Not. LBR_Flg ) GoTo 210 If ( ANS .eq. 'v' .or. ANS .eq. 'V' ) View_flg = .True. If ( ANS .eq. 'e' .or. ANS .eq. 'E' ) Extr_flg = .True. If ( View_flg .or. Extr_flg ) GoTo 250 210 Type *, '-- Illegal Command --' 230 Continue Type 1020, ' ' Type 1020, ' Commands available:' Type 1020, ' ' If ( Lbr_Flg ) Then Type 1020, ' E - Extract a member to a file' EndIf Type 1020, ' L - List the directory again' Type 1020, ' N - Get a new library file' If ( Lbr_Flg ) Then Type 1020, ' V - View member at terminal (squeezed or unsqueezed)' Type 1020, ' No check on whether member is viewable' EndIf Type 1020, ' X - No option wanted (exit)' Type 1020, ' ? - Display this list' GoTo 200 250 Continue Type 1400 Accept 1410, N If (( N .le. 0 ) .or. ( N .gt. Num_Members )) Then Type *, '-- Illegal member number --' Goto 250 EndIf Call Position_Lib( First_Byte_Arr(N) ) Remaining_Size = Num_Bytes_Arr(N) If ( Lib_Type .eq. 'A' ) GoTo 500 C Now handle selection from .LBR file 300 Continue Call Get_Byte_Knt( Frec, 2 ) Squeezed = .False. If ( Frec .eq. LBR_recognize ) Then Remaining_Size = Remaining_Size - 5 ! Keep track of member size Squeezed = .True. Call Get_Byte_Knt( I2, 2 ) ! Get past the CRC File_Name = ' ' Call Get_Byte( C ) ! Get the member orig name I = 0 Do While ( C .ne. 0 ) I = I + 1 File_Name(I:I) = Char( C ) Call Get_Byte( C ) Remaining_Size = Remaining_Size - 1 EndDo Call Init_UnSq ! Init the decode tree Else File_Name = Member_Names(N) EndIf Call Open_Ext_File( File_Name ) ! Open the output LUN If ( Squeezed ) Then Call Get_Char_Sq( I2 ) Do While (( I2 .ne. -1 ) .and. .Not. Cancel_Op ) Call Put_Char_UnComp( I2 ) Call Get_Char_Sq( I2 ) EnDDo Else I2 = F1 ! Save the characters Call Put_Char_UnComp( I2 ) ! that i checked for I2 = F2 ! the recognition value Call Put_Char_UnComp( I2 ) Call Get_Char( I2 ) Do While (( I2 .ne. -1 ) .and. .Not. Cancel_op ) Call Put_Char_UnComp( I2 ) Call Get_Char( I2 ) EnDDo EndIf Call Close_Ext_File GoTo 200 C This code is for the .ARC library format 500 Continue Type *, 'Not implemented yet' c Now lets setup for another lib file 700 Continue Close( Unit=2 ) Goto 10 800 Continue Call Exit 900 Continue If ( IOS .gt. 68 ) Then Type *,'Unkown error on OPEN:', IOS Else Type *, 'Error on OPEN: ', For_IOS( IOS ) EndIf Call Exit 1000 Format( ' ', a, ' ', i4 ) 1008 Format( ' # Member Name # Bytes Date Time') 1009 Format( ' ---- ------------ ------- -------- --------') 1010 Format( ' ', I3, '. ', a, ' ', I7, 3( ' ', A ) ) 1011 Format( ' Extracting: ', a, '.', a, ', First Byte: ', I7, 1 ', # Bytes: ', I7 ) 1020 Format( a ) 1021 Format( q, a ) 1030 Format( ' ', a, I4, a ) 1110 Format( ' Member#', I3, '. ', a, 1 ', First: ', i7, ', Number: ', i7 ) 1111 Format( ' ', A, I7 ) 1400 Format( '$Enter member number: ' ) 1410 Format( I3 ) 1450 Format( 128A1 ) End C------------------------------------------------------------------------ C Subroutine called to open an output LUN for processing a member C of library (eitrher .LBR or .ARC) C C Inputs: C File_Name Member filename C C Outputs: C The Bin_Flg will be set if the extension of the file is C .EXE, .BIN, .COM, .CMD, .OVR etc... C C------------------------------------------------------------------------ Subroutine Open_Ext_File( File_Name ) Implicit None Logical*1 File_Flg, Squeezed, Ctrlz_Flg Character File_Name*(*), Carriage*4, ANS, File_Ext*3 Character Open_Name*12 Integer K, I, IOS Logical*1 View_flg, Bin_flg, Extr_flg, LBR_Flg, Cancel_Op Integer Remaining_Size Common /Global/ Remaining_Size, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Cancel_Op Character For_IOS(68)*30 Common /ForIOS/ For_IOS Bin_Flg = .True. K = Index( File_Name, '.' ) If ( K. eq. 0 )Then Type *, 'Is ', File_Name, ' a text file? ' Accept 1100, Ans If ( Ans .eq. 'y' .or. Ans .eq. 'Y' ) Bin_Flg = .False. Else File_Ext = File_Name(K+1:) K = Index( 'COM EXE REL CMD COM OVR BIN', File_Ext ) Bin_Flg = .False. If ( K .ne. 0 ) Bin_Flg = .True. EndIf If ( View_flg .and. Bin_Flg ) Then Type *, '---> Can''t view a binary file, extracting...' View_Flg = .False. EndIf If ( View_Flg .or. Bin_Flg ) Then Carriage = 'NONE' Else Carriage = 'LIST' EndIf Cancel_op = .False. If ( View_flg ) Then Open_Name = 'Sys$OutPut' Else OPen_Name = File_Name Write( 6, * ) 'Extracting to ', File_Name, '...' EndIf Call Cancel_AST_Start Type *, '+++ To cancel operation type Ctrl-C +++' Type *, ' ' Open( Unit=1, File=Open_Name, Status='NEW', RecL=128, 1 IoStat=IOS, CarriageControl=Carriage, Err=900 ) Return 900 Continue Type *, 'Error opening file: ', FOR_IOS( IOS ) Return 1100 Format( A ) End Subroutine Close_Ext_File Implicit None Integer K Integer First_In, Last_In, Buf_Index, Buf_Length, Out_Index Byte In_Buf(4096), Out_Buf(128) Common /Buffers/ First_In, Last_In, Buf_Index, Buf_Length, In_Buf, 1 Out_Buf, Out_Index If ( Out_Index .gt. 1 ) Then Write( 1, 1100 ) (Out_Buf(K), K=1,Out_Index) Out_Index = 1 EndIf Close( Unit=1 ) Return 1100 Format( 128A1 ) End C------------------------------------------------------------------------ C Subroutine used to get the next byte from the input buffer C If the input buffer is empty the next record will be read C C Inputs: C Common containing information about the buffers C C OutPut: C C is the next byte value from the input buffer C C------------------------------------------------------------------------ Subroutine Get_Byte( C ) Implicit None Byte C Integer First_In, Last_In, Buf_Index, Buf_Length, Out_Index Byte In_Buf(4096), Out_Buf(128) Common /Buffers/ First_In, Last_In, Buf_Index, Buf_Length, In_Buf, 1 Out_Buf, Out_Index If ( Buf_Index .gt. Buf_Length ) Then Call Position_Lib( Last_In + 1 ) EndIf C = In_Buf( Buf_Index ) Buf_Index = Buf_Index + 1 Return End C------------------------------------------------------------------------ C Subroutine used to get the next byte from the input buffer C Call Get_Byte after checking remaining size of member C C Inputs: C Common containing information about the member C C OutPut: C I is the next byte value from the input buffer in I*2 C C------------------------------------------------------------------------ Subroutine Get_Char( I ) Implicit None Integer*2 I, W Byte C Equivalence ( W, C ) Logical*1 View_flg, Bin_flg, Extr_flg, LBR_Flg, Cancel_Op Integer Remaining_Size Common /Global/ Remaining_Size, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Cancel_Op W = 0 If ( remaining_Size .gt. 0 ) Then Call Get_Byte( C ) Remaining_Size = Remaining_Size - 1 Else W = -1 EndIf I = W Return End C------------------------------------------------------------------------ C Subroutine used to get KNT bytes from input C Call the Get_Byte subroutine to minimize buffer manipulation C C Input: C Buffer address to fill C KNT number of bytes to fill C C Output: C Fills parameter buffer with KNT bytes C C------------------------------------------------------------------------ Subroutine Get_Byte_Knt( Buf, Knt ) Implicit None Integer Knt, I Byte Buf(KNT) Do I = 1, KNT Call Get_Byte( Buf(I) ) EndDo Return End C------------------------------------------------------------------------ C Subroutine that translates a byte to ASCII C C Input: C Will call Get_Char to get a bytes needed for translation C C Output: C The translated value (unsqueezed) in I*2 format C C------------------------------------------------------------------------ Subroutine Get_Char_Sq( W ) Implicit None Integer*2 SpEOF Parameter ( SPEOF = 256 ) Integer*2 W Integer*2 I, K, CurIn Integer*2 DNode(0:255,0:1), BPos Common /UnSq/ DNode, BPos I = 0 Do While ( I .ge. 0 ) BPos = BPos + 1 If ( BPos .gt. 7 ) Then BPos = 0 Call Get_Char( CurIN ) If ( Curin .eq. -1 ) Then W = -1 Return EndIf Else Curin = Ishft( Curin, -1 ) !!!VMS!!! VAX intrinsic function EndIf K = Curin .and. 1 I = DNode( I, K ) EndDo I = -( I + 1 ) If ( I .eq. SPEOF ) Then W = -1 Else W = I EndIf Return End C------------------------------------------------------------------------ C Subroutine used to put a byte into outbut buffer and will check C for compression using the DLE technique C C Input: C W I*2 value holding the char to output C C Output: C Places data into the output buffer C C------------------------------------------------------------------------ Subroutine Put_Char_UnComp( W ) Implicit None Integer*2 DLE Parameter ( DLE = '90'x ) Integer*2 W, WC, RepCt, LastC Byte C Equivalence ( WC, C ) Data RepCt /0/ If ( Repct .gt. 0 ) Then ! Are we repeating a char? If ( W .eq. 0 ) Then Call Put_Char_Crc( DLE ) ! DLE was a real one Else ! Count is what we have RepCt = W ! Set the count right repct = repct - 1 ! Now put the proper Do While ( repCt .gt. 0 ) ! number of characters Call Put_Char_Crc( LastC ) ! into the buffer repct = repct - 1 EndDo EndIf repct = 0 ! All done with this repeat Else ! Not repeating yet If ( W .eq. DLE ) Then ! Repeat introducer? RepCt = 1 ! Yes, flag the repeat Else ! No, just put the char Call Put_Char_Crc( W ) ! Always save last sent LastC = W EndIf EndIf Return End C------------------------------------------------------------------------ C Subroutine that places a byte into the output buffer C C Input: C A byte value C C OutPut: C The byte will be placed into the output buffer. When the C buffer is full then it will be written. C C------------------------------------------------------------------------ Subroutine Put_Byte( C ) Implicit None Byte CR, LF Parameter ( LF = '12'o ) Parameter ( CR = '15'o ) Byte C Logical*1 CR_Flg Integer K Logical*1 View_flg, Bin_flg, Extr_flg, LBR_Flg, Cancel_Op Integer Remaining_Size Common /Global/ Remaining_Size, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Cancel_Op Integer First_In, Last_In, Buf_Index, Buf_Length, Out_Index Byte In_Buf(4096), Out_Buf(128) Common /Buffers/ First_In, Last_In, Buf_Index, Buf_Length, In_Buf, 1 Out_Buf, Out_Index Data CR_Flg /.False./ If ( .Not. ( View_flg .or. Bin_Flg )) Then If ( CR_Flg ) Then If ( C .eq. LF ) Then Write( 1, 1100 ) (Out_Buf(K), K=1,Out_Index-1) Out_Index = 1 CR_Flg = .False. Return Else Out_Buf( Out_Index ) = CR Out_Index = Out_Index + 1 If ( Out_Index .gt. 128 ) Then Write( 1, 1100 ) (Out_Buf(K), K=1,128 ) Out_Index = 1 EndIf EndIf EndIf If ( C .eq. CR ) Then CR_Flg = .True. Return EndIf Cr_Flg = .False. EndIf Out_Buf( Out_Index ) = C Out_Index = Out_Index + 1 If ( Out_Index .gt. 128 ) Then Write( 1, 1100 ) (Out_Buf(K), K=1,128 ) Out_Index = 1 EndIf Return 1100 Format( 128A1 ) End C------------------------------------------------------------------------ C Subroutine that is used to calc a CRC C C Input: C I*2 with the character to add to the CRC C C Output: C Call Put_Byte to add the byte to the output buffer C C------------------------------------------------------------------------ Subroutine Put_Char_Crc( W ) Implicit None Logical*1 View_flg, Bin_flg, Extr_flg, LBR_Flg, Cancel_Op Integer Remaining_Size Common /Global/ Remaining_Size, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Cancel_Op Integer*2 W, Wc, T1, T2, CRCVal Integer*2 CRCTab(0:255) Byte C Equivalence ( Wc, C ) Wc = W Call Put_Byte( C ) If ( .Not. Lbr_Flg ) Then T1 = ( 'FF'X .and. Ishft( CrcVal, -8 ) ) !!!VMS!!! T2 = CrcTab(( CrcVal .xor. W ) .and. 'ff'X ) CrcVal = T1 .Xor. T2 EndIf Return End C------------------------------------------------------------------------ C Subroutine that sets up the translation array for the specified C member C C Input: C C Output: C The translation node array is filled in if C The original name of the member file. C C------------------------------------------------------------------------ Subroutine Init_UnSq Implicit None Integer*2 SpEOF Parameter ( SPEOF = 256 ) Integer*2 I, NumNodes Logical*1 View_flg, Bin_flg, Extr_flg, LBR_Flg, Cancel_Op Integer Remaining_Size Common /Global/ Remaining_Size, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Cancel_Op Integer*2 DNode(0:255,0:1), BPos Common /UnSq/ DNode, BPos Call Get_Byte_Knt( NumNodes, 2 ) BPos = 100 Dnode(0,0) = -(SPEOF+1) Dnode(0,1) = -(SPEOF+1) NumNodes = NumNodes - 1 Do I = 0, NumNodes Call Get_Byte_Knt( DNode( I, 0 ), 2 ) Call Get_Byte_Knt( DNode( I, 1 ), 2 ) EndDo d Write( 6, * ) 'Translation arrays:' d Do I = 0, NumNodes d Write( 6, 1000 ) I, Dnode(I,0), Dnode(I,1) d1000 Format( ' #', I3, 2( ' ', Z4.4 ) ) d EndDo Return End C------------------------------------------------------------------------ C Subroutine called to position to a specified byte of a library C file opened on LUN 2 C C Inputs: C Byte_Lk The first byte wanted C C Outputs: C Will put the requested byte in the buffer C C------------------------------------------------------------------------ Subroutine Position_Lib( Byte_Lk ) Implicit None Character For_IOS(68)*30 Common /ForIOS/ For_IOS Integer I, J, K, L, Q, Byte_Lk, IoS Integer First_In, Last_In, Buf_Index, Buf_Length, Out_Index Byte In_Buf(4096), Out_Buf(128) Common /Buffers/ First_In, Last_In, Buf_Index, Buf_Length, In_Buf, 1 Out_Buf, Out_Index C Check the starting byte that is requested 100 Continue If ( Byte_Lk .lt. First_In ) Goto 150 ! Need to REWIND file If ( Byte_Lk .gt. Last_In ) Goto 200 ! Read the next buffer C Otherwise byte is in the current buffer Buf_Index = Byte_Lk - First_In + 1 Return C Needed to start over in the file 150 Continue Rewind 2 Last_In = 0 C Read the next buffer 200 Continue Do I = 1, 4096 In_Buf(I) = 0 EndDo Read( 2, 1010, End=500, Err=800, IoStat=IOS ) Q, ( In_Buf(K),K=1,Q ) d Write( 6, 1111 ) ( In_Buf(K),K=1,128 ) d1111 Format( 8(/' ', 16( z2.2, ' ' ) ) ) Buf_Length = Q First_In = Last_In + 1 Last_In = First_In + Buf_Length - 1 Goto 100 C End of File Encountered while attempting to find a sector 500 Continue Rewind 2 First_In = 0 Last_In = 0 Return C Error occurred on read 800 Continue If ( IOS .gt. 68 ) Then Type *, 'Unknown error on READ: ', IOS Else Type *, 'Error on READ: ', For_IOS( IOS ) EndIf Return 1010 Format( Q, 4096A1 ) End C------------------------------------------------------------------------------- C Subroutine used to convert a time in MSDOS I*2 format to a string C This routine calls a VMS FORTRAN shift routine (ISHFT). C C Inputs: C T 2 byte value containing time C Format: Bits 0-4 is number of 2 sec intervals C Bits 5-10 is number of minutes C Bits 11-15 is the number of hours C Outputs: C T_Str in form: hh:mm:ss C C------------------------------------------------------------------------------- Subroutine Time_Str( T, T_Str ) Implicit None Integer*2 T, Work Integer Sec, Hr, Min Character T_Str*(*) Integer*2 H_Mask, M_Mask, S_Mask Parameter ( H_Mask = 'F800'x, 1 M_Mask = '07E0'x, 1 S_Mask = '001F'x ) Work = T .and. S_Mask Sec = Work Work = T .and. M_Mask Work = IShft( Work, -5 ) ! Shift right 5 !!!VMS!!! Min = Work Work = T .and. H_Mask Work = IShft( Work, -11 ) ! Shift right 11 !!!VMS!!! Hr = Work Write( T_Str, 1000, err = 100 ) Hr, Min, Sec*2 Return 100 Continue T_Str = 'UnKnown' Return 1000 Format( I2.2, 2( ':', I2.2 ) ) End C------------------------------------------------------------------------------- C Subroutines used to convert a count of days from a base date to C a year, month and day. The base date can be selected. C This routine uses VMS RTL routines for date and time manipulation. C C Inputs: C BY Base year (ie. 80 is 1-Jan-1980 is day 1) C D 2 byte value containing the date that is the number C of days since a base date C C Outputs: C D_Str in form: mm/dd/yy C C------------------------------------------------------------------------------- Subroutine Date_Str( BY, D, D_Str ) Implicit None Integer*2 D, Num_Time(7) Integer BY, Work, Delta(2), Base(2), Act_Date(2) Integer Lib$SubX, Sys$BinTim, Sys$NumTim, Stat !!!VMS!!! Character D_Str*(*), Temp_Str*23, Err Err = 'T' If ( D .gt. 9999 ) Goto 100 Err = 'B' Write( Temp_Str, 1001, Err=100 ) BY-1 Stat = Sys$BinTim( Temp_Str, Base ) !!!VMS!!! If ( .Not. Stat ) GoTo 100 Err = 'D' Write( Temp_Str, 1000, Err=100 ) D Stat = Sys$BinTim( Temp_Str, Delta ) !!!VMS!!! If ( .Not. Stat ) GoTo 100 Err = 'S' Stat = Lib$SubX( Base, Delta, Act_Date, 2 ) !!!VMS!!! If ( .Not. Stat ) GoTo 100 Err = 'N' Stat = Sys$NumTim( Num_Time, Act_Date ) !!!VMS!!! If ( .Not. Stat ) GoTo 100 Err = 'W' Write( D_Str, 1002, Err=100 ) Num_Time(2), Num_Time(3), 1 Num_Time(1)-1900 Return 100 Continue D_Str = 'Cnv Err' // Err ! Can't convert Return 1000 Format( I4.4, ' 00:00:00.00' ) 1001 Format( '31-DEC-19', I2.2, ' 00:00:00.00' ) 1002 Format( I2.2, 2( '/', I2.2 ) ) End C------------------------------------------------------------------------------- C Subroutine used to enable the control C trap used as a cancel signal C for View and Extract functions. C C This routine is very VMS specific! C------------------------------------------------------------------------------- Subroutine Cancel_AST_Start Implicit None Integer JPI_ITEM, IO_Func, K, L, IOS, TT_LEN Integer Lib$GetJPI, Sys$Assign, Sys$QioW Integer*2 TT_Chan Character TT_Name*7 Include '($IODEF)' Include '($JPIDEF)' External Cancel_AST JPI_Item = JPI$_Terminal IOS = Lib$GetJPI( JPI_ITEM,,,, TT_Name, TT_Len ) If ( .Not. IOS ) Call Lib$Stop( %Val( IOS ) ) IOS = Sys$Assign( TT_Name(1:TT_Len), TT_Chan,, ) If ( .Not. IOS ) Call Lib$Stop( %Val( IOS ) ) IO_Func = IO$_SetMode .or. IO$M_CtrlCAST IOS = Sys$QioW( , %Val(TT_Chan), %Val(IO_Func),,,, Cancel_AST,,,,, ) If ( .Not. IOS ) Call Lib$Stop( %Val( IOS ) ) Return End C------------------------------------------------------------------------------- C Subroutine to set Cancel AST for View and extract functions C C This routine is VMS specific C------------------------------------------------------------------------------- Subroutine Cancel_AST Implicit None Logical*1 View_flg, Bin_flg, Extr_flg, LBR_Flg, Cancel_Op Integer Remaining_Size Common /Global/ Remaining_Size, View_Flg, Bin_Flg, Extr_Flg, 1 LBR_Flg, Cancel_Op Cancel_OP = .True. Type *, '+++ Operation Cancelled +++' Type *, ' ' Return End