subroutine ASMBL (ismbl,ix,iy) c c ASMBL draws a data symbol at the current point according to the c instructions supplied: iwhich (1-5) c isize (0-9) c ifill (0 1 or 2) c ismbl is set negative by the subroutine to indicate that a symbol c procedure has been defined and can be used subsequently c c ismbl encodes the SSMBL arguments (iwhich,idone,isize,ifill) c c SSMBL is a version of SMBL using Postscript procedure definitions c logical*1 plcmd(80) c c decode the argument ismbl call idigt (ismbl,iwhich,isize,ifill) if (ifill.gt.2) ifill=1 isiz1=isize+1 if (iwhich.gt.6) iwhich=6 go to (100,200,300,400,500,600),iwhich c--------------------------------------------------------------------- c define a procedure to draw a filled circle 100 if (ifill.ne.1) go to 125 if (ismbl.lt.0) go to 115 encode (32,105,plcmd) isiz1,10 105 format('/fc { currentpoint 'i2' 0 360 arc'a1) call sendl(plcmd,32) c call lgo('R',-isiz1,0) encode (11,110,plcmd) 10 110 format('fill } def'a1) call sendl(plcmd,11) c c draw a filled circle 115 encode (3,120,plcmd) 10 120 format('fc'a1) call sendl(plcmd,3) ismbl=-iabs(ismbl) return c c define a procedure to empty a circle 125 if (ismbl.lt.0) go to 140 encode (32,130,plcmd) isiz1,10 130 format('/ec { currentpoint 'i2' 0 360 arc'a1) call sendl(plcmd,32) call lgo('R',-isiz1,0) encode (31,135,plcmd) 10 135 format('1 setgray fill 0 setgray } def'a1) call sendl(plcmd,31) c c empty a circle 140 encode (3,145,plcmd) 10 145 format('ec'a1) call sendl(plcmd,3) c c define an open circle procedure 150 if (ismbl.lt.0) go to 170 encode (6,155,plcmd) 10 155 format('/oc {'a1) call sendl(plcmd,6) call lgo('R',isiz1,0) encode (43,160,plcmd) isiz1,isiz1,10 160 format('currentpoint exch 'i2' sub exch 'i2' 0 360 arc'a1) call sendl(plcmd,43) call lgo('R',-isiz1,0) encode (21,165,plcmd) 10 165 format('stroke newpath } def'a1) call sendl(plcmd,21) c c draw an open circle 170 call lgo('M',ix,iy) encode (3,175,plcmd) 10 175 format('oc'a1) call sendl(plcmd,3) if (ifill.eq.2) go to 180 ismbl=-iabs(ismbl) return c c define a half-filled circle procedure 180 if (ismbl.lt.0) go to 190 encode (54,185,plcmd) isiz1,10 185 format('/hf { currentpoint 'i2' -90 90 arc closepath fill } def' & a1) call sendl(plcmd,54) c c half-fill a circle 190 call lgo('M',ix,iy) encode (3,195,plcmd) 10 195 format('hf'a1) call sendl(plcmd,3) ismbl=-iabs(ismbl) return c--------------------------------------------------------------------- c define a procedure to draw a filled diamond 200 if (ifill.ne.1) go to 225 if (ismbl.lt.0) go to 215 encode (6,205,plcmd) 10 205 format('/fd {'a1) call sendl(plcmd,6) call lgo('R',0,isiz1) call lgo('I',isiz1,-isiz1) call lgo('I',-isiz1,-isiz1) call lgo('I',-isiz1,isiz1) encode (21,210,plcmd) 10 210 format('closepath fill } def'a1) call sendl(plcmd,21) c c draw a filled diamond 215 encode (3,220,plcmd) 10 220 format('fd'a1) call sendl(plcmd,3) ismbl=-iabs(ismbl) return c c define a procedure to empty a diamond 225 if (ismbl.lt.0) go to 240 encode (6,230,plcmd) 10 230 format('/ed {'a1) call sendl(plcmd,6) call lgo('R',0,isiz1) call lgo('I',isiz1,-isiz1) call lgo('I',-isiz1,-isiz1) call lgo('I',-isiz1,isiz1) encode (41,235,plcmd) 10 235 format('closepath 1 setgray fill 0 setgray } def'a1) call sendl(plcmd,41) c c empty a diamond 240 encode (3,245,plcmd) 10 245 format('ed'a1) call sendl(plcmd,3) c c define a procedure to outline a diamond 250 if (ismbl.lt.0) go to 265 encode (6,255,plcmd) 10 255 format('/od {'a1) call sendl(plcmd,6) call lgo('R',0,isiz1) call lgo('I',isiz1,-isiz1) call lgo('I',-isiz1,-isiz1) call lgo('I',-isiz1,isiz1) encode (31,260,plcmd) 10 260 format('closepath stroke newpath } def'a1) call sendl(plcmd,31) c c outline a diamond 265 call lgo('M',ix,iy) encode (3,270,plcmd) 10 270 format('od'a1) call sendl(plcmd,3) if (ifill.eq.2) go to 275 ismbl=-iabs(ismbl) return c c define a procedure to half-fill a diamond 275 if (ismbl.lt.0) go to 290 encode (6,280,plcmd) 10 280 format('/hd {'a1) call sendl(plcmd,6) call lgo('R',0,isiz1) call lgo('I',isiz1,-isiz1) call lgo('I',-isiz1,-isiz1) encode (21,285,plcmd) 10 285 format('closepath fill } def'a1) call sendl(plcmd,21) c c half-fill a diamond 290 call lgo('M',ix,iy) encode (3,295,plcmd) 10 295 format('hd'a1) call sendl(plcmd,3) ismbl=-iabs(ismbl) return c--------------------------------------------------------------------- c define a procedure to draw a filled square 300 if (ifill.ne.1) go to 325 if (ismbl.lt.0) go to 315 encode (6,305,plcmd) 10 305 format('/fs {'a1) call sendl(plcmd,6) isiz2=2*isiz1 call lgo('R',0,isiz1) call lgo('I',isiz1,0) call lgo('I',0,-isiz2) call lgo('I',-isiz2,0) call lgo('I',0,isiz2) call lgo('I',isiz1,0) call lgo('R',0,-isiz1) encode (21,310,plcmd) 10 310 format('closepath fill } def'a1) call sendl(plcmd,21) c c draw a filled square 315 encode (3,320,plcmd) 10 320 format('fs'a1) call sendl(plcmd,3) ismbl=-iabs(ismbl) return c c define a procedure to empty a square 325 if (ismbl.lt.0) go to 340 encode (6,330,plcmd) 10 330 format('/es {'a1) call sendl(plcmd,6) isiz2=2*isiz1 call lgo('R',0,isiz1) call lgo('I',isiz1,0) call lgo('I',0,-isiz2) call lgo('I',-isiz2,0) call lgo('I',0,isiz2) call lgo('I',isiz1,0) call lgo('R',0,-isiz1) encode (41,335,plcmd) 10 335 format('closepath 1 setgray fill 0 setgray } def'a1) call sendl(plcmd,41) c c empty a square 340 encode (3,345,plcmd) 10 345 format('es'a1) call sendl(plcmd,3) c c define a procedure to outline a square 350 if (ismbl.lt.0) go to 365 encode (6,355,plcmd) 10 355 format('/os {'a1) call sendl(plcmd,6) call lgo('R',0,isiz1) call lgo('I',isiz1,0) call lgo('I',0,-isiz2) call lgo('I',-isiz2,0) call lgo('I',0,isiz2) call lgo('I',isiz1,0) call lgo('R',0,-isiz1) encode (31,360,plcmd) 10 360 format('closepath stroke newpath } def'a1) call sendl(plcmd,31) c c outline a square 365 call lgo('M',ix,iy) encode (3,370,plcmd) 10 370 format('os'a1) call sendl(plcmd,3) if (ifill.eq.2) go to 375 ismbl=-iabs(ismbl) return c c define a procedure to half-fill a square 375 if (ismbl.lt.0) go to 390 encode (6,380,plcmd) 10 380 format('/hs {'a1) call sendl(plcmd,6) call lgo('R',-isiz1,isiz1) call lgo('I',isiz2,-isiz2) call lgo('I',-isiz2,0) call lgo('I',0,isiz2) call lgo('R',isiz1,-isiz1) encode (21,385,plcmd) 10 385 format('closepath fill } def'a1) call sendl(plcmd,21) c c half-fill a square 390 call lgo('M',ix,iy) encode (3,395,plcmd) 10 395 format('hs'a1) call sendl(plcmd,3) ismbl=-iabs(ismbl) return c--------------------------------------------------------------------- c define a procedure to draw a filled triangle 400 if (ifill.ne.1) go to 425 if (ismbl.lt.0) go to 415 encode (6,405,plcmd) 10 405 format('/ft {'a1) call sendl(plcmd,6) rt3=sqrt(3.) isiz2=irnd(isiz1*2/rt3) isiz3=irnd(isiz1*rt3) isiz4=irnd(isiz1/rt3) call lgo('R',0,isiz2) call lgo('I',-isiz1,-isiz3) call lgo('I',2*isiz1,0) call lgo('I',-isiz1,isiz3) call lgo('I',-isiz1,-isiz3) call lgo('R',isiz1,isiz4) encode (21,410,plcmd) 10 410 format('closepath fill } def'a1) call sendl(plcmd,21) c c draw a filled triangle 415 encode (3,420,plcmd) 10 420 format('ft'a1) call sendl(plcmd,3) ismbl=-iabs(ismbl) return c c define a procedure to empty a triangle 425 if (ismbl.lt.0) go to 440 encode (6,430,plcmd) 10 430 format('/et {'a1) call sendl(plcmd,6) rt3=sqrt(3.) isiz2=irnd(isiz1*2/rt3) isiz3=irnd(isiz1*rt3) isiz4=irnd(isiz1/rt3) call lgo('R',0,isiz2) call lgo('I',-isiz1,-isiz3) call lgo('I',2*isiz1,0) call lgo('I',-isiz1,isiz3) call lgo('I',-isiz1,-isiz3) call lgo('R',isiz1,isiz4) encode (41,435,plcmd) 10 435 format('closepath 1 setgray fill 0 setgray } def'a1) call sendl(plcmd,41) c c empty a triangle 440 encode (3,445,plcmd) 10 445 format('et'a1) call sendl(plcmd,3) c c define a procedure to outline a triangle 450 if (ismbl.lt.0) go to 465 encode (6,455,plcmd) 10 455 format('/ot {'a1) call sendl(plcmd,6) call lgo('R',0,isiz2) call lgo('I',-isiz1,-isiz3) call lgo('I',2*isiz1,0) call lgo('I',-isiz1,isiz3) call lgo('I',-isiz1,-isiz3) call lgo('R',isiz1,isiz4) encode (31,460,plcmd) 10 460 format('closepath stroke newpath } def'a1) call sendl(plcmd,31) c c outline a triangle 465 call lgo('M',ix,iy) encode (3,470,plcmd) 10 470 format('ot'a1) call sendl(plcmd,3) if (ifill.eq.2) go to 475 ismbl=-iabs(ismbl) return c c define a procedure to half-fill a triangle 475 if (ismbl.lt.0) go to 490 encode (6,480,plcmd) 10 480 format('/ht {'a1) call sendl(plcmd,6) call lgo('R',0,isiz2) call lgo('I',-isiz1,-isiz3) call lgo('I',isiz1,0) encode (21,485,plcmd) 10 485 format('closepath fill } def'a1) call sendl(plcmd,21) c c half-fill a triangle 490 call lgo('M',ix,iy) encode (3,495,plcmd) 10 495 format('ht'a1) call sendl(plcmd,3) ismbl=-iabs(ismbl) return c--------------------------------------------------------------------- c define a procedure to draw a filled inverted triangle 500 if (ifill.ne.1) go to 525 if (ismbl.lt.0) go to 515 encode (6,505,plcmd) 10 505 format('/fi {'a1) call sendl(plcmd,6) rt3=sqrt(3.) isiz2=irnd(isiz1*2/rt3) isiz3=irnd(isiz1*rt3) isiz4=irnd(isiz1/rt3) call lgo('R',0,-isiz2) call lgo('I',-isiz1,isiz3) call lgo('I',2*isiz1,0) call lgo('I',-isiz1,-isiz3) call lgo('I',-isiz1,isiz3) call lgo('R',isiz1,-isiz4) encode (21,510,plcmd) 10 510 format('closepath fill } def'a1) call sendl(plcmd,21) c c draw a filled inverted triangle 515 encode (3,520,plcmd) 10 520 format('fi'a1) call sendl(plcmd,3) ismbl=-iabs(ismbl) return c c define a procedure to empty an inverted triangle 525 if (ismbl.lt.0) go to 540 encode (6,530,plcmd) 10 530 format('/ei {'a1) call sendl(plcmd,6) rt3=sqrt(3.) isiz2=irnd(isiz1*2/rt3) isiz3=irnd(isiz1*rt3) isiz4=irnd(isiz1/rt3) call lgo('R',0,-isiz2) call lgo('I',-isiz1,isiz3) call lgo('I',2*isiz1,0) call lgo('I',-isiz1,-isiz3) call lgo('I',-isiz1,isiz3) call lgo('R',isiz1,-isiz4) encode (41,535,plcmd) 10 535 format('closepath 1 setgray fill 0 setgray } def'a1) call sendl(plcmd,41) c c empty an inverted triangle 540 encode (3,545,plcmd) 10 545 format('ei'a1) call sendl(plcmd,3) c c define a procedure to outline an inverted triangle 550 if (ismbl.lt.0) go to 565 encode (6,555,plcmd) 10 555 format('/oi {'a1) call sendl(plcmd,6) call lgo('R',0,-isiz2) call lgo('I',-isiz1,isiz3) call lgo('I',2*isiz1,0) call lgo('I',-isiz1,-isiz3) call lgo('I',-isiz1,isiz3) call lgo('R',isiz1,-isiz4) encode (31,560,plcmd) 10 560 format('closepath stroke newpath } def'a1) call sendl(plcmd,31) c c outline an inverted triangle 565 call lgo('M',ix,iy) encode (3,570,plcmd) 10 570 format('oi'a1) call sendl(plcmd,3) if (ifill.eq.2) go to 575 ismbl=-iabs(ismbl) return c c define a procedure to half-fill an inverted triangle 575 if (ismbl.lt.0) go to 590 encode (6,580,plcmd) 10 580 format('/hi {'a1) call sendl(plcmd,6) call lgo('R',0,-isiz2) call lgo('I',-isiz1,isiz3) call lgo('I',isiz1,0) encode (21,585,plcmd) 10 585 format('closepath fill } def'a1) call sendl(plcmd,21) c c half-fill an inverted triangle 590 call lgo('M',ix,iy) encode (3,595,plcmd) 10 595 format('hi'a1) call sendl(plcmd,3) ismbl=-iabs(ismbl) return c--------------------------------------------------------------------- c no further symbols are defined at present 600 return end