c lpgplt - plot tek file on the datasouth graphics printer c popen - initialize plot file subroutine popen common/cpplot/ib,bbuf,ixpen,iypen integer ib,ixpen,iypen byte bbuf(512) common/scale/xsc,ysc real xsc,ysc call creblk(1,'wf:lpgplt.tmp',150,ier) if(.not.(ier.lt.0))goto 23000 call creblk(1,'dk:lpgplt.tmp',150,ier) 23000 continue if(.not.(ier.lt.0))goto 23002 type *,' *** error creating file =',ier,' ***' call exit(0) 23002 continue ib=0 call rdblk(1,ib,bbuf,1,ier) if(.not.(ier.le.0))goto 23004 type *,' *** error reading file =',ier 23004 continue c erase bit map file call derase c Scaled for tektronics 4663 addressable graphics units (ADU) c Page format is 'A-DRAFTING' c X = 10.5 inches = 4096 ADU c Y = 7.74 inches = 3019.23 ADU c tek steps per inch = 4096/10.5 psc=390.1 c dots per inch in x dimension xsc=72.2/psc c dots per inch in y dimension ysc=75.5/psc call makdot(1) return end c pclose - plot and close bit-map file subroutine pclose common/cpplot/ib,bbuf,ixpen,iypen integer ib,ixpen,iypen byte bbuf(512) call wrblk(1,ib,bbuf,1,ier) call rdblk(1, 0,bbuf,1,ier) call doplot call clsblk(1,ier) c send line and exit graphics mode call lpsend(29) return end c ploc - locate the bit in bit map file representing given xy pair logical*1 function ploc(ix,iy,iblk,ibyt,ibit) integer ix,iy,iblk,ibyt,ibit integer jblk,jbyt,jbit,kblk if(.not.((ix.lt.1).or.(iy.lt.1).or.(ix.gt.792).or.(iy.gt.768))) & goto 23006 ploc=.false. goto 23007 c else 23006 continue kblk=(ix-1)*3 jblk=(iy-1)/256 jbyt=1+((iy-1)-(jblk*256))/8 jbit=iy-jblk*256-(jbyt-1)*8 iblk=(jblk+kblk)/16 ibyt=jbyt+(jblk+kblk-iblk*16)*32 ibit=jbit ploc=.true. 23007 continue return end c pmove - move the pen to (ixin,iyin) without drawing subroutine pmove(ixin,iyin) integer ixin,iyin common/scale/xsc,ysc real xsc,ysc common/cpplot/ib,bbuf,ixpen,iypen integer ib,ixpen,iypen byte bbuf(512) ixpen=ixin*xsc+1. iypen=iyin*ysc+1. return end c pdraw - draw line from current pen position to the point (ixin,iyin) subroutine pdraw(ixin,iyin) integer ixin,iyin integer x,y common/cdot/dotsiz,npd,ixd,iyd integer dotsiz,npd,ixd(81),iyd(81) common/scale/xsc,ysc real xsc,ysc common/cpplot/ib,bbuf,ixpen,iypen integer ib,ixpen,iypen byte bbuf(512) x=ixin*xsc+1. y=iyin*ysc+1. if(.not.(dotsiz.le.1))goto 23008 call line(ixpen,iypen,x,y) goto 23009 c else 23008 continue call fatlin(ixpen,iypen,x,y) 23009 continue ixpen=x iypen=y return end c pdot - put a dot at (x,y) subroutine pdot(x,y) integer x,y common/cdot/dotsiz,npd,ixd,iyd integer dotsiz,npd,ixd(81),iyd(81) common/cpplot/ib,bbuf,ixpen,iypen integer ib,ixpen,iypen byte bbuf(512) ixc=x iyc=y c for i=1 23010 if(.not.(i.le.npd))goto 23012 call pset(ixc+ixd(i),iyc+iyd(i)) i=i+1 goto 23010 c endfor 23012 continue return end c makdot - make dot pattern subroutine makdot(num) common/cdot/dotsiz,npd,ixd,iyd integer dotsiz,npd,ixd(81),iyd(81) dotsiz=num npd=0 ir=dotsiz/2 irsq=(dotsiz/2.)**2-.3 c for i=-ir 23013 if(.not.(i.le.ir))goto 23015 c for j=-ir 23016 if(.not.(j.le.ir))goto 23018 if(.not.(i**2+j**2.le.irsq))goto 23019 npd=npd+1 ixd(npd)=i iyd(npd)=j 23019 continue j=j+1 goto 23016 c endfor 23018 continue i=i+1 goto 23013 c endfor 23015 continue return end c pset - set a bit in the bit map file corresponding to the point (ix,iy) subroutine pset(ix,iy) common/cpplot/ib,bbuf,ixpen,iypen integer ib,ixpen,iypen byte bbuf(512) integer ix,iy,iblk,ibyt,ibit logical*1 bmask(8),ploc data bmask/1,2,4,8,16,32,64,128/ if(.not.(ploc(ix,iy,iblk,ibyt,ibit)))goto 23021 if(.not.(ib.ne.iblk))goto 23023 call wrblk(1,ib ,bbuf,1,ier) call rdblk(1,iblk,bbuf,1,ier) ib=iblk 23023 continue bbuf(ibyt)=bbuf(ibyt).or.bmask(ibit) 23021 continue return end c ppage - subroutine ppage common/cpplot/ib,bbuf,ixpen,iypen integer ib,ixpen,iypen byte bbuf(512) call wrblk(1,ib,bbuf,1,ier) call rdblk(1, 0,bbuf,1,ier) call doplot call derase return end c ppen - change dot size subroutine ppen(bpen) byte bpen common/cpplot/ib,bbuf,ixpen,iypen integer ib,ixpen,iypen byte bbuf(512) if(.not.(bpen.ge.'0' .and. bpen .le.'9'))goto 23025 i=bpen-'0' idot = 1+i*(75./200.) call makdot(idot) 23025 continue return end c doplot - put out hard copy of plot file to the datasouth subroutine doplot byte ff(3) data ff/29,12,0/ byte bmask(8),gmask(6) common/cpplot/ib,bbuf,ixpen,iypen integer ib,ixpen,iypen byte bbuf(512) common/bitcom/iblk,ibyt,ibit integer iblk,ibyt,ibit common/lpgcom/bc,ibcnt,gbuf integer bc,ibcnt byte gbuf(770) logical tsxenv logical*1 flag data bmask/1,2,4,8,16,32,64,128/ data gmask/32,16,8,4,2,1/ data flag /.false./ if(.not.(.not.flag))goto 23027 c initialize lp on first pass open(unit=6,name='LP:',type='OLD') c form feed to line printer call fastlp(ff) c initialize line printer graphics call lpgini flag = .true. 23027 continue call lpgclr iblk=0 ibyt=1 ibit=1 c for ix=1 23029 if(.not.(ix.le.792))goto 23031 bc=bc+1 c for iy=1 23032 if(.not.(iy.le.768))goto 23034 if(.not.((bbuf(ibyt).and.bmask(ibit)).ne.0))goto 23035 gbuf(iy+1)=gbuf(iy+1).or.gmask(bc) 23035 continue ibit=ibit+1 if(.not.(ibit.gt.8))goto 23037 ibit=1 ibyt=ibyt+1 if(.not.(ibyt.gt.512))goto 23039 ibyt=1 iblk=iblk+1 call rdblk(1,iblk,bbuf,1,ier) if(.not.(ier.lt.0))goto 23041 type *,' *** error in rdblk ',ier 23041 continue 23039 continue 23037 continue iy=iy+1 goto 23032 c endfor 23034 continue if(.not.(bc.ge.6))goto 23043 call lpgout 23043 continue ix=ix+1 goto 23029 c endfor 23031 continue return end c derase - clear the bit map file subroutine derase common/cpplot/ib,bbuf,ixpen,iypen integer ib,ixpen,iypen byte bbuf(512) do 23045 i=1,512 bbuf(i)=0 23045 continue c for ib=0 23047 if(.not.(ib.lt.150))goto 23049 call wrblk(1,ib,bbuf,1,ier) ib=ib+1 goto 23047 c endfor 23049 continue return end c lpgini - initialize line printer graphics subroutine lpgini byte grfset(2) common/lpgcom/bc,ibcnt,gbuf integer bc,ibcnt byte gbuf(770) data grfset/28,0/ ibcnt=768 c set graphics mode call fastlp(grfset) c clear the lp graphics buffer call lpgclr return end c lpgout - flush gbuf out to line printer subroutine lpgout c send line to printer with "6" at end call lpsend('6') call lpgclr return end c lpgclr - clear gbuf subroutine lpgclr common/lpgcom/bc,ibcnt,gbuf integer bc,ibcnt byte gbuf(770) bc=0 c for i=1 23050 if(.not.(i.le.ibcnt))goto 23052 gbuf(i)='@' i=i+1 goto 23050 c endfor 23052 continue return end c lpsend - prepare graphic string for sending to Datasouth 180 printer subroutine lpsend(term) byte term integer end common/lpgcom/bc,ibcnt,gbuf integer bc,ibcnt byte gbuf(770) c strip trailing blanks c for end=ibcnt 23053 if(.not.(end.gt.0.and.gbuf(end).eq.'@'))goto 23055 end=end-1 goto 23053 c endfor 23055 continue c terminate line with "term" gbuf(end+1)=term gbuf(end+2)=0 call fastlp(gbuf) return end c line subroutine line(x0,y0,x1,y1) integer x0,y0,x1,y1 integer x,y integer dx,dy integer xinc,yinc integer res1 integer res2 integer slope xinc = 1 yinc = 1 dx = x1-x0 dy = y1-y0 if(.not.(dx.lt.0))goto 23056 xinc = -1 dx = -dx 23056 continue if(.not.(dy.lt.0))goto 23058 yinc = -1 dy = -dy 23058 continue slope = xinc*yinc res1 = 0 res2 = 0 x = x0 y = y0 if(.not.(dx.lt.dy))goto 23060 c while 23062 if(.not.(y.ne.y1))goto 23063 call pset(x,y) if(.not.(res1.gt.res2))goto 23064 res2 = res2+dy-res1 res1 = 0 x = x+xinc 23064 continue res1 = res1+dx y = y+yinc goto 23062 c endwhile 23063 continue goto 23061 c else 23060 continue c while 23066 if(.not.(x.ne.x1))goto 23067 call pset(x,y) if(.not.(res1.gt.res2))goto 23068 res2 = res2+dx-res1 res1 = 0 y = y+yinc 23068 continue res1 = res1+dy x = x+xinc goto 23066 c endwhile 23067 continue 23061 continue call pset(x1,y1) return end c fatlin subroutine fatlin(x0,y0,x1,y1) integer x0,y0,x1,y1 integer x,y integer dx,dy integer xinc,yinc integer res1 integer res2 integer slope xinc = 1 yinc = 1 dx = x1-x0 dy = y1-y0 if(.not.(dx.lt.0))goto 23070 xinc = -1 dx = -dx 23070 continue if(.not.(dy.lt.0))goto 23072 yinc = -1 dy = -dy 23072 continue slope = xinc*yinc res1 = 0 res2 = 0 x = x0 y = y0 if(.not.(dx.lt.dy))goto 23074 c while 23076 if(.not.(y.ne.y1))goto 23077 call pdot(x,y) if(.not.(res1.gt.res2))goto 23078 res2 = res2+dy-res1 res1 = 0 x = x+xinc 23078 continue res1 = res1+dx y = y+yinc goto 23076 c endwhile 23077 continue goto 23075 c else 23074 continue c while 23080 if(.not.(x.ne.x1))goto 23081 call pdot(x,y) if(.not.(res1.gt.res2))goto 23082 res2 = res2+dx-res1 res1 = 0 y = y+yinc 23082 continue res1 = res1+dy x = x+xinc goto 23080 c endwhile 23081 continue 23075 continue call pdot(x1,y1) return end