NetNews Usenet Archive 1992 #18/NN_1992_18.iso/spool/vmsnet/sources/313

Internet Message Format | 1992-08-21 | 46.6 KB

Path: sparky!uunet!elroy.jpl.nasa.gov!swrinde!network.ucsd.edu!mvb.saic.com!vmsnet-sources
From: [e-mail] (Dick Munroe)
Newsgroups: vmsnet.sources
Subject: UBBS, part 11/12
Message-ID: <[e-mail]>
Date: 21 Aug 92 20:23:05 GMT
Organization: Doyle, Munroe Consultants, Inc., Hudson, MA
Lines: 1692
Approved: [e-mail]

Submitted-by: [e-mail] (Dick Munroe)
Posting-number: Volume 3, Issue 119
Archive-name: ubbs/part11
-+-+-+-+-+-+-+-+ START OF PART 11 -+-+-+-+-+-+-+-+
XEnter name of file to download, ? for list, or <cr> to exit. ABC.XYZ`0D
XLast file added: 24-Jul-1986
XView (A)ll or (U)napproved files? `5BU`5D`0D
X    Files since:  1-Jul-1985
X(D)ownload, (U)pload, (H)elp or (E)xit? `5Bexit`5D D`0D
XArea? APP`0D
XEnter name of file to download, ? for list, or <cr> to exit. ABC.XYZ`0D
XLast file added: 12-Feb-1986
XView (A)ll or (U)napproved files? `5BU`5D`0D
X    Files since:  1-Jul-1985
XDDD2.1               23-Jul-1986  Size:     0  Ubinar    Accesses:    0
X
X     Keywords: a By:JASON FARNON                 `20
X
Xa
Xa
XCommand?D`0D
XDeleted`0D
XSTAR.TREK            18-Jul-1986  Size:    48  Uascii    Accesses:    0
X
X     Keywords: ASCII-GAME By:MIKE SHIRLEY                 `20
X
XSTAR TREK GAME-EXEC-SAVE-AND RUN.COMPATABLE W/3.3 OR PRODOS.
XCommand?X`0D
X(D)ownload, (U)pload, (H)elp or (E)xit? `5Bexit`5D `0D
X11:20:38-05 Command (B,C,E,F,G,H,K,M,P,R,S,U,W,X,?)?G`0D
X
XThank you for calling UBBS
X  BBS          logged out at 24-JUL-1986 11:20:41.34
$ CALL UNPACK [.UTILITY]SYSOP.HOWTO;2 134575356
$ create 'f'
XC---------------------------------------------------------------------------
V--
XC`09Program used to provide LSWEEP and some ARC functionality on VMS
XC
XC`09VMSsweep will handle .LBR and .ARC* files and can be used to extract`20
XC`09members or just display them on the terminal if they are non binary
XC
XC`09Restrictions:`20
XC`09`09The VMS file must have a maximum record length of 4096 bytes.`20
XC`09`09The library file (.ARC* or .LBR) can only have 200 members
XC
XC`09Functions provided:
XC`09`09View a member at the terminal -squeezed or unsqueezed
XC`09`09Extract a member to a file (Max 510 byte records)`20
XC`09`09List the directory of a library file
XC`09`09New library file requested
XC
XC`09Author:
XC`09`09John T. Coburn`09`09Digital Equipment, Cleveland
XC`09`09Copyright (c) 1986
XC
XC`09Please feel free to distribute this program by any noncommercial
XC`09means to anyone who can use it.
XC
XC`09* ARC is Copyright 1985,1986 by System Enhancements Associates
XC
XC`09This program was in general based on the Turbo Pascal program`20
XC`09DEARC that is in the public domain. Also referenced ARC sources
XC`09from System Enhancement Associates
XC
XC---------------------------------------------------------------------------
V--
XC---------------------------------------------------------------------------
V--
XC`09Modification History:
XC
XC`09Vers`09Date`09`09Who`09`09Comments
XC
XC`09V2.8`0912 Dec 86`09John Coburn`09Fix problem when running
XC`09`09`09`09`09`09in a subprocess
XC`09`09`09`09Walt Lamia`09Extraction of all members
XC
XC`09V2.7`0922 Nov 86`09John Coburn`09Add CRC checking for LBRs
XC
XC`09V2.6`0930 Oct 86`09John Coburn`09Add CRC checking for ARCs
XC
XC`09V2.5`0929 Oct 86`09John Coburn`09Fixed bug that occurred
XC`09`09`09`09`09`09when extracting unsqueezed
XC`09`09`09`09`09`09binary files. Also fixed
XC`09`09`09`09`09`09boundary condition problem`20
XC`09`09`09`09`09`09in decompression table that
XC`09`09`09`09`09`09caused ARC extracts to fail.
XC
XC`09V2.4`09 6 Sep 1986`09John Coburn`09Change to allow single CR or LF
XC`09`09`09`09Glenn Everharts`09to be a record terminator.
XC`09`09
XC`09V2.3`09 1 Mar 1986`09John Coburn`09Removed unreliable CRC checking
XC
XC`09V2.2`09 ???`09`09John Coburn`09Enhance ARC functions
XC
XC`09V2.1`09 ???`09`09John Coburn`09Add ARC functionality
XC
XC`09V2.0`09 1 Feb 1986`09John Coburn`09First released version
XC---------------------------------------------------------------------------
V--
X
X `09Program VAX_ARC_LBR
X
X`09Implicit None
X`0C`0A
X`09Character`09For_IOS(68)*30
X`09Common`09/ForIOS/ For_IOS
X
X!`20
X! `09Define FORTRAN error numbers for use with IOSTAT and ERRSNS
X!`20
X`09Data For_IOS /68*' '/
X`09Data FOR_IOS ('00000011'X ) /' syntax error in NAMELIST input'/
X`09Data FOR_IOS ('00000012'X ) /' too many values for NAMELIST variable'/
X`09Data FOR_IOS ('00000013'X ) /' invalid reference to variable'/
X`09Data FOR_IOS ('00000014'X ) /' REWIND error '/
X`09Data FOR_IOS ('00000015'X ) /' duplicate file specifications '/
X`09Data FOR_IOS ('00000016'X ) /' input record too long '/
X`09Data FOR_IOS ('00000017'X ) /' BACKSPACE error '/
X`09Data FOR_IOS ('00000018'X ) /' end-of-file during read '/
X`09Data FOR_IOS ('00000019'X ) /' record number outside range '/
X`09Data FOR_IOS ('0000001A'X ) /' OPEN or DEFINE FILE required'/
X`09Data FOR_IOS ('0000001B'X ) /' too many records in I/O statement'/
X`09Data FOR_IOS ('0000001C'X ) /' CLOSE error '/
X`09Data FOR_IOS ('0000001D'X ) /' file not found '/
X`09Data FOR_IOS ('0000001E'X ) /' open failure '/
X`09Data FOR_IOS ('0000001F'X ) /' mixed file access modes '/
X`09Data FOR_IOS ('00000020'X ) /' invalid logical unit number '/
X`09Data FOR_IOS ('00000021'X ) /' ENDFILE error '/
X`09Data FOR_IOS ('00000022'X ) /' unit already open '/
X`09Data FOR_IOS ('00000023'X ) /' segmented record format error '/
X`09Data FOR_IOS ('00000024'X ) /' attempt to access non-existent record'/
X`09Data FOR_IOS ('00000025'X ) /' inconsistent record length '/
X`09Data FOR_IOS ('00000026'X ) /' error during write '/
X`09Data FOR_IOS ('00000027'X ) /' error during read '/
X`09Data FOR_IOS ('00000028'X ) /' recursive I/O operation '/
X`09Data FOR_IOS ('00000029'X ) /' insufficient virtual memory '/
X`09Data FOR_IOS ('0000002A'X ) /' no such device '/
X`09Data FOR_IOS ('0000002B'X ) /' file name specification error '/
X`09Data FOR_IOS ('0000002C'X ) /' inconsistent record type'/
X`09Data FOR_IOS ('0000002D'X ) /' keyword value error in OPEN statement '/
X`09Data FOR_IOS ('0000002E'X ) /' inconsistent OPEN/CLOSE parameters'/
X`09Data FOR_IOS ('0000002F'X ) /' write to READONLY file '/
X`09Data FOR_IOS ('00000030'X ) /' invalid arg to FORTRAN RTL'/
X`09Data FOR_IOS ('00000031'X ) /' invalid key specification'/
X`09Data FOR_IOS ('00000032'X ) /' inconsistent key change, duplicate key'/
X`09Data FOR_IOS ('00000033'X ) /' inconsistent file organization'/
X`09Data FOR_IOS ('00000034'X ) /' specified record locked'/
X`09Data FOR_IOS ('00000035'X ) /' no current record'/
X`09Data FOR_IOS ('00000036'X ) /' REWRITE error'/
X`09Data FOR_IOS ('00000037'X ) /' DELETE error'/
X`09Data FOR_IOS ('00000038'X ) /' UNLOCK error'/
X`09Data FOR_IOS ('00000039'X ) /' FIND error'/
X`09Data FOR_IOS ('0000003B'X ) /' list-directed I/O syntax error '/
X`09Data FOR_IOS ('0000003C'X ) /' infinite format loop '/
X`09Data FOR_IOS ('0000003D'X ) /' format/variable-type mismatch '/
X       `09Data FOR_IOS ('0000003E'X ) /' syntax error in format '/
X`09Data FOR_IOS ('0000003F'X ) /' output conversion error '/
X`09Data FOR_IOS ('00000040'X ) /' input conversion error '/
X`09Data FOR_IOS ('00000042'X ) /' output statement overflows record '/
X`09Data FOR_IOS ('00000043'X ) /' input requires too much data '/
X`09Data FOR_IOS ('00000044'X ) /' variable format expression error '/
X`0C`0A
X`09Byte`09`09ArcMark, FBuf(128)
X`09Integer*2`09LBR_Recognize
X`09Integer`09`09Max_Num_Members
X
X`09Parameter ( ArcMark = 26 )
X`09Parameter ( LBR_recognize = 'FF76'x )
X`09Parameter ( Max_Num_Members = 200 )
X
X`09Character`09File_Name*12, In_FILE_NAME*50, ANS*1, Lib_Type*1
X`09Character`09Technique*10, Techs(10)*10, Actual_Len_Str*8
X`09Data`09Techs `09/ 2*'    --', '  Packed', ' Squeezed',`20
X`091`09`09  3*'Crunch(un)', ' Crunched',`20
X`092`09`09 2*' Unknown' /
X
X`09Character`09Member_NAMES(Max_Num_Members)*12
X`09Character`09Mem_Date(Max_Num_Members)*8
X`09Character`09Mem_Time(Max_Num_Members)*8
X
X`09Integer`09`09First_Byte_Arr(Max_Num_Members)
X`09Integer`09`09HDR_Vers(Max_Num_Members), Act_Len(Max_Num_Members)
X`09Integer`09`09Num_Bytes_Arr(Max_Num_Members)
X`09Integer*2`09CRCS(Max_Num_Members)
X
X`09Integer`09`09Temp
X
X`09Byte`09`09DIR_ENTRY(32)
X
X`09Byte`09`09STATUS, NAME(8), EXTEN(3), LBR_Filler(6), F1, F2
X`09Integer*2`09INDX, NSECTS, CRC, Frec, Crea_Date, Upd_Date
X`09Integer*2`09Crea_Time, Upd_Time
X`09Integer`09`09Num_Members, NBlks, Ivcr
X
X`09Common`09/LBR_Dire/ STATUS, NAME, EXTEN, INDX, NSECTS, CRC,`20
X`091`09`09   Crea_Date, Upd_Date, Crea_Time, Upd_Time,`20
X`091`09`09   LBR_Filler, F1, F2
X
X`09Equivalence`09( DIR_ENTRY(1), STATUS )
X`09Equivalence`09( Frec, F1 )
X
X`09Integer`09`09First_In, Last_In, Buf_Index, Buf_Length
X`09Integer`09 `09Out_Index, Out_Length, Out_Num
X`09Byte`09`09In_Buf(4096), Out_Buf(512)
X`09Common`09/Buffers/ First_In, Last_In, Buf_Index, Buf_Length, In_Buf,
X`091`09`09Out_Buf, Out_Index, Out_Length, Out_Num
X
X`09Logical*1`09View_Cr, View_flg, Bin_flg, Extr_flg
X`09Logical*1`09LBR_Flg, Cancel_Op, AST_On_Flg
X`09Integer`09`09Remaining_Size
X`09Integer*2`09CRC_Val
X`09Common`09/Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg,`2
V0
X`091`09`09 LBR_Flg, Cancel_Op, AST_On_Flg, CRC_Val
X
X`09Integer*2`09I2
X`09Integer`09`09Q, I, J, K, M, N, DIR_SECTS, ISTAT, Ios
X`09INTEGER`09`09N1,N2,NN
X
X`09Logical*1`09Squeezed, File_OK
X`09Byte`09`09Tbytes(13), C, HDR_Ver
X`0C`0A
XC`09Start of Code
X
X`09Type *, ' '
X`09Type *, 'V M S   S w e e p   V2.8'
X`09Type *, 'for .LBR and .ARC files'
X`09Type *, ' '
X
X10`09Continue
X`09Last_In = 0
X`09First_In = 0
X`09Out_Index = 1
X`09In_FILE_NAME = ' '
X`09View_Cr = .False.
X`09Type 1020,'$Enter "library": '
X`09Accept 1021, Q, In_FILE_NAME(1:Q)`20
X`09If ( Q .eq. 0 ) GoTo 800
X
X`09K = Index( In_File_Name(1:Q), '.' )
X`09If ( K .eq. 0 ) Then
X`09  Lib_Type = ' '
X`09Else
X`09  Lib_Type = In_File_Name(K+1:K+1)
X`09EndIf
X
X`09If ( Lib_Type .eq. 'l' ) Lib_Type = 'L'
X`09If ( Lib_Type .eq. 'a' ) Lib_Type = 'A'
X
X20`09Continue
X`09If ( Lib_Type .ne. 'A' .and. Lib_Type .ne. 'L' ) Then
X`09  Type 1020, '$ARC or LBR file `5BL`5D: '
X`09  Accept 1021, I, Lib_Type
X`09  If ( I .eq. 0 ) Lib_Type = 'L'
X`09  If ( Lib_Type .eq. 'l' ) Lib_Type = 'L'
X`09  If ( Lib_Type .eq. 'a' ) Lib_Type = 'A'
X`09  If ( Lib_Type .ne. 'A' .and. Lib_Type .ne. 'L' ) Then
X`09    Type *, '--- Invalid File type entered: ', Lib_Type
X`09    GoTo 20
X`09  EndIf
X`09  If ( k .eq. 0 ) Then
X`09    If ( Lib_Type .eq. 'A' )In_File_Name(Q+1:) = '.ARC'
X`09    If ( Lib_Type .eq. 'L' )In_File_Name(Q+1:) = '.LBR'
X`09  EndIf
X`09EndIf
X
X`09Lbr_Flg = .True.
X`09If ( Lib_Type .eq. 'A' ) LBR_Flg = .False.
X
X`09Open( Unit=2, File=In_File_Name, Status='OLD', ReadOnly,`20
X`091`09DefaultFile='.', Err=900, IoStat=IoS )
X
X`09Call Position_Lib( 1 )
X`09N = 0
X
X`09If ( .Not. Lbr_Flg ) GoTo 75
X`0C`0A
X
XC`09Handle the .LBR file Specified
X
X50`09Continue
X
X`09Call Get_Byte_Knt( DIR_ENTRY, 32 )
X
X`09File_OK = .True.
X`09Do I=1,8
X`09  If ( Name(I) .ne. ' ' ) File_OK = .False.
X`09EndDo
X`09Do I=1,3
X`09  If ( EXTEN(I) .ne. ' ' ) File_OK = .False.
X`09EndDo
X
X`09If ( .Not. File_OK ) Then
X`09  Write( 6, * ) '+++ Requested file is not an LBR file +++'
X`09  Write( 6, * ) '+++ Invalid directory format for LBR  +++'
X`09  GoTo 700
X`09EndIf
X
X`09DIR_SECTS = NSECTS`09`09! How many directory segments are there
X
X`09If ( DIR_SECTS .GT. 1 ) Then
X`09   Write( 6, 1030 ) '++ There are ', DIR_SECTS,`20
X`091`09' directory segments in ' // In_File_name(1:Q) // ' ++'
X`09Else
X`09   Write( 6, 1030 ) '++ There is ', DIR_SECTS,`20
X`091`09' directory segment in ' // In_File_name(1:Q) // ' ++'
X`09EndIf
X
X`09Do 70 I = 2, DIR_SECTS*4
X`09    Call Get_Byte_Knt( DIR_ENTRY, 32 )
X`09    `09If ( STATUS .eq. 0 ) Then
X`09`09    If ( N .eq. max_num_members ) goto 100
X`09`09    N = N + 1
X`09`09    Member_Names(N) = ' '
X`09`09    M = 1
X`09`09    Do While ( M .le. 8 .and. Name(M) .ne. ' ' )
X`09`09`09    Member_Names(N)(M:M) = Char( Name(M) )
X`09`09`09    M = M + 1
X`09`09    EndDo
X`09`09    Member_Names(N)(M:M) = '.'
X`09`09    Hdr_Vers(N) = 10`09`09`09! Special blank
X`09`09    Do K=1,3
X`09`09`09    Member_NAMES(N)(M+K:M+K) = Char( EXTEN(K) )
X`09`09    EndDo
X`09`09    Temp = NSECTS
X`09`09    Num_Bytes_ARR(N) = Temp * 128
X`09`09    Act_Len(N) = Num_Bytes_ARR(N)`20
X`09`09    Temp = Indx
X`09`09    First_Byte_arr(N) = Temp * 128 + 1
X`09`09    CRCS(N) = CRC
X`09`09    If ( Crea_Date .ne. 0 ) Then
X`09`09`09Call LBR_Date_Str( 78, Crea_Date, Mem_Date(N) )
X`09`09    Else
X`09`09`09Mem_Date(N) = '   --'
X`09`09    EndIf
X`09`09    If ( Crea_Time .ne. 0 ) Then
X`09`09`09Call Time_Str( Crea_Time, Mem_Time(N) )
X`09`09    Else
X`09`09`09Mem_Time(N) = '  -'
X`09`09    EndIf
X`09    EndIf
X70`09Continue
X
XC`09Now lets determine how many of the members are squeezed
X
X`09Do I = 1, N
X`09  Call Position_Lib( First_Byte_Arr(I) )
X`09  Call Get_Byte_KNT( I2, 2 )`09`09! Read first 2 bytes
X`09  If ( I2 .eq. LBR_recognize ) Then
X`09    Hdr_Vers(I) = 4`09`09`09! Squeezed`20
X`09    Act_Len(I) = 0`09`09`09! Unknown actual size
X`09    Call Get_Byte_Knt( I2, 2 )`09`09! Get past the CRC
X`09    File_Name = ' '`20
X`09    Call Get_Byte( C )`09`09`09! Get the member orig name
X`09    K = 1
X`09    Do While ( C .ne. 0 )
X`09      File_Name(K:K) = Char( C )
X`09      Call Get_Byte( C )
X`09      K = K + 1
X`09    EndDo
X`09    Member_Names(I) = File_Name
X`09  Else
X`09    Hdr_Vers(I) = 2`09`09`09! Not squeezed
X`09  EndIf
X`09EndDo
X
X`09Goto 100
X`0C`0A
X
XC`09Read the .ARC file to get 'directory' type info
X
X75`09Continue`09`09! Get info for .ARC file
X
X`09Type *, 'Gathering "directory" information for ', In_File_Name(1:Q)
X`09Type *, ' '
X
X`09Call Get_Byte( C )
X
X`09Do While ( C .ne. -1 )
X`09  If ( C .ne. ArcMark ) Then`09`09! Not an ARC file
X`09    I = 0
X`09    Do While ( C .ne. ArcMark .and. I .lt. 10 )
X`09      Call Get_Byte( C )
X`09      I = I + 1
X`09    EndDo
X`09    If ( I .ge. 10 ) Then
X`09      Write( 6, * ) '+++ Requested file not an ARC file +++'
X`09      Write( 6, * ) '+++ Could not find the mark of ARC +++'
X`09      Goto 700
X`09    Else
X`09      Write( 6, * ) '+++ Bad Header encountered +++'
X`09      Write( 6, 1030 ) '+++ Skipped ', I, ' bytes  +++'
X`09    EndIf
X`09  EndIf
X
X`09  Call Get_Byte( Hdr_Ver )
X`09  If ( Hdr_Ver .lt. 0 ) Then `09`09! invalid header
X`09   Type *, 'Cannot handle this version of .ARC file:', Hdr_ver
X`09   goto 700
X`09  EndIf
X`09  If ( Hdr_Ver .eq. 0 ) Then `09`09! special endoffile
X`09    GoTo 100
X`09  EndIf
X
X`09  If ( N .eq. max_num_members ) goto 100
X`09  N = N + 1
X
X`09  Call Get_Byte_Knt( TBytes, 13 )
X
X`09  Member_NAMES(N) = ' '
X`09  M = 1
X`09  Do While ( TBytes(M) .ne. 0 )
X`09    Member_NAMES(N)(M:M) = Char( TBytes(M) )
X`09    M = M + 1
X`09  EndDo
X
X`09  Call Get_Byte_Knt( Num_Bytes_Arr(N), 4 )
X`09  Call Get_Byte_Knt( Crea_Date, 2 )
X`09  If ( Crea_Date .ne. 0 ) Then
X`09    Call ARC_Date_Str( Crea_Date, Mem_Date(N) )
X`09  Else
X`09    Mem_Date(N) = '   --'
X`09  EndIf
X`09  Call Get_Byte_Knt( Crea_Time, 2 )`09`09! Discard time`20
X`09  If ( Crea_Time .ne. 0 ) Then
X`09    Call Time_Str( Crea_Time, Mem_Time(N) )
X`09  Else
X`09    Mem_Time(N) = '  -'
X`09  EndIf
X`09  Call Get_Byte_Knt( CRCs(N), 2 )
X
X`09  If ( Hdr_Ver .gt. 1 ) Then
X`09    Call Get_Byte_Knt( Act_Len(N), 4 )`09`09! expanded length
X`09  Else
X`09    Act_Len(N) = Num_Bytes_Arr(N)
X`09  EndIf
X
X`09  Hdr_Vers(N) = Hdr_Ver
X`09  First_Byte_arr(N) = Buf_Index + First_In - 1
X
X`09  Call Position_Lib( Num_Bytes_Arr(N) + First_Byte_Arr(N) )
X
X`09  Call Get_Byte( C )
X
X`09EndDo
X`0C`0A
X
XC`09Now display the directory for this library
X
X100`09Continue
X`09Num_Members = N
X
X150`09Continue
X`09If ( Num_Members .GT. 1 ) Then
X`09   Write( 6, 1030 ) '++ There are ', Num_Members,`20
X`091`09`09`09' members ++'
X`09Else
X`09   Write( 6, 1030 ) '++ There is ', Num_Members, ' member ++'
X`09EndIf
X
X`09Write( 6, 1020 ) ' '
X`09Write( 6, 1008 )
X`09Write( 6, 1009 )
X`09Do I = 1, Num_Members
X`09  K = Index( Member_Names(I), '.' )`09`09! Make sure that`20
X`09  If ( K .eq. 0 ) Then`09`09`09`09! that created files
X`09    K = 1`09`09`09`09`09! don't get a .DAT
X`09    Do While ( Member_Names(I)(K:K) .ne. ' ' )`09! extension when
X`09      K = K + 1`09`09`09`09`09! extracting a member
X`09    EndDo`09`09`09`09`09! that has no extension
X`09    Member_Names(I)(K:K) = '.'
X`09  EndIf
X`09  NBLKS = Num_Bytes_Arr(I) / 512
X`09  If ( NBLKS*512 .ne. Num_Bytes_ARR(I) ) Nblks = NBlks + 1
X`09  Technique = Techs( Hdr_Vers(I) )
X`09  Actual_Len_Str = '    ??'
X`09  If ( Act_Len(I) .ne. 0 ) Then
X`09    Write( Actual_Len_Str, 1001, Err=160 ) Act_Len(I)
X`09  EndIf
X160`09  Write( 6,1010 ) I, Member_NAMES(I), Num_Bytes_Arr(I), CRCS(I),
X`091`09`09  Mem_Date(I), Mem_Time(I)(1:5), Technique,`20
X`091`09`09  Actual_Len_Str
X`09EndDo
X`0C`0A
X
Xc`09Now lets see if the user wants to extract any members
X
X200`09Continue
X`09Type 1020, ' '
X`09Type 1020, '$Enter command (? for list) `5BX`5D: '
X`09Accept 1020, ANS
X`09If ( ANS .eq. ' ' ) ANS = 'X'
X`09If ( ANS .eq. 'x' .or. ANS .eq. 'X' ) Goto 800
X
X`09View_flg = .False.
X`09Extr_flg = .False.
X`09Bin_flg  = .False.
X`09Ivcr = 0
X
X`09If ( ANS .eq. '?' ) Goto 230
X`09If ( ANS .eq. 'l' .or. ANS .eq. 'L' ) GoTo 150
X`09If ( ANS .eq. 'n' .or. ANS .eq. 'N' ) GoTo 700
X   `09If ( ANS .eq. 'i' .or. ANS .eq. 'I' ) ivcr=-1
X   `09If ( ANS .eq. 'k' .or. ANS .eq. 'K' ) ivcr=+1
X`09If ( ANS .eq. 'v' .or. ANS .eq. 'V' ) View_flg = .True.
X`09If ( ANS .eq. 'e' .or. ANS .eq. 'E' ) Extr_flg = .True.
X
X`09If ( View_flg .or. Extr_flg ) GoTo 250
Xc Allow K and I modes to set carriage control for terminal
Xc output...
X`09If(ivcr.eq.0)goto 207
X`09If(ivcr.eq.-1)View_cr=.false.
X`09If(ivcr.eq.1)View_cr=.True.
X`09Goto 200
X207`09Continue
X
X210`09Type *, '-- Illegal Command --'
X
X230`09Continue
X`09Type 1020, ' '
X`09Type 1020, ' Commands available:'
X`09Type 1020, ' '
X`09Type 1020, '   E - Extract a member to a file'
X`09Type 1020, '   L - List the directory again'
X`09Type 1020, '   N - Get a new library file'
X`09Type 1020, '   V - View member at terminal'
X`09Type 1020, '   K - Convert isolated CR or LF to CRLF'
X`09Type 1020, '   I - Leave isolated CR or LF alone (image)'
X`09Type 1020, '   X - No option wanted (exit)'
X`09Type 1020, '   ? - Display this list'
X
X`09GoTo 200
X
X250`09Continue
X`09Type 1400
X`09Accept 1410, N
X
X`09If ( N .le. 0 ) Then
X`09  Type *, '-- Illegal member number --'
X`09  Goto 250
X`09EndIf
X
X`09IF (N .GT. NUM_MEMBERS) THEN
X`09   N1 = 1
X`09   N2 = NUM_MEMBERS
X`09ELSE
X`09   N1 = N
X`09   N2 = N
X`09ENDIF
X
X`09If ( .Not. LBR_Flg ) GoTo 500
X`0C`0A
X
XC`09Now handle selection from .LBR file
X
X300`09Continue
X
X`09DO N = N1, N2
X
X`09Call Position_Lib( First_Byte_Arr(N) )
X`09Remaining_Size = Num_Bytes_Arr(N)
X
X`09CRC_Val = 0
X
X`09If ( Hdr_Vers(N) .eq. 4 ) Then
X`09  Squeezed = .True.
X`09  Call LBR_Init_UnSq`09`09`09`09! Init the decode tree
X`09Else
X`09  Squeezed = .False.
X`09EndIf
X
X`09Call Open_Ext_File( File_Name )`09`09! Open the output LUN
X
X`09If ( Squeezed ) Then
X`09  Call Get_Char_Sq( I2 )
X`09  Do While (( I2 .ne. -1 ) .and. .Not. Cancel_Op )
X`09    Call Put_Char_UnComp( I2 )
X`09    Call Get_Char_Sq( I2 )
X`09  EndDo
X`09Else
X`09  Call Get_Char( I2 )
X`09  Do While (( I2 .ne. -1 ) .and. .Not. Cancel_op )
X`09    Call Put_Char_CRC( I2 )
X`09    Call Get_Char( I2 )
X`09  EnDDo
X`09EndIf
X
X`09If (Remaining_Size.gt.0) Then
X`09  Call Get_Char_Knt( FBuf, Remaining_Size)`09! Finish CRC
X`09EndIf
X
X`09Call Close_Ext_File( CRCS(N) )
X
X`09ENDDO
X
X`09GoTo 200
X`0C`0A
X
XC`09This code is for the .ARC library format
X
X500`09Continue
X
X`09DO N = N1, N2
X
X`09Call Position_Lib( First_Byte_Arr(N) )
X`09Remaining_Size = Num_Bytes_Arr(N)
X
X`09CRC_Val = 0
X
X`09GoTo ( 510, 510, 520, 530, 590, 590, 590, 540 ), Hdr_Vers(N)
X`09Type *, '--- Illegal or Unknown ARC Header value: ', Hdr_Vers(N)
X`09GoTo 200
X
X510`09Continue `09`09! Extract member that has no compression
X`09Call Open_Ext_File( Member_Names(N) )
X
X`09Call Get_Char( I2 )
X`09Do While (( I2 .ne. -1 ) .and. .Not. Cancel_Op )
X`09  Call Put_Char_CRC( I2 )
X`09  Call Get_Char( I2 )
X`09EnDDo
X`09Goto 595
X
X520`09Continue`09`09! Extract member that uses DLE compression
X`09Call Open_Ext_File( Member_Names(N) )      `20
X
X`09Call Get_Char( I2 )
X`09Do While (( I2 .ne. -1 ) .and. .Not. Cancel_Op )
X`09  Call Put_Char_UnComp( I2 )
X`09  Call Get_Char( I2 )
X`09EnDDo
X`09Goto 595
X
X530`09Continue`09`09! Extract Member that uses Huffman squeeze
X`09Call Open_Ext_File( Member_Names(N) )
X
X`09Type *, ' '
X`09Type *, '--- Warning --- File may not extract properly ---'
X`09Type *, ' '
X
X`09Call Init_Unsq
X`09Call Get_Char_Sq( I2 )
X`09Do While (( I2 .ne. -1 ) .and. .Not. Cancel_Op )
X`09  Call Put_Char_UnComp( I2 )
X`09  Call Get_Char_Sq( I2 )
X`09EnDDo
X`09Goto 595
X
X540`09Continue
X`09Call Open_Ext_File( Member_Names(N) )
X`09Call DeComp_LZW_Var
X`09Goto 595
X
X590`09Continue
X`09Type *, 'Not implemented yet, Need a newer version'
X`09Type *, '(Also, old crunch options not supported.)'
X`09GoTo 200
X
X595`09Continue
X`09Call Close_Ext_File( CRCS(N) )
X
X`09ENDDO
X
X`09GoTo 200
X
Xc`09Now lets setup for another lib file`20
X
X700`09Continue
X`09Close( Unit=2 )`20
X`09Goto 10
X
X800`09Continue
X
X`09Call Exit
X`0C`0A
X
X900`09Continue
X`09If ( IOS .gt. 68 ) Then
X`09  Type *,'Unkown error on OPEN:', IOS
X`09Else`20
X`09  Type *, 'Error on OPEN: ', For_IOS( IOS )
X`09EndIf
X
X`09Call Exit
X
X1000`09Format( ' ', a, '     ', i4 )
X1001`09Format( I8 )
X1008`09Format( '   #  Member Name   # Bytes  CRC     Date    Time   ',
X`091`09'Stor. Type  Actual Len' )
X1009`09Format( ' ---- ------------  -------  ----  --------  -----  ',
X`091`09'----------  ----------' )
X1010`09Format( ' ', I3, '. ', a, '  ', I7, '  ', Z4.4, 4( '  ', A ) )
X
X1011`09Format( ' Extracting: ', a, '.', a, ', First Byte: ', I7,`20
X`091`09', # Bytes: ', I7 )
X1020`09Format( a )
X1021`09Format( q, a )
X1030`09Format( ' ', a, I4, a )
X1110`09Format( ' Member#', I3, '. ', a,`20
X`091`09', First: ', i7, ', Number: ', i7  )
X1111`09Format( ' ', A, I7 )
X1400`09Format( '$Enter member number (9999 for all) : ' )
X1410`09Format( I3 )
X
X`09End
X`0C`0A
XC------------------------------------------------------------------------
XC`09Subroutine called to open an output LUN for processing a member
XC`09of library (eitrher .LBR or .ARC)
XC                                                  `20
XC`09Inputs:
XC`09`09File_Name`09Member filename
XC
XC`09Outputs:
XC`09`09The Bin_Flg will be set if the extension of the file is
XC`09`09.EXE, .BIN, .COM, .CMD, .OVR etc...
XC
XC------------------------------------------------------------------------
X
X`09Subroutine Open_Ext_File( File_Name )
X
X`09Implicit None
X
X`09Logical*1`09File_Flg, Squeezed, Ctrlz_Flg
X
X`09Character`09File_Name*(*), Carriage*4, ANS, File_Ext*3
X`09Character`09Open_Name*12
X
X`09Integer`09`09K, I, IOS, Record_Length
X
X`09Logical*1`09View_Cr, View_flg, Bin_flg, Extr_flg
X`09Logical*1`09LBR_Flg, Cancel_Op, AST_On_Flg
X`09Integer`09`09Remaining_Size
X`09Integer*2`09CRC_Val
X`09Common`09/Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg,`2
V0
X`091`09`09 LBR_Flg, Cancel_Op, AST_On_Flg, CRC_Val
X
X`09Integer`09`09First_In, Last_In, Buf_Index, Buf_Length
X`09Integer`09   `09Out_Index, Out_Length, Out_Num
X`09Byte`09`09In_Buf(4096), Out_Buf(512)
X`09Common`09/Buffers/ First_In, Last_In, Buf_Index, Buf_Length, In_Buf,
X`091`09`09Out_Buf, Out_Index, Out_Length, Out_Num
X
X`09Character`09For_IOS(68)*30
X`09Common`09/ForIOS/ For_IOS
X
X`09Out_Num = 0
X`09Bin_Flg = .True.
X`09K = Index( File_Name, '.' )
X`09If ( K. eq. 0 )Then
X`09  Type *, 'Is ', File_Name, ' a text file? '
X`09  Accept 1100, Ans
X`09  If ( Ans .eq. 'y' .or. Ans .eq. 'Y' ) Bin_Flg = .False.
X`09Else
X`09  File_Ext = File_Name(K+1:K+3)
X`09  Do K = 1, 3`09`09`09! Upcase the extension
X`09    If ( File_Ext(K:K) .ge. 'a' .and. File_Ext(K:K) .le. 'z' ) Then
X`09      File_Ext(K:K) = Char( Ichar( File_Ext(K:K) ) - '40'o )
X`09    EndIf
X`09  EndDo
X          K = Index( ' LBR ARC COM EXE REL CMD COM OVR BIN', File_Ext )
X`09  Bin_Flg = .False.`20
X`09  If ( K .ne. 0 ) Bin_Flg = .True.
X`09EndIf
X
X`09If ( .Not. Bin_Flg ) Then
X`09  Type *, '++ Member being treated as Text (Bit 8 cleared) ++'
X`09EndIf
X
X`09If ( View_flg .and. Bin_Flg ) Then
X`09  Type *, '---> Can''t view a binary file, extracting...'
X`09  View_Flg = .False.
X`09EndIf
X
X`09If ( Bin_Flg ) Then
X`09  Out_Length = 128
X`09  Carriage = 'NONE'
X`09Else
X`09  Out_Length = 510
X`09  Carriage = 'LIST'
X`09EndIf
X
X`09Cancel_op = .False.
X
X`09If ( View_flg ) Then
X`09  Open_Name = 'Sys$OutPut'
X`09Else
X`09  OPen_Name = File_Name
X`09  Do I = 1, 11
X`09    If ( Open_Name(I:I) .eq. '-' ) Open_Name(I:I) = '_'
X`09  EndDo
X`09  Write( 6, * ) 'Extracting to ', Open_Name, '...'
X`09EndIf
X
X`09If ( .Not. AST_On_Flg ) Then
X`09  Call Cancel_AST_Start
X`09  AST_On_Flg = .True.
X`09EndIf
X
X`09Type *, '+++ To cancel operation type Ctrl-C +++'
X`09Type *, ' '
X
X`09Open( Unit=1, File=Open_Name, Status='NEW', RecL=Out_Length,`20
X`091     IoStat=IOS, CarriageControl=Carriage, Err=900 )
X
X`09Return
X
X900`09Continue
X`09Type *, 'Error opening file: ', FOR_IOS( IOS )
X`09Return
X
X1100`09Format( A )
X
X`09End
X`0C`0A
XC------------------------------------------------------------------------
XC`09Subroutine used to close the open LUN used for extract and View
XC`09commands. Insures that the last partial buffer is written.
XC
XC`09Inputs:
XC`09`09Uses info in buffer common to empty the output buffer
XC`09`09If needed.
XC
XC`09Outputs:
XC`09`09The last buffer is emptied before closing the LUN
XC
XC------------------------------------------------------------------------
X
X`09Subroutine Close_Ext_File( Mem_CRC )
X
X`09Implicit None
X
X`09Byte`09`09B(2)
X`09Integer*2`09Mem_CRC, Loc_CRC, KeepCRC
X
X`09Equivalence`09( Loc_CRC, B(1) )
X
X`09Integer `09K
X
X`09Integer`09`09First_In, Last_In, Buf_Index, Buf_Length
X`09Integer`09 `09Out_Index, Out_Length, Out_Num
X`09Byte`09`09In_Buf(4096), Out_Buf(512)
X`09Common`09/Buffers/ First_In, Last_In, Buf_Index, Buf_Length, In_Buf,
X`091`09`09Out_Buf, Out_Index, Out_Length, Out_Num
X
X`09Logical*1`09View_Cr, View_flg, Bin_flg, Extr_flg
X`09Logical*1`09LBR_Flg, Cancel_Op, AST_On_Flg
X`09Integer`09`09Remaining_Size
X`09Integer*2`09CRC_Val
X`09Common`09/Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg,`2
V0
X`091`09`09 LBR_Flg, Cancel_Op, AST_On_Flg, CRC_Val
X
Xc`09Start of routine code
X
X`09Loc_CRC = Mem_CRC          `20
X
X`09If ( Out_Index .gt. 1 ) Then
X`09  Write( 1, 1100 ) (Out_Buf(K), K=1,Out_Index)
X`09  Out_Num = Out_Num + 1
X`09  Out_Index = 1
X`09EndIf
X
X`09If ( Cancel_Op ) Then
X`09  Close( Unit=1, Disp='DELETE' )
X`09Else
X`09  Close( Unit=1 )
X`09  KeepCRC = CRC_Val
X`09  If ( .Not. LBR_Flg ) Then
X`09    Call ARC_CRC( CRC_Val, B(1) )
X`09    Call ARC_CRC( CRC_Val, B(2) )
X`09  Else
X`09    Call LBR_CRC( CRC_Val, B(2) )
X`09    Call LBR_CRC( CRC_Val, B(1) )
X`09  EndIf
X`09  If ( Mem_CRC .ne. 0 ) Then`09`09! Zero CRC means no check
X`09    If ( CRC_Val .ne. 0 ) Then
X`09      Type *,'--- Warning --- CRC Error ---'
X`09      Type 2000, Mem_CRC, KeepCRC, Crc_Val
X2000`09      Format( ' Member CRC: ', Z4.4, ', Calc''d CRC: ', Z4.4,`20
X`091`09`09', Final value CRC: ', Z4.4 )
X`09    EndIf
X`09  EndIf
X`09EndIf
X
X`09If ( .Not. View_Flg .and. .Not. Cancel_Op ) Then
X`09  If ( Bin_Flg )Then
X`09    Type 1000, Out_Num
X`09  Else
X`09    Type 1001, Out_Num
X`09  EndIf
X`09EndIf
X
X`09Return
X1000`09Format( //' --> ', I6, ' Records written' )
X1001`09Format( //' --> ', I6, ' Lines written' )
X1100`09Format( 510A1 )
X
X`09End
X`0C`0A
XC------------------------------------------------------------------------
XC`09Subroutine used to get the next byte from the input buffer
XC`09If the input buffer is empty the next record will be read`20
XC
XC`09Inputs:
XC`09`09Common containing information about the buffers
XC
XC`09OutPut:
XC`09`09C is the next byte value from the input buffer
XC
XC------------------------------------------------------------------------
X
X`09Subroutine Get_Byte( C )
X
X`09Implicit None
X
X`09Byte`09`09C
X
X`09Integer`09`09First_In, Last_In, Buf_Index, Buf_Length
X`09Integer`09 `09Out_Index, Out_Length, Out_Num
X`09Byte`09`09In_Buf(4096), Out_Buf(512)
X`09Common`09/Buffers/ First_In, Last_In, Buf_Index, Buf_Length, In_Buf,
X`091`09`09Out_Buf, Out_Index, Out_Length, Out_Num
X
X`09If ( Buf_Index .gt. Buf_Length ) Then
X`09    Call Position_Lib( Last_In + 1 )
X`09EndIf
X
X`09C = In_Buf( Buf_Index )
X`09Buf_Index = Buf_Index + 1
X
X`09Return
X`09End
X`0C`0A
XC------------------------------------------------------------------------
XC`09Subroutine used to get the next byte from the input buffer
XC`09Call Get_Byte after checking remaining size of member
XC
XC`09Inputs:
XC`09`09Common containing information about the member
XC
XC`09OutPut:
XC`09`09I is the next byte value from the input buffer in I*2
XC
XC------------------------------------------------------------------------
X
X`09Subroutine Get_Char( I )
X
X`09Implicit None
X
X`09Integer*2`09I, W
X`09Byte`09`09C
X
X`09Integer*4`09Knt
X
X`09Equivalence`09( W, C )
X
X`09Logical*1`09View_Cr, View_flg, Bin_flg, Extr_flg
X`09Logical*1`09LBR_Flg, Cancel_Op, AST_On_Flg
X`09Integer`09`09Remaining_Size
X`09Integer*2`09CRC_Val
X`09Common`09/Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg,`2
V0
X`091`09`09 LBR_Flg, Cancel_Op, AST_On_Flg, CRC_Val
X
X`09W = 0
X`09If ( remaining_Size .gt. 0 ) Then
X`09    Call Get_Byte( C )
X`09    Remaining_Size = Remaining_Size - 1
X`09    If ( LBR_Flg ) Then
X`09`09Knt = Knt + 1
X`09`09Call LBR_CRC( CRC_Val, C )
Xc`09`09Type 10, 'Knt: ', Knt, ', Char: ', C, ', CRC: ', CRC_Val
Xc10`09`09Format( x, A, I5, A, Z2, A, Z4.4 )
X`09    EndIf
X`09Else
X`09    W = -1
X`09EndIf
X
X`09I = W
X
X`09Return
X`09End
X`0C`0A
XC------------------------------------------------------------------------
XC`09Subroutine used to get KNT bytes from input
XC`09Call the Get_Byte subroutine to minimize buffer manipulation
XC
XC`09Input:
XC`09`09Buffer address to fill
XC`09`09KNT number of bytes to fill
XC
XC`09Output:
XC`09`09Fills parameter buffer with KNT bytes
XC
XC------------------------------------------------------------------------
X
X`09Subroutine Get_Byte_Knt( Buf, Knt )
X
X`09Implicit None
X
X`09Integer`09`09Knt, I
X
X`09Byte`09`09Buf(KNT)
X
X`09Do I = 1, KNT
X`09    Call Get_Byte( Buf(I) )
X`09EndDo
X
X`09Return
X`09End
X`0C`0A
XC------------------------------------------------------------------------
XC`09Subroutine used to get KNT bytes from input
XC`09Call the Get_Char subroutine to minimize buffer manipulation
XC
XC`09Input:
XC`09`09Buffer address to fill
XC`09`09KNT number of bytes to fill
XC
XC`09Output:
XC`09`09Fills parameter buffer with KNT bytes
XC
XC------------------------------------------------------------------------
X
X`09Subroutine Get_Char_Knt( Buf, Knt )
X
X`09Implicit None
X
X`09Integer`09`09Knt, I
X
X`09Byte`09`09Buf(KNT)
X
X`09Do I = 1, KNT
X`09    Call Get_Char( Buf(I) )
X`09EndDo
X
X`09Return
X`09End
X`0C`0A
XC------------------------------------------------------------------------
XC`09Subroutine that translates a byte to ASCII
XC
XC`09Input:
XC`09`09Will call Get_Char to get a bytes needed for translation
XC
XC`09Output:
XC`09`09The translated value (unsqueezed) in I*2 format
XC
XC------------------------------------------------------------------------
X
X`09Subroutine Get_Char_Sq( W )
X
X`09Implicit None
X
X`09Integer*2`09SpEOF
X`09Parameter`09( SPEOF = 256 )
X
X`09Integer*2`09W
X`09Integer*2`09I, K, CurIn
X
X`09Integer*2`09DNode(0:255,0:1), BPos
X`09Common`09/UnSq/`09DNode, BPos
X
X`09I = 0
X`09Do While ( I .ge. 0 )
X`09  BPos = BPos + 1
X`09  If ( BPos .gt. 7 ) Then
X`09    BPos = 0
X`09    Call Get_Char( CurIN )
X`09    If ( Curin .eq. -1 ) Then
X`09      W = -1
X`09      Return
X`09    EndIf
X`09  Else
X`09    Curin = Ishft( Curin, -1 )`09`09!!!VMS!!! VAX intrinsic function
X`09  EndIf
X`09  K = Curin .and. 1
X`09  I = DNode( I, K )
X`09EndDo
X
X`09I = -( I + 1 )
X`09If ( I .eq. SPEOF ) Then
Xc`09  Type *, 'Special End of File found'
X`09  W = -1
X`09Else
X`09  W = I
X`09EndIf
X`09Return
X`09End                       `20
X`0C`0A
XC------------------------------------------------------------------------
XC`09Subroutine used to put a byte into outbut buffer and will check
XC`09for compression using the DLE technique
XC
XC`09Input:
XC`09`09W`09I*2 value holding the char to output
XC
XC`09Output:        `20
XC`09`09Places data into the output buffer
XC
XC------------------------------------------------------------------------
X
X`09Subroutine Put_Char_UnComp( W )
X
X`09Implicit None
X
X`09Integer*2`09DLE
X`09Parameter`09( DLE = '90'x )
X
X`09Integer*2`09W, WC, RepCt, LastC
X
X`09Byte`09`09C
X
X`09Equivalence`09( WC, C )
X
X`09Data`09RepCt`09/0/
X
X`09If ( Repct .gt. 0 ) Then`09`09! Are we repeating a char?
X`09  If ( W .eq. 0 ) Then
X`09    Call Put_Char_Crc( DLE )`09`09! DLE was a real one
X`09  Else`09`09`09`09`09! Count is what we have
X`09    RepCt = W`09`09`09`09! Set the count right
X`09    repct = repct - 1`09`09`09! Now put the proper
X`09    Do While ( repCt .gt. 0 )`09`09!  number of characters
X`09      Call Put_Char_Crc( LastC )`09!  into the buffer
X`09      repct = repct - 1
X`09    EndDo
X`09  EndIf
X`09  repct = 0`09`09`09`09! All done with this repeat
X`09Else`09`09`09`09`09! Not repeating yet
X`09  If ( W .eq. DLE ) Then`09`09! Repeat introducer?
X`09    RepCt = 1`09`09`09`09! Yes, flag the repeat
X`09  Else`09`09`09`09`09! No, just put the char
X`09    Call Put_Char_Crc( W )`09`09! Always save last sent
X`09    LastC = W
X`09  EndIf
X`09EndIf
X
X`09Return
X`09End
X`0C`0A
XC------------------------------------------------------------------------
XC`09Subroutine that places a byte into the output buffer
XC
XC`09Input:
XC`09`09A byte value
XC
XC`09OutPut:
XC`09`09The byte will be placed into the output buffer. When the
XC`09`09buffer is full then it will be written.
XC
XC------------------------------------------------------------------------
X
X`09Subroutine Put_Byte( C )
X
X`09Implicit None
X
X`09Byte`09`09CR, LF
X`09Parameter`09( LF = '12'o )
X`09Parameter`09( CR = '15'o )
X
X`09Byte`09`09C
X
X`09Logical*1`09CR_Flg
X
X`09Integer `09K
X
X`09Logical*1`09View_Cr, View_flg, Bin_flg, Extr_flg
X`09Logical*1`09LBR_Flg, Cancel_Op, AST_On_Flg
X`09Integer`09`09Remaining_Size
X`09Integer*2`09CRC_Val
X`09Common`09/Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg,`2
V0
X`091`09`09 LBR_Flg, Cancel_Op, AST_On_Flg, CRC_Val
X
X`09Integer`09`09First_In, Last_In, Buf_Index, Buf_Length
X`09Integer`09 `09Out_Index, Out_Length, Out_Num
X`09Byte`09`09In_Buf(4096), Out_Buf(512)
X`09Common`09/Buffers/ First_In, Last_In, Buf_Index, Buf_Length, In_Buf,
X`091`09`09Out_Buf, Out_Index, Out_Length, Out_Num
X
X`09Data`09CR_Flg /.False./
X
X`09If ( .Not. Bin_Flg ) Then
X`09  C = C .and. '7F'x
X`09  If ( C .eq. '1a'x ) Then`09`09! If `5Ez don't put in file
Xc`09    Remaining_Size = 0
X`09    Return
X`09  EndIf
X
X`09  If ((C.eq.LF.or.C.eq.CR).and.View_cr)Then
Xc Write out line if CR or LF up to what's saved alread.
Xc View_Cr mode only...
X`09    Write(1, 1100) (Out_Buf(K), K=1,Out_Index-1)
X`09    Out_Index=1
X`09    Out_Num = Out_Num+1
X`09    CR_FLG = .False.
X`09    Return
X`09  Endif
X`09  If ( CR_Flg ) Then
X`09    If ( C .eq. LF ) Then
X`09      Write( 1, 1100 ) (Out_Buf(K), K=1,Out_Index-1)
X`09      Out_Index = 1
X`09      Out_Num = Out_Num + 1
X`09      CR_Flg = .False.
X`09      Return
X`09    Else
X`09      Out_Buf( Out_Index ) = CR
X`09      Out_Index = Out_Index + 1
X`09      If ( Out_Index .gt. Out_Length ) Then
X`09       Write( 1, 1100 ) (Out_Buf(K), K=1,Out_Length )
X`09       Out_Index = 1
X`09       Out_Num = Out_Num + 1
X`09      EndIf
X`09    EndIf
X`09  EndIf
X`09  If ( C .eq. CR ) Then
X`09    CR_Flg = .True.
X`09    Return
X`09  EndIf
X`09  Cr_Flg = .False.
X`09EndIf
X
X`09Out_Buf( Out_Index ) = C
X`09Out_Index = Out_Index + 1
X
X`09If ( Out_Index .gt. Out_Length ) Then
X`09  Write( 1, 1100 ) (Out_Buf(K), K=1,Out_Length )
X`09  Out_Index = 1
X`09  Out_Num = Out_Num + 1
X`09EndIf
X
X`09Return
X
X1100`09Format( 510A1 )
X
X`09End
X`0C`0A
XC------------------------------------------------------------------------
XC`09Subroutine that is used to calc a CRC`20
XC
XC`09Input:
XC`09`09I*2 with the character to add to the CRC
XC
XC`09Output:
XC`09`09Call Put_Byte to add the byte to the output buffer
XC
XC------------------------------------------------------------------------
X
X`09Subroutine Put_Char_Crc( W )
X
X`09Implicit None
X
X`09Logical*1`09View_Cr, View_flg, Bin_flg, Extr_flg
X`09Logical*1`09LBR_Flg, Cancel_Op, AST_On_Flg
X`09Integer`09`09Remaining_Size
X`09Integer*2`09CRC_Val
X`09Common`09/Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg,`2
V0
X`091`09`09 LBR_Flg, Cancel_Op, AST_On_Flg, CRC_Val
X
X`09Integer*2`09W, Wc, Knt
X
X`09Byte`09`09C
X
X`09Equivalence`09( Wc, C )
X
X`09Wc = W
X`09Call Put_Byte( C )
X
X`09If ( .Not. Lbr_Flg ) Then
X`09  Call ARC_CRC( CRC_Val, C )
Xc`09  Type 10, 'Rem: ', Remaining_size, ', Char: ', C, ', CRC: ', CRC_Val
Xc10`09  Format( x, A, I5, A, Z2, A, Z4.4 )
X`09EndIf
X
X`09Return
X`09End
X`0C`0A
XC------------------------------------------------------------------------
XC`09Subroutine that process the header of a squeezed member of a`20
XC`09LBR file.`20
XC
XC------------------------------------------------------------------------
X
X`09Subroutine LBR_Init_UnSq
X
X`09Implicit None
X
X`09Integer*2`09I2, K
X
X`09Byte`09`09C
X
X`09Logical*1`09View_Cr, View_flg, Bin_flg, Extr_flg
X`09Logical*1`09LBR_Flg, Cancel_Op, AST_On_Flg
X`09Integer`09`09Remaining_Size
X`09Integer*2`09CRC_Val
X`09Common`09/Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg,`2
V0
X`091`09`09 LBR_Flg, Cancel_Op, AST_On_Flg, CRC_Val
X
X`09Call Get_Char_KNT( I2, 2 )`09`09! Read first 2 bytes
X`09Call Get_Char_Knt( I2, 2 )`09`09! Get past the CRC
X`09Call Get_Char( C )`09`09`09! Get the member orig name
X`09Do While ( C .ne. 0 )`09`09`09!  Read all of it
X`09  Call Get_Char( C )`09`09`09!  until we point to the
X`09EndDo`09`09`09`09`09!  decode tree
X
X`09Call Init_UnSq`09`09`09`09! Read the decode tree
X
X`09Return
X`09End
X`0C`0A
XC------------------------------------------------------------------------
XC`09Subroutine that sets up the translation array for the specified`20
XC`09member`20
XC
XC`09Input:
XC
XC`09Output:
XC`09`09The translation node array is filled in`20
XC
XC------------------------------------------------------------------------
X
X`09Subroutine Init_UnSq
X
X`09Implicit None
X
X`09Integer*2`09SpEOF
X`09Parameter`09( SPEOF = 256 )
X
X`09Integer*2`09I, NumNodes
X
X`09Logical*1`09View_Cr, View_flg, Bin_flg, Extr_flg
X`09Logical*1`09LBR_Flg, Cancel_Op, AST_On_Flg
X`09Integer`09`09Remaining_Size
X`09Integer*2`09CRC_Val
X`09Common`09/Global/ Remaining_Size, View_Cr, View_Flg, Bin_Flg, Extr_Flg,`2
V0
X`091`09`09 LBR_Flg, Cancel_Op, AST_On_Flg, CRC_Val
X
X`09Integer*2`09DNode(0:255,0:1), BPos
X`09Common`09/UnSq/`09DNode, BPos
X
X`09Call Get_Char_Knt( NumNodes, 2 )
X
X`09BPos = 100
X`09Dnode(0,0) = -(SPEOF+1)
X `09Dnode(0,1) = -(SPEOF+1)
X
X`09NumNodes = NumNodes - 1
X
X`09Do I = 0, NumNodes
X`09  Call Get_Char_Knt( DNode( I, 0 ), 2 )
X`09  Call Get_Char_Knt( DNode( I, 1 ), 2 )
X`09EndDo
X
Xd`09  Write( 6, * ) 'Translation arrays:'
Xd`09  Do I = 0, NumNodes
Xd`09    Write( 6, 1000 ) I, Dnode(I,0), Dnode(I,1)
Xd1000`09    Format( ' #', I3, 2( ' ', Z4.4 ) )
Xd`09  EndDo
X
X`09Return
X`09End
X`0C`0A
XC------------------------------------------------------------------------
XC`09Subroutine called to position to a specified byte of a library`20
XC`09file opened on LUN 2
XC
XC`09Inputs:
XC`09`09Byte_Lk`09`09The first byte wanted
XC
XC`09Outputs:
XC`09`09Will put the requested byte in the buffer
XC
XC------------------------------------------------------------------------
X
X`09Subroutine Position_Lib( Byte_Lk )
X
X`09Implicit None
X
X`09Character`09For_IOS(68)*30
X`09Common`09/ForIOS/ For_IOS
X
X`09Integer`09`09I, J, K, L, Q, Byte_Lk, IoS
X
X`09Integer`09`09First_In, Last_In, Buf_Index, Buf_Length
X`09Integer`09 `09Out_Index, Out_Length, Out_Num
X`09Byte`09`09In_Buf(4096), Out_Buf(512)
X`09Common`09/Buffers/ First_In, Last_In, Buf_Index, Buf_Length, In_Buf,
X`091`09`09Out_Buf, Out_Index, Out_Length, Out_Num
X
XC`09Check the starting byte that is requested
X
X100`09Continue
X`09If ( Byte_Lk .lt. First_In ) Goto 150`09`09! Need to REWIND file
X`09If ( Byte_Lk .gt. Last_In ) Goto 200`09`09! Read the next buffer
X
XC`09Otherwise byte is in the current buffer
X
X`09Buf_Index = Byte_Lk - First_In + 1
X
X`09Return
X
XC`09Needed to start over in the file
X
X150`09Continue             `20
X
X`09Rewind`092
X`09Last_In = 0
X
XC`09Read the next buffer
X
X200`09Continue
X`09Do I = 1, 4096
X`09  In_Buf(I) = 0
X`09EndDo
X`09Read( 2, 1010, End=500, Err=800, IoStat=IOS ) Q, ( In_Buf(K),K=1,Q )
X
Xd`09Write( 6, 1111 ) ( In_Buf(K),K=1,128 )
Xd1111`09Format( 8(/' ', 16( z2.2, ' ' ) ) )
X
X`09Buf_Length = Q
X`09First_In = Last_In + 1
X`09Last_In = First_In + Buf_Length - 1
X
X`09Goto 100
X
XC`09End of File Encountered while attempting to find a sector
X
X500`09Continue
X`09Rewind 2
X`09First_In = 0
X`09Last_In = 0
X
X`09Return
X
XC`09Error occurred on read
X
X800`09Continue
X`09If ( IOS .gt. 68 ) Then
X`09  Type *, 'Unknown error on READ: ', IOS
X`09Else
X`09  Type *, 'Error on READ: ', For_IOS( IOS )
X`09EndIf
X
X`09Return
X
X1010`09Format( Q, 4096A1 )
X
X`09End
X`0C`0A
XC---------------------------------------------------------------------------
V----
XC`09Subroutine used to convert a time in MSDOS I*2 format to a string
XC`09This routine calls a VMS FORTRAN shift routine (ISHFT).
XC
XC`09Inputs:
XC`09`09T`092 byte value containing time`20
XC`09`09`09Format: Bits 0-4 is number of 2 sec intervals
XC`09`09`09`09Bits 5-10 is number of minutes
XC`09`09`09`09Bits 11-15 is the number of hours
XC`09Outputs:
XC`09`09T_Str`09in form: hh:mm:ss
XC
XC---------------------------------------------------------------------------
V----
X
X`09Subroutine Time_Str( T, T_Str )
X
X`09Implicit None
X
X`09Integer*2`09T, Work
X`09Integer`09`09Sec, Hr, Min
X
X`09Character`09T_Str*(*)
X
X`09Integer*2`09H_Mask, M_Mask, S_Mask
X`09Parameter`09( H_Mask = 'F800'x,`20
X`091`09`09  M_Mask = '07E0'x,`20
X`091`09`09  S_Mask = '001F'x )
X
X`09Work = T .and. S_Mask
X`09Sec = Work
X
X`09Work = T .and. M_Mask
X`09Work = IShft( Work, -5 )`09`09! Shift right 5 !!!VMS!!!
X`09Min = Work
X
X`09Work = T .and. H_Mask
X`09Work = IShft( Work, -11 )`09`09! Shift right 11 !!!VMS!!!
X`09Hr = Work
X
X`09Write( T_Str, 1000, err = 100 ) Hr, Min, Sec*2
X
X`09Return
X
X100`09Continue
X
X`09T_Str = 'UnKnown'
X
X`09Return
X
X1000`09Format( I2, 2( ':', I2.2 ) )
X
X`09End
X`0C`0A
XC---------------------------------------------------------------------------
V----
XC`09Subroutine used to convert a date in MSDOS File date format into
XC`09a year, month and day.`20
XC
XC`09This routine uses VMS FORTRAN intrinsic function for shifting
XC
XC`09Inputs:
XC`09`09D`092 byte value containing the date`20
XC
XC`09Outputs:
XC`09`09D_Str`09in form: mm/dd/yy
XC
XC---------------------------------------------------------------------------
V----
X
X`09Subroutine ARC_Date_Str( D, D_Str )
X                 `20
X`09Implicit None
X
X`09Integer*2`09D, Work
X`09Integer`09`09Yr, Mo, Dy
X
X`09Character`09D_Str*(*)
X
X`09Integer*2`09Y_Mask, M_Mask, D_Mask
X`09Parameter`09( Y_Mask = 'FE00'x,`20
X`091`09`09  M_Mask = '01E0'x,`20
X`091`09`09  D_Mask = '001F'x )
X
X`09Work = D .and. D_Mask
X`09Dy = Work
X
X`09Work = D .and. M_Mask
X`09Work = IShft( Work, -5 )`09`09! Shift right 5 !!!VMS!!!
X`09Mo = Work
X
X`09Work = D .and. Y_Mask
X`09Work = IShft( Work, -9 )`09`09! Shift right 9 !!!VMS!!!
X`09Yr = Work
X
X`09Write( D_Str, 1000, err = 100 ) Mo, Dy, Yr+80
X
X`09Return
X
X100`09Continue
X
X`09D_Str = 'UnKnown'
X
X`09Return
X
X1000`09Format( I2, 2( '/', I2.2 ) )
X
X`09End
X`0C`0A
XC---------------------------------------------------------------------------
V----
XC`09Subroutines used to convert a count of days from a base date to
XC`09a year, month and day. The base date can be selected.
XC`09This routine uses VMS RTL routines for date and time manipulation.
XC
XC`09Inputs:
XC`09`09BY`09Base year (ie. 80 is 1-Jan-1980 is day 1)
XC`09`09D`092 byte value containing the date that is the number
XC`09`09`09of days since a base date
XC
XC`09Outputs:
XC`09`09D_Str`09in form: mm/dd/yy
XC
XC---------------------------------------------------------------------------
V----
X
X`09Subroutine LBR_Date_Str( BY, D, D_Str )
X
X`09Implicit None
X
X`09Integer*2`09D, Num_Time(7)
X
X`09Integer`09`09BY, Work, Delta(2), Base(2), Act_Date(2)
X
X`09Integer`09`09Lib$SubX, Sys$BinTim, Sys$NumTim, Stat`09!!!VMS!!!
X
X`09Character`09D_Str*(*), Temp_Str*23, Err
X
X`09Err = 'T'
X`09If ( D .gt. 9999 ) Goto 100
X
X`09Err = 'B'
X`09Write( Temp_Str, 1001, Err=100 ) BY-1
X`09Stat = Sys$BinTim( Temp_Str, Base )`09`09!!!VMS!!!
X`09If ( .Not. Stat ) GoTo 100
X
X`09Err = 'D'
X`09Write( Temp_Str, 1000, Err=100 ) D
X`09Stat = Sys$BinTim( Temp_Str, Delta )            !!!VMS!!!
X`09If ( .Not. Stat ) GoTo 100
X
X`09Err = 'S'
X`09Stat = Lib$SubX( Base, Delta, Act_Date, 2 )     !!!VMS!!!
X`09If ( .Not. Stat ) GoTo 100
X
X`09Err = 'N'
X`09Stat = Sys$NumTim( Num_Time, Act_Date )         !!!VMS!!!
X`09If ( .Not. Stat ) GoTo 100
X
X`09Err = 'W'
X`09Write( D_Str, 1002, Err=100 ) Num_Time(2), Num_Time(3),`20
X`091`09`09Num_Time(1)-1900
X
X`09Return
X
X100`09Continue
X`09D_Str = 'Cnv Err' // Err`09`09! Can't convert
X`09Return
X
X1000`09Format( I4.4, ' 00:00:00.00' )
X1001`09Format( '31-DEC-19', I2.2, ' 00:00:00.00' )    `20
X1002`09Format( I2, 2( '/', I2.2 ) )
X
X`09End
X`0C`0A
XC---------------------------------------------------------------------------
V----
XC`09Subroutine used to enable the control C trap used as a cancel signal
XC`09for View and Extract functions.
XC
XC`09This routine is very VMS specific!
XC---------------------------------------------------------------------------
V----
X
X`09Subroutine Cancel_AST_Start
X
X`09Implicit None
X
X`09Integer`09`09JPI_ITEM, IO_Func, K, L, IOS, TT_LEN
X`09Integer`09`09Lib$GetJPI, Sys$Assign, Sys$QioW
X
X`09Integer*2`09TT_Chan
X
X`09Character`09TT_Name*7
X
X`09Include`09`09'($IODEF)'
X`09Include`09`09'($JPIDEF)'
X
X`09External`09Cancel_AST
X
X`09JPI_Item = JPI$_Terminal
X`09IOS = Lib$GetJPI( JPI_ITEM,,,, TT_Name, TT_Len )
X`09If ( .Not. IOS ) Call Lib$Stop( %Val( IOS ) )
X
X`09If ( TT_Name .eq. ' ' ) Then
X`09  TT_Name = 'TT:'
X`09  TT_Len = 3
X`09EndIf
X
X`09IOS = Sys$Assign( TT_Name(1:TT_Len), TT_Chan,, )
X`09If ( .Not. IOS ) Call Lib$Stop( %Val( IOS ) )
X
X`09IO_Func = IO$_SetMode .or. IO$M_CtrlCAST
X
X`09IOS = Sys$QioW( , %Val(TT_Chan), %Val(IO_Func),,,, Cancel_AST,,,,, )
X`09If ( .Not. IOS ) Call Lib$Stop( %Val( IOS ) )
X
X`09Return
X`09End
X`0C`0A
XC---------------------------------------------------------------------------
V----
XC`09Subroutine to set Cancel AST for View and extract functions
XC
XC`09This routine is VMS specific
XC---------------------------------------------------------------------------
V----
X
X`09Subroutine Cancel_AST
X
X`09Implicit None
X
X`09Logical*1`09View_Cr, View_flg, Bin_flg, Extr_flg
X`09Logical*1`09LBR_Flg, Cancel_Op, AST_On_Flg
+-+-+-+-+-+-+-+-  END  OF PART 11 +-+-+-+-+-+-+-+-