c File LA100S.FOR c Rev. 8406.121 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 LA100S (iarray) c c Output Graphics Bitmap, LA100 style. c This subroutine is called by subroutine LA100P. c integer iarray(1024) byte sizchr logical*1 oldsty byte line(132), mapdat(64), fmt1(12), escape, FF c common /RASDMP/ ixmin, ixmax, iymin, iymax common /LA100U/ lui, luo, luterm, iopen c data iopen / 0 / data escape / 27 / data FF / 12 / data oldsty / .TRUE. / ! LA100 Old ROM or KSR model c data mapdat / '?', '_', 'O', 'o', 'G', 'g', 'W', 'w', 1 'C', 'c', 'S', 's', 'K', 'k', '[', '{', 2 'A', 'a', 'Q', 'q', 'I', 'i', 'Y', 'y', 3 'E', 'e', 'U', 'u', 'M', 'm', ']', '}', 4 '@', '`', 'P', 'p', 'H', 'h', 'X', 'x', 5 'D', 'd', 'T', 't', 'L', 'l', '\', '|', 6 'B', 'b', 'R', 'r', 'J', 'j', 'Z', 'z', 7 'F', 'f', 'V', 'v', 'N', 'n', '^', '~' / c data fmt1 / '(', '1', 'H', ' ', ',', 1 '1', '2', '8', 'A', '1', ')', 0 / c if (iarray(1) .lt. 0) go to 900 ! end-of-file code? if (iopen .ne. 0) go to 75 ! file already open? c c Open LA100 output file, and send initial escape-sequence c for graphics mode. c open (unit=luo, name='LA:LA100G.OUT', type='NEW', 1 carriagecontrol='FORTRAN', err=1911) c sizchr = '1' if (oldsty) go to 60 ! old style ROM or LA50? sizchr = '9' 60 write (luo, 1001) escape, 'P', sizchr, 'q' 1001 format (1H+, 4A1, $) iopen = 1 c 75 ixmaxl = ixmax do 70 k=ixmax,1,-1 if (iarray(k) .ne. 0) go to 80 ! strip off trailing white ixmaxl = ixmaxl - 1 70 continue c 80 if (ixmaxl .le. ixmin) ixmaxl = ixmin + 1 ki = ixmin ! input pointer 100 ko = 1 ! output pointer 110 nrep = 129 - ko if (nrep .le. 7) go to 280 ! near end of output? if (ki .gt. ixmaxl) go to 340 ! is input exhausted? ks = ki ! starting k value ke = ks + 1 ! 1st compare index nrep = 1 do 140 k=ke,ixmaxl if (iarray(ke) .ne. iarray(ks)) go to 145 nrep = nrep + 1 ke = ke + 1 ! increment index 140 continue 145 if (nrep .lt. 4) go to 300 ! not enough to worry about nfound = nrep ! save it if (oldsty) nrep = nrep * 2 c c Insert repeat introducer into output line buffer. c line(ko) = '!' ko = ko + 1 if (nrep .lt. 1000) go to 192 n = nrep / 1000 line(ko) = n + 48 ! thousand's character ko = ko + 1 nrep = MOD (nrep, 1000) go to 193 192 if (nrep .lt. 100) go to 194 193 n = nrep / 100 line(ko) = n + 48 ! hundred's character ko = ko + 1 nrep = MOD (nrep, 100) go to 195 194 if (nrep .lt. 10) go to 196 195 n = nrep / 10 line(ko) = n + 48 ! ten's character ko = ko + 1 nrep = MOD (nrep, 10) 196 line(ko) = nrep + 48 ! one's character ko = ko + 1 index = iarray(ki) + 1 line(ko) = mapdat(index) ko = ko + 1 ki = ki + nfound ! update input pointer first. if (ki .gt. ixmaxl) go to 340 ! input done? force output. go to 330 c c write short non-repeating portions here. c 280 if (oldsty) nrep = nrep / 2 300 continue do 320 k=1,nrep index = iarray(ki) + 1 if (.not.oldsty) go to 310 line(ko) = mapdat(index) ko = ko + 1 310 line(ko) = mapdat(index) ! double horizontal bits ko = ko + 1 ki = ki + 1 if (ki .gt. ixmaxl) go to 340 ! input done? force output. 320 continue c 330 if (ko .lt. 128) go to 110 ! room in output buffer? go to 345 ! nope. dump it. c c This is the final write for this scan. c 340 line(ko) = '-' ! append graphics go to 348 345 ko = ko - 1 ! remove anticipated byte 348 continue if (ko .le. 0) go to 350 encode (3, 1012, fmt1(6)) ko 1012 format (I3) write (luo, fmt1) (line(k),k=1,ko) 350 if (ki .le. ixmaxl) go to 100 ! until input exhausted return c c EOF code passed: Close output. c 900 write (luo, 1901) escape, '\', FF 1901 format (1H , 3A1) close (unit=luo) iopen = 0 return c 1911 write (luterm, 1913) 1913 format(' ',/,' ?LA100S-F-LA100 output file failed to open.') call EXIT c end