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