c wrtfil - subroutines for producing tek 4662 commands c c c date of first version: 21-Jun-83 c c programmer: Matt Prucka c c********************************************************************** c addressable device units per inch c bell c device name is 'A' c end-of-line c end-of-string c error output c escape c form feed c gs char. is used to enable graphics mode c address of job-status-word c lower case bit of job-status-word c line feed c maximum characters in string buffer c sync char. is used to pad tek string c us char. is used to enable alpha mode c opnfil - opens file where tektronic 4662 plotter commands will be dumped subroutine opnfil(str,iunit,inew) external len byte str(1) if(.not.(inew.eq.0))goto 23000 open(unit=iunit,name=str,type='OLD',readonly,err=1, & carriagecontrol='LIST') goto 23001 c else 23000 continue if(.not.(inew.eq.1))goto 23002 open(unit=iunit,name=str,type='NEW',err=1,carriagecontrol= & 'LIST') 23002 continue 23001 continue return 1 write (7,201)(str(i),i=1,len(str)) call exit 201 format(' *** can''t open file: ',99 a1) end c clofil - closes file subroutine clofil(str) byte str(1) c c Common block for PLT parameters c real*8prmnam,txtnam,keywrd bytexlabel,ylabel,rlabel,xfmt,yfmt,rfmt,msg,filonm(14) bytefilinm(40) logical*1dataon,pltfnd,msgflg,finflg,modflg,conton,axflg,newpag, & ecflg,typerr,dbflg c common /params/xmin,xmax,xint,xcycle,xpct,xlen,xllc,ymin,ymax, & yint,ycycle,ypct,ylen,yllc,rmin,rmax,rint,rcycle,rpct,pltype, & typlin,pltlin,symnum,sizsym,solid,sizann,wtlnan,xanlab,yanlab, & ranlab,yhor,grid,sizlab,wtlnlb,ticmrk,shade,echo,wtlnax,openax, & sizmsg,wtlnms,xmsg,ymsg,angmsg,datmsg,sizfac,smooth,header,sort, & unused(1) common /flags/dataon,pltfnd,msgflg,finflg,modflg,conton,axflg, & newpag,ecflg,typerr,dbflg common /names/prmnam(50),txtnam(6),keywrd(25),filinm,filonm common /text/xlabel(52),ylabel(52),rlabel(52),xfmt(6),yfmt(6), & rfmt(6),msg(256) common /misc/ifrom,ito,inow,ipage,model,lunin,lunout c common /axes/rxmin,rxmax,rymin,rymax,rxlen,rylen,rxllc,ryllc, & pxmin,pxmax,pymin,pymax,pxlen,pylen,pxllc,pyllc common /size/tiklen,hitann,hitlab,hitsym,hitmsg,iaxlnw,igrlnw, & ianlnw,ilblnw,ipllnw,imslnw,avgaxl common /msks/ msk1,msk2,msk3,msk4,msk5 close(unit=lunout) return end c flush - force output to tek file subroutine flush call puttek(-1) return end c puttek - put a string of characters to plotter subroutine puttek(str) byte str(1),buf(99) external len c c Common block for PLT parameters c real*8prmnam,txtnam,keywrd bytexlabel,ylabel,rlabel,xfmt,yfmt,rfmt,msg,filonm(14) bytefilinm(40) logical*1dataon,pltfnd,msgflg,finflg,modflg,conton,axflg,newpag, & ecflg,typerr,dbflg c common /params/xmin,xmax,xint,xcycle,xpct,xlen,xllc,ymin,ymax, & yint,ycycle,ypct,ylen,yllc,rmin,rmax,rint,rcycle,rpct,pltype, & typlin,pltlin,symnum,sizsym,solid,sizann,wtlnan,xanlab,yanlab, & ranlab,yhor,grid,sizlab,wtlnlb,ticmrk,shade,echo,wtlnax,openax, & sizmsg,wtlnms,xmsg,ymsg,angmsg,datmsg,sizfac,smooth,header,sort, & unused(1) common /flags/dataon,pltfnd,msgflg,finflg,modflg,conton,axflg, & newpag,ecflg,typerr,dbflg common /names/prmnam(50),txtnam(6),keywrd(25),filinm,filonm common /text/xlabel(52),ylabel(52),rlabel(52),xfmt(6),yfmt(6), & rfmt(6),msg(256) common /misc/ifrom,ito,inow,ipage,model,lunin,lunout c common /axes/rxmin,rxmax,rymin,rymax,rxlen,rylen,rxllc,ryllc, & pxmin,pxmax,pymin,pymax,pxlen,pylen,pxllc,pyllc common /size/tiklen,hitann,hitlab,hitsym,hitmsg,iaxlnw,igrlnw, & ianlnw,ilblnw,ipllnw,imslnw,avgaxl common /msks/ msk1,msk2,msk3,msk4,msk5 data nbuf/0/ if(.not.(str(1).lt.0))goto 23004 c flush write(lunout,200)(buf(i),i=1,nbuf) goto 23005 c else 23004 continue nchr=len(str) if(.not.((nchr+nbuf).ge.99))goto 23006 write(lunout,200)(buf(i),i=1,nbuf) nbuf=0 23006 continue c for i=1 23008 if(.not.(i.le.nchr))goto 23010 buf(nbuf+i)=str(i) i=i+1 goto 23008 c endfor 23010 continue nbuf=nbuf+nchr 23005 continue return 200 format( 99 a1 ) end c bell - places a bell in output file subroutine bell byte buf(2) data buf/7,0/ call puttek(buf) return end c draw - places tek 4662 draw instruction to output file subroutine draw(x,y) byte buf(6) real x,y call intotk(x,y,buf) call puttek(buf) return end c move - places tek 4662 move instruction to output file subroutine move(x,y) byte buf(7) real x,y common/pstat/mode buf(1)=29 call intotk(x,y,buf(2)) call puttek(buf) mode=29 return end c intotk - convert coordinates in inches to tektronics byte string subroutine intotk(xx,yy,buf) byte buf(1) integer x,y,i real xx,yy x=max0(min1(xx*390.1,4095.),0) y=max0(min1(yy*390.1,4095.),0) c hiy buf(1)=' '+y/128 c eb buf(2)='`'+mod(x,4)+mod(y,4)*4 c loy buf(3)='`'+mod(y,128)/4 c hix buf(4)=' '+x/128 c lox buf(5)='@'+mod(x,128)/4 buf(6)=0 return end c alphrt - places tek 4662 set alpha rotation instructions to output file subroutine alphrt(rot) byte str(10) integer rot integer nrot integer orot,ols,ocs,lpen common/calpha/orot,ols,ocs,lpen nrot=rot if(.not.(nrot.ne.orot))goto 23011 str(1)=27 str(2)='A' str(3)='J' c while 23013 if(.not.(nrot.lt.0))goto 23014 nrot=nrot+360 goto 23013 c endwhile 23014 continue i=itoc(nrot,str(4),7) call puttek(str) orot=nrot 23011 continue return end c alphsz - places tek 4662 set alpha size subroutine alphsz(wid, hgt) byte str(16) real ls,cs integer nls,ncs integer orot,ols,ocs,lpen common/calpha/orot,ols,ocs,lpen c line space nls=amin1(hgt*390.1*(105./64.),999.) c character space ncs=amin1(wid*390.1*( 55./36.),999.) if(.not.(nls.ne.ols .or. ncs.ne.ocs))goto 23015 str(1)=27 str(2)='A' str(3)='I' i=itoc(ncs,str(4),7) str(i+4)=',' i=itoc(nls,str(i+5),7) call puttek(str(1)) ols=nls ocs=ncs 23015 continue return end c alpha - places tek 4662 instruction to print out alpha characters subroutine alpha(stri) byte stri(1),str(99) common/pstat/mode if(.not.(mode .eq. 31))goto 23017 i=1 goto 23018 c else 23017 continue str(1)=31 i=2 mode=31 23018 continue j=1 c for 23019 if(.not.(i.lt.99.and.stri(j).ne.0))goto 23021 str(i)=stri(j) j=j+1 i=i+1 goto 23019 c endfor 23021 continue str(i)=0 call puttek(str) return end c newpen - places tek 4662 instruction for pen subroutine newpen(npen) integer npen byte buf(6) data buf/27,'A','B','P','1',0/ if(.not.(npen.ne.lpen))goto 23022 i=itoc(min0(npen,9),buf(5),2) call puttek(buf) lpen=npen 23022 continue return end c page - signal new page (media change) subroutine page byte tekpag(4) data tekpag/27,'A','K',0/ call puttek(tekpag) return end c erase - clear RETROGRAPHICS screen subroutine erase byte tekera(3) data tekera/27,12,0/ call puttek(tekera) return end