c drasym - draw a symbol using table of symbol node definitions subroutine drasym(k,xll,yll,w,h,crot,srot) logical*1 filled real x,y,lastx,lasty real chrhgt,sfac(16) integer tnode 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 c SYMNOD - data defining nodes for symbols in character set integer nkhar,nnode,khar(32),node(111) data nkhar,nnode/32, 111/ data khar/ 1, 7, 12, 17, 22, 28, 34, 46, 52, 57, 64, 64, 64, 64, & 64, 64, 65, 112, 112, 112, 112, 112, 112, 112, 112, 112, 112, & 112, 112, 112, 112, 112/ data node/ -255, 24415, 24479,-24673,-24737, 24415, -255,-24705, - & 250, 360, 24447, -255, 32667,-24733, 25443, 32667, -255, 32611, & 24475,-24677, 32611, -255,-24705, 32607, 24447, 32671,-24705, - & 255, 24479,-24673, 24415,-24737, 24479, -255, 24447,-24705, -255, & -24673, 24415, -255, 32607, 32671, -255, 24479,-24737, -255, & 32671, 32607, -255, 24447,-24705, -255, 24415,-24673, 24479,- & 24737, -255, 32607, 32639,-24705, 32671, 24447, 32639,-23425, - & 255, 26719, 30326, 31094, 31100, 29817, 29572, 28804, 29591, & 28308, 30367, 32671,-31079,-30061,-30069, -255, 30320,-32659,- & 31114,-30601,-31880,-32130,-32641,-32122, -32633,-31093,-29045,- & 27771,-27780,-28297,-27533,-27032, -27041, -255, 29038,-32667,- & 30613, -255, 27507, -250, -90, 27520, -255, 25736, -250, 90, & 25708/ data chrhgt/64./ data sfac/1.,1.05,1.1,1.1,1.3,1.,1.,1.,1.,1.,.88,.92,.97,.97,1.14, & 1./ c line width in inches data filinc/.01/ if(.not.(k.lt.0 .or. k.ge.nkhar))goto 23000 c check range of symbol code return c else 23000 continue if(.not.(k.le.15))goto 23002 c symbols 0-14 have special scaling ww = w*sfac(k+1)/chrhgt hh = h*sfac(k+1)/chrhgt goto 23003 c else 23002 continue ww = w/chrhgt hh = h/chrhgt 23003 continue 23001 continue arc = 0. chord = 360./16. c origin for symbol definition xxll = xll yyll = yll lastx = xxll lasty = yyll if(.not.(k .ge. 10 .and. k .le. 15))goto 23004 c See if this is a filled symbol. filled = .true. k = k-10 goto 23005 c else 23004 continue if(.not.(k .le. 6 .and. solid .ne. 0 ))goto 23006 filled = .true. goto 23007 c else 23006 continue filled = .false. 23007 continue 23005 continue c find first and last nodes in table fnode = khar(k+1) if(.not.(k+1.lt.nkhar))goto 23008 lnode = khar(k+2)-1 goto 23009 c else 23008 continue lnode = nnode 23009 continue if(.not.(dbflg))goto 23010 type *,' fnode,lnode = ',fnode,lnode c Process nodes until we finish the character 23010 continue c repeat 23012 continue c for j = fnode 23015 if(.not.(j.le.lnode))goto 23017 call newnod(node(j),nx,ny) if(.not.(dbflg))goto 23018 type *,' nx,ny = ',nx,ny 23018 continue if(.not.(nx .eq. 255))goto 23020 if(.not.(ny .eq. 1))goto 23022 c move call newnod(node(j+1),nx,ny) x = xxll+(crot*(nx-127)-srot*(ny-127))*ww y = yyll+(srot*(nx-127)+crot*(ny-127))*hh call plot2(x,y,3) j = j+1 goto 23023 c else 23022 continue if(.not.(ny .eq. 6))goto 23024 c arc arc = node(j+1) call newnod(node(j+2),nx,ny) x = xxll+(crot*(nx-127)-srot*(ny-127))*ww y = yyll+(srot*(nx-127)+crot*(ny-127))*hh call draarc(x,y,lastx,lasty,arc,chord) if(.not.(abs(arc) .ge. 360.))goto 23026 x = lastx y = lasty 23026 continue j = j+2 23024 continue 23023 continue goto 23021 c else 23020 continue c draw x = xxll+(crot*(nx-127)-srot*(ny-127))*ww y = yyll+(srot*(nx-127)+crot*(ny-127))*hh call plot2(x,y,2) 23021 continue lastx = x lasty = y j = j+1 goto 23015 c endfor 23017 continue c If this is a filled symbol, reduce its size and re-do it if(.not.(k .le. 5 .and. filled))goto 23028 ww = ww - filinc/chrhgt hh = hh - filinc/chrhgt 23028 continue 23013 if(.not.(ww.lt.0. .or. hh.lt.0. .or. .not.filled))goto 23012 c Done with the symbol x = xxll y = yyll if(.not.(filled))goto 23030 call plot2(x,y,2) goto 23031 c else 23030 continue call plot2(x,y,3) 23031 continue return end c draarc - draw a circular arc of angle "arc" from (xpen,ypen) to (xp,yp) subroutine draarc(xp,yp,xpen,ypen,arc,chord) data pi/3.14159/ data eps/1.e-3/ xdif=xp-xpen ydif=yp-ypen dxy=sqrt(xdif**2 + ydif**2) xret=xpen yret=ypen if(.not.(dxy .le. eps))goto 23032 call plot2(xp,yp,2) return 23032 continue angnxt=atan2(ydif,xdif) if(.not.(abs(arc) .ge. 360.))goto 23034 c circle radius=dxy/2. cenang=angnxt+pi angarc=2.*pi goto 23035 c else 23034 continue angarc=arc*(pi/180.) sinang=sin(abs(angarc/2.)) if(.not.(sinang.lt..01))goto 23036 call plot2(xp,yp,2) return 23036 continue radius=amin1((dxy/2.)/sinang, 4096.) if(.not.(arc .gt. 0. .and. arc .le. 180.))goto 23038 cenang=(3.*pi-angarc)/2.+angnxt goto 23039 c else 23038 continue if(.not.(arc .gt. 180. .and. arc .lt. 360.))goto 23040 cenang=(-pi-angarc)/2.+angnxt goto 23041 c else 23040 continue if(.not.(arc .lt. 0. .and. arc .ge. -180.))goto 23042 cenang=(-3.*pi-angarc)/2.+angnxt goto 23043 c else 23042 continue if(.not.(arc .lt. -180. .and. arc .gt. -360.))goto 230 & 44 cenang=(pi-angarc)/2.+angnxt 23044 continue 23043 continue 23041 continue 23039 continue 23035 continue cosnxt=cos(cenang) sinnxt=sin(cenang) sgn=sign(1.,angarc) absarc=abs(angarc) units=amin1(abs(chord*(pi/180.)), absarc) c for ang=units 23046 if(.not.(ang.lt.absarc))goto 23048 rca=radius*cos(ang)-radius rsa=radius*sin(ang)*sgn xx=rca*cosnxt-rsa*sinnxt+xret yy=rca*sinnxt+rsa*cosnxt+yret call plot2(xx,yy,2) ang=ang+units goto 23046 c endfor 23048 continue if(.not.( angarc .ge. 2.*pi ))goto 23049 call plot2(xret,yret,2) goto 23050 c else 23049 continue call plot2(xp,yp,2) 23050 continue return end