c post script graphics test c PostScript file produced by fortran program c February 27, 1992 c by Tatsuki Ogino STELAB, Nagoya University parameter(ier0=1) character chr*30 chr="This is an example symbol TEST" call xyopen(x,y,ier) ino=0 do 300 jj=1,2 ier=jj ino=ino+1 call plots(x,y,ier,ino) call factor(1.00) call factor(0.30) c do 200 jjl=1,3 if(jjl.eq.1) call plot(0.0,0.0,-3) if(jjl.eq.2) call plot(500.0,800.0,-3) if(jjl.eq.3) call plot(500.0,800.0,-2) 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 call newpen(3) call plot(x1,y1,3) call plot(x2,y2,2) call plot(x1,y2,2) call plot(x2,y1,2) call plot(x1,y1,2) c do 10 j=1,10 call newpe1(11-j) y=y2-10.0*float(j-1) call plot(x1,y,3) call plot(x2,y,2) y=y1+10.0*float(j-1) call plot(x1,y,3) call plot(x2,y,2) x=x2-10.0*float(j-1) call plot(x,y1,3) call plot(x,y2,2) x=x1+10.0*float(j-1) call plot(x,y1,3) call plot(x,y2,2) 10 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+10.0*float(i-1) call symbol2(xa,ya,ha,chr,aa,30) 100 continue c aa=0.0 call newpen(8) xa=100 ya=300 call plot(x1,ya,3) call plot(x2,y2,2) c call plot(xa,y1,-3) c call plot(xa,ya,-2) c call plot(x1,y1,2) call linee call number(xa,ya,ha,x1,aa,32) xa=xa+200 call number(xa,ya,ha,y1,aa,32) call newpen(2) xa=xa-200 ya=ya+30 call plot(x1,y2,3) call plot(x2,ya,2) call linee call number(xa,ya,ha,x2,aa,32) xa=xa+200 call number(xa,ya,ha,y2,aa,32) write(6,*) "(Solar-Terrestrial Environment" write(6,*) " Laboratory) 120 370 shtr" write(6,*) "(Toyokawa-Nagoya) 120 400 shnr" write(6,*) "(Nagoya University) 120 430 shni" write(6,*) "(STELAB) 120 460 shnb" c 200 continue 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,*) "/ws { widthshow} def" write(6,*) "/aws { awidthshow} 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) write(6,10) x1,y1 if(im.eq.2) write(6,20) x1,y1 if(im.eq.-3) write(6,30) x1,y1 if(im.eq.-2) write(6,40) x1,y1,x1,y1 10 format(f5.1,1x,f5.1," m") 20 format(f5.1,1x,f5.1," l") 30 format(f5.1,1x,f5.1," tl") 40 format(f5.1,1x,f5.1," l sn",1x,f5.1,1x,f5.1," tl") 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 symbol2(x,y,h,isymb,ang,n) character isymb*80,ica*80,ich(80)*1 equivalence (ica,ich) ica=isymb write(6,*) "gs" 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" h1=0.03*h h2=0.03*h write(6,40) h1,h2 40 format(f5.1," 0.0 8#040 ",f5.1," 0.0 ") write(6,*) "(",(ich(i),i=1,n),") aws" write(6,*) "gr" 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