c
c#######################################################################
c
c Postscript version of ZXplot routines using postscript character writing,
c Line pattern generating facilities.
c Written by Ming Xue at CIMMS/CAPS, Feb. 1990.
c
c#######################################################################
c
subroutine xtpnup(x,y) 21,2
C position pen at point (x,y) defined in maths space
common /xpen11/ xpen,ypen,flen,blen,npd,xmpen,ympen
call ppenup
( x,y)
xpen= x
ypen= y
return
end
subroutine xtpndn (x,y) 22,2
C Join point (x,y) defined in maths space with current line thickness
common /xpen11/ xpen,ypen,flen,blen,npd,xmpen,ympen
common /xlpn13/ hf1,hb1,hf2,hb2,lfull,lfull0,lthick, dthick
xp1=xpen
yp1=ypen
xp2=x
yp2=y
call ppendn( xp2, yp2)
xpen=xp2
ypen=yp2
return
end
subroutine xbrokn(if1,ib1,if2,ib2) 23,10
C Set broken line patten in the one thousandth of the total vetical ND-space
C range unit.
common /xlpn13/ hf1,hb1,hf2,hb2,lfull,lfull0,lthick, dthick
common/psdef/io
character char_io*132
common /psscal/ p1,p2,p3,p4, xa,xb,ya,yb, xsca,ysca
COMMON /XPHY01/PL,PR,PB,PT,XRANGE,YRANGE
common /xfctr1/ fctr
fctr = sqrt( abs(xrange*yrange) )
h=0.0013*fctr
hf1=h*if1
hb1=h*ib1
hf2=h*if2
hb2=h*ib2
p=p4-p3
write(char_io,'(a)') 'S '
call write_ps(char_io)
write(char_io,100) max(1,nint(hf1*p)),max(1,nint(hb1*p)),
: max(1,nint(hf1*p)),max(1,nint(hb2*p))
call write_ps(char_io)
100 format(' [',4i3,' ] 0 d')
lfull=0 ! Is the current line setting 'full'?
lfull0=1 ! To use own dash line plotting algorithm? Used in XPENDN.
entry xbrokn0
c
c To be called by XPSPAC to reset the dash line lengths when
c the size of plotting space as measured by xrange or yange change
c
if( lfull.eq.1) return
fctr1 = sqrt( abs(xrange*yrange) )
if( abs(fctr-fctr1).gt. 0.001) then
p=p4-p3
hf1=hf1*fctr1/fctr
hb1=hb1*fctr1/fctr
hf2=hf2*fctr1/fctr
hb2=hb2*fctr1/fctr
write(char_io,'(a)') 'S '
call write_ps(char_io)
write(char_io,100) max(1,nint(hf1*p)),max(1,nint(hb1*p)),
: max(1,nint(hf1*p)),max(1,nint(hb2*p))
call write_ps(char_io)
fctr = fctr1
endif
return
entry xdash
C Set line atribute as dash line.
fctr = sqrt( abs(xrange*yrange) )
h=0.0013*fctr
p =p4-p3
hf1=h*10
hb1=h*5
hf2=h*10
hb2=h*5
write(char_io,'(a)') 'S '
call write_ps(char_io)
write(char_io,100) max(1,nint(hf1*p)),max(1,nint(hb1*p)),
: max(1,nint(hf1*p)),max(1,nint(hb2*p))
call write_ps(char_io)
lfull=0
lfull0=1
return
entry xdot
C Set line atribute as dash line.
fctr = sqrt( abs(xrange*yrange) )
h=0.0013*fctr
p = p4-p3
hf1=h*1
hb1=h*6
hf2=h*1
hb2=h*6
write(char_io,'(a)') 'S '
call write_ps(char_io)
write(char_io,100) max(1,nint(hf1*p)),max(1,nint(hb1*p)),
: max(1,nint(hf1*p)),max(1,nint(hb2*p))
call write_ps(char_io)
lfull=0
lfull0=1
return
entry xqbrkn(kf1,kb1,kf2,kb2)
h=0.0013*fctr
kf1=hf1/h
kb1=hb1/h
kf2=hf2/h
kb2=hb2/h
return
entry xfull
C Set line atribute as solid (full) line.
lfull =1
lfull0=1
write(char_io,'(a)') 'S '
call write_ps(char_io)
write(char_io,'(a)') ' [] 0 d'
call write_ps(char_io)
return
entry xqfull(kfull)
kfull=lfull
return
end
subroutine xthick(ithick) 45,2
C Set thickness of lines.
COMMON /XPHY01/PL,PR,PB,PT,XRANGE,YRANGE
common /xlpn13/ hf1,hb1,hf2,hb2,lfull,lfull0,lthick, dthick
integer lnmag,alnmag,blnmag
save lnmag
data lnmag /1/
fctr = sqrt( abs(xrange*yrange) )
c print*,'in xthick, lnmag,ithick,fctr=',lnmag,ithick,fctr
lthick=ithick
c print*,'ithick,lnmag,fctr=',ithick,lnmag,fctr
call PSlnwd(0.25*ithick*lnmag*fctr)
return
entry xlnmag(alnmag)
c
c Magnify the line thickness by a factor of nlnmag.
c
lnmag = alnmag
fctr = sqrt( abs(xrange*yrange) )
c print*,'in xlnmag, lnmag,ithick,fctr=',lnmag,lthick,fctr
call PSlnwd(0.5*lthick*lnmag*fctr)
return
entry xqlnmag(blnmag)
C Enquiry routine for line magnification factor
blnmag = lnmag
return
entry xqthik(kthick)
C Enquiry routine for line thickness.
kthick=lthick
return
end
subroutine Xcharl(x,y,ch) 45,4
character*(*) ch
COMMON /XCHP21/ XCHPEN, YCHPEN ,XCHMO,YCHMO,XCHPO,YCHPO
integer wrtch
c
c#######################################################################
c
c Save the postion of last character string plotting. Strictly it should be
c the last pen postion at the end of string plotting, which is not calculated.
c
c#######################################################################
c
call xtstchwrt(x,y,wrtch)
if(wrtch.eq.0) return
xchpen=x
ychpen=y
x1=x
y1=y
CALL xtrans(x1,y1)
CALL PSstrg(x1,y1,ch,-1)
RETURN
END
cC
SUBROUTINE Xcharr(x,y,ch) 31,4
character*(*) ch
COMMON /XCHP21/ XCHPEN, YCHPEN ,XCHMO,YCHMO,XCHPO,YCHPO
integer wrtch
call xtstchwrt(x,y,wrtch)
if(wrtch.eq.0) return
xchpen=x
ychpen=y
x1=x
y1=y
CALL xtrans(x1,y1)
CALL PSstrg(x1,y1,ch,+1)
RETURN
END
SUBROUTINE Xcharc(x,y,ch) 119,4
character*(*) ch
COMMON /XCHP21/ XCHPEN, YCHPEN ,XCHMO,YCHMO,XCHPO,YCHPO
integer wrtch
call xtstchwrt(x,y,wrtch)
if(wrtch.eq.0) return
xchpen=x
ychpen=y
x1=x
y1=y
CALL xtrans(x1,y1)
CALL PSstrg(x1,y1,ch,0)
RETURN
END
subroutine xchmag(h) 40
common /xpsize/ psize1
common /xcha20/ hctr,sctr,cratio, kfont,nundln
common /xftr06/ xfactr,yfactr
common /psscal/ p1,p2,p3,p4, xa,xb,ya,yb, xsca,ysca
common /xpsd01/ xside, yside
sctr=abs(h)/yfactr
hctr = h
if(abs(yside-1.0).lt.0.001) then ! yside=1.0
fntsiz= abs(h)*psize1*550 ! when yside =1.0
else
fntsiz= abs(h)*psize1*460 ! when yside =1.5
endif
call PSftsz(nint(fntsiz*1.2))
return
entry xqchmg(hh )
hh=hctr
return
entry xchsiz( hc )
sctr= abs(hc)
hctr = hc*yfactr
if(abs(yside-1.0).lt.0.001) then ! yside=1.0
fntsiz= abs(hc)*yfactr*psize1*550 ! when yside =1.0
else
fntsiz= abs(hc)*yfactr*psize1*460 ! when yside =1.5
endif
call PSftsz(nint(fntsiz*1.2))
return
entry xqchsz( cs1 )
cs1= hctr/yfactr
return
end
subroutine xcfont( ifont ) 11,5
common /xcha20/ hctr,sctr,cratio, kfont,nundln
if( ifont.eq. kfont) return
call PSfont(ifont)
kfont=ifont
return
entry xqcfnt ( nfont )
nfont=kfont
return
end
subroutine xarrow(u,v,x0,y0, xleng,uunit) 3,16
C
C Plot vector (U,V) at (X0,Y0). by making use of PostScript
C arrow procedure. Unit X-component UUNIT is plotted with
C length XLENG in mapped maths coordinate. Length of vector in
C Y-direction is scaled according to the mapping.
C
c parameter(pi=3.14159,angle1=(15./180+1)*pi,angle2=(-15./180+1)*pi)
c PARAMETER(SINA1=-.25882,COSA1=-.96593,SINA2=-SINA1,COSA2=COSA1)
parameter(pi=3.14159,angle1=(20./180+1)*pi,angle2=(-20./180+1)*pi)
PARAMETER(SINA1=-.342,COSA1=-.93969,SINA2=-SINA1,COSA2=COSA1)
common /xart36/ kartyp,kvmode,vsc
common/psdef/io
character char_io*132
c
if( abs(u)+abs(v).eq.0.0) return
alpha= xleng/uunit *0.5
xc0=0.0
yc0=0.0
xpleng =xpntsd( xc0,yc0,xc0+xleng,yc0 )
dx=u*alpha
dy=v*alpha
c to plot arrow in absolute space (for conformality)
px0=x0
py0=y0
px1=x0+dx
py1=y0+dy
call xtrans(px0,py0)
call xtrans(px1,py1)
dpx=px1-px0
dpy=py1-py0
pxa=px0-dpx
pya=py0-dpy
dpxy=sqrt( dpx*dpx+dpy*dpy)
if(dpxy.gt.1.0e-30) then
sinta=dpy/dpxy
costa=dpx/dpxy
arrow=0.40* min(xpleng,2*dpxy)
if( kartyp.eq.2 ) arrow=0.40* dpxy*2
px3=px1+arrow*(costa*cosa1-sinta*sina1)
py3=py1+arrow*(sinta*cosa1+costa*sina1)
px4=px1+arrow*(costa*cosa2-sinta*sina2)
py4=py1+arrow*(sinta*cosa2+costa*sina2)
call PStran(pxa,pya)
call PStran(px1,py1)
call PStran(px3,py3)
call PStran(px4,py4)
C write(char_io,100) pxa,pya,px1,py1,px3,py3,px4,py4
C call write_ps(char_io)
C Or without using arw procedure:
C100 format(1x,8f9.4,' arw')
write(char_io,200) pxa,pya,px1,py1,px3
call write_ps(char_io)
write(char_io,201) py3,px4,py4,px1,py1
call write_ps(char_io)
endif
200 format(1x,'S',2f9.4,' m',2f9.4,' l',f9.4)
201 format(f9.4,' l S',2f9.4,' m',2f9.4,' l S')
return
entry xartyp(ktype)
kartyp=ktype
return
end
subroutine xvectk_old(x0,y0, xleng, uunit, key ),36
C Plot unit vectors starting at (X0,Y0), by making use of PostScript
C arrow procedure.
C KEY=-1, 0, 1, 2, for none,in both X and Y-direction,X only, Y only
c
c Corrected an error with the vector key plot.
c
parameter(pi=3.14159,angle1=(10./180+1)*pi,angle2=(-10./180+1)*pi)
parameter(sina1=-.17365,cosa1=-.98481,sina2=-sina1,cosa2=cosa1)
character ch*20
common/psdef/io
character char_io*132
call xqrang(xrg,yrg)
call xqmap(xl,xr,yb,yt)
xscale=xr-xl
yscale=yt-yb
yf=0.4+( min(xrg,yrg) -0.4)*0.5
ctrsiz=3.0*yf*0.01
call xchmag(ctrsiz)
vunit=uunit
dx=xleng
dy=xleng
pxo=x0
pyo=y0
px1=x0+dx
py1=y0
px2=x0
py2=y0+dy
call xtrans(pxo,pyo)
call xtrans(px1,py1)
call xtrans(px2,py2)
dph=sqrt( (px1-pxo)**2+(py1-pyo)**2 )
dpv=sqrt( (px2-pxo)**2+(py2-pyo)**2 )
5 if( dpv.gt.1.5*dph ) then
dpv=dpv*0.5
dy=dy*0.5
vunit=vunit*0.5
goto 5
endif
6 if( dpv.lt.0.75*dph ) then
dpv=dpv*2
dy=dy*2
vunit=vunit*2
goto 6
endif
px2=x0
py2=y0+dy
call xtrans(px2,py2)
if( key.eq.0.or.key.eq.1) then
arrow=0.30*dph
costa=(px1-pxo)/dph
sinta=(py1-pyo)/dph
endif
if(key.eq.0.or.key.eq.2) then
arrow=0.30*dph
costa=(px2-pxo)/dpv
sinta=(py2-pyo)/dpv
endif
px3=px1+arrow*(costa*cosa1-sinta*sina1)
py3=py1+arrow*(sinta*cosa1+costa*sina1)
px4=px1+arrow*(costa*cosa2-sinta*sina2)
py4=py1+arrow*(sinta*cosa2+costa*sina2)
call PStran(pxo,pyo)
call PStran(px1,py1)
call PStran(px3,py3)
call PStran(px4,py4)
C write(char_io,100) pxo,pyo,px1,py1,px3,py3,px4,py4
c call write_ps(char_io)
C Or without using arw procedure:
if( key.eq.0.or.key.eq.1) then
write(char_io,200) pxo,pyo,px1,py1,px3
call write_ps(char_io)
write(char_io,201) py3,px4,py4,px1,py1
call write_ps(char_io)
write(ch,'(f6.1,'' m/s'')') uunit
lch=10
call xchlj (ch,lch)
call xcharl(x0+dx +0.01*xscale,y0,ch(1:lch) )
endif
if(key.eq.0.or.key.eq.2) then
write(char_io,200) pxo,pyo,px2,py2,px3
call write_ps(char_io)
write(char_io,201) py3,px4,py4,px2,py2
call write_ps(char_io)
call xqobag( xang, yang )
call xqchor( asym )
call xchori(90.0+ yang- xang)
write(ch,'(f6.1,'' m/s'')') vunit
lch=10
call xchlj (ch,lch)
call xcharl(x0-.02*xscale ,y0 ,ch(1:lch) )
call xchori( asym )
endif
100 format(1x,8f7.2,' arw')
200 format(1x,'S',2f7.2,' m',2f7.2,' l',f7.2)
201 format(f7.2,' l S',2f7.2,' m',2f7.2,' l S')
return
end