c	File LA100P.FOR
c	Rev. 8405.301
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 LA100P (istat)
c
c	Prints Graphics Raster Dump on DEC LA100 Letterprinter 100
c
	integer*2 iptabl(256)
	byte cell(512,16,2)
	integer*2 celbuf(256,16,2)
	integer iread(16,2), iavail(2), ihave(2), iarray(1024)
	integer iblkh(2), iblkn(2), iblkb(2), iblkr(2), iblku(2)
c
	common /LA100U/ lui, luo, luterm, iopen
	common /RASDMP/ ixmin, ixmax, iymin, iymax
c
	equivalence (cell, celbuf)
c
	data iblkh / -1, -1 /			! current cells we have
	data iblkn /  0, 0 /			! starting cells needed
	data iblkr /  0, 0 /			! cells to get
	data iblku /  0, 0 /			! cells to use
c
	data ixmin /    1 /
	data ixmax /  958 /
	data iymin /    1 /
	data iymax /  720 /
c
c	Begin by opening raster bitmap data file:
c
	open (unit=lui, name='RASFIL.TMP', type='OLD',
	1	access='DIRECT', recordsize=128, err=970)
c
c	Read pointer table from first block:
c
	read (lui ' 1) iptabl
c
c	Begin at top, and work down, one six-bit scan pass
c	at a time.
c
	ipltop = (iymax+5) / 6		! top scan pass,
	iplbot = (iymin+5) / 6		! bottom scan pass,
	iscan  = MOD (ipltop-1, 32)	! need starting byte row
	ibits  = iscan * 6 + 5		! translate to top bit #,
	ibyte  = ibits / 8		!  then byte number,
	irow   = MOD (ibyte, 8)		!   and then row # in block
c
	do 1000 ipline = ipltop, iplbot, -1
c
c	determine the starting cell number(s) for this scan;
c
	  iscan = ipline - 1
	  iblkn(1) = (iscan * 6 + 5) / 64	! starting cell no., 1st bit
	  iblkn(2) = (iscan * 6) / 64		! same for last bit
	  iblkn(1) = iblkn(1) * 16 + 1
	  iblkn(2) = iblkn(2) * 16 + 1
c
c	Determine what needed cells are already in the two cell-scan
c	buffers.  Set indices into those, and set "get needed block"
c	flags for those not already loaded.
c
	  ineed = 1
	  if (iblkn(1) .ne. iblkn(2)) ineed = ineed + 1
	  iblku(1) = 0
	  iblku(2) = 0
	  iavail(1) = 1
	  iavail(2) = 1
	  ih = 0
c
c	if a needed block is in memory, mark it in the "use" array,
c	and unavailable.
c
	  do 180 i=1,ineed
	    do 160 j=1,2
	      if (ihave(j) .ne. iblkn(i)) go to 160
	      iblku(i) = j
	      iavail(j) = 0
	      ih = ih + 1
	      go to 180
  160	    continue
  180	  continue
	  if (ih .eq. ineed) go to 400	! no reading necessary
c
c	if a needed block is not in memory, increment the "get" count,
c	and assign an unused buffer to it.
c
	  iget = 0
	  do 230 i=1,ineed
	    if (iblku(i) .ne. 0) go to 230	! already have it?
	    iget = iget + 1		! neither has it; better get it.
	    do 215 j=1,2		! check availability of buffer,
	      if (iavail(j) .eq. 0) go to 215
	      iblkb(iget) = j		! buffer j is free for use;
	      iblku(i) = j		! mark it now as used.
	      iblkr(iget) = iblkn(i)	! get this block,
	      ihave(j) = iblkn(i)	! and note having it.
	      iavail(j) = 0		! buffer j is no longer available.
	      go to 230
  215	    continue
  230	  continue
c
c	Read blocks (cells) from disk, if necessary.  Otherwise, simply
c	flag zero blocks as such.
c
	  if (iget .eq. 0) go to 400		! none to get?
	  do 360 i=1,iget
	    iblk = iblkr(i)			! the start block no.
	    iuse = iblkb(i)			! the buffer no.
	    do 350 j=1,16			! 16 cells wide
	      if (iblk .le. 0) go to 330	! cell number too small?
	      if (iblk .gt. 256) go to 330	! cell number too large?
	      index = iptabl(iblk)		! disk file block number
	      if (index .eq. 0) go to 330   ! All entries zero. Skip read.
	      index = index + 2			! bypass header blocks
	      read (lui ' index) (celbuf(k,j,iuse),k=1,256)
	      iread(j,iuse) = 1			! indicate real read op
	      go to 340
  330	      iread(j,iuse) = 0
  340	      iblk = iblk + 1
  350	    continue
  360	  continue
c
c	Now, dump the scan to the printer.
c
  400	  continue
	  method = 5 - (((ipline+3) .and. 3) + 1)
	  ibuf1 = iblku(1)
	  ibuf2 = iblku(2)
	  if (ibuf2 .eq. 0) ibuf2 = ibuf1
	  n = 1
	  k1s = irow * 64 + 1
	  k2s = k1s - 64
	  if (k2s .gt. 0) go to 410
	  k2s = k2s + 512
c
  410	  go to (420, 460, 500, 540), method
c
c	method 1:
c
  420	  continue
	  do 430 j=1,16
	    if (iread(j,ibuf1) .ne. 0) go to 426
	    do 424 k=1,64
	      iarray(n) = 0
	      n = n + 1
  424	    continue
	    go to 430
c
  426	    continue
	    k1 = k1s
	    do 428 k=1,64
	      iarray(n) = (cell(k1,j,ibuf1) .and. "000374) / 4
	      n = n + 1
	      k1 = k1 + 1
  428	    continue
  430	  continue
	  go to 580
c
c	method 2:
c
  460	  continue
	  do 490 j=1,16
	    iz1 = 0
	    iz2 = 0
	    if (iread(j,ibuf1) .ne. 0) iz1 = iz1 + 1
	    if (iread(j,ibuf2) .ne. 0) iz2 = iz2 + 1
	    iz3 = iz1 + iz2
	    if (iz3 .ne. 0) go to 465
	    do 464 k=1,64
	      iarray(n) = 0
	      n = n + 1
  464	    continue
	    go to 490
c
  465	    continue
	    k1 = k1s
	    k2 = k2s
	    do 485 k=1,64
	      ival = 0
	      if (iz1 .eq. 0) go to 475
	      ival = (cell(k1,j,ibuf1) .and. "000003) * 16
  475	      if (iz2 .eq. 0) go to 480
	      ival = ival + (cell(k2,j,ibuf2) .and. "000360) / 16
  480	      iarray(n) = ival
	      n = n + 1
	      k1 = k1 + 1
	      k2 = k2 + 1
  485	    continue
  490	  continue
	  irow = irow - 1
	  go to 580
c
c	method 3:
c
  500	  continue
	  do 530 j=1,16
	    iz1 = 0
	    iz2 = 0
	    if (iread(j,ibuf1) .ne. 0) iz1 = iz1 + 1
	    if (iread(j,ibuf2) .ne. 0) iz2 = iz2 + 1
	    iz3 = iz1 + iz2
	    if (iz3 .ne. 0) go to 510
	    do 515 k=1,64
	      iarray(n) = 0
	      n = n + 1
  515	    continue
	    go to 530
c
  510	    continue
	    k1 = k1s
	    k2 = k2s
	    do 520 k=1,64
	      ival = 0
	      if (iz1 .eq. 0) go to 512
	      ival = (cell(k1,j,ibuf1) .and. "000017) * 4
  512	      if (iz2 .eq. 0) go to 514
	      ival = ival + (cell(k2,j,ibuf2) .and. "000300) / 64
  514	      iarray(n) = ival
	      n = n + 1
	      k1 = k1 + 1
	      k2 = k2 + 1
  520	    continue
  530	  continue
	  irow = irow - 1
	  go to 580
c
c	method 4:
c
  540	  continue
	  do 570 j=1,16
	    if (iread(j,ibuf1) .ne. 0) go to 550
	    do 545 k=1,64
	      iarray(n) = 0
	      n = n + 1
  545	    continue
	    go to 570
c
  550	    continue
	    k1 = k1s
	    do 560 k=1,64
	      iarray(n) = (cell(k1,j,ibuf1) .and. "000077)
	      n = n + 1
	      k1 = k1 + 1
  560	    continue
  570	  continue
	  irow = irow - 1
c
  580	  if (irow .lt. 0) irow = 7
	  call LA100S (iarray)			! dump it.
c
 1000	continue				! next scan.
c
c	close output
c
	iarray(1) = -1
	call LA100S (iarray)
c
c	close raster bitmap file
c
	close (unit=lui)
c
c	exit neatly.
c
	istat = 0
	return
c
c	exit after file not found.
c
  970	istat = -1
	return
c
	end
                                                                                                                                          