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	V01.02 January 1986 CJD
C	Put buffers in COMMON so that they can be NODSK'd.
C	Get date and time from correct place in new style BACKUP block.
C	Separate backup sets by FF.
C	Show total files/blocks for LIST and FULL formats (not BRIEF).
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
	INTEGER*4 KFIL,KUSD,KALL,JFIL,JUSD,JALL,JGRP,JMEM
C
C qio parameters ...
C
	INTEGER PRL(6),IOSB(2)
C
C directory info save buffer
C
	INTEGER DIRFID(10000)
	INTEGER IDIR(8)
C
	COMMON/BUFFER/IBUFF,DIRFID
C
C
C variables
C
	BYTE FILE(12),TEMP(40)
	EQUIVALENCE(IBUFF(1),BBUFF(1))
	DATA IFF/0/
C
C setup for processing
C
	TYPE*,'** BRU Directory listing V01.02'
	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
	GOTO 6539
 1070	CONTINUE
	WRITE (4,6522)KFIL,KUSD,KALL
 6539	CONTINUE
	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'
C	Bodge to read date/time from the right place. There must be some
C	info telling us which BRU version wrote this tape, but it isn't
C	obvious where. For now, check that the first letter of the month
C	is alphabetic -- in old BRU, this was at BBUFF(58). If not
C	alphabetic, assume new format.
	J=56				! Start of date/time for old BRU
	IF(BBUFF(65).GE."101) J=62	! ditto, new BRU
	WRITE(4,1090)IFF,IBUFF(7),(BBUFF(I),I=1,12),(BBUFF(I),I=15,26),
     /		(BBUFF(J+I),I=1,13)
 1090	FORMAT(A1,'VOL',I1,' Backupset ="',12A1,'" Disc label ="',12A1,
     /	'" Dump taken at ',2A1,'-',3A1,'-',2A1,' ',2A1,':',2A1,':',2A1)
	IFF="14				! FF's between subsequent sets
	WRITE(4,1100)IBUFF(27),IAND("77777777,LONG(IBUFF(25))),
     /		IBUFF(22),LONG(IBUFF(23))
 1100	FORMAT('Device type = ',A2,' Size =',I8,' Index file 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 unsigned 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	WRITE (4,6522)KUSD,KFIL,KALL
6522	FORMAT(' Total Files in set ',I7,' Space Used/Alloc',
     1  I7,'/',I7)
	KUSD=0
	KALL=0 !ALLOCATED SPACE TOTAL
	KFIL=0 !FILES
	JGRP=-1
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 <fid><fsq><uic><FILENAME ><EXT><ver>
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)
C	If UIC changes, show total of files/blocks in last directory.
C	Note: not sure if directories are completely sorted, but they seem
C	to be. If they aren't, then this won't be correct.
	IF(JGRP.LT.0) GOTO 11832		! First directory
	IF(IGRP.EQ.JGRP .AND. IMEM.EQ.JMEM) GOTO 11833
	WRITE(4,11831) JGRP,JMEM,JFIL,JUSD,JALL
11831	FORMAT('Directory [',O3,',',O3,']  Total files',I6,
     /		'  Space used/alloc',I6,'/',I6)
11832	JGRP=IGRP
	JMEM=IMEM
	JFIL=0
	JUSD=0
	JALL=0
11833	IUSED=LONG(IBUFF(I+12))
	IF(IBUFF(I+14).EQ.0)IUSED=IUSED-1
	IALLOC=LONG(IBUFF(I+10))
	KFIL=KFIL+1
	KUSD=KUSD+IUSED
	KALL=KALL+IALLOC
	JFIL=JFIL+1
	JUSD=JUSD+IUSED
	JALL=JALL+IALLOC
	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	IF(JGRP.GE.0) WRITE(4,11831) JGRP,JMEM,JFIL,JUSD,JALL
	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