C R J D Kirkman. 1981 - A program to produce directory listings of C BRU format tapes. C C x01.01 December 1981 - Correct behaviour for multi-reel input C tapesets. Note only one deck is used for input. C C slow version of BRUDIR, Uses a workfile to cater for 10000 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 BReif, LIst (default) or FUll formats. C The listing is output to a user specified file. C PROGRAM BRUDIR C C Reader data buffer C INTEGER IBUFF(2072) BYTE BBUFF(4144) INTEGER*4 LONG,IALLOC,IMAX,IUSED C C qio parameters ... C INTEGER PRL(6),IOSB(2) C C directory info save buffer C INTEGER DIRFID(10000) INTEGER IDIR(8) C C C variables C BYTE FILE(12),TEMP(40) EQUIVALENCE(IBUFF(1),BBUFF(1)) C C setup for processing C TYPE*,'** BRU Directory listing x01.00' TYPE1000 1000 FORMAT('$Input Tapedeck:') ACCEPT1010,TEMP 1010 FORMAT(40A1) 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.UNIT.LT.0)IUNIT=0 IF(TEMP(5).EQ.':')IUNIT=IUNIT*8+TEMP(4)-48 !'0' CALL ASNLUN(6,TEMP,IUNIT,IDS) IF(IDS.NE.1)TYPE*,'ASNLUN fails ',IDS IF(IDS.NE.1)CALL EXIT TYPE1020 ACCEPT*,IDENS 1020 FORMAT('$Density (800/1600):') PRL(1)="4004 !1600 or coredump IF(IDENS.EQ.800)PRL(1)=4 CALL WTQIO("1400,6,6) !attach CALL WTQIO("2400,6,6) !rewind CALL WTQIO("2500,6,6,,IOSB,PRL) !set density TYPE1030 1030 FORMAT('$Listing format (FULL,BRIEF,LIST):') ACCEPT1010,TEMP IFORMT=1 !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 TYPE1040 1040 FORMAT('$Output file:') ACCEPT1050,ILEN,TEMP 1050 FORMAT(Q,40A1) 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 at this point we should be at BOT with the tapedeck on LUN 6 C the listing file open on LUN 4. C 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 start with the volume label. CALL GETADR(PRL,IBUFF) PRL(2)=4144 CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IOSB(1).NE.1)TYPE*,'Error on volume label read',IOSB IF(IOSB(2).NE.80)TYPE*,'Unexpected length at BOT',IOSB IF(IBUFF(1).NE.'VO'.OR.IBUFF(2).NE.'L1')TYPE*, / 'Not VOL1 at BOT' WRITE(4,1060)(BBUFF(I),I=5,10),IDENS 1060 FORMAT('Volume label = "',6A1,'" Density ',I4) CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IOSB(2).NE.512)TYPE*,'Boot block error - Prob not BRU tape' C C this is the point where we expect a new backupset/ of eot C 1070 CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IOSB(1).EQ."366)GOTO 8060 IF(IOSB(1).NE.1)TYPE*,'tape error',IOSB,' on HDR1' IF(IOSB(2).NE.80)TYPE*,'Expected HDR1 found ',IOSB IF(IBUFF(1).NE.'HD'.OR.IBUFF(2).NE.'R1')TYPE*, / 'Not HDR1 when expected' WRITE(4,1080)(BBUFF(I+4),I=1,17) 1080 FORMAT('Ansi file label = "',17A1,'"') CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IBUFF(1).NE.'HD'.OR.IBUFF(2).NE.'R2')TYPE*,'HDR2 expected' CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IOSB(1).NE."366)TYPE*,'Tape mark expected' CALL WTQIO("1000,6,6,,IOSB,PRL) !now backup descriptor IF(IOSB(2).NE.80)TYPE*,'Backupset descriptor expected' WRITE(4,1090)IBUFF(7),(BBUFF(I),I=1,12),(BBUFF(I),I=15,26), / (BBUFF(I+56),I=1,13) 1090 FORMAT('VOL',I1,' Backupset ="',12A1,'" Disc label ="',12A1,'"', / ' Dump taken at ',2A1,'-',3A1,'-',2A1,' ',2A1,':',2A1,':',2A1) WRITE(4,1100)IBUFF(27),IAND("77777777,LONG(IBUFF(25))), / IBUFF(22),LONG(IBUFF(23)) 1100 FORMAT('Device type = ',A2,' Size =',I8,' Indexfile size =',I6 / ' MFD size = ',I7) CALL WTQIO("1000,6,6,,IOSb,PRL) !read boot block CALL WTQIO("1000,6,6,,IOSB,PRL) !read home block I=IBUFF(6) IF(I.EQ.0)I='??' IMAX=IBUFF(4) !is unisgned int IF(IMAX.LT.0)IMAX=IMAX+65536 !correct that WRITE(4,1101)IBUFF(1),LONG(IBUFF(2)),IMAX,IBUFF(5),IBUFF(7),I 1101 FORMAT('Bitmap size = ',I6,' Starts at lbn=',I10, / ' Maximum files = ',I6/ / 'Cluster factor =',I6,' Structure level =',O6,' Disk type "', / A2,'"') ICOUNT=0 !there are no stored entries yet 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 1110 CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IOSB(1).EQ."366)GOTO 8000 !eof 1120 IF(IOSB(2).NE.80)TYPE*,'unexpected Sentinel length',IOSB IF(IBUFF(1).NE.'DA')GOTO 1140 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 compress the directory entries C - No longer since they are in a file C C IPTR=ICOUNT !end of buffer used C ICOUNT=0 !assert empty now C DO 1131 I=0,IPTR-1,8 !scan all buffer C IF(IDIR(I+1).EQ.0)GOTO 1131 C DO 1132 J=1,8 C IDIR(ICOUNT+J)=IDIR(I+J) C1132 CONTINUE C IDIR(I+1)=0 C ICOUNT=ICOUNT+8 C1131 CONTINUE C TYPE*,'Directory compressed from ',IPTR/8,' to',ICOUNT/8 1130 CALL WTQIO("1000,6,6,,IOSB,PRL) !look for something else. IF(IOSB(1).EQ."366)GOTO 8000 !deal with eof IF(IOSB(2).NE.80)GOTO 1130 !get more entries GOTO 1120 !work out what new sentinel 1140 IF(IBUFF(1).NE.'UF')GOTO 1160 !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) 1150 CALL WTQIO("1000,6,6,,IOSB,PRL) !read another block IF(IOSB(1).EQ."366)GOTO 8000 !eof IF(IOSB(2).EQ.80)GOTO 1120 !find what this is C Here should be a block of a directory DO 1151 I=0,IOSB(2)/2-1,8 !number of 8 word entries C SINCE we find extra entries at end, assume for now that BRU C compresses directories, see if first zero FID is end of directory C was GOTO 1151 to skip individual entry C IF(IBUFF(I+1).EQ.0)GOTO 1150 !deleted entry DO 1152 J=1,8 IDIR(J)=IBUFF(I+J) 1152 CONTINUE IDIR(3)=IUFD C C have made an entry with C ICOUNT=ICOUNT+1 DIRFID(ICOUNT)=IDIR(1) WRITE(3'ICOUNT)IDIR IF(ICOUNT.GT.10000)STOP ' Directory buffer full' IF(IFORMT.NE.0)GOTO 1151 CALL R50ASC(12,IBUFF(I+4),FILE) !convert to the file in ascii IGRP=IAND(ISHFT(IUFD,-8),"377) IMEM=IAND(IUFD,"377) WRITE(4,1153)IGRP,IMEM,FILE,IBUFF(I+8),IBUFF(I+1),IBUFF(I+2) 1153 FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,' (',O5,',',O5, / ')') 1151 CONTINUE GOTO 1150 !read another 1160 IF(IBUFF(1).NE.'HE')GOTO 1190 !if not unrecognised C C here process headers and corresponding UFD records C C the directory entries are already buffered. For each header C read in, find the entry, and print it out. C after finding zero the entry for later compression, to occur C when he hit the DATA sentinel. C 1170 CALL WTQIO("1000,6,6,,IOSb,PRL) !read ufd block IF(IOSB(1).EQ."366)GOTO 8000 !eof IF(IOSB(2).NE.80)GOTO 1180 IF(IBUFF(1).NE.'UF')GOTO 1120 !dispatch this IUFD=0 IF(IBUFF(11).EQ.1)IUFD=IBUFF(14)!get uic C The above allows us to do a 3 word match, thus accounting C for synonyms. C GOTO 1170 1180 CONTINUE !here with a block of headers DO 1181 I=0,IOSB(2)/2-1,256 !each header in the buffer DO 1182 J=1,ICOUNT !scan up directory buffer C C fileid, seq are at offsets 2,3 current ufd is IUFD C C IF(IUFD.EQ.IDIR(J+3).AND.IDIR(J+1).EQ.IBUFF(I+2).AND. C / IDIR(J+2).EQ.IBUFF(I+3))GOTO 1183 IF(DIRFID(J).EQ.IBUFF(I+2))GOTO 1183 1182 CONTINUE !with scan CALL R50ASC(12,IBUFF(I+24),FILE) WRITE(4,999)IBUFF(I+2),IBUFF(I+3),IBUFF(I+5),FILE,IBUFF(I+28) 999 FORMAT('FID',O6,':',O6,O7,' ',9A1,'.',3A1,';',O4) GOTO 1181 !some how we lost this one 1183 READ(3'J)IDIR CALL R50ASC(12,IDIR(4),FILE) IGRP=IAND(ISHFT(IUFD,-8),"377) IMEM=IAND(IUFD,"377) IUSED=LONG(IBUFF(I+12)) IF(IBUFF(I+14).EQ.0)IUSED=IUSED-1 IALLOC=LONG(IBUFF(I+10)) IF(IFORMT.NE.2)GOTO 1185 IF(IBUFF(I+29).EQ.1)GOTO 1187 WRITE(4,1184)IGRP,IMEM,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) 1184 FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,I6,'./',I6,'. ', / '(',O6,',',O6,') ',2A1,'-',3A1,'-',2A1,' ',2A1,':', / 2A1,':',2A1,' ',2A1,'-',3A1,'-',2A1,' ',2A1,':', / 2A1,':',2A1,' (',I4,')') GOTO 1189 1187 WRITE(4,1188)IGRP,IMEM,FILE,IDIR(8),IUSED,IALLOC, / IDIR(1),IDIR(2),(BBUFF(I*2+K),K=72,84) 1188 FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,I6,'./',I6,'. ', / '(',O6,',',O6,') ',2A1,'-',3A1,'-',2A1,' ',2A1,':', / 2A1,':',2A1) GOTO 1189 1185 IF(IFORMT.NE.1)GOTO 1189 WRITE(4,1186)IGRP,IMEM,FILE,IDIR(8),IUSED,(BBUFF(I*2+K),K=72,84) 1186 FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,I7,'. ' / ,2A1,'-',3A1,'-',2A1,' ',2A1,':',2A1,':',2A1) 1189 DIRFID(J)=0 1181 CONTINUE GOTO 1170 1190 STOP 'Unexpected sentinel block' C C deal with end of backupset. C 8000 CALL WTQIO("1000,6,6,,IOSB,PRL) !read EOF1/EOV1 IF(BBUFF(3).EQ.'F')GOTO 8040 !was eof1 WRITE(4,8010) 8010 FORMAT(' *-End of Volume-*') CALL WTQIO("2540,6,6) !unload input tape 8020 CALL WTQIO("2520,6,6,,IOSB) !sense characteristics IF(IAND(IOSB(2),"1400).EQ.0)GOTO 8030 !wait until a new tape CALL WAIT(1,2) !wait 1 second GOTO 8020 !and look again C C now have seen a tape on the deck C 8030 PRL(1)=1 CALL WTQIO("2440,6,6,,IOSB,PRL) !skip 1 to get to header CALL GETADR(PRL,IBUFF) ! PRL(2)=4144 CALL WTQIO("1000,6,6,,IOSB,PRL) !after skipping Backupset header GOTO 1110 8040 WRITE(4,8050) 8050 FORMAT(' End of Backupset.') DO 8001 I=1,ICOUNT IF(DIRFID(I).EQ.0)GOTO 8001 READ(3'I)IDIR CALL R50ASC(12,IDIR(4),FILE) !convert to the file in ascii IUFD=IDIR(3) IGRP=IAND(ISHFT(IUFD,-8),"377) IMEM=IAND(IUFD,"377) WRITE(4,8002)IGRP,IMEM,FILE,IDIR(8),IDIR(1),IDIR(2) 8002 FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,' (',O5,',',O5, / ')') 8001 CONTINUE PRL(1)=1 !setup to skip eof labels CALL WTQIO("2440,6,6,,IOSB,PRL) ! CALL GETADR(PRL,BBUFF) PRL(2)=4144 GOTO 1070 8060 WRITE(4,8070) 8070 FORMAT('*EOT*') CLOSE(UNIT=4) TYPE*,'*EOT*' CALL WTQIO("2400,6,6) !rewind again CALL WTQIO("2000,6,6) !and detach CALL EXIT END C C files 11 I*4 is the opposite to Fortran I*4 INTEGER*4 FUNCTION LONG(ID) INTEGER*2 ID(2),IT(2) INTEGER*4 IJ EQUIVALENCE(IJ,IT(1)) IT(1)=ID(2) IT(2)=ID(1) LONG=IJ RETURN END