c post script graphics test parameter(ier0=1) character chr*30/"This is an example symbol TEST"/ call xyopen(x,y,ier) ino=0 pi=3.1415926 do 300 jj=1,1 ier=jj ino=ino+1 call plots(x,y,ier,ino) call factor(1.00) x1=50.0 y1=50.0 if(ier.eq.2) then x2=800.0 y2=550.0 else x2=550.0 y2=800.0 endif c c x1c=0.5*(x1+x2) y1c=0.5*(y1+y2) c rl1=0.15*(x2-x1) rl1=0.12*(x2-x1) rl0=(x2-x1)/6.0 rld=0.14*rl1 alp=2.0*pi*30.0/360.0 c call newpe1(0) do 10 j=1,7 y11=y1c-3.0*rl0 y12=y1c+3.0*rl0 x=x1c+rl0*float(j-4) c call plot(x,y11,3) c call plot(x,y12,2) x11=x1c-3.0*rl0 x12=x1c+3.0*rl0 y=y1c+rl0*float(j-4) c call plot(x11,y,3) c call plot(x12,y,2) 10 continue c call newpe1(3) rl2=0.6*rl1 th=pi*float(0)/180.0 x=x1c+rl2*cos(th) y=y1c+rl2*sin(th) call plot(x,y,3) do 12 j=1,45 th=pi*float(j)/180.0 x=x1c+rl2*cos(th) y=y1c+rl2*sin(th) call plot(x,y,2) x30=x y30=y 12 continue x21=rl2-rld*sin(alp) y21=-rld*cos(alp) x22=rl2+rld*sin(alp) y22=-rld*cos(alp) x31=x1c+x21*cos(th)-y21*sin(th) y31=y1c+x21*sin(th)+y21*cos(th) x32=x1c+x22*cos(th)-y22*sin(th) y32=y1c+x22*sin(th)+y22*cos(th) call plot(x1c,y1c,3) call plot(x30,y30,2) call plot(x31,y31,3) call plot(x30,y30,2) call plot(x32,y32,2) c c call newpe1(4) do 20 j=1,8 th=2.0*pi*float(j-1)/8.0 x11=rl1*cos(th) y11=rl1*sin(th) x21=rl1-rld*cos(alp) x22=x21 y21=rld*sin(alp) y22=-y21 x30=x1c+rl1*cos(th) y30=y1c+rl1*sin(th) x31=x1c+x21*cos(th)-y21*sin(th) y31=y1c+x21*sin(th)+y21*cos(th) x32=x1c+x22*cos(th)-y22*sin(th) y32=y1c+x22*sin(th)+y22*cos(th) call plot(x1c,y1c,3) call plot(x30,y30,2) call plot(x31,y31,3) call plot(x30,y30,2) call plot(x32,y32,2) 20 continue c call linee do 100 i=1,6 xa= 70.0+15.0*float(i-1) ya=100.0+30.0*float(i-1) ha=2.0+4.0*float(i) aa=0.0+0.0*float(i-1) c call symbol(xa,ya,ha,chr,aa,30) 100 continue c call newpen(8) c call number(xa,ya,ha,x1,aa,32) xa=xa+200 c call number(xa,ya,ha,y1,aa,32) call newpen(2) xa=xa-200 ya=ya+30 c call number(xa,ya,ha,x2,aa,32) xa=xa+200 c call number(xa,ya,ha,y2,aa,32) c write(6,*) "(Solar-Terrestrial Environment" c write(6,*) " Laboratory) 120 370 shtr" c write(6,*) "(Toyokawa-Nagoya) 120 400 shnr" c write(6,*) "(Nagoya University) 120 430 shni" c write(6,*) "(STELAB) 120 460 shnb" c call plote 300 continue stop end c subroutine xyopen(x,y,ier) subroutine xyopen(x,y,ier) write(6,10) 10 format( "%!") write(6,*) "%%Page: 1 1" write(6,*) "/l { lineto} def" write(6,*) "/m { moveto} def" write(6,*) "/s { show} def" write(6,*) "/sl { setlinewidth} def" write(6,*) "/sn {stroke newpath} def" write(6,*) "/tr {/Times-Roman findfont} def" write(6,*) "/sf { scalefont} def" write(6,*) "/se {setfont} def" write(6,*) "/ro { rotate} def" write(6,*) "/sd { setdash} def" write(6,*) "/st {stroke} def" write(6,*) "/sp {stroke showpage} def" write(6,*) "/tl { translate} def" write(6,*) "/sc { scale} def" write(6,*) "/ftr /Times-Roman findfont 20 scalefont def" write(6,*) "/fnr /Helvetica findfont 20 scalefont def" write(6,*) "/fni /Helvetica-Oblique findfont 20 scalefont def" write(6,*) "/fnb /Helvetica-Bold findfont 30 scalefont def" write(6,*) "/shtr {moveto ftr setfont show} def" write(6,*) "/shnr {moveto fnr setfont show} def" write(6,*) "/shni {moveto fni setfont show} def" write(6,*) "/shnb {moveto fnb setfont show} def" write(6,*) "/c {setrgbcolor 1 0 translate newpath 0 0 moveto 1 0 1 lineto 1 1 lineto 1 0 lineto closepath 2 fill} def" write(6,*) "/ch {sethsbcolor 1 0 translate newpath 0 0 moveto 1 0 1 lineto 1 1 lineto 1 0 lineto closepath 2 fill} def" write(6,*) "/gs {gsave} def" write(6,*) "/gr {grestore 0.0 0.0 0.0 setrgbcolor} def" write(6,*) "/crg {setrgbcolor} def" write(6,*) "/chs {sethsbcolor} def" write(6,*) "/sg { setgray} def" return end subroutine plots(x,y,ir,ino) c* write(6,*) "%!" if(ino.ge.2) write(6,10) ino,ino 10 format("%%Page:",1x,i2,1x,i2) if(ir.eq.2) then il=0 x=90.0 y=-600.0 write(6,*) "90.0 ro" write(6,*) "0.0 -600.0 tl" c write(6,*) "newpath" endif return end subroutine plote write(6,*) "sp" return end subroutine linee write(6,*) "st" return end subroutine plot(x1,y1,im) if(im.eq.3) then write(6,10) x1,y1 10 format(f5.1,1x,f5.1," m") else write(6,20) x1,y1 20 format(f5.1,1x,f5.1," l") endif c write(6,*) "st return end subroutine factor(fct) write(6,10) fct,fct 10 format(f6.2,1x,f6.2," sc") return end subroutine newpen(ip) i1=(ip-1)/2 i2=ip-2*i1 write(6,*) "sn" pi1=0.40*float(i1-1) write(6,30) pi1 30 format(f3.1," sl") if(i2.ne.1) then write(6,*) "[2 2] 0 sd" endif return end subroutine newpe1(ip) i1=ip write(6,*) "sn" pi1=0.4*float(i1-1) write(6,30) pi1 30 format(f3.1," sl") return end subroutine symbol(x,y,h,isymb,ang,n) character isymb*80,ica*80,ich(80)*1 equivalence (ica,ich) ica=isymb write(6,*) "tr" write(6,10) h 10 format(f5.1," sf") write(6,*) "se" write(6,20) x,y 20 format(f5.1,1x,f5.1," m") write(6,30) ang 30 format(f5.1," ro") c* write(6,*) "(",isymb,") s" write(6,*) "(",(ich(i),i=1,n),") s" return end subroutine number(x,y,h,anu,ang,n) character isymb*9 write(6,*) "tr" write(6,10) h 10 format(f5.1," sf") write(6,*) "se" write(6,20) x,y 20 format(f5.1,1x,f5.1," m") write(6,30) ang 30 format(f5.1," ro") write(isymb,40) anu 40 format(1pe9.2) write(6,*) "(",isymb,") s" return end subroutine color1(nx,ny,xb,yb,xl,yl,u,ico) dimension u(1) dx=xl/float(nx) dy=yl/float(ny) c write(6,*) "gs" write(6,20) dx,dy 20 format(f6.2,1x,f6.2," sc") c y=yb/dy-1.0 x=xb/dx-1.0+float(nx) write(6,22) x,y do 100 j=1,ny y=1.0 x=-float(nx) xx=x yy=y write(6,22) xx,yy 22 format(f6.2,1x,f6.2," tl") do 100 i=1,nx i1=i+nx*(j-1) x1=u(i1) if(ico.eq.2) go to 32 if(ico.eq.3) go to 33 x1=1.0*x1 r=x1 g=1.0 b=1.0 go to 40 32 continue r=x1 g=x1 b=1.0 go to 40 33 continue x1=1.0*x1 r=x1 g=1.0 b=x1 c 40 continue r=amax1(r,0.0) g=amax1(g,0.0) b=amax1(b,0.0) r=amin1(r,1.0) g=amin1(g,1.0) b=amin1(b,1.0) write(6,24) r,g,b c* 24 format(f4.2,1x,f4.2,1x,f4.2," c") 24 format(f4.2,1x,f4.2,1x,f4.2," ch") 100 continue write(6,*) "gr" return end subroutine chrgb(r,g,b) write(6,10) r,g,b 10 format(f4.2,1x,f4.2,1x,f4.2," crg") return end subroutine chhsb(h,s,b) write(6,10) h,s,b 10 format(f4.2,1x,f4.2,1x,f4.2," chs") return end subroutine chgry(g) write(6,10) g,g,g 10 format(f4.2,1x,f4.2,1x,f4.2," crg") return end subroutine chgr(g) write(6,10) g 10 format(f4.2," sg") return end