c#######################################################################
c
c Update summary ( zzj, April, 1996 )
c 1. Including symbol font when call
c PSfont(n)
c n=5 corresponds to Symbol (Creek letter fond)
c 2. Modification was made on program setcolors to eliminate
C some of unnecesary writing to PostCript io channel;
c option 5 is available in setcolors
c#######################################################################
c#######################################################################
c
c Interface of ZXplot with Postscript.
c Created by Ming Xue at CIMMS/CAPS, Feburary, 1990-1996.
c
c#######################################################################
c
SUBROUTINE xdevic 10,18
save nzxcal, mbordr
data nzxcal /0/ ,mbordr/0/
common /xpsize/ psize
common /xpsd01/ xside, yside
common /xoutch/ nch
integer ncunique
integer icoltable
common /xcltbl/ ncunique,icoltable
c
c#######################################################################
c
c Set up device ( Paper for GHOST )
c
c#######################################################################
c
nch = 6
CALL PSopn
CALL xichar
CALL xdspac( 1.0 )
CALL xminit
nzxcal=1
CALL XSETCLRS(icoltable)
CALL xcolor(1)
CALL xthick(1)
RETURN
c
c#######################################################################
c
c Advance plotting onto next frame
c
c#######################################################################
c
ENTRY xframe
CALL xqmap ( x1,x2,y1,y2 )
CALL xlpnup(x1,y1)
CALL PSfram
RETURN
c
c#######################################################################
c
c Terminate graphic plotting
c
c#######################################################################
c
ENTRY xgrend
IF( nzxcal.eq.0) then
write(nch,'(1x,a)') 'XGREND called before device is set up.'
RETURN
ENDIF
CALL xqmap ( x1,x2,y1,y2 )
CALL xlpnup(x1,y1)
CALL PScls
RETURN
ENTRY xfbord(mbord)
mbordr=mbord
RETURN
END
SUBROUTINE ppenup(x1,y1) 10,1
CALL PSpnup(x1,y1)
RETURN
END
SUBROUTINE ppendn(x,y) 7
CALL PSpndn(x,y)
RETURN
END
c
c#######################################################################
c
c Define a normalized device (ND) space (0.0,XSIDE,0.0,YSIDE) on device
c provided. The size of this space is 'PSIZE' times of the max device
c space. YSIDE should be 1.0, XSIDE can be bigger or smaller that 1.0
c depending on device.
c XSIDE, YSIDE should be passed to ZXPLOT through common block PSIDES.
c This routine sets up this space using GHOST.
c
c#######################################################################
c
SUBROUTINE xdspac(psize) 13,3
common /xpsize/ psize1
common /xpsd01/ xside, yside
common /xoutch/ nch
data yside0 /1.0/
save yside0
psize1=psize
c
xside=1.0
c
c#######################################################################
c
c To use only a squared plotting area, set yside=1.0:
c To make a full use of the US letter size plotting space, set yside=1.5:
c
c#######################################################################
c
yside=yside0
IF( psize.le.0.0) then
write(nch,'(1x,a)')
: ' Zero or negative values for PSIZE not permitted!'
write(nch,'(1x,a)')
: ' It should be in range of 0.1 to 1.0,please reset value'
STOP
ENDIF
edgex=0.5*xside*(1.0/psize-1)
edgey=edgex*yside/xside
x1=-edgex
x2= edgex+xside
y1=-edgey
y2= edgey+yside
if(abs(yside-1.0).lt.0.001) then ! yside=1.0
c
c To use only a squared plotting area:
c
call PSspac(50.0, 600.0, 50.0, 600.0, X1,X2,Y1,Y2)
else ! yside=1.5
c
c To use full US letter size plotting area:
c
c CALL PSspac(100.0,560.0,60.0,750.0,X1,X2,Y1,Y2)
CALL PSspac(100.0,560.0,750.0-yside*460,750.0,X1,X2,Y1,Y2)
endif
return
entry xpaprlnth( yside0a )
yside0=yside0a
RETURN
END
SUBROUTINE window(x1,x2,y1,y2),1
CALL PSwndw(x1,x2,y1,y2)
RETURN
END
c
c#######################################################################
c
c Low level PostScript interface for ZXplot
c
c By Shian-Jiann Lin Feb.20, 1990 At CIMMS/CAPS, OU
c Modified and extended by Ming Xue to include font writing capablilities.
c
c This routine can only be called once.
c
c This routine opens the io & set up the min. header.
c
c#######################################################################
c
SUBROUTINE PSopn 1,45
common/psdef/io
character char_io*132
character*80 filename
character psfn*(*)
common /xoutch/ nch
data filename /'zxout.ps'/
data lfn /8/
save filename,lfn
integer iounit
common /psbufferlines/ lines
write(nch,'(/1x,a,a,a)')
: 'PostScript output is in ',filename(1:lfn),'.'
write(nch,'(1x,a,i2,a/)')
: 'Data IO unit ',io,' to be used for writing the PS file.'
open(unit=io,file=filename(1:lfn),
: status='unknown',form='formatted')
lines = 0 ! set initial number of buffer lines to zero
write(char_io,'(a)') '%!PS-Adobe-2.0'
call write_ps(char_io)
write(char_io,'(a)')'%%Title:ZX-PLOT'
call write_ps(char_io)
write(char_io,'(a)')'%%Pages:(atend)'
call write_ps(char_io)
write(char_io,'(a)')'%%DocumentFonts:(atend)'
call write_ps(char_io)
write(char_io,'(a)')'%%EndComments'
call write_ps(char_io)
c
C Save the graphics state.
write(char_io,'(a)')'gsave'
call write_ps(char_io)
C
C Define Proc. here.......
C
write(char_io,'(a)')'/w {setlinewidth} def'
call write_ps(char_io)
write(char_io,'(a)')'/d {setdash} def'
call write_ps(char_io)
write(char_io,'(a)')'/m {moveto} def'
call write_ps(char_io)
write(char_io,'(a)')'/l {lineto} def'
call write_ps(char_io)
write(char_io,'(a)')'/S {stroke} def'
call write_ps(char_io)
write(char_io,'(a)')'/N {newpath} def'
call write_ps(char_io)
write(char_io,'(a)')'/h {closepath} def'
call write_ps(char_io)
write(char_io,'(a)')'/q {gsave} def'
call write_ps(char_io)
write(char_io,'(a)')'/Q {grestore} def'
call write_ps(char_io)
write(char_io,'(a)')'/g {setgray} def'
call write_ps(char_io)
write(char_io,'(a)')'/ct 256 array def'
call write_ps(char_io)
write(char_io,'(a)') '/o {ct exch get aload pop setrgbcolor} def'
call write_ps(char_io)
write(char_io,'(a)')'/f {fill} def'
call write_ps(char_io)
write(char_io,'(a)')'/ff {findfont} def'
call write_ps(char_io)
write(char_io,'(a)')'/scf {scalefont} def'
call write_ps(char_io)
write(char_io,'(a)')'/stf {setfont} def'
call write_ps(char_io)
write(char_io,'(a)')'/rs { dup stringwidth pop'
call write_ps(char_io)
write(char_io,'(a)')'neg 0 rmoveto show } def'
call write_ps(char_io)
write(char_io,'(a)')'/cs { dup stringwidth pop'
call write_ps(char_io)
write(char_io,'(a)')'-0.5 mul 0 rmoveto show } def'
call write_ps(char_io)
write(char_io,'(a)')'/arrowdict 8 dict def'
call write_ps(char_io)
write(char_io,'(a)')'/arw %Procedure for an arrow'
call write_ps(char_io)
write(char_io,'(a)')'{arrowdict begin'
call write_ps(char_io)
write(char_io,'(a)')' /y4 exch def /x4 exch def'
call write_ps(char_io)
write(char_io,'(a)')' /y3 exch def /x3 exch def'
call write_ps(char_io)
write(char_io,'(a)')' /y2 exch def /x2 exch def'
call write_ps(char_io)
write(char_io,'(a)')' /y1 exch def /x1 exch def'
call write_ps(char_io)
write(char_io,'(a)')' S x1 y1 m x2 y2 l x3 y3 l S'
call write_ps(char_io)
write(char_io,'(a)')' x4 y4 m x2 y2 l S'
call write_ps(char_io)
write(char_io,'(a)')' end } def '
call write_ps(char_io)
write(char_io,'(a)') '/landscape %transform to landscape layout '
call write_ps(char_io)
write(char_io,'(a)') '{792 0 translate 90 rotate'
call write_ps(char_io)
write(char_io,'(a)') '0 180 translate} def'
call write_ps(char_io)
write(char_io,'(a)')' %%EndProlog'
call write_ps(char_io)
write(char_io,'(a)') '%%Page: 1'
call write_ps(char_io)
write(char_io,'(a)') '%%set defaults:'
call write_ps(char_io)
write(char_io,'(a)') '%%landscape'
call write_ps(char_io)
write(char_io,'(a)') '/Helvetica ff 12 scf stf'
call write_ps(char_io)
return
entry xpsfn(psfn, iounit )
c write(6,'(a,1x,a)')'filename=', filename
c write(6,'(a,1x,a)')'psfn =', psfn
filename = psfn
lfn = 80
call xstrlnth(filename,lfn)
io = iounit
return
end
SUBROUTINE PSfram 1,6
common/psdef/io
character char_io*132
integer nofram
common /pageno/ nofram
nofram=nofram+1
write(char_io,'(a,i5)') 'S %End of frame ',nofram
call write_ps(char_io)
write(char_io,'(a)') ' showpage'
call write_ps(char_io)
write(char_io,'(a,I4)') '%%Page: ',nofram+1
call write_ps(char_io)
write(char_io,'(a)') ' %%landscape %for landscape layout.'
call write_ps(char_io)
write(char_io,'(a)') ' 0.3 w %set default lw for new frame'
call write_ps(char_io)
c
c write PS buffer constent to disk before moving onto next frame
c
call flush_ps_buffer
RETURN
END
BLOCK DATA
integer nofram
common /psdef/io
common /pageno/ nofram
data nofram/0/
data io /13/
END
C
SUBROUTINE PScls 1,4
common/psdef/io
integer nofram
common /pageno/nofram
character char_io*132
write(char_io,'(a)') 'S'
call write_ps(char_io)
C Implement showpage and write the trailer here.
write(char_io,'(a)')'showpage'
call write_ps(char_io)
C Restore the original graphic state of the laser printer.
write(char_io,'(a)') 'Q'
write(char_io,'(a,I4)') '%%Pages: ', nofram+1
call write_ps(char_io)
C write buffer content to disk
call flush_ps_buffer
C Close the io.
close(io)
RETURN
END
c
c#######################################################################
c
c (pl,pr,pt,pb) sets the area on the given device and map it with
c coordinate space (x1,x2,y1,y2).
c
c 11 X 8.5 " = 792 X 612 (1" = 72 points)
c
c Maximum allowable space in x - 792 (US paper size)
c
c#######################################################################
c
SUBROUTINE PSspac(pl,pr,pb,pt, x1,x2,y1,y2) 2
common /psscal/ p1,p2,p3,p4, xa,xb,ya,yb, xsca,ysca
p1=pl
p2=pr
p3=pb
p4=pt
xa=x1
xb=x2
ya=y1
yb=y2
xsca = (p2-p1)/(xb-xa)
ysca = (p4-p3)/(yb-ya)
RETURN
END
C
SUBROUTINE PStran(x,y) 13
common/psdef/io
character char_io*132
common /psscal/ pa,pb,pc,pd, xa,xb,ya,yb, xsca,ysca
x = pa+ (x-xa)*xsca
y = pc+ (y-ya)*ysca
RETURN
END
SUBROUTINE PSpnup(x1,y1) 1,4
common/psdef/io
character char_io*132
x=x1
y=y1
call PStran(x,y)
write(char_io,100) x,y
call write_ps(char_io)
100 format(1x,'S',1x,f10.2,1x,f10.2,1x,'m')
RETURN
ENTRY PSpndn(x2,y2)
x=x2
y=y2
CALL PStran(x,y)
write(char_io,110) x,y
call write_ps(char_io)
110 format(3x,f10.2,1x,f10.2,1x,'l')
RETURN
END
C
SUBROUTINE PSwndw(x1,x2,y1,y2) 1
RETURN
END
C
c#######################################################################
c
c Set gray degree to area filling routine xfilarea
c
c#######################################################################
c
SUBROUTINE PSgray(gray) 2,2
common/psdef/io
character char_io*132
write(char_io,'(1x,a)') 'S'
call write_ps(char_io)
write(char_io,100) gray
call write_ps(char_io)
100 format(1x,f5.3,1x,'g')
RETURN
END
SUBROUTINE PSlnwd(wd) 2,2
common/psdef/io
character char_io*132
write(char_io,'(1x,a)') 'S'
call write_ps(char_io)
write(char_io,100) wd
call write_ps(char_io)
100 format(1x,f5.3,1x,'w')
RETURN
END
c
c#######################################################################
c
c Re-set font by its number.
c
c#######################################################################
c
SUBROUTINE PSfont(n) 1,6
common/psdef/io
character char_io*132
character fontname*20,ftname*(*)
save nftsiz,fontname
C Set default font name and font size:
data nftsiz,fontname /12,'Helvetica' /
IF( n.eq.1) THEN
fontname='Courier'
ELSEIF(n.eq.2)THEN
fontname='Helvetica'
ELSEIF(n.eq.3)THEN
fontname='Times-Roman'
ELSEIF(n.eq.4)THEN
fontname='Times-Oblique'
ELSEIF(n.eq.5)THEN
fontname='Symbol'
ENDIF
write(char_io,100)fontname
call write_ps(char_io)
write(char_io,101)nftsiz
call write_ps(char_io)
100 format(' /',a,' ff ')
101 format(i6,' scf stf')
RETURN
c
c#######################################################################
c
c Set postscript font size (height) in the number of points.
c
c#######################################################################
c
ENTRY PSftsz(nsiz)
nftsiz=nsiz
c nftsiz=9+0.5*(nsiz-9)
write(char_io,100)fontname
call write_ps(char_io)
write(char_io,101)nftsiz
call write_ps(char_io)
RETURN
c
c#######################################################################
c
c Re-set font option by its name, its size is set by PSftsz.
c
c#######################################################################
c
ENTRY PSftnm(ftname)
fontname=ftname
write(char_io,100)fontname
call write_ps(char_io)
write(char_io,101)nftsiz
call write_ps(char_io)
RETURN
END
c
c#######################################################################
c
C Write a character string CH with left, centered and right
C justification for just = -1,0,1.
c
c#######################################################################
c
Subroutine PSstrg(x1,y1,ch,just) 3,7
character ch*(*)
common/psdef/io
character char_io*256
common /xags09/ da,ca,xangle,xsyman,srang,ksr,xx,yy
x=x1
y=y1
CALL PStran(x,y)
c print*,'mark 1'
write(char_io,100) x,y
c print*,'mark 2', char_io
call write_ps(char_io)
100 format(1x,'S',1x,f7.2,1x,f7.2,1x,'m')
CALL PSrot(xangle+xsyman)
IF(just.lt.0)THEN
c print*,'mark 3'
write(char_io,'(a,a,a)') '(' ,ch, ') show'
c print*,'mark 4'
call write_ps(char_io)
ELSEIF(just.eq.0) THEN
c print*,'mark 5'
write(char_io,'(a,a,a)') '(' ,ch, ') cs'
c print*,'mark 6'
call write_ps(char_io)
ELSEIF(just.gt.0) THEN
c print*,'mark 7'
write(char_io,'(a,a,a)') '(' ,ch, ') rs'
c print*,'mark 8'
call write_ps(char_io)
ENDIF
CALL PSrot(-xangle-xsyman)
RETURN
END
c
c#######################################################################
c
c Rotate the coordinate frame anticlockwise through angle TangleU
c
c#######################################################################
c
Subroutine PSrot(angle) 2,1
common/psdef/io
character char_io*132
IF(angle.ne.0.0) then
write(char_io,'(f8.2,'' rotate'')') angle
call write_ps(char_io)
endif
RETURN
END
SUBROUTINE ZFILLN(X,Y,NP) 1,2
integer np
real x(np),y(np)
CALL XFILAREA(x,y,np)
RETURN
END
SUBROUTINE XFILAREA(X,Y,NP) 16,11
C This routine fills a polygon with gray pre-set by PSgray.
C The polygon is enclosed by curve (x(np), y(np)) defined in
C zxplot mathematical space. The polygon itself will be drawn
C in the width set by PSlnwd or by ZXplot routine Xthick.
common/psdef/io
character char_io*132
common /psscal/ pa,pb,pc,pd, xa,xb,ya,yb, xsca,ysca
real x(np),y(np)
parameter (npmax=20000)
REAL xra(npmax),yra(npmax)
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
real x1,x2,y1,y2
if(iwndon.eq.1)then
nn=0
do i=1,np-1
x1=x(i)
x2=x(i+1)
y1=y(i)
y2=y(i+1)
call xtstwd(x1,y1,x2,y2,idispl)
if(idispl.ne.0) then
nn=nn+1
IF( nn.gt.npmax) GOTO 999
xra(nn)=x1
yra(nn)=y1
nn=nn+1
IF( nn.gt.npmax) GOTO 999
xra(nn)=x2
yra(nn)=y2
end if
end do
else
IF( np.gt.npmax) then
write(6,'(1x,a,/1x,a,i6)')
: 'Work array xra and yra defined in XAREAFIL not large enough.',
: 'Only ',npmax,' points were used.'
endif
do i=1,min(npmax,np)
xra(i) = x(i)
yra(i) = y(i)
enddo
nn = min(npmax,np)
end if
if(nn .ge. 3) then
x1=xra(1)
y1=yra(1)
write(char_io,'(a)') ' N'
call write_ps(char_io)
call xtrans(x1,y1)
call PStran(x1,y1)
write(char_io,100) x1,y1
call write_ps(char_io)
100 format(1x,f7.2,1x,f7.2,1x,'m')
do 5 i=2,nn
x1=xra(i)
y1=yra(i)
call xtrans(x1,y1)
call PStran(x1,y1)
write(char_io,110) x1,y1
call write_ps(char_io)
110 format(1x,f7.2,1x,f7.2,1x,'l')
5 continue
write(char_io,'(a)') 'h f'
call write_ps(char_io)
endif
return
999 write(6,'(1x,a,/1x,a,i6)')
:'Work array xra and yra defined in XFILAREA were too small',
:'Please increase the array size to more than ',npmax
return
end
subroutine xichar 2
C This routine is not needed when characters are written using postscript
C facilitites.
common /xchr30/ ncram(256)
do 5 i=1,256
ncram(i)=i
5 continue
return
end
subroutine xafstyl(nstyle) 4
return
end
subroutine xafpatn(npat)
return
end
subroutine xlncinx(ind)
return
end
subroutine xafcinx(ind)
return
end
subroutine set 14
end
subroutine xqset 1
end
subroutine xzx2ncar 2
end
subroutine strmln 1,2
write(6,'(a,/a)')
:' Sorry, subroutine strmln is not available with the Postscript',
:' version. No streamline field is plotted.'
return
end
SUBROUTINE XWRTCTBL(rgb_table,nc_max) 1,2
c#######################################################################
c
c Activate pre-defined color table in rgb_table
c
c#######################################################################
integer nc_max,j,jj
real rgb_table(3,nc_max)
integer io
common/psdef/io
character char_io*132
DO j=1,nc_max
jj = j -1
write(char_io,110)jj,rgb_table(1,j),rgb_table(2,j),rgb_table(3,j)
call write_ps(char_io)
END DO
110 format(' ct ',i3,' [',f6.3,1x,f6.3,1x,f6.3,'] put')
RETURN
END
SUBROUTINE COLOR(icolor) 36,2
integer icolor
call xcolor(icolor)
RETURN
END
SUBROUTINE XCOLOR(icolor) 86,1
c
c#######################################################################
c
c Choose color by it index out of predefined color table.
c
c#######################################################################
c
c INPUT:
c
c icolor index of the color
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit none
common /psdef/io
character char_io*132
integer io,icolor
integer kolor, lcolor
save kolor
data kolor /1/
kolor = icolor
write(char_io,100) icolor
call write_ps(char_io)
100 format(1x,'S ',i3,1x,'o')
RETURN
ENTRY XQCOLOR(lcolor)
lcolor = kolor
RETURN
END
subroutine xpscmnt(ch) 10,1
character*(*) ch
common /psdef/io
character char_io*132
write(char_io,'(a,a)') '%%PSCOMMENT:',ch
call write_ps(char_io)
return
end
subroutine write_ps( char_io ) 92,1
character char_io*(*)
integer max_buffer
parameter(max_buffer=500)
character ps_buffer(max_buffer)*132
common /psbuffer/ ps_buffer
common /psbufferlines/ lines
if( lines+1 .gt. max_buffer ) call flush_ps_buffer
lines = lines + 1
ps_buffer(lines)=char_io
return
end
subroutine flush_ps_buffer 3
common /psdef/io
integer max_buffer
parameter(max_buffer=500)
character ps_buffer(max_buffer)*132
common /psbuffer/ ps_buffer
common /psbufferlines/ lines
do i=1,lines
! lps_buffer=132
! call xstrlnth(ps_buffer(i), lps_buffer)
! write(io,'(a)') ps_buffer(i)(1:lps_buffer)
write(io,'(a)') trim(ps_buffer(i))
enddo
lines = 0
return
end