program cmpdsk
	integer*4 qlzw_dcm,qlzw_cmp
	external qlzw_dcm,qlzw_cmp
	integer*4 ibuf(9000),lastrec,sys$qiow,sys$assign
	integer*4 getgeom,opnfiles
	external getgeom,opnfiles,sys$qiow,sys$assign
	integer*4 lhostf,ncyls,nsect,ntrks,lfile
c File must pre-exist since we open in readonly mode.
	character*256 idxfile
	integer*4 idxbuf(128)
c index buffer format:
c record of data file
c length of data in bytes
c flags. 0 = no compress, 1=compressed
c padding so things are a mult. of 4
	integer*4 idxblk,datblk,dskchn,iiiosb
	external writeblock
	integer*4 cbuf(32000),dbuf(32000)
	common/fblks/idxblk,datblk,idxbuf,cbuf,dbuf
	save iiiosb,ibuf
	include '($iodef)'
	character*64 device
	character*256 filnam
	integer*4 ldevice,lfilnam,iiosb(2)
	lastrec=1
	write(6,1)
1	format('$Enter disk>')
	read(5,2)ldevice,device
2	format(q,a)
	write(6,3)
3	format('$Enter filespec for compressed files>')
	read(5,2)lfilnam,filnam
	kkk=getgeom(device(:ldevice),ntrks,nsect,ncyl,nblocks)
	if ((kkk.and.1).eq.0)stop 'Bad device geometry sensed'
	kkk=opnfiles(nblocks,ncyl,nsect,ntrks,filnam(:lfilnam))
	if ((kkk.and.1).eq.0)stop 'Files did not open correctly'
c Now the device geometry is found and we have opened files and written
c out the geometry. Now write the files out. Unit 1 is the data,
c unit 2 is the index info.
	nchunks=(nblocks+31)/32
c presumes 32 blocks per chunk...this is a quick 'n' dirty hack, not
c intended for the ages but to work serviceably...
	nblk=0
	kkk=sys$assign(device(:ldevice),dskchn,,,,)
	if((kkk.and.1).eq.0)stop 'Could not assign channel to disk'
	do 100 nn=1,nchunks
c read a chunk and emit the data
	do 2101 nnnn=1,8192
2101	ibuf(nnnn)=0
	kkk=sys$qiow(%val(4),%val(dskchn),%val(io$_readlblk),iiosb,
     1  ,,ibuf,%val(16384),%val(nblk),,,)
c allow read error on the last chunk without exit. Could be faked geom...
	if((iiosb(1).and.1).eq.0.and.nn .lt. nchunks)stop 'Disk read err'
c on last chunk read one at a time
	if(nn.eq.nchunks)then
	iibbb=%loc(ibuf)
	kblk=nblk
	do 3100 nnnn=1,32
	kkk=sys$qiow(%val(4),%val(dskchn),%val(io$_readlblk),iiosb,
     1  ,,%val(iibbb),%val(512),%val(kblk),,,)
	iibbb=iibbb+512
	kblk=kblk+1
3100	continue
	endif
	mbytes=32*512
	iiiosb=0
	call writeblock(iiiosb,mbytes,ibuf,nblk,lastrec)
	nblk=nblk+32
100	continue
c avoid disk high boundary problem by adding one pseudo sector
c zero the buffer however to waste little space as possible.
	do 102 nn=1,9000
102	ibuf(nn)=0
	do 101 nn=nchunks+1,nchunks+32
	do 1101 nnnn=1,8192
1101	ibuf(nnnn)=0
	kkk=sys$qiow(%val(4),%val(dskchn),%val(io$_readlblk),iiosb,
     1  ,,ibuf,%val(16384),%val(nblk),,,)
c
	mbytes=32*512
	iiiosb=0
	call writeblock(iiiosb,mbytes,ibuf,nblk,lastrec)
	nblk=nblk+32
101	continue
	close(unit=2)
	close(unit=1)
	call exit
	end
	integer*4 function getgeom(disk,ntrks,nsect,ncyl,nblocks)
	INCLUDE '($DVIDEF)'
	INCLUDE '($IODEF)'
	Integer*4 lib$sys_trnlog,sys$assign,sys$qiow,SYS$GETDVIW
	External lib$sys_trnlog,sys$assign,sys$qiow,SYS$GETDVIW
	Character*(*) disk
	Integer*4 Status,IDKDL,DSKCHN,I4WRK
	Integer*4 Sizes(4)
C DATA BUFFER AREA
	INTEGER*4 DBF(2076)
C I/O STATUS BLOCKS
	INTEGER*2 IOSBRM(4)
	INTEGER*2 IOSBLO(4)
	INTEGER*4 IOSR(2),IOSL(2)
	EQUIVALENCE(IOSBRM(1),IOSR(1)),(IOSBLO(1),IOSL(1))
C REMOTE AND LOCAL I/O STAT BLKS (NET AND DISK DEVICES RESPECTIVELY)
	INTEGER*2 WRKIOS(4)
C WORK IOSB.
C HEADER IS FIRST 4 LONGWORDS
C BUFFER IS THE REST (PLUS A LITTLE SLOP)
C ITEM LIST FOIR GETDVI
	INTEGER*2 DVII2(6,5)
	INTEGER*4 DVIITM(3,5)
	EQUIVALENCE(DVII2(1,1),DVIITM(1,1))
C  BUF LENGTH, ITEM CODE - 1ST 2 WORDS
C  BUFFER ADDRESS
C  RETURN LENGTH ADDRESS  - NEXT 2 LONGWORDS, EACH ITEM (4 IN ALL)
C TERMINATE GETDVI ITEMLIST
	DVIITM(1,5)=0
	DVIITM(2,5)=0
	DVIITM(3,5)=0
C FIRST ITEM - DISK SIZE
	DVII2(1,1)=4
	DVII2(2,1)=DVI$_MAXBLOCK
	DVIITM(2,1)=%LOC(SIZES(4))
	DVIITM(3,1)=%LOC(I4WRK)
C SECOND ITEM - NUMBER OF TRACKS
	DVII2(1,2)=4
	DVII2(2,2)=DVI$_TRACKS
	DVIITM(2,2)=%LOC(SIZES(1))
	DVIITM(3,2)=%LOC(I4WRK)
C THIRD ITEM - NUMBER OF SECTORS
	DVII2(1,3)=4
	DVII2(2,3)=DVI$_SECTORS
	DVIITM(2,3)=%LOC(SIZES(2))
	DVIITM(3,3)=%LOC(I4WRK)
C FOURTH ITEM - NUMBER OF CYLINDERS
	DVII2(1,4)=4
	DVII2(2,4)=DVI$_CYLINDERS
	DVIITM(2,4)=%LOC(SIZES(3))
	DVIITM(3,4)=%LOC(I4WRK)
C
	netblk=0
	netchn=0
	getgeom=1
c Zero in channel indicates failure
c First translate the logicals
	idkdl=len(disk)
C ASSIGN A CHANNEL TO THE NAMED DISK.
	STATUS=SYS$ASSIGN(Disk(1:IDKDL),DSKCHN,,)
	if(.not.status)then
	  getgeom=4
	  return
	endif
c Issue packack
        status=sys$qiow(%val(1),%val(dskchn),%val(IO$_PACKACK),
     1  IOSBLO,,,,,,,,)
C NOW GET HOLD OF SIZE INFO
	SIZES(1)=0
	STATUS=SYS$GETDVIW(%VAL(2),%VAL(DSKCHN),,DVIITM,,,,)
	if(.not.status)then
	  getgeom=4
	  return
	endif
C SIZES ARRAY now contains the t/s/c/b stuff
	nblocks=sizes(4)
	ntrks=sizes(1)
	nsect=sizes(2)
	ncyl=sizes(3)
100	CONTINUE
	return
	END
C routines for dthstimg to let it read data blocks off a compressed disk
C image
C call opnfiles(hstfsz,cyls,sect,trks,filename)
c Opens files if they exist or returns with error. Should return 1 if
c all is well.
c
c
c Call readblock(iosb,sizetoread,bufferaddress,wantblock)
c reads the record containing the block into buffer.
c
c Buffers are presumed to be 64 blocks long by the macro currently.
c "wantblock" is the LBN wanted (512 byte blocks) though what we
c need to do is read the record containing that block. Sizetoread
c can be used to check block factor.
	integer*4 function opnfiles(lhostf,ncyls,nsect,ntrks,file)
	character*(*) file
	integer*4 ibuf(128)
	integer*4 lhostf,ncyls,nsect,ntrks,lfile
c File must pre-exist since we open in readonly mode.
	character*256 idxfile
	integer*4 idxbuf(128)
c index buffer format:
c record of data file
c length of data in bytes
c flags. 0 = no compress, 1=compressed
c padding so things are a mult. of 4
	integer*4 idxblk,datblk
	integer*4 cbuf(32000),dbuf(32000)
	common/fblks/idxblk,datblk,idxbuf,cbuf,dbuf
c assume that index file is same name as file with "_idx" added
	opnfiles=1
	lenfile=len(file)
c chop off version no. if ; is the delimiter
	if(index(file,';').gt.0)lenfile=index(file,';') - 1
	idxfile=file(:lenfile) // '_idx'
	lenidx=lenfile+4
	open(unit=1,file=file,organization='sequential',
     1  access='direct',recordtype='fixed',form='unformatted',
     1  status='new',recl=128,err=999)
	open(unit=2,file=idxfile(:lenidx),organization='sequential',
     1  access='direct',recordtype='fixed',form='unformatted',
     1  status='new',recl=128,err=999)
c read the first record and get geometry.
	ibuf(1)=lhostf
	ibuf(2)=ncyls
	ibuf(3)=nsect
	ibuf(4)=ntrks
	write(unit=2,rec=1)ibuf
	idxblk = -1
	datblk = -1
	return
999	continue
	opnfiles=8
	close(unit=1)
	close(unit=2)
	return
	end
	subroutine writeblock(iiiosb,nbytes,ibuff,nblk,ldrec)
	integer*4 iiiosb,nbytes,nblk,ldrec
	integer*4 ibuff(512)
	integer*4 idxbuf(128)
c index buffer format:
c record of data file
c length of data in bytes
c flags. 0 = no compress, 1=compressed
c padding so things are a mult. of 4
	integer*4 idxblk,datblk
	integer*4 qlzw_dcm,qlzw_cmp
	external qlzw_dcm,qlzw_cmp
	integer*4 cbuf(32000),dbuf(32000)
	common/fblks/idxblk,datblk,idxbuf,cbuf,dbuf
	iiiosb=1
c Initially copy the data into dbuf
	nwd=(nbytes+3)/4
	do 2 n2=1,nwd
	dbuf(n2)=ibuff(n2)
2	continue
c now compress if we can
	kkk=qlzw_cmp(dbuf,nbytes,cbuf,iclen,128000)
	ldflg=1
	if((kkk.and.1).eq.0)ldflg=0
c don't store compressed unless we save a block or more
	if(iclen.gt.(nbytes-511))ldflg=0
c ldflg is 1 if we compressed ok, else 0
	ldlen=32*512
	if(ldflg.eq.1)ldlen=iclen
c note that the cache already filters here, so just read the thing.
	nbkfac=nbytes/512
	loblk=nblk/nbkfac
c get block factor, then compute record number via division
c Now read the index record for this data record to find where it is.
	nidx=loblk/32
	nidx=nidx+2
c 32 index records of 4 longs each fit into a block
	if(idxblk.ne.nidx)then
	  read(2,rec=nidx,err=77)idxbuf
77	continue
	  idxblk = nidx
	endif
	idxofs=loblk-(32*(nidx-2))
	idxofs=(4 * idxofs) + 1
	idxbuf(idxofs)=ldrec
	idxbuf(idxofs+1)=ldlen
	idxbuf(idxofs+2)=ldflg
c Write the index record every time. It will overwrite disk a lot, but
c basically this is not a problem save for speed a bit.
	write(2,rec=nidx)idxbuf
c figure no. blocks in this "record"
	ncbks=(ldlen+511)/512
	nlo=1
	nhi=128
	nbk=ldrec
	do 1 n1=1,ncbks
	if (ldflg.eq.0)write(1,rec=nbk)(dbuf(ii),ii=nlo,nhi)
	if (ldflg.ne.0)write(1,rec=nbk)(cbuf(ii),ii=nlo,nhi)
	nlo=nlo+128
	nhi=nhi+128
	nbk=nbk+1
1	continue
c keep track of the record written assuming sequential I/O
	lastrec=nbk
	ldrec=nbk
	return
	end