C FDHOSTCOMP subroutines
C Supports following calls:
C call filopn(nma,fnl,maxsiz,istat) open file
c call filcls close file
c call bufrd(dat,LBN,Isize,istat) read buff
c call bufwt(dat,LBN,isize,istat) write buff
C used by fdhostcomp to do actual file I/O
C Glenn C. Everhart 6/30/1989
C
	Subroutine FilOpn(FNA,NL,MAXsiz,Istat)
	Character*(*) nl
	logical*1 fna(30)
	integer*4 maxsiz,istat
	Integer*2 nrmbuf(8220),cmpbuf(8220)
	logical*1 lrmbuf(17000),lcmpbf(17000)
	Equivalence(nrmbuf(1),lrmbuf(1))
	Equivalence(cmpbuf(1),lcmpbf(1))
C normal text and compressed text buffers
	Integer*4 Idirty
C idirty made nonzero to flag track buffer was modified
	Integer*4 TrkBuf(128,32),TBH(4110)
	Equivalence(trkbuf(1,1),tbh(4))
C use longword 1 for track number (track=32 sectors here since 64 sectors is just too big
C for an RMS record). Longword 2 for flag (compressed or noncompressed data) so we don't
C have to store data that GROWS when "compressed" via LZW algorithm.
C tbh(3) will be size of data so we can find it in one place. Buffer headers carry it
C for compressed data, but not for uncompressed, so reserve a spot here.
C track buffer, 32 sectors of 512 bytes each, used as unit of compression.
	Integer*4 lbnfence,LBNF,ixxx
	Common/Trkbuf/tbh,nrmbuf,cmpbuf,idirty,LBNF,ixxx
	integer*4 dsksz
	Data dsksz/5120/
	Data lbnfence/255/
C LBNfence is the LBN below which we do NOT compress/decompress data.
C This allows us to put the index file (at least start of it) into a
C part of the disk that is not compressed. Block numbers above this
C fence are compressed/decompressed.
	LBNF=LBNFence/32
C divide by 32 since the recording is granular to 32 blocks. Saves arithmetic later.
	idirty=0
	open(unit=1,file=nl,organization='indexed',access='keyed',
     1  key=(1:4:integer),recordtype='variable',form='unformatted',
     2  status='unknown',iostat=ixxx,recl=4250,
     3  err=9999)
	istat=1
	Maxsiz=dsksz
c set preset max size
c also set up buffer sizes initially
	nrmbuf(1)=0
	nrmbuf(2)=0
	nrmbuf(3)=0
	cmpbuf(1)=0
	cmpbuf(2)=0
	cmpbuf(3)=0
C set initially to impossible base
	tbh(1)=-1
	return
9999	continue
c return severe error
	istat=4
	return
	end
	Subroutine FilCls
	close(unit=1)
	return
	end
	Subroutine BufRd(bufdat,Lbn,Isiz,Istat)
	integer*2 bufdat(8200)
	Integer*4 LBN,isiz,Istat
	Integer*2 nrmbuf(8220),cmpbuf(8220)
	logical*1 lrmbuf(17000),lcmpbf(17000)
	Equivalence(nrmbuf(1),lrmbuf(1))
	Equivalence(cmpbuf(1),lcmpbf(1))
C normal text and compressed text buffers
	Integer*4 Idirty
C idirty made nonzero to flag track buffer was modified
	Include '($fordef)'
	Integer*4 TrkBuf(128,32),TBH(4110)
	integer*2 tbh2(8192)
	logical*1 tbh1(16384)
	integer*4 tbh4(4096)
	Equivalence(trkbuf(1,1),tbh(4))
	Equivalence(trkbuf(1,1),tbh1(1))
	Equivalence(trkbuf(1,1),tbh2(1))
	Equivalence(tbh2(1),tbh4(1))
C track buffer, 32 sectors of 512 bytes each, used as unit of compression.
C tbh(1)=track#
C tbh(2)=compressed/decompressed
C   1=compressed, 0=uncompressed
C tbh(3)=size of buffer data
C tbh(4-4099 = data
	Integer*4 lbnfence,LBNF,ixxx
	Common/Trkbuf/tbh,nrmbuf,cmpbuf,idirty,LBNF,ixxx
	istat=1
	lbnbas=lbn/32
	lbnlo=lbnbas*32
	lbnhi=lbnlo+31
c find block range covered by this read. Start at lbn.
	nblks=(isiz+511)/512
C Since we mark whether a track is recorded compressed or not, read it in here and figure
C out from the flag whether to decompress it. Great stuff!
C First zero the area, then read. If nothing's there, we return the zeroes.
	do 100 n=2,4099
	tbh(n)=0
100	continue
	tbh(1)=lbnbas
	read(unit=1,keyeq=lbnbas,keyid=0,iostat=ioxx)tbh
c This gets the first block (at least) of the I/O.
C decompress if appropriate now
	iout=1
	ilbn=lbn
	Nlbn=nblks
C iout is our output subscript for returning data to our caller. ILbn is LBN
110	Continue
	if(tbh(2).eq.0)goto 200
C Data was compressed. Now decompress it.
	tbh2(1)=0
	tbh1(5)=0
C tbh1 byte is next bit offset
	nrmbuf(1)=0
	nrmbuf(2)=16990
c set initial of buffer to start
	Call lz_decompress(256,256,trkbuf(1,1),nrmbuf)
	goto 300
200	Continue
C Fix so that nrmbuf has valid looking data whether original was compressed or not
	kkk=1+((tbh(3)+1)/2)
	do 220 n=1,kkk
	nrmbuf(n+2)=tbh2(n)
220	Continue
300	Continue
C now figure out what data needs to be copied into bufdat from the just-decompressed data
C and copy it.
C nrmbuf has data preceded by a longword of extra rubbish (buffer size)
C (actually, 16 bits offset to current pos, 16 bits of size)
	ibas=3
	ibas=ibas+(lbn-lbnlo)*256
115	Continue
	do 120 n=1,256
C copy a block
	bufdat(iout)=nrmbuf(ibas)
	iout=iout+1
	ibas=ibas+1
120	Continue
	ilbn=ilbn+1
	nlbn=nlbn-1
	if(nlbn.le.0)goto 130
	if(ilbn.le.lbnhi)goto 115
c passed this buffer-full, so better go read another buffer-full.
C can't get more than 2 buffers in this design since all reads are limited by
C fddrv to 8K (16 blocks) or less.
	lbnbas=lbnbas+1
	do 125 n=2,4099
	tbh(n)=0
125	continue
	tbh(1)=lbnbas
C read second (of at most 2) tracks.
	read(unit=1,keyeq=lbnbas,keyid=0,iostat=ioxx)tbh
	if(tbh(2).eq.0)goto 1200
C Data was compressed. Now decompress it.
	tbh2(1)=0
	tbh1(5)=0
C tbh1 byte is next bit offset
	nrmbuf(1)=0
	nrmbuf(2)=16990
	Call lz_decompress(256,256,trkbuf(1,1),nrmbuf)
	goto 1300
1200	Continue
C Fix so that nrmbuf has valid looking data whether original was compressed or not
	kkk=1+((tbh(3)+1)/2)
	do 1220 n=1,kkk
	nrmbuf(n+2)=tbh2(n)
1220	Continue
1300	Continue
C Now go back and finish output to user buffer
	ibas=3
C this is a continuation so we're guaranteed starting at the bottom here.
	GoTo 115
130	Continue
C All done the read now, and data is copied to user.
C (zeroes ginned up where needed also, if read failed to find data there)
	return
	end
	Subroutine BufWt(bufdat,Lbn,Isiz,Istat)
	parameter (io_ok=0)
	integer*2 bufdat(8200)
	Integer*4 LBN,isiz,Istat
	Integer*2 nrmbuf(8220),cmpbuf(8220)
	logical*1 lrmbuf(17000),lcmpbf(17000)
	Equivalence(nrmbuf(1),lrmbuf(1))
	Equivalence(cmpbuf(1),lcmpbf(1))
C normal text and compressed text buffers
	Integer*4 Idirty
	Include '($fordef)'
C idirty made nonzero to flag track buffer was modified
	Integer*4 TrkBuf(128,32),TBH(4110)
	integer*2 tbh2(8192)
	Integer*4 tbh4(4096)
	Equivalence(trkbuf(1,1),tbh(4))
	Logical*1 tbh1(16384)
	Equivalence(trkbuf(1,1),tbh1(1))
	Equivalence(trkbuf(1,1),tbh2(1))
	Equivalence(tbh2(1),tbh4(1))
C track buffer, 32 sectors of 512 bytes each, used as unit of compression.
C tbh(1)=track#
C tbh(2)=compressed/decompressed
C   1=compressed, 0=uncompressed
C tbh(3)=size of buffer data (in bytes, data only)
C tbh(4-4099 = data
	Integer*4 lbnfence,LBNF,ixxx
	Common/Trkbuf/tbh,nrmbuf,cmpbuf,idirty,LBNF,ixxx
	istat=1
	lbnbas=lbn/32
	lbnlo=lbnbas*32
	lbnhi=lbnlo+31
c find block range covered by this read. Start at lbn.
	nblks=(isiz+511)/512
C Since we mark whether a track is recorded compressed or not, read it in here and figure
C out from the flag whether to decompress it. Great stuff!
C First zero the area, then read. If nothing's there, we return the zeroes.
	do 100 n=2,4099
	tbh(n)=0
100	continue
	tbh(1)=lbnbas
C since the part we write may be only part of a track, we have to read all of it
C and move in the new data, then recompress if appropriate.
C Since the max read or write amount is 8K (16 blocks), in practice this
C means we ALWAYS will have to do this. Therefore there's nothing to be
C gained by trying to special-case the case of writing a full track; we'll
C never see such a request (with the current setup of FDDRV anyway).
	read(unit=1,keyeq=lbnbas,keyid=0,iostat=ioxx)tbh
C Ensure the record exists
	if(ioxx.ne.io_ok) then
	 call errsns(,,,,istatt)
	 if(istatt.eq.for$_attaccnon) then
	  tbh(1)=lbnbas
	  write(unit=1)(tbh(kkk),kkk=1,10)
C Read the record just written so it becomes the current one.
	  read(unit=1,keyeq=lbnbas,keyid=0,iostat=ioxx)(tbh(kkk),kkk=1,10)
	  tbh(1)=lbnbas
C write the record with a few bytes of data, all 0's, to make rewrite work
C for$_attaccnon = 36
	 end if
C reset error indicator
C This is in case buffer is shorter than max of array...ensure we read it OK once.
	read(unit=1,keyeq=lbnbas,keyid=0,iostat=ioxx)tbh(1)
	end if
c This gets the first block (at least) of the I/O.
C decompress if appropriate now
	iout=1
	ilbn=lbn
	Nlbn=nblks
C iout is our output subscript for returning data to our caller. ILbn is LBN
110	Continue
	if(tbh(2).eq.0)goto 200
C Data was compressed. Now decompress it.
	tbh2(1)=0
C should have read in the size used automgically
	tbh1(5)=0
C tbh1 byte is next bit offset
	nrmbuf(1)=0
	nrmbuf(2)=16990
	Call lz_decompress(256,256,trkbuf(1,1),nrmbuf)
	goto 300
200	Continue
C Fix so that nrmbuf has valid looking data whether original was compressed or not
	kkk=1+((tbh(3)+1)/2)
	do 220 n=1,kkk
	nrmbuf(n+2)=tbh2(n)
220	Continue
	nrmbuf(1)=tbh(3)
	nrmbuf(2)=tbh(3)
300	Continue
C now figure out what data needs to be copied into bufdat from the just-decompressed data
C and copy it.
C nrmbuf has data preceded by a longword of extra rubbish (buffer size)
C (actually, 16 bits offset to current pos, 16 bits of size)
	ibas=3
	ibas=ibas+(lbn-lbnlo)*256
115	Continue
	do 120 n=1,256
C copy a block
	nrmbuf(ibas)=bufdat(iout)
c	bufdat(iout)=nrmbuf(ibas)
	iout=iout+1
	ibas=ibas+1
120	Continue
	ilbn=ilbn+1
	nlbn=nlbn-1
	If(nlbn.le.0)goto 1207
C skip out to write stuff out if done all blocks to be done here
	if(ilbn.le.lbnhi)goto 115
1207	Continue
c passed this buffer-full, so better go read another buffer-full.
C can't get more than 2 buffers in this design since all reads are limited by
C fddrv to 8K (16 blocks) or less.
C Now the buffer nrmbuf is set up as a "full" buffer
	nrmbuf(2)=nrmbuf(1)
C so now compress it if we're above the "fence" value
	if(lbnbas.le.LBNF)goto 140
C Compress data.
	tbh(1)=lbnbas
	tbh(2)=1
C At this point we have decompressed data, 32 blocks full, in the buffer, plus a 4 byte
C header. Set this up as its' size.
	nrmbuf(2)=(32*512)+4
	nrmbuf(1)=0
	tbh2(1)=0
	tbh1(5)=0
C tbh1 byte is next bit offset
	kk= lz_compress(256,256,tbh2(1),nrmbuf(1))
C lz_compress routines return the size used in 2nd word. Add slop for extra bits. (+1 for
C  good luck)
	tbh(3)=tbh2(2)+2
	tbh(2)=1
	GoTo 150
140	Continue
C Not compressing. Move data into track buffer
	tbh(1)=lbnbas
	do 142 n=1,8192
	tbh2(n)=nrmbuf(n+2)
142	Continue
	tbh(2)=0
	tbh(3)=8192
150	Continue
C allow extra 2 bytes. One for Fortran-ism starting at 1, one for last few bits.
	kkk=3+(tbh(3)+3)/4
	tbh(1)=lbnbas
	read(unit=1,keyeq=lbnbas,keyid=0,iostat=ioxx)tbh(1)
	tbh(1)=lbnbas
	ReWrite(unit=1,iostat=ioxy)(tbh(kk),kk=1,kkk)
C Write out only data (plus our header)
C now exit if we got done all the blocks that were to be done here.
	if(nlbn.le.0)goto 130
C There are more blocks to do, so read next buffer in.
	lbnbas=lbnbas+1
	do 125 n=2,4099
	tbh(n)=0
125	continue
	tbh(1)=lbnbas
C read second (of at most 2) tracks.
	read(unit=1,keyeq=lbnbas,keyid=0,iostat=ioxx)tbh
	if(ioxx.ne.io_ok) then
	 call errsns(,,,,istatt)
	 if(istatt.eq.for$_attaccnon) then
	  tbh(1)=lbnbas
	  write(unit=1)(tbh(kkk),kkk=1,10)
C write the record with a few bytes of data, all 0's, to make rewrite work
C Read the record just written so it becomes the current one.
	  read(unit=1,keyeq=lbnbas,keyid=0,iostat=ioxx)(tbh(kkk),kkk=1,10)
	  tbh(1)=lbnbas
C for$_attaccnon = 36
	 end if
C reset error indicator
	read(unit=1,keyeq=lbnbas,keyid=0,iostat=ioxx)tbh(1)
	end if
	if(tbh(2).eq.0)goto 1200
C Data was compressed. Now decompress it.
	tbh2(1)=0
C should have read in the size used automgically
	tbh1(5)=0
C tbh1 byte is next bit offset
	nrmbuf(1)=0
	nrmbuf(2)=16990
	Call lz_decompress(256,256,trkbuf(1,1),nrmbuf)
	goto 1300
1200	Continue
C Fix so that nrmbuf has valid looking data whether original was compressed or not
	kkk=1+((tbh(3)+1)/2)
	do 1220 n=1,kkk
	nrmbuf(n+2)=tbh2(n)
1220	Continue
1300	Continue
C Now go back and finish output to user buffer
	if(lbnbas.le.LBNF)goto 2140
C Compress data.
	tbh(1)=lbnbas
	tbh(2)=1
C At this point we have decompressed data, 32 blocks full, in the buffer, plus a 4 byte
C header. Set this up as its' size.
	nrmbuf(2)=(32*512)+4
	nrmbuf(1)=0
	tbh2(1)=0
	tbh1(5)=0
C tbh1 byte is next bit offset
	kk= lz_compress(256,256,tbh2(1),nrmbuf(1))
C lz_compress routines return the size used in 2nd word. Add slop for extra bits. (+1 for
C  good luck)
	tbh(3)=tbh2(2)+2
	GoTo 2150
2140	Continue
C Not compressing. Move data into track buffer
	tbh(1)=lbnbas
	do 2142 n=1,8192
	tbh2(n)=nrmbuf(n+2)
2142	Continue
	tbh(2)=0
	tbh(3)=8192
2150	Continue
C allow extra 2 bytes. One for Fortran-ism starting at 1, one for last few bits.
	kkk=3+(tbh(3)+3)/4
	tbh(1)=lbnbas
	read(unit=1,keyeq=lbnbas,keyid=0,iostat=ioxx)tbh(1)
	tbh(1)=lbnbas
	ReWrite(unit=1,iostat=ioxy)(tbh(kk),kk=1,kkk)
C Write out only data (plus our header)
	Ibas=3
	GoTo 115
130	Continue
C All done the write now, and data is copied from user.
C (zeroes ginned up where needed also, if read failed to find data there)
	return
	end