c	File LA100B.FOR
c	Rev. 8406.011
c
c	Contributed to DECUS at Spring 1984 U.S. Symposium
c	by Rob Hamilton of Multiware Inc., Davis, CA
c
c	*****************************************************
c	   This software is provided on an "AS-IS" basis.
c	*****************************************************
c
	Subroutine INIDAF (lu)
c
c	Initialize the direct-access raster file, using the user-supplied
c	logical unit number.
c
	integer lu
c
	integer*2 iptabl
	byte iobufs
	common /DOTBUF/ ludaf , icucel, ncells, icb,
	1		ixcelc, iycelc, ncbu  , ncache, icount(32),
	2		ibn(32), iptabl(256)  , iobufs(512,32)
	common /DOTDEB/ ihit, imiss
	common /LA100U/ lui, luo, luterm, iopen
c
	data ncache / 32 /	! (also needs editing in COMMON /DOTBUF/)
c
	ludaf = lu
	open (	unit        = ludaf,
	1	name        = 'RASFIL.TMP',
	2	type        = 'NEW',
	3	access      = 'DIRECT',
	4	recordsize  = 128,
	5	initialsize = 258,
	6	err         = 900 )
c
c	Begin: clear cache buffer-to-block indicies and usage counters
c
	do 100 i=1,ncache
	ibn(i) = 0
	icount(i) = -1
  100	continue
c
c	Clear pointer table
c
	do 140 i=1,256
	iptabl(i) = 0
  140	continue
c
c	Initialize Misc. Variables
c
	icb = 0					! current cache buffer
	ncbu = 0				! # cache buffers used
	ixcelc = -9999				! force new cell
	ncells = 0
	ihit = 0
	imiss = 0
	return
c
c	Error opening raster bitmap file
c
  900	write (luterm, 1901)
 1901	format(' LA100G-F-Raster file failed on open')
	stop
c
	end
	Subroutine FINDAF
c
c	Close raster file neatly.
c
	logical*1 report
	integer*2 iptabl
	byte iobufs
	common /DOTBUF/ ludaf , icucel, ncells, icb,
	1		ixcelc, iycelc, ncbu  , ncache, icount(32),
	2		ibn(32), iptabl(256)  , iobufs(512,32)
	common /DOTDEB/ ihit, imiss
	common /LA100U/ lui, luo, luterm, iopen
c
	data report / .FALSE. /		! print cache statistics?
c
c	Write cached blocks back to disk.
c
	do 100 i=1,ncache
	if (ibn(i) .le. 0) go to 100
	iblk = ibn(i)
	write (ludaf ' iblk) (iobufs(k,i),k=1,512)
  100	continue
c
c	Write the pointer table to the beginning of the file.
c
	iblk = 1
	write (ludaf ' iblk) iptabl
c
c	Close the file and return.
c
	close (unit=ludaf)
c
	if (.not.report) go to 200
	write (luterm, 1105) ihit, imiss
 1105	format (' ',/, ' Input file processing is complete.',/,
	1 ' Total cached-block benefit: ',
	1 I5, ' hits, ',I5, ' misses. ')
	hits = FLOAT(ihit)
	rmises = FLOAT(imiss)
	ratio = (hits * 100.0) / (hits + rmises)
	write (luterm, 1106) ratio
 1106	format(' (Hit ratio = ', F5.1, '%)')
	write (luterm, 1107) ncells
 1107	format(' Total disk cells used: ',I3)
c
  200	continue
	return
c
	end
	Subroutine SETDOT (ix, iy)
c
c	Set a dot in the direct access file
c
	integer ix, iy
c
	integer ibit8(8)
	integer*2 iptabl
	byte iobufs
	common /DOTBUF/ ludaf , icucel, ncells, icb,
	1		ixcelc, iycelc, ncbu  , ncache, icount(32),
	2		ibn(32), iptabl(256)  , iobufs(512,32)
c
	data ibit8  / 1, 2, 4, 8, 16, 32, 64, 128 /
c
c	Begin:  determine cell number
c
	ixcell = ix / 64
	iycell = iy / 64
	if (ixcell .eq. ixcelc .and. iycell .eq. iycelc) go to 700
	if (ix .lt. 0 .or. iy .lt. 0) return
	if (ixcell .ge. 16 .or. iycell .ge. 16) return
	ixcelc = ixcell
	iycelc = iycell
	icell  = iycell * 16 + ixcell + 1
c
c	Get the entry from the pointer table.
c
  200	ientry = iptabl(icell)			!where is it?
	if (ientry .ne. 0) go to 300		!does it exist?
c
c	The addressed cell does not exist yet.  It will
c	be allocated now.
c
	ncells = ncells + 1
	iptabl(icell) = ncells
	call BLKIO (1, ncells)			!clear new block
	icucel = ncells				!make it current
	go to 700
c
c	Read the cell in from mass storage
c
  300	call BLKIO (0, ientry)
	icucel = icell
c
c	Determine the byte number and the bit number of the
c	bit we are setting.
c
  700	ibyte = ((iy .and. 63) / 8) * 64 + (ix .and. 63) + 1
	ibit  = (iy .and. 7) + 1
c
c	Set the bit, leaving previously set bits alone.
c
	iobufs(ibyte, icb) = iobufs(ibyte, icb) .or. ibit8(ibit)
	return
c
	end
	Subroutine BLKIO (iopco, icell)
c
c	Do block I/O for Bit-map
c
c	Opcode = 0  ==> read specified block
c	Opcode = 1  ==> clear and allocate new block
c
	integer iopco, icell
c
	integer*2 iptabl
	byte iobufs
	common /DOTBUF/ ludaf , icucel, ncells, icb,
	1		ixcelc, iycelc, ncbu  , ncache, icount(32),
	2		ibn(32), iptabl(256)  , iobufs(512,32)
	common /DOTDEB/ ihit, imiss
c
	data nhblks / 2 /	!number of header/pointer blocks
	data maxint / 32767 /
c
c	Search cache block table for entry least used.
c	Grab the first unused entry, if any exist.
c
	iblk = icell + nhblks			!desired block
	icb = 1
	if (iopco .ne. 0 .or. ncbu .eq. 0) go to 60
	do 50 i=1,ncbu				!quick search for read
	if (iblk .eq. ibn(i)) go to 180		!jump and get it!
   50	continue
c
   60	max = 0
	do 100 i=1,ncache
	if (icount(i) .lt. 0) go to 120		!not used yet?
	if (icount(i) .le. max) go to 90	!this one used least?
	icb = i
	max = icount(i)
   90	if (icount(i) .lt. maxint) icount(i) = icount(i) + 1
  100	continue
	imiss = imiss + 1
	go to 130		!get rid of old one; write it out.
c
  120	icb = i			!use unused block; skip write
	ncbu = ncbu + 1
	go to 140
c
c	write old cell out to disk.
c
  130	write (ludaf ' ibn(icb)) (iobufs(k,icb),k=1,512)
c
  140	if (iopco .ne. 1) go to 160		!clear new buffer?
	do 150 k=1,512
	iobufs(k,icb) = 0
  150	continue
	go to 300
c
c	Read new block?  (Opcode = 0)
c
  160	if (iopco .ne. 0) go to 300
	read (ludaf ' iblk) (iobufs(k,icb),k=1,512)
	go to 200
c
c	Designate cached block current.
c
  180	icb = i
	ihit = ihit + 1
  200	continue
c
  300	icount(icb) = 0		!mark recent access,
	ibn(icb) = iblk		!set block number of current block
	return
c
	end
	Subroutine RFLINT (itype)
c
c	Set line type for rasterizing
c
	common /LINTPC/ ltarys(4,8), ltaray(4), lintyp, loop, ltflip,
	1		ltindx
	data ltarys /	10, 10, 10, 10,
	2		 8,  5,  2,  5,
	3		 2,  2,  2,  2,
	4		 1,  1,  1,  1,
	5		 5,  1,  5,  1,
	6		 8,  2,  8,  2,
	7		 8,  8,  3,  8,
	8		10,  5, 10,  5/
c
	lintyp = itype - 1
	if (itype .le. 0 .or. itype .gt. 8) lintyp = 0
	if (lintyp .eq. 0) return
	ndx = lintyp + 1
	do 100 i=1,4
	  ltaray(i) = ltarys(i, ndx)
  100	  continue
	loop   = 0
	ltflip = 0
	ltindx = 0
	return
c
	end
	Subroutine DOTFIL (ix1, iy1, ix2, iy2)
c
c	Use Bresenham's algorithm to Rasterize a vector
c
	integer ix1, iy1, ix2, iy2
	integer idx, idy, incr1, incr2, id, ix, iy, iend
c
	common /LINTPC/ ltarys(4,8), ltaray(4), lintyp, loop, ltflip,
	1		ltindx
c
	data ltaray / 10, 10, 10, 10 /
	data lintyp / 0 /
	data loop   / 0 /
	data ltflip / 0 /
	data ltindx / 0 /
c
c	Begin:
c
	idx = ix2 - ix1
	idy = iy2 - iy1
	inc = 1
	if (idx .lt. 0) go to 40
	if (idy .lt. 0) inc = -inc
	go to 60
   40	if (idy .ge. 0) inc = -inc
c
   60	idx = IABS (idx)
	idy = IABS (idy)
	i2dx = idx + idx
	i2dy = idy + idy
c
c	|Slope| < 1.0
c
	if (idx .lt. idy) go to 300
	id = i2dy - idx
	incr1 = i2dy
	incr2 = i2dy - i2dx
c
	if (ix1 .le. ix2) go to 120
	  ix = ix2
	  iy = iy2
	  iend = ix1
	  go to 140
  120	  ix = ix1
	  iy = iy1
	  iend = ix2
c
  140	if (lintyp .eq. 0) go to 150
	loop = loop - 1
	if (loop .ge. 0) go to 145
	ltindx = ltindx .and. "003
	ltindx = ltindx + 1
	ltflip = 1 - ltflip
	loop = ltaray(ltindx)
  145	if (ltflip .eq. 0) go to 160
  150	call SETDOT (ix, iy)
  160	if (ix .eq. iend) go to 400
	ix = ix + 1
	if (id .ge. 0) go to 170
	  id = id + incr1
	  go to 140
  170	  iy = iy + inc
	  id = id + incr2
	  go to 140
c
c	cases where |slope| > 1.0
c
  300	id = i2dx - idy
	incr1 = i2dx
	incr2 = i2dx - i2dy
c
	if (iy1 .le. iy2) go to 320
	  ix = ix2
	  iy = iy2
	  iend = iy1
	  go to 340
  320	  ix = ix1
	  iy = iy1
	  iend = iy2
c
  340	if (lintyp .eq. 0) go to 350
	loop = loop - 1
	if (loop .ge. 0) go to 345
	ltindx = ltindx .and. "003
	ltindx = ltindx + 1
	ltflip = 1 - ltflip
	loop = ltaray(ltindx)
  345	if (ltflip .eq. 0) go to 360
  350	call SETDOT (ix, iy)
  360	if (iy .eq. iend) go to 400
	iy = iy + 1
	if (id .ge. 0) go to 370
	  id = id + incr1
	  go to 340
  370	  ix = ix + inc
	  id = id + incr2
	  go to 340
c
  400	return
c
	end
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������