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       Mod to differentiate between IAS & RSX tapes, F. Borger, June 2 1983
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
C 
C qio parameters ...
C 
	INTEGER PRL(6),IOSB(2)
C 
C directory info save buffer
C 
C	INTEGER DIRFID(10000)
C	INTEGER IDIR(8)
	LOGICAL*1 RADGRO(3),RADUSR(3)
C 
C 
C variables
C 
	BYTE FILE(12),TEMP(40),LASTFL(12)
	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
 1013	TYPE1015
 1015	FORMAT(' IASV3.1/LATER RSX (1)'/
 	1'         EARLY RSX (2)'/
	2'$       OR IASV3.2 (3) ? ')
	ACCEPT*,IAS
	IF (IAS.LT.1.OR.IAS.GT.3) GOTO 1013
	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
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
C	Handle dump date differently if Early RSX or IAS/Later RSX
C
	IF (IAS.NE.2) WRITE(4,1090)IBUFF(7),(BBUFF(I),I=1,12),
     /		(BBUFF(I),I=15,26),(BBUFF(I+62),I=1,13)
	IF (IAS.EQ.2) 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,'"')
C
	IF (IAS.EQ.3) CALL WTQIO("1000,6,6,,IOSB,PRL)	!read ? block
C
C	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
C
	DO 2221 IJK=1,12
2221	LASTFL(IJK)=0
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
C	IUFD=0
C	IF(IBUFF(11).EQ.1)IUFD=IBUFF(14)!get owning uic (bin)
C
C	MODIFIED, Directory uic owner not always the directory, so
C	Save RAD50 version of UIC which is the correct one
	CALL R50ASC(3,IBUFF(6),RADGRO)
	CALL R50ASC(3,IBUFF(7),RADUSR)
	CALL UFDCON(RADGRO,RADUSR,IUFD)
 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
C	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
C	IF(IBUFF(I+1).EQ.0)GOTO 1150	!deleted entry
C	DO 1152 J=1,8
C	IDIR(J)=IBUFF(I+J)
C1152	CONTINUE
C	IDIR(3)=IUFD
C
C have made an entry with <fid><fsq><uic><FILENAME ><EXT><ver>
C
C	ICOUNT=ICOUNT+1
C	DIRFID(ICOUNT)=IDIR(1)
C	WRITE(3'ICOUNT)IDIR
C	IF(ICOUNT.GT.10000)STOP ' Directory buffer full'
C	IF(IFORMT.NE.0)GOTO 1151
C	CALL R50ASC(12,IBUFF(I+4),FILE)	!convert to the file in ascii
C	IGRP=IAND(ISHFT(IUFD,-8),"377)
C	IMEM=IAND(IUFD,"377)
C	WRITE(4,1153)IGRP,IMEM,FILE,IBUFF(I+8),IBUFF(I+1),IBUFF(I+2)
C1153	FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,'  (',O5,',',O5,
C     /  ')')
C1151	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
C	IUFD=0
C	IF(IBUFF(11).EQ.1)IUFD=IBUFF(14)!get owning uic (bin)
C
C	MODIFIED, Directory uic owner not always the directory, so
C	Save RAD50 version of UIC which is the correct one
	CALL R50ASC(3,IBUFF(6),RADGRO)
	CALL R50ASC(3,IBUFF(7),RADUSR)
	CALL UFDCON(RADGRO,RADUSR,IUFD)
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
C	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
C	IF(DIRFID(J).EQ.IBUFF(I+2))GOTO 1183
C1182	CONTINUE		!with scan
C	CALL R50ASC(12,IBUFF(I+24),FILE)
C	WRITE(4,999)IBUFF(I+2),IBUFF(I+3),IBUFF(I+5),FILE,IBUFF(I+28)
C999	FORMAT('FID',O6,':',O6,O7,' ',9A1,'.',3A1,';',O4)
C	GOTO 1181		!some how we lost this one
C1183	READ(3'J)IDIR
	CALL R50ASC(12,IBUFF(I+24),FILE)
C
	DO 3333 IJK=1,12
	IF(FILE(IJK).NE.LASTFL(IJK)) GOTO 3334
3333	CONTINUE
	GOTO 1189
C
3334	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))
	KFIL=KFIL+1
	KUSD=KUSD+IUSED
	KALL=KALL+IALLOC
	IF(IFORMT.NE.2)GOTO 1185
	IF(IBUFF(I+29).EQ.1)GOTO 1187
	WRITE(4,1184)IGRP,IMEM,FILE,IBUFF(I+28),IUSED,IALLOC,
     /		IBUFF(I+2),IBUFF(I+3),(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,' (',I5,')')
	GOTO 1189
1187	WRITE(4,1188)IGRP,IMEM,FILE,IBUFF(I+28),IUSED,IALLOC,
     /		IBUFF(I+2),IBUFF(I+3),(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 2222
	WRITE(4,1186)IGRP,IMEM,FILE,IBUFF(I+28),IUSED,(BBUFF(I*2+K),K=72,84)
1186	FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,I7,'. '
     /		,2A1,'-',3A1,'-',2A1,' ',2A1,':',2A1,':',2A1)
	GOTO 1189
2222	IF(IFORMT.NE.0)GOTO 1189
	CALL R50ASC(12,IBUFF(I+24),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+28),IBUFF(I+2),IBUFF(I+3)
1153	FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,'  (',O5,',',O5,
     /  ')')
C1189	DIRFID(J)=0
1189	DO 3335 IJK=1,12
3335	LASTFL(IJK)=FILE(IJK)
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.')
C	DO 8001 I=1,ICOUNT
C	IF(DIRFID(I).EQ.0)GOTO 8001
C	READ(3'I)IDIR
C	CALL R50ASC(12,IDIR(4),FILE)	!convert to the file in ascii
C	IUFD=IDIR(3)
C	IGRP=IAND(ISHFT(IUFD,-8),"377)
C	IMEM=IAND(IUFD,"377)
C	WRITE(4,8002)IGRP,IMEM,FILE,IDIR(8),IDIR(1),IDIR(2)
C8002	FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,'  (',O5,',',O5,
C     /  ')')
C8001	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
C
C	SPECIAL function to convert ascii uic to octal
C
	SUBROUTINE UFDCON(RADGRO,RADUSR,IUFD)
	LOGICAL*1 RADGRO(3),RADUSR(3)
	DECODE (3,100,RADGRO) I
	DECODE (3,100,RADUSR) J
100	FORMAT (O3)
	IUFD=IAND(ISHFT(I,8),"177400)
	IUFD=IOR(IUFD,J)
	RETURN
	END
