Program BRUDIR c c A program to produce directory listings of c BRU format tapes. c c R J D Kirkman. 1981 - c c x01.01 December 1981 - Correct behaviour for multi-reel input c tapesets. Note that only one deck is used for input. c c Alan E. Frisbie modifications: c c f01.02 ??-Feb-82 - Delete density question and add LOTS of comments c c f01.03 08-Mar-82 - Only list UIC when it changes c c f01.04 27-Mar-82 - Do Form Feed for each new Backupset c c f01.05 01-Feb-86 - Convert FID array to Virtual c - Add Mike Murphy's fixes and cleanups c c f01.06 02-Feb-86 - Clean up directory printing logic & compress spaces c - Fix printing of backup date on old/new tapes c - Replace numbers with names for QIO function codes c - Resequence all statement labels -- FORMATs are 9xxx c c f01.07 11-Apr-88 E.C.M. Beumer - HCS Industrial Automation !EBHCS c - Several cleanups and possible bugs c - Print totalised blocks used/allocated and number c of files per directory c - Print grand total of blocks used/allocated and c number of files and directories on end of backupset c c Slow version of BRUDIR, Uses a workfile to cater for up to 32767 files on disk c c Program to list a directory of a BRU format tape, c encompassing all the images on the tape, in any of c BRief, LIst (default) or FUll formats. c The listing is output to a user specified file. c c----------------------------------------------------------------------- c c Reader data buffer c Integer IBuff(2072) Byte BBuff(4144) Equivalence(IBuff(1), BBuff(1)) c Integer*4 LONG, IALLOC, IMAX, IUSED Integer*4 GTALLO, TALLOC, TIUSED, GTUSED !EBHCS Integer*4 TFILE, GTFILE, TDIR !EBHCS Integer*2 OUTLEN !EBHCS c c QIO parameters ... c Integer PRL(6), IOSB(2) Integer*2 IORLB ! Read Logical Block Integer*2 IOATT ! Attach Integer*2 IODET ! Detach Integer*2 IORWD ! Rewind Integer*2 IOSPF ! Space File(s) Integer*2 IOSTC ! Set Characteristics Integer*2 IOSEC ! Sense Characteristics Integer*2 IORWU ! Rewind and Unload c c Directory info save buffer c Integer IDIRFD VIRTUAL IDIRFD(32767) Integer IDIR(8) c c Output line buffer c Byte OutLin(94) ! Output line buffer c c c Other Variables c Byte File(12), Temp(40), Tape(5), FF Byte Space, AZero ! ASCII Space ( ) and Zero (0) Byte Months(3, 12) ! Months of the year (ASCII) c Integer IDS ! Status from ASNLUN directive Integer IFormt ! Format for listing (BRIEF, LIST, FULL) Integer ICount ! Current entry in File ID Table Integer IUFD ! Current UFD Integer IGrp, IMem ! Current group and member of UIC Integer OGrp, OMem ! For holding old group and member Integer LastC ! Last character in line for FULL Logical SeeEnd ! End of backupset Logical OldTyp ! True if tape is pre-DG015 mods c ! (circa 26-Dec-79) c Integer ILen ! Length of command line read Integer IUnit ! Unit number of Mag Tape Drive Integer IDens ! Density of Mag Tape Drive (800/1600) Integer IDevT ! Device Type of BRUed disk Integer I, J, K ! The usual index variables & counters c c c----------------------------------------------------------------------- c c Initialized data for BRUDIR c Data IORLB /"1000/ ! Read Logical Block Data IOATT /"1400/ ! Attach Data IODET /"2000/ ! Detach Data IORWD /"2400/ ! Rewind Data IOSPF /"2440/ ! Space File(s) Data IOSTC /"2500/ ! Set Characteristics Data IOSEC /"2520/ ! Sense Characteristics Data IORWU /"2540/ ! Rewind and Unload c Data SeeEnd /.False./ ! True if End of backupset seen Data FF /12/ ! ASCII Form Feed character Data Space /' '/, AZero /'0'/ ! ASCII Space and Zero characters c Data Months /'J', 'a', 'n', 'F', 'e', 'b', 'M', 'a', 'r', + 'A', 'p', 'r', 'M', 'a', 'y', 'J', 'u', 'n', + 'J', 'u', 'l', 'A', 'u', 'g', 'S', 'e', 'p', + 'O', 'c', 't', 'N', 'o', 'v', 'D', 'e', 'c'/ c c======================================================================== c c Start of BRUDIR main program c c======================================================================== c c Setup for processing c Type *, ' ' ! Blank line on terminal Type *, '** BRU Directory listing program f01.07' c c Get Magtape device and unit number c c Set defaults for most installations c Tape(1) = 'M' Tape(2) = 'S' Tape(3) = '0' Tape(4) = ':' Tape(5) = 0 Iunit = 0 !EBHCS c Type 9000, (Tape(I), I = 1, 4) 9000 Format('$BRD -- Input Tapedeck (Default = ', 4A1, ') : ') Read (5, 9008, END=9999) ILen, Temp If (ILen .GT. 0) Then If (Temp(1) .GT. 'Z') Temp(1) = Temp(1) - 32 If (Temp(2) .GT. 'Z') Temp(2) = Temp(2) - 32 IUnit = Temp(3) - '0' If (IUnit .GT. 7 .OR. IUnit .LT. 0) IUnit = 0 If (Temp(5) .EQ. ':') IUnit = IUnit*8 + Temp(4) - '0' ! Unit > 8 Tape(1) = Temp(1) Tape(2) = Temp(2) Endif c Call ASNLUN(6, Tape, IUnit, IDS) ! Assign LUN 6 to tape drive If (IDS .NE. 1) Type *, 'BRD -- ASNLUN failed ', IDS If (IDS .NE. 1) Call Exit c c Get the Magtape Density c IDens = 1600 ! Default to 1600 BPI c c*** Type 9002 c*** Accept *, IDENS c*** 9002 Format('$BRD -- Density (800/1600) (Default = 1600) : ') PRL(1) = "4004 ! 1600 or coredump If (IDens .EQ. 800) PRL(1) = 4 c Call WTQIO(IOATT, 6, 6) ! Attach Call WTQIO(IORWD, 6, 6) ! Rewind c*** Call WTQIO(IOSTC, 6, 6, , IOSB, PRL) ! Set density c c What kind of directory is desired? c Type 9004 9004 Format('$BRD -- Listing format (BRIEF, LIST, FULL)', + ' (Default = LIST) : ') Read (5, 9008, END=9999) ILen, Temp IFORMT = 1 ! Default to LIST If (Temp(1) .GE. 'a' .AND. Temp(1) .LE. 'z') Temp(1) = Temp(1) - 32 If (Temp(1) .EQ. 'B') IFORMT = 0 If (Temp(1) .EQ. 'F') IFORMT = 2 c c Find out where to put the directory c Type 9006 9006 Format('$BRD -- Output file (Default = Terminal): ') Read (5, 9008, END=9999) ILen, Temp 9008 Format(Q, 40A1) Type *, ' ' ! Blank line on terminal c c Open Directory Listing File c If (ILen .EQ. 0) Call ASNLUN(4, 'TI', 0) ! Default TTY output If (ILen .NE. 0) Call ASNLUN(4, 'SY', 0) Temp(ILen+1) = 0 If (ILen .NE. 0) Open(Unit = 4, NAME = Temp, CARRIAGECONTROL = 'LIST', + Type = 'NEW') If (ILen .EQ. 0) Open(Unit = 4, NAME = 'TI:', CARRIAGECONTROL = 'LIST', + Type = 'NEW') c c c At this point we should be at BOT with the tapedeck on LUN 6, c the listing file open on LUN 4, c and the terminal for errors/comments on LUN 5 c c c Open a scratch file for directory entries c Open(Unit = 3, RECORDSIZE = 4, ACCESS = 'DIRECT', Type = 'SCRATCH') c c======================================================================= c c Here is where we start reading the tape c c Start with the volume label. c Call GETADR(PRL, IBuff) ! Get the address of our buffer PRL(2) = 4144 ! Maximum length of a BRU record c c Verify that the tape has a "VOL1" label c Call WTQIO(IORLB, 6, 6, , IOSB, PRL) ! Read record If (IOSB(1) .NE. 1) Type *, 'BRD -- Error on volume label read', IOSB If (IOSB(2) .NE. 80) Type *, 'BRD -- Unexpected length at BOT', IOSB If (IBuff(1) .NE. 'VO' .OR. IBuff(2) .NE. 'L1') Type *, + 'BRD -- Not VOL1 at BOT' c c Report Volume Label and Density c Call ZEB(BBuff, 5, 10) ! Get rid of any non-printing char's Write(4, 9010) (BBuff(I), I = 5, 10) 9010 Format('Volume label = "', 6A1, '"', /) c c Check for 512-byte second tape block (Tape Boot block) c Call WTQIO(IORLB, 6, 6, , IOSB, PRL) If (IOSB(2) .NE. 512) + Type *, 'BRD -- Boot block error - Probably not a BRU tape' c c This is the point where we expect a new backupset or EOT c 2100 OGrp = 257 ! Set old group nr. to illegal value OMem = 257 ! Same for old member Call WTQIO(IORLB, 6, 6, , IOSB, PRL) If (IOSB(1) .EQ. "366) Go To 8300 ! *TM* End of Tape If (IOSB(1) .NE. 1) + Type *, 'BRD -- tape error', IOSB, ' on HDR1' If (IOSB(2) .NE. 80) + Type *, 'BRD -- Expected 80-byte HDR1 record. Found ', IOSB If (IBuff(1) .NE. 'HD' .OR. IBuff(2) .NE. 'R1') + Type *, 'BRD -- HDR1 not found when expected' c If (ILen .NE. 0 .AND. SeeEnd) Write (4, 9012) FF ! Do Form Feed 9012 Format(80A1) c Write(4, 9014) (BBuff(I+4), I = 1, 17) ! Report Tape File Label 9014 Format('ANSI file label = "', 17A1, '"') c Call WTQIO(IORLB, 6, 6, , IOSB, PRL) ! Read "HDR2" record If (IBuff(1) .NE. 'HD' .OR. IBuff(2) .NE. 'R2') + Type *, 'BRD -- HDR2 not found when expected' c Call WTQIO(IORLB, 6, 6, , IOSB, PRL) ! Read tape mark (we hope) If (IOSB(1) .NE. "366) + Type *, 'BRD -- Tape mark not found when expected' c c The next tape record should be a Backupset descriptor (Control Record) c Call WTQIO(IORLB, 6, 6, , IOSB, PRL) ! now backup descriptor If (IOSB(2) .NE. 80) + Type *, 'BRD -- Backupset descriptor not found when expected' c c The backup descriptor tells what kind of disk the tape came from, c its name, size and various other parameters. Report the relevant c ones. c Call ZEB(BBuff, 1, 12) ! Get rid of any non-printing char's Call ZEB(BBuff, 15, 26) ! Get rid of any non-printing char's Call ZEB(BBuff, 63, 75) ! Get rid of any non-printing char's c Write(4, 9016) IBuff(7), (BBuff(I), I = 1, 12), + (BBuff(I), I = 15, 26) c 9016 Format('VOL', I1, ' Backupset = "', 12A1, '"', / + 'Disk label = "', 12A1, '"') c c Get the date and time from the GTIM$ formatted words at the start of c the control record instead of the ASCII formatted string near the end. c This is because DEC changed the format in 1979/80 and the string moved. c Now we can read both formats. We check and report which format the c tape is in for the terminally curious. c OldTyp = .False. ! Assume this is a new tape If (IBuff(39) .EQ. 'OC') OldTyp = .True. ! Unless it isn't c Encode (39, 9018, OutLin) + IBuff(16), (Months(K,IBuff(15)), K = 1, 3), IBuff(14), + IBuff(17), IBuff(18), IBuff(19) c 9018 Format('Date/Time of Dump = ' + I2, '-', 3A1, '-', I2, ' ', I2, ':', I2, ':', I2) c If (OutLin(30) .EQ. Space) OutLin(K) = AZero ! Change Space to Zero c Do 2200 K = 32, 39 ! Scan Date/Time field If (OutLin(K) .EQ. Space) OutLin(K) = AZero ! Change Spaces to Zeros 2200 Continue c Write (4, 9012) (OutLin(K), K = 1, 39) ! Write date/time of dump c c Continue with printing the information in the Control Record c Call ZEB(BBuff, 54, 55) ! Get rid of any non-printing char's IDEVT = IBuff(27) ! Device type c Write(4, 9020) IDEVT, IAND("77777777, LONG(IBuff(25))), + IBuff(22), LONG(IBuff(23)) ! Device Type, Size, Index, MFD c 9020 Format( + 'Device Type = "', A2, '"'/, + 'Device Size = ', I10, /, + 'Indexfile size = ', I10, /, + 'MFD size = ', I10) c Call WTQIO(IORLB, 6, 6, , IOSb, PRL) ! read boot block of original disk Call WTQIO(IORLB, 6, 6, , IOSB, PRL) ! read home block of original disk c c Report the parameters from the saved disk's Home Block c I = IBuff(6) If (I .EQ. 0) I = IDEVT ! Disk device type IMAX = IBuff(4) ! Max Files is unsigned integer If (IMAX .LT. 0) IMAX = IMAX + 65536 ! correct that c Call ZEB(BBuff, 485, 496) ! Get rid of any non-printing char's Write(4, 9022) IBuff(1), LONG(IBuff(2)), IMAX, IBuff(5), IBuff(7), I, + (BBuff(I), I = 485, 496) c 9022 Format( + 'Header bitmap size = ', I10, /, + 'Header bitmap LBN = ', I10, /, + 'Maximum files = ', I10, /, + 'Cluster factor = ', I10, /, + 'Structure level = ', O10, /, + 'Disk Type = "', A2, '"', /, + 'Disk owner = "', 12A1, '"') c If (OldTyp) Write(4, 9023) 9023 Format(/, 'This tape has Control records in the old format.', /, + 'Read the BRU tape format description.') c ICOUNT = 0 ! There are no stored entries yet TIUSED = 0 !EBHCS TALLOC = 0 !EBHCS TFILE = 0 !EBHCS TDIR = 0 !EBHCS GTUSED = 0 !EBHCS GTALLO = 0 !EBHCS GTFILE = 0 !EBHCS c c Here we expect a Type record. c If this is a continuation tape only then it need not be c the UFD record, but may be HEAD or DATA c 3000 Call WTQIO(IORLB, 6, 6, , IOSB, PRL) If (IOSB(1) .EQ. "366) Go To 8100 ! EOF 3050 If (IOSB(2) .NE. 80) + Type *, 'BRD -- Unexpected Sentinel length', IOSB If (IBuff(1) .NE. 'DA') Go To 3150 c c Normally we might do something else, however for a directory c we simply skip the data blocks we fall over c c c Scan for an 80-byte sentinel record ("UFD ", "HEAD", or "DATA") c 3100 Call WTQIO(IORLB, 6, 6, , IOSB, PRL) ! Look for something else. If (IOSB(1) .EQ. "366) Go To 8100 ! Deal with EOF If (IOSB(2) .NE. 80) Go To 3100 ! Get more entries Go To 3050 ! Work out what new sentinel c 3150 If (IBuff(1) .NE. 'UF') Go To 4000 ! Not a UFD c c Enter a UFD record, get current UIC value c IUFD = 0 If (IBuff(11) .EQ. 1)IUFD = IBuff(14) ! Get owning UIC (bin) 3200 Call WTQIO(IORLB, 6, 6, , IOSB, PRL) ! Read another block If (IOSB(1) .EQ. "366) Go To 8100 ! EOF? If (IOSB(2) .EQ. 80) Go To 3050 ! Find what this is c c Here should be a block of a directory c c Process the Directory Block (8-word entries) c DO 3300 I = 0, IOSB(2) / 2 - 1, 8 ! Number of 8 word entries c c Since we find extra entries at end, assume for now that BRU c compresses directories, first zero FID is end of directory c If (IBuff(I+1) .EQ. 0) Go To 3200 ! Deleted entry c c Copy directory information to temporary buffer for writing to disk c DO 3250 J = 1, 8 IDIR(J) = IBuff(I+J) 3250 Continue IDIR(3) = IUFD c c Have made an entry with c ICOUNT = ICOUNT + 1 ! Increment slots used in IDIRFD IDIRFD(ICOUNT) = IDIR(1) ! Put FileID in next IDIRFD slot Write(3'ICOUNT) IDIR ! Write entire directory entry to disk c If (ICOUNT .GT. 32767) + STOP 'BRD -- Internal directory buffer full' c 3300 Continue c Go To 3200 ! Read another c c Come here if an 80-byte record is not "DATA" or "UFD ". c If it isn't "HEAD", something is very wrong. c 4000 If (IBuff(1) .NE. 'HE') Go To 8000 ! If not "HEAD", unrecognised c c----------------------------------------------------------------------- c c Here, process headers ("HEAD") and corresponding UFD records c c The directory entries are already on disk. For each header c read in, find the entry, and print it out. c After finding, zero the entry. c 4050 Call WTQIO(IORLB, 6, 6, , IOSb, PRL) ! Read UFD block If (IOSB(1) .EQ. "366) Go To 8100 ! EOF If (IOSB(2) .NE. 80) Go To 4100 ! This must be a block of file headers If (IBuff(1) .NE. 'UF') Go To 3050 ! dispatch this c c Handle "UFD " record (Repeat of earlier one) c IUFD = 0 If (IBuff(11) .EQ. 1) IUFD = IBuff(14) ! Get UIC c c The above allows us to do a 3 word match, thus accounting c for synonyms. c Go To 4050 c c Process a block of File Headers. c 4100 DO 4500 I = 0, IOSB(2)/2 - 1, 256 ! Each header in the buffer c c Find the corresponding entry in the IDIRFD table c DO 4150 J = ICOUNT, 1, -1 ! Scan up directory buffer If (IDIRFD(J) .EQ. IBuff(I+2)) Go To 4200 4150 Continue ! With scan c c If we fall through, this must be a "Lost" file (No directory entry) c Call R50ASC(12, IBuff(I+24), FILE) ! Convert filename to ASCII Write(4, 9024) IBuff(I+2), IBuff(I+3), + IBuff(I+5), FILE, IBuff(I+28) 9024 Format('FID', O6, ':', O6, O7, ' ', 9A1, '.', 3A1, ';', O4) Go To 4500 ! Some how we lost this one c c----------------------------------------------------------------------- c c Found the IDIRFD entry -- Read directory entry from the disk scratch file c 4200 Read(3'J) IDIR ! Read the entry from disk Call R50ASC(12, IDIR(4), FILE) ! Convert filename to ASCII IGRP = IAND(ISHFT(IUFD, -8), "377) ! Get UIC Group number IMEM = IAND(IUFD, "377) ! ... and Member number IUSED = LONG(IBuff(I+12)) ! # blocks used by the file If (IBuff(I+14) .EQ. 0) ! Decr. if next block + IUSED = IUSED - 1 ! ... has zero bytes IALLOC = LONG(IBuff(I+10)) ! # blocks allocated to file c c Test to see if we should print the UIC this time around. c OGrp and OMem are the UIC Group & Member from the last file. c We only want to print them if they change. c If ((OGrp .EQ. IGrp) .AND. (OMem .EQ. IMem)) Go To 4250 OGrp = IGrp ! Now they're the same OMem = IMem ! For the next time around If (TDIR .NE. 0) Then !EBHCS GTUSED = GTUSED + TIUSED !EBHCS GTALLO = GTALLO + TALLOC !EBHCS GTFILE = GTFILE + TFILE !EBHCS Encode (46, 9920, OutLin) TIUSED, TALLOC, TFILE !EBHCS 9920 Format('Total of ', I6, './', I6,'. blocks in ', !EBHCS + I4, '. files') !EBHCS If ((TIUSED .EQ. 1).AND.(TALLOC .EQ. 1)) Outlin(31) = Space !EBHCS If (TFILE .EQ. 1) Outlin(46) = Space !EBHCS Call Squeez(OutLin, 10, 24) ! Squeeze blanks from used/all. !EBHCS Call SSpace(Outlin, 46, Outlen) ! Remove multiple spaces!EBHCS Write (4,9930) (OutLin(K), K = 1, Outlen) !EBHCS 9930 Format(/,9X, 94A1, /) !EBHCS EndIf !EBHCS TIUSED = 0 !EBHCS TALLOC = 0 !EBHCS TFILE = 0 !EBHCS TDIR = TDIR + 1 !EBHCS c c Print the UIC in this path c Write(4, 9026) IGRP, IMEM 9026 Format(/, '[', O3, ',', O3, ']', /) c c This path is used if the UIC was the same as last time. We won't print it c 4250 TIUSED = TIUSED + IUSED !EBHCS TALLOC = TALLOC + IALLOC !EBHCS TFILE = TFILE + 1 !EBHCS c c Convert directory/header information to character form as if we were c going to do a FULL directory listing. We will then pick and choose c which parts to print. c Encode (94, 9028, OutLin) FILE, IDIR(8), IUSED, IALLOC, + IDIR(1), IDIR(2), (BBuff(I*2+K), K = 72, 84) + , (BBuff(I*2+K), K = 59, 71), IBuff(I+29) c 9028 Format(9A1, '.', 3A1, ';', O4, I6, './', I6, '. ', + '(', O6, ',', O6, ') ', + 2A1, '-', 3A1, '-', 2A1, ' ', + 2A1, ':', 2A1, ':', 2A1, ' ', + 2A1, '-', 3A1, '-', 2A1, ' ', + 2A1, ':', 2A1, ':', 2A1, ' (', I4, ')') c Call Squeez(OutLin, 15, 18) ! Squeeze Version Number Call Squeez(OutLin, 27, 33) ! Squeeze Allocated blocks Call Squeez(OutLin, 36, 49) ! Squeeze File ID Call Squeez(OutLin, 90, 94) ! Squeeze Modification Count c If (Iformt .EQ. 0) Then ! BRIEF format listing !EBHCS LastC = 18 ! Print full buffer length !EBHCS ElseIf (Iformt .EQ. 1) Then ! LIST format listing !EBHCS Call Copy (OutLin(26), OutLin(50), 19) !EBHCS LastC = 44 !EBHCS ElseIf (Iformt .EQ. 2) Then ! FULL format listing !EBHCS LastC = 94 ! Print modification date/count !EBHCS If (IBuff(I+29) .EQ. 1) LastC = 68 ! Unless mod. count is 1!EBHCS Else !EBHCS Stop 'BRD -- Error in Listing Format type' !EBHCS EndIf !EBHCS c Write (4,9030) (OutLin(K), K = 1, LastC) 9030 Format(9X, 94A1) IDIRFD(J) = 0 ! Clear this Directory pointer 4500 Continue c c We have finished this block of File Headers. Go back and try c to read another block. c Go To 4050 c c======================================================================= c c Error and various Types of end conditions c c----------------------------------------------------------------------- c 8000 STOP 'BRD -- Unexpected sentinel block' ! ERROR HALT c c----------------------------------------------------------------------- c c Deal with end of backupset. (EOF) c 8100 Call WTQIO(IORLB, 6, 6, , IOSB, PRL) ! Read EOF1/EOV1 If (BBuff(3) .EQ. 'F') Go To 8200 ! Was EOF1 -- End of Backupset c c We're at the end of a reel. Wait for the operator to mount c the next reel. c Write(4, 9032) 9032 Format(' *-End of Volume-*') Call WTQIO(IORWU, 6, 6) ! Unload input tape 8120 Call WTQIO(IOSEC, 6, 6, , IOSB) ! Sense characteristics If (IAND(IOSB(2), IOATT) .EQ. 0) Go To 8130 ! wait until a new tape Call Wait(1, 2) ! Wait 1 second Go To 8120 ! and look again c c Now there is a tape on the drive c 8130 PRL(1) = 1 Call WTQIO(IOSPF, 6, 6, , IOSB, PRL) ! Skip 1 file to get to header Call GETADR(PRL, IBuff) PRL(2) = 4144 ! Max. length of a BRU record Call WTQIO(IORLB, 6, 6, , IOSB, PRL) ! after skipping Backupset header Go To 3000 c c----------------------------------------------------------------------------- c c We're reached the end of a Backupset. Almost done. c 8200 GTUSED = GTUSED + TIUSED !EBHCS GTALLO = GTALLO + TALLOC !EBHCS GTFILE = GTFILE + TFILE !EBHCS Encode (46, 9920, OutLin) TIUSED, TALLOC, TFILE !EBHCS If ((TIUSED .EQ. 1) .AND. (TALLOC .EQ. 1)) Outlin(31) = Space !EBHCS If (TFILE .EQ. 1) Outlin(46) = Space !EBHCS Call Squeez(OutLin, 10, 24) ! Squeeze Used/Allocated !EBHCS Call SSpace(Outlin, 46, Outlen) ! Remove multiple spaces !EBHCS Write (4,9930) (OutLin(K), K = 1, Outlen) !EBHCS If (TDIR .GT. 1) Then !EBHCS Encode (73, 9921, OutLin) GTUSED, GTALLO, GTFILE, TDIR !EBHCS 9921 Format('Grand total of ', I6, './', I6,'. blocks in ', I4, !EBHCS * '. files in ', I4, '. directories') !EBHCS If ((GTUSED .EQ. 1) .AND. (GTALLO .EQ. 1)) Outlin(37) = Space !EBHCS If (GTFILE .EQ. 1) Outlin(52) = Space !EBHCS If (TDIR .EQ. 1) Outlin(73) = Space !EBHCS Call Squeez(OutLin, 16, 30) ! Squeeze Used/Allocated !EBHCS Call SSpace(Outlin, 73, Outlen) ! Remove multiple spaces !EBHCS Write (4,9930) (OutLin(K), K = 1, Outlen) !EBHCS EndIf !EBHCS Write(4, 9034) 9034 Format(' End of Backupset.') c SeeEnd = .True. ! Set flag so we do a before next set c c Print the directory entries for which there were no File Headers c (Probably multiple pointers to the same file, otherwise an error.) c DO 8220 I = 1, ICOUNT ! Scan IDIRFD array If (IDIRFD(I) .EQ. 0) Go To 8220 ! This entry was processed c c Aha! This one wasn't processed. Get it and print it. c READ(3'I) IDIR ! Read directory entry Call R50ASC(12, IDIR(4), FILE) ! Convert to the file in ASCII IUFD = IDIR(3) IGRP = IAND(ISHFT(IUFD, -8), "377) ! Get UIC Group number IMEM = IAND(IUFD, "377) ! and Member number c c Just print the BRIEF directory entry c c c First check to see if we should print the UIC c If ((OGrp .EQ. IGrp) .AND. (OMem .EQ. IMem)) Go To 8210 OGrp = IGrp ! Now they're the same OMem = IMem ! For the next time around c c Print the new UIC c Write(4, 9026) IGRP, IMEM c c Don't Print the UIC c 8210 Write(4, 9036) File, IDIR(8), IDIR(1), IDIR(2) 9036 Format(9X, 9A1, '.', 3A1, ';', O4, ' (', O5, ',', O5, ')') 8220 Continue c c c----------------------------------------------------------------------------- c c We're all done processing this Backupset. Now see if there c is another one on this tape. c PRL(1) = 1 ! Setup to skip EOF labels Call WTQIO(IOSPF, 6, 6, , IOSB, PRL) ! Skip 1 file (EOF labels) Call GETADR(PRL, BBuff) PRL(2) = 4144 ! Max. length of a BRU record Go To 2100 ! Go read the next Backupset c c----------------------------------------------------------------------------- c c End of the last tape (*TM* read when expecting a possible c new Backupset label). Clean up and get out. c 8300 Write(4, 9038) 9038 Format('*EOT*') Close(Unit = 4) ! The scratch file will be deleted when we close it Type *, 'BRD -- *EOT*' Call QIO(IORWD, 6, 6) ! Rewind tape again (no wait) Call WTQIO(IODET, 6, 6) ! and detach 9999 Call Exit c c----------------------------------------------------------------------- c End Integer*4 Function Long(ID) c c Files 11 I*4 is the opposite to Fortran I*4 c Integer*2 ID(2), IT(2) Integer*4 IJ Equivalence(IJ, IT(1)) c IT(1) = ID(2) IT(2) = ID(1) Long = IJ Return End Subroutine ZEB(B, I, J) c c Convert any non-printing characters in array "B" to spaces c Byte B(1) Integer*2 I, J Byte Space c Data Space /' '/ c Do 100 K = I, J If (B(K) .LT. Space) B(K) = Space 100 Continue c Return End Subroutine Copy(BBuff1, BBuff2, Len) !EBHCS c !EBHCS c Copy BBuff1 to BBuff2 for Len bytes !EBHCS c !EBHCS Byte BBuff1(1),BBuff2(1) !EBHCS Integer*2 Len,I !EBHCS c !EBHCS Do 100 I = 1, Len !EBHCS BBuff1(I) = BBuff2(I) ! Copy !EBHCS 100 Continue !EBHCS c !EBHCS Return !EBHCS End !EBHCS Subroutine SSpace(BBuff, Inlen, Outlen) !EBHCS c !EBHCS c Remove multiple spaces from the specified byte array !EBHCS c !EBHCS Byte BBuff(1) !EBHCS Integer*2 Inlen, Outlen !EBHCS c !EBHCS Byte Space !EBHCS Integer*2 I, J !EBHCS c !EBHCS Data Space /' '/ ! ASCII Space character !EBHCS c !EBHCS c-----------------------------------------------------------------------!EBHCS c !EBHCS Outlen = Inlen !EBHCS I = 1 !EBHCS J = 2 !EBHCS 10 If ((BBuff(I) .EQ. Space) .AND. !EBHCS * (BBuff(J) .EQ. Space)) Then ! Skip over spaces !EBHCS Call Copy (BBuff(J), BBuff(J+1), Outlen-J+1) !EBHCS Outlen =Outlen - 1 !EBHCS Go To 10 !EBHCS Endif !EBHCS I = I + 1 !EBHCS J = J + 1 !EBHCS If (J .LE. Outlen) Go To 10 !EBHCS Return !EBHCS End !EBHCS Subroutine Squeez(BBuff, First, Last) c c Left squeeze spaces from the specified characters of a byte array: c c " A B C D" becomes "ABCD " c Byte BBuff(1) Integer*2 First, Last c Byte Space Integer*2 I, J c Data Space /' '/ ! ASCII Space character c c----------------------------------------------------------------------- c J = First ! Initialize output pointer c Do 100 I = First, Last If (BBuff(I) .EQ. Space) Go To 100 ! Skip over spaces BBuff(J) = BBuff(I) ! Copy non-space to the left J = J+1 ! Bump output pointer 100 Continue c If (J .EQ. Last+1) Return ! Return if there were no spaces c Do 200 I = J, Last ! Otherwise... BBuff(I) = Space ! Fill rest of output with spaces 200 Continue c Return End