rex@erebus (Rex Sanders) (10/18/87)
ccps is a library of (mostly) Fortran subroutines for converting dusty decks
of Fortran that use the "Calcomp standard" subroutine library to create plots.
Using this library will create a (not very pretty) PostScript output file
that can be sent to an Apple LaserWriter. See the man page for details.
The library contains some ancient Fortran I make no apologies for. The
library also contains several subroutines for local functions that you
can remove or ignore. The dgxplt subroutine is for use with the
Dynamic Graphics Inc. Surface Display Library. This stuff has been in use
for about 6 months on a 4.3 BSD VAX system.
-- Rex Sanders, US Geological Survey
rex@erebus.stanford.edu
------------------------------------------------------------------------------
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# README
# ccps.man.out
# ccps.man
# Makefile
# axis.f
# centch.f
# circle.f
# dgxplt.f
# factor.f
# letter.f
# line.f
# newpen.f
# number.f
# pfleck.f
# pflemv.f
# pl.c
# plot.f
# plots.f
# scale.f
# spot.f
# symbol.f
# where.f
# tests
# This archive created: Sat Jun 13 19:24:28 1987
export PATH; PATH=/bin:$PATH
echo shar: extracting "'README'" '(391 characters)'
if test -f 'README'
then
echo shar: will not over-write existing file "'README'"
else
sed 's/^X//' << \SHAR_EOF > 'README'
XThis directory contains the source code for "ccps", the CalComp-to-PostScript
Xsubroutine library. The library implements the CalComp subroutine calls,
Xand spits out a file named "ps_plot" that can be printed on any PostScript
Xprinter with Adobe's Courier font.
X
XSee also the subdirectory "tests", with 8 tests for the CalComp and SDL
Xsubroutines using this library.
X
X-- Rex Sanders
X 3/87
SHAR_EOF
if test 391 -ne "`wc -c < 'README'`"
then
echo shar: error transmitting "'README'" '(should have been 391 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'ccps.man.out'" '(1642 characters)'
if test -f 'ccps.man.out'
then
echo shar: will not over-write existing file "'ccps.man.out'"
else
sed 's/^X//' << \SHAR_EOF > 'ccps.man.out'
X
X
X
XCCPS(3F) UNIX Programmer's Manual CCPS(3F)
X
X
X
XNAME
X ccps - CalComp-to-PostScript plotting subroutine library
X
XUSAGE
X f77 junk.f -l_c_c_p_s
X
XDESCRIPTION
X The ccps subroutines can be called to generate a plot file
X (_p_s__p_l_o_t) containing PostScript commands for the laser
X printers using the postscript language, such as the Apple
X LaserWriter. The available plotting area is about 10.5
X inches (X-axis) by 8.0 inches (Y-axis).
X
X The _p_s__p_l_o_t file is plotted using the _p_p_r(1) command.
X _p_s__p_l_o_t is created in the working directory, overwriting any
X existing _p_s__p_l_o_t file.
X
X These subroutines are "CalComp-compatible", and compatible
X with the _c_a_l_c_o_m_p(3f) (CalComp 1077 plotter), _h_o_u_s_t_o_n(3f)
X (Houston DP8-S3 plotter), _h_p_7_4_7_5(3f) (HP 7475A plotter),
X _i_m_p_l_o_t(3f) (Imagen 8/300 laser printer), and _c_c_t_c_s(3f) (Tek-
X tronix 4014 terminal) subroutines. This library also con-
X tains interfaces for Surface Display Library and navplt.
X You can get a manual for these subroutines from Rex Sanders
X (x7052, A220).
X
XFILES
X /usr/local/lib/libccps.a
X
XSEE ALSO
X calcomp(3f), houston(3f), hp7475(3f), implot(3f), cctcs(3f),
X sdl(3f), navplt(1)
X "Programming CalComp Electromechanical Plotters, 1976"
X
XBUGS
X There is no way to plot more than one page at a time.
X
XAUTHORS
X Rex Sanders, USGS Pacific Marine Geology - primary author.
X Public domain - several auxiliary subroutines.
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
XPrinted 3/5/87 LOCAL 1
X
X
X
SHAR_EOF
echo shar: 62 control characters may be missing from "'ccps.man.out'"
if test 1642 -ne "`wc -c < 'ccps.man.out'`"
then
echo shar: error transmitting "'ccps.man.out'" '(should have been 1642 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'ccps.man'" '(1462 characters)'
if test -f 'ccps.man'
then
echo shar: will not over-write existing file "'ccps.man'"
else
sed 's/^X//' << \SHAR_EOF > 'ccps.man'
X.lg 0
X.TH CCPS 3F LOCAL "USGS Pacific Marine Geology"
X.SH NAME
Xccps \- CalComp-to-PostScript plotting subroutine library
X.SH USAGE
X\fBf77\fR junk.f \fB-l\fIccps\fR
X.SH DESCRIPTION
XThe
X.B ccps
Xsubroutines can be called to generate a plot file
X(\fIps_plot\fR) containing PostScript commands
Xfor the laser printers using the postscript language,
Xsuch as the Apple LaserWriter.
XThe available plotting area is about 10.5 inches (X-axis) by
X8.0 inches (Y-axis).
X.PP
XThe \fIps_plot\fR file is plotted using the
X.IR ppr (1)
Xcommand.
X\fIps_plot\fR is created in the working directory,
Xoverwriting any existing
X\fIps_plot\fR file.
X.PP
XThese subroutines are \*(lqCalComp-compatible\*(rq,
Xand compatible with the
X.IR calcomp (3f)
X(CalComp 1077 plotter),
X.IR houston (3f)
X(Houston DP8-S3 plotter),
X.IR hp7475 (3f)
X(HP 7475A plotter),
X.IR implot (3f)
X(Imagen 8/300 laser printer),
Xand
X.IR cctcs (3f)
X(Tektronix 4014 terminal)
Xsubroutines.
XThis library also contains interfaces for
XSurface Display Library and navplt.
XYou can get a manual for these subroutines
Xfrom Rex Sanders (x7052, A220).
X.SH FILES
X/usr/local/lib/libccps.a
X.SH SEE ALSO
Xcalcomp(3f), houston(3f), hp7475(3f), implot(3f), cctcs(3f), sdl(3f), navplt(1)
X.br
X\*(lqProgramming CalComp Electromechanical Plotters, 1976\*(rq
X.SH BUGS
XThere is no way to plot more than one page at a time.
X.SH AUTHORS
XRex Sanders, USGS Pacific Marine Geology \- primary author.
X.br
XPublic domain \- several auxiliary subroutines.
SHAR_EOF
if test 1462 -ne "`wc -c < 'ccps.man'`"
then
echo shar: error transmitting "'ccps.man'" '(should have been 1462 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'Makefile'" '(865 characters)'
if test -f 'Makefile'
then
echo shar: will not over-write existing file "'Makefile'"
else
sed 's/^X//' << \SHAR_EOF > 'Makefile'
X# Makefile for PostScript printers - "libccps.a"
X# Rex Sanders, 2/87
X#Note: cannot use optimizer on pflemv.f
X#Usage: 'make all' - makes ccps.a in source dir.
X# 'make ccps.a'
X# 'make install' - installs libccps.a
X# 'make clean' - cleans all .o files from source dir.
X
XFOBJ = axis.o centch.o circle.o dgxplt.o factor.o letter.o line.o \
X newpen.o number.o pfleck.o plot.o plots.o \
X scale.o spot.o symbol.o where.o
XCOBJ = pl.o
XFFLAGS = -O
X#FFLAGS = -g
XCFLAGS = -O
X#CFLAGS = -g
X
Xall : ccps.a
X
Xccps.a : ${FOBJ} pflemv.o ${COBJ}
X ar ru ccps.a ${FOBJ} pflemv.o ${COBJ}
X ranlib ccps.a
X
X${FOBJ} :
X
X#Note: cannot use optimizer on pflemv.f
Xpflemv.o: pflemv.f
X ${FC} -c pflemv.f
X
X${COBJ} :
X
Xinstall : ccps.a
X install -c -o bin -g bin -m 0444 ccps.a /usr/local/lib/libccps.a
X ranlib /usr/local/lib/libccps.a
X
Xclean:
X rm -f ccps.a ${FOBJ} pflemv.o ${COBJ}
SHAR_EOF
if test 865 -ne "`wc -c < 'Makefile'`"
then
echo shar: error transmitting "'Makefile'" '(should have been 865 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'axis.f'" '(2822 characters)'
if test -f 'axis.f'
then
echo shar: will not over-write existing file "'axis.f'"
else
sed 's/^X//' << \SHAR_EOF > 'axis.f'
X subroutine axis(x,y,lbl,nc,s,theta,amin,delta)
X save
Xc
Xc this subroutine draws an axis with "tic" marks at one inch
Xc intervals with their associated values and addelta a label.
Xc the arguments are:
Xc x,y = the coordinates in inches of the starting point of
Xc the axis
Xc lbl = a holerith string that will be used as the axis label
Xc it is centered and drawn in 0.14 inch high letters.
Xc nc = number of characters in lbl. if pos, label, scale, &
Xc tic marks are drawn on ccw side of the axis. if neg,
Xc they are placed on the cw side.
Xc s = the length of the axis in inches.
Xc theta = the angle in degrees from the +x direction that the
Xc axis is drawn. =0 implies a horizontal axis reading
Xc left to right. =90 implies a verticle axis reading
Xc bottom to top.
Xc amin = the minimum value shown on the axis.
Xc delta = the scale increment per inch on the scale.
Xc
X dimension lbl(1) , jdl(1)
Xc
Xc nn =specifies the number of digits affter the decimal
Xc point on numeric lettering. calcomp versions allow
Xc only 2 positions after the decimal.
Xc
X data nn/2/,jdl/4h *10/
X xb=x
X yb=y
X ymin=amin
X n=s+.5
X nac=iabs(nc)
X yyd=.5*s-.06*nac
X angrad=1.7453293e-2*theta
X f=cos(angrad)
X g=sin(angrad)
X sgn=isign(1,nc)
X fsv=sgn*f
X gsv=sgn*g
X t=-.07*(sgn-1.)
X shftx=t*gsv
X shfty=t*fsv
X xa=xb-.1*gsv
X ya=yb+.1*fsv
X xc=xb-.15*gsv-.17*f-shftx
X yc=yb+.15*fsv-.17*g+shfty
X xd=xb+yyd*f-.33*gsv-shftx
X yd=yb+yyd*g+.33*fsv+shfty
X exp=0.
X dd=abs(delta)
X if (dd.ge..01.and.dd.le.100.) go to 50
X nac=nac+4
X 10 if (dd.lt..01) go to 40
X 20 if (dd.gt.100.) go to 30
X go to 50
X 30 dd=dd*.1
X ymin=ymin*.1
X exp=exp+1.
X go to 20
X 40 dd=dd*10.
X ymin=ymin*10.
X exp=exp-1.
X go to 10
X 50 call number(xc,yc,.105 ,ymin,theta,nn)
X dd=sign(dd,delta)
X do 60 i = 1,n
X call plot(xa,ya,1)
X call plot(xb,yb,2)
X xa=xa+f
X xb=xb+f
X xc=xc+f
X ya=ya+g
X yb=yb+g
X yc=yc+g
X ymin=ymin+dd
X call plot(xb,yb,1)
X call plot(xa,ya,1)
X 60 call number(xc,yc,.105,ymin,theta,nn)
X if (exp) 80,70,80
X 70 call symbol(xd,yd,.14,lbl,theta,nac)
X return
X 80 ncc=nac-4
X call symbol(xd,yd,.14,lbl,theta,ncc)
X call where(aa,bb,fact)
X call symbol(aa,bb,.14,jdl,theta,4)
X call where(aa,bb,fact)
X aa=aa+cos(angrad)*(.08)-sin(angrad)*.08
X bb=bb+sin(angrad)*(.08)+cos(angrad)*.08
X call number(aa,bb,.07,exp,theta,-1)
X return
X end
SHAR_EOF
if test 2822 -ne "`wc -c < 'axis.f'`"
then
echo shar: error transmitting "'axis.f'" '(should have been 2822 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'centch.f'" '(923 characters)'
if test -f 'centch.f'
then
echo shar: will not over-write existing file "'centch.f'"
else
sed 's/^X//' << \SHAR_EOF > 'centch.f'
X subroutine centch(x,y,ang,ht,xx,yy)
Xc **** Calculate coords of bottom left of char cell
Xc Input:
Xc x,y = coords of center of char cell
Xc ang, ht = angle (degrees) and height (inches) of cell
X
Xc Output:
Xc xx,yy = coords of bottom, left corner
X
Xc ---- Set x,y shift factors for Unix/houston:
X parameter (xadj=0.3333, yadj=0.5000)
X
Xc ---- See if x or y indicate `use last coordinate':
X if (abs(x-999.) - 0.1 .lt. 0.) then
X call where(xlast, ylast, rfact)
X xloc = xlast
X else
X xloc = x
X end if
X if (abs(y-999.) - 0.1 .lt. 0.) then
X call where(xlast, ylast, rfact)
X yloc = ylast
X else
X yloc = y
X end if
X
Xc ---- Calculate bottom left corner from center. ----
X rang = .0174533 * ang
X cosa = cos (rang)
X sina = sin (rang)
X xx = xloc - ht*cosa*xadj + yadj*ht*sina
X yy = yloc - ht*sina*xadj - yadj*ht*cosa
X return
X end
SHAR_EOF
if test 923 -ne "`wc -c < 'centch.f'`"
then
echo shar: error transmitting "'centch.f'" '(should have been 923 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'circle.f'" '(535 characters)'
if test -f 'circle.f'
then
echo shar: will not over-write existing file "'circle.f'"
else
sed 's/^X//' << \SHAR_EOF > 'circle.f'
X subroutine circle(xorg,yorg,rad)
XC
XC draw a circle in PostScript for ccps library
XC Rex Sanders, 3/87
XC
X common /cqpbnf/ xold, yold, fac, ires
X save /cqpbnf/
X real xold, yold, fac
X integer ires
X
XC
XC Output "stroke x y radius 0 360 arc stroke"
XC
X call plsout ("stroke ")
X call pliout (nint (xorg*fac*ires))
X call plcout (32)
X call pliout (nint (yorg*fac*ires))
X call plcout (32)
X call pliout (nint (rad*fac*ires))
X call plsout (" 0 360 arc stroke\n")
X call plot(xorg,yorg,3)
X
X return
X end
SHAR_EOF
if test 535 -ne "`wc -c < 'circle.f'`"
then
echo shar: error transmitting "'circle.f'" '(should have been 535 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'dgxplt.f'" '(1367 characters)'
if test -f 'dgxplt.f'
then
echo shar: will not over-write existing file "'dgxplt.f'"
else
sed 's/^X//' << \SHAR_EOF > 'dgxplt.f'
X subroutine dgxplt(iac, iun, ivl, idm, xpl, ypl)
Xc** Purpose: SDL -> PostScript printer interface subroutine
Xc**
Xc** Author: Rex Sanders, USGS Pacific Marine Geology, 2/87
X integer iac, iun, ivl, idm
X real xpl(idm), ypl(idm)
X
Xc** SDL common block
X common /dgsdlp/ ipentp, ipenlt, ipenbl, xold, yold, iflbld
X integer ipentp, ipenlt, ipenbl, iflbld
X real xold, yold
X
Xc** ccps common block
X common /cqpbnf/ xdum, ydum, fac, ires
X save /cqpbnf/
X real xdum, ydum, fac
X integer ires
X
Xc** Local variables
X integer i
X
Xc** Switch on input value of iac - 1..5 (6 ignored)
Xc** Draw regular or bold line
X if (iac .eq. 1 .or. iac .eq. 2) then
X if (iac .eq. 1) call newpen(ipenlt)
X if (iac .eq. 2) then
X if (ipenlt .ne. ipenbl) then
X call newpen(ipenbl)
X else
X call newpen(3)
X endif
X endif
X
X call plot(xpl(1), ypl(1), 3)
X
X do 100 i = 2, (ivl - 1)
X call pliout(nint(xpl(i)*fac*ires))
X call plcout(32)
X call pliout(nint(ypl(i)*fac*ires))
X call plsout(" L\n")
X100 continue
X
X call plot(xpl(ivl), ypl(ivl), 2)
X
Xc** Initiate plotting
X else if (iac .eq. 3) then
X call plots(0, 0, 8)
X
Xc** New page
X else if (iac .eq. 4) then
X call plsout("gsave showpage grestore\n")
X
Xc** Terminate plotting
X else if (iac .eq. 5) then
X call plot(0.0, 0.0, 999)
X end if
X
X return
X end
SHAR_EOF
if test 1367 -ne "`wc -c < 'dgxplt.f'`"
then
echo shar: error transmitting "'dgxplt.f'" '(should have been 1367 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'factor.f'" '(355 characters)'
if test -f 'factor.f'
then
echo shar: will not over-write existing file "'factor.f'"
else
sed 's/^X//' << \SHAR_EOF > 'factor.f'
X subroutine factor (f)
X real f
XC
XC sets plot sizing factor -
XC if f = 2.0 then all subsequent pen movements will be twice normal size
XC if f is reset to 1.0, all plotting returns to normal size
XC
X
X common /cqpbnf/ xold, yold, fac, ires
X save /cqpbnf/
X real xold, yold, fac
X integer ires
X
X fac = f
X return
X end
SHAR_EOF
if test 355 -ne "`wc -c < 'factor.f'`"
then
echo shar: error transmitting "'factor.f'" '(should have been 355 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'letter.f'" '(258 characters)'
if test -f 'letter.f'
then
echo shar: will not over-write existing file "'letter.f'"
else
sed 's/^X//' << \SHAR_EOF > 'letter.f'
X subroutine letter (nchr,iht,iang,x,y,str)
Xc ---- Translate parameters from old Benson-Lehner letter calls
Xc ---- to hp parameters and call symbol. ----
X character str*(*)
X
X ht = iht * .06
X ang = float (iang)
X call symbol (x,y,ht,str,ang,nchr)
X return
X end
SHAR_EOF
if test 258 -ne "`wc -c < 'letter.f'`"
then
echo shar: error transmitting "'letter.f'" '(should have been 258 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'line.f'" '(1520 characters)'
if test -f 'line.f'
then
echo shar: will not over-write existing file "'line.f'"
else
sed 's/^X//' << \SHAR_EOF > 'line.f'
X subroutine line(xa,ya,n,k,ltype,inum)
X save
Xc
Xc draw line connecting data point coordinates array value
Xc ** xa(n*k+1) must contain minimum x scale value (inch)
Xc ** ya(n*k+1) y
Xc ** xa(n*k+k+1) must contain delta x value (per inch)
Xc ** ya(n*k+k+1) y
Xc
X dimension xa(1),ya(1)
Xc ns= count to plot symbol
Xc il= flag to plot line
Xc is= flag to plot symbol
Xc lim= last (x,y) point to plot
X ns= iabs(ltype)
X il= 0
X if(ltype.ge.0) il=1
X is= 1
X if(ltype.eq.0) is=0
X lim= n*k
X xmin= xa(lim+1)
X ymin= ya(lim+1)
X xinc= xa(lim+k+1)
X yinc= ya(lim+k+1)
Xc pen up to 1st point
X x = (xa(1)-xmin) / xinc
X y = (ya(1)-ymin) / yinc
X call plot (x,y, 3)
Xc plot array of (x,y) coord. points
X if (il.eq.0) go to 20
X do 10 i = 1,lim,k
X x= (xa(i)-xmin)/ xinc
X y= (ya(i)-ymin)/ yinc
Xc plot line
X call plot (x,y,2)
X 10 continue
Xc
X 20 if (is.eq.0) go to 40
X j=1
X do 30 i = 1,lim,k
X j= j-1
X if (j.gt.0) go to 30
X j= ns
X x= (xa(i)-xmin)/ xinc
X y= (ya(i)-ymin)/ yinc
Xc plot symbol
X call symbol (x,y,.08 ,inum,0.0, -1)
X 30 continue
X 40 return
X end
SHAR_EOF
if test 1520 -ne "`wc -c < 'line.f'`"
then
echo shar: error transmitting "'line.f'" '(should have been 1520 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newpen.f'" '(509 characters)'
if test -f 'newpen.f'
then
echo shar: will not over-write existing file "'newpen.f'"
else
sed 's/^X//' << \SHAR_EOF > 'newpen.f'
X subroutine newpen (ipen)
X integer ipen
XC
XC Selects new pen as indicated by ipen
XC Where:
XC ipen = 1..n indicating pen 1 - n
XC Simulated by changing line width for PostScript printers
XC
X
X integer npen
X integer usepen
X integer savpen
X save savpen
X data savpen /1/
X
X npen = max (ipen, 1)
X if (npen .ne. savpen) then
XC
XC Want pen width to be odd number of pixels wide
XC
X usepen = ((npen -1) * 2) + 1
X call pliout (usepen)
X call plsout (" W\n")
X
X savpen = npen
X end if
X
X return
X end
SHAR_EOF
if test 509 -ne "`wc -c < 'newpen.f'`"
then
echo shar: error transmitting "'newpen.f'" '(should have been 509 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'number.f'" '(1469 characters)'
if test -f 'number.f'
then
echo shar: will not over-write existing file "'number.f'"
else
sed 's/^X//' << \SHAR_EOF > 'number.f'
X subroutine number (xpage, ypage, height, fpn, angle, ndec)
X real xpage, ypage, height, fpn, angle
X integer ndec
XC
XC Convert floating point number into numbers on graph
XC
XC Limit: f19.9 maximum number printable
XC If this limit is raised, string lengths and formats must be changed
XC
XC Basic method: build proper string, hand to symbol
XC
XC Rex Sanders, USGS, 3/87
XC
X character*19 floats
X character* 7 formts
X integer maxnpl, maxnpr
X parameter (maxnpl = 9, maxnpr = 9)
X
X real afpn
X integer npl, npr, nchar, ntrunc, inum
X
X afpn = abs (fpn)
XC
XC First cut on # places left of decimal point
XC
X if (fpn .eq. 0) then
X npl = 1
X else if (fpn .gt. 0) then
X npl = max (int (log10 (fpn)), 0) + 1
X else if (fpn .lt. 0) then
X npl = max (int (log10 (afpn)), 0) + 2
X endif
XC
XC Guaranteed a decimal point
XC
X if (ndec .ge. 0) then
X npl = min (npl, maxnpl)
X npr = min (ndec, maxnpr)
X nchar = npl + npr + 1
X write(formts, 101) nchar, npr
X101 format('(f', i2, '.', i1, ')')
X write(floats, formts) fpn
XC
XC No decimal point, write as integer
XC
X else
X ntrunc = abs (ndec) - 1
X npl = max (min (npl - ntrunc, maxnpl), 1)
X write(formts, 102) npl
X102 format('(i', i1, ')')
X
X inum = nint(fpn/(10**ntrunc))
X write(floats, formts) inum
X nchar = npl
X endif
X
X call symbol (xpage, ypage, height, floats, angle, nchar)
X
X return
X end
SHAR_EOF
if test 1469 -ne "`wc -c < 'number.f'`"
then
echo shar: error transmitting "'number.f'" '(should have been 1469 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'pfleck.f'" '(969 characters)'
if test -f 'pfleck.f'
then
echo shar: will not over-write existing file "'pfleck.f'"
else
sed 's/^X//' << \SHAR_EOF > 'pfleck.f'
X subroutine pfleck (lstop)
Xc *** Subroutine to see if file "ps_plot" exists
Xc ---- Returns true if file exists and user does not want to
Xc ---- overwrite it,
Xc ---- else returns false. ----
X
Xc ---- Graig McHendrie, USGS, June 6, 1984 - original for Houston plotter
Xc ---- Rex Sanders, USGS, February 1987 - modified for PostScript printers
X
X logical lstop
X
X external system,getyna
X logical system
X logical lans
X character pflenm*8
X
Xc ---- Set name of file to be checked. ----
X pflenm = 'ps_plot'
X
Xc ---- If file doesn't exist, return false. ----
X if (system ('test -s ' // pflenm)) then
X lstop = .false.
X
Xc ---- If file does exist, see if user wants to continue anyway. ----
X else
X write(*,100) pflenm
X100 format('File ''', a, ''' already exists.',
X & ' Continuing will destroy it.'/
X & ' Do you want to continue (y/n) ?'$)
X call getyna(lans)
Xc ---- Return false if answered yes, true if no. ----
X lstop = .not. lans
X end if
X return
X end
SHAR_EOF
echo shar: 1 control character may be missing from "'pfleck.f'"
if test 969 -ne "`wc -c < 'pfleck.f'`"
then
echo shar: error transmitting "'pfleck.f'" '(should have been 969 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'pflemv.f'" '(1630 characters)'
if test -f 'pflemv.f'
then
echo shar: will not over-write existing file "'pflemv.f'"
else
sed 's/^X//' << \SHAR_EOF > 'pflemv.f'
X subroutine pflemv (newfle)
Xc **** Subroutine to rename the ps_plot file.
Xc ---- newfile = new name for file. ----
X
Xc Graig McHendrie, USGS, Feb 6, 1985 - original for Houston plotter
Xc Rex Sanders, USGS, February 1987 - modified for PostScript printers
X
X external system,getyna
X integer system
X logical lans,lmvit
X character newfle*(*), tcmd*48, mcmd*48, gpif*32
X character*8 pflenm
X
X pflenm = 'ps_plot'
X
Xc ---- Build commands for test and move operations. ----
X tcmd = 'test -s ' // newfle
X mcmd = 'mv ' // pflenm // newfle
X lmvit = .false.
X
Xc ---- Perform test command on new name. If file doesn't exist,
Xc ---- 'icde' will be 1 and it is ok to rename h_plot.
X icde = system (tcmd)
X if (icde .ne. 0) then
X lmvit = .true.
Xc ---- File already exists. ----
X else
X write(*,100) newfle, pflenm
X100 format(/' ',a, ' already exists.'/
X &' Renaming ''',a,''' to this name will destroy the old version.'/
X & ' Is that acceptable (y/n) ?'$)
X call getyna(lans)
Xc ---- Find out if user wants to overwrite the existing file. ----
X if (lans) then
X lmvit = .true.
X else
X gpif = pflenm
X end if
X end if
X
Xc ---- It's ok to rename h_plot to newfile. ----
X if (lmvit) then
X icde = system (mcmd)
X if (icde .ne. 0) then
X write(*,90) mcmd,icde
X90 format(' There was a system problem with the command:'/
X & ' ',a/
X & ' The error return code was ',i5)
X gpif = pflenm
X else
X gpif = newfle
X end if
X end if
X
Xc ---- Write to standard_output the final name of the plot file. ----
X write(*,120) gpif
X120 format(/' The plot file from this run is: ',a)
X return
X end
SHAR_EOF
echo shar: 1 control character may be missing from "'pflemv.f'"
if test 1630 -ne "`wc -c < 'pflemv.f'`"
then
echo shar: error transmitting "'pflemv.f'" '(should have been 1630 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'pl.c'" '(993 characters)'
if test -f 'pl.c'
then
echo shar: will not over-write existing file "'pl.c'"
else
sed 's/^X//' << \SHAR_EOF > 'pl.c'
X/*
X * low-level i/o routines for the ccps plotting package
X *
X * Rex Sanders, USGS, 2/87
X *
X */
X
X#include <stdio.h>
X
Xstatic FILE *fp;
X
Xvoid
Xplbegn_()
X{
X
X char *fname = "ps_plot";
X long t;
X
X if ((fp = fopen(fname, "w")) == NULL)
X {
X fprintf(stderr, "plbegn: can't open %s\n", fname);
X exit(1);
X }
X
X fputs ("%!\n", fp);
X fputs ("% Postscript output from ccps library\n", fp);
X t = time(0);
X fprintf (fp, "%% Created: %s", ctime(&t));
X
X}
X
Xvoid
Xpldone_()
X{
X fputs ("% end of ccps output\n", fp);
X fclose(fp);
X}
X
Xvoid
Xplcout_(c)
Xchar *c;
X{
X/*
X * send one char to plot file
X */
X putc(*c, fp);
X}
X
Xvoid
Xpliout_(i)
Xint *i;
X{
X/*
X * send one integer value to plot file
X */
X fprintf(fp, "%d", *i);
X}
X
Xvoid
Xplfout_(f)
Xfloat *f;
X{
X/*
X * send one float value to plot file
X */
X fprintf(fp, "%.3f", *f);
X}
Xvoid
Xplsout_(s, l)
Xchar *s;
Xlong int l;
X{
X/*
X * send a string to plot file
X */
Xchar *string;
X for(string = s; l > 0; l--, string++) putc(*string, fp);
X}
SHAR_EOF
if test 993 -ne "`wc -c < 'pl.c'`"
then
echo shar: error transmitting "'pl.c'" '(should have been 993 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'plot.f'" '(2119 characters)'
if test -f 'plot.f'
then
echo shar: will not over-write existing file "'plot.f'"
else
sed 's/^X//' << \SHAR_EOF > 'plot.f'
X subroutine plot (x, y, ipen)
X real x, y
X integer ipen
XC
XC Plotter driver conforming to:
XC "Programming CalComp Electromechanical Plotters", CalComp, January 1976
XC Output for PostScript printers like Apple LaserWriter Plus
XC
XC Rex Sanders, USGS, 2/87
XC
XC Where:
XC x,y = coordinates, in inches from the current origin, of the position
XC to which the pen is to be moved
XC
XC ipen = pen control, origin definition, and plot termiination such that:
XC if ipen = 1, move with pen in present condition
XC if ipen = 2, move with pen down
XC if ipen = 3, move with pen up
XC if ipen = -1, move with no pen change, reset origin to terminal position
XC if ipen = -2, move with pen down, reset origin to terminal position
XC if ipen = -3, move with pen up, reset origin to terminal position
XC if ipen = 999, move with pen up, terminate plot, close plot file
XC if ipen = anything else, no action is taken
XC
X
X common /cqpbnf/ xold, yold, fac, ires
X save /cqpbnf/
X real xold, yold, fac
X integer ires
X
X integer locpen
X logical penup
X save penup
X data penup /.true./
X
X locpen = abs (ipen)
X
XC
XC Check pen for proper values
XC
X if (locpen .ne. 1 .and. locpen .ne. 2 .and. locpen .ne. 3 .and.
X& ipen .ne. 999) return
X
XC
XC Reset locpen to current pen status
XC
X if (locpen .eq. 1) then
X if (penup) then
X locpen = 3
X else
X locpen = 2
X endif
X endif
X
XC
XC Set up for move or draw
XC Output "x y"
XC
X call pliout (nint (x * fac * ires))
X call plcout (32)
X call pliout (nint (y * fac * ires))
X
XC
XC Pen down - draw
XC
X if (locpen .eq. 2) then
X call plsout (" D\n")
X penup = .false.
X
XC
XC Pen up - move
XC
X else if (locpen .eq. 3 .or. locpen .eq. 999) then
X call plsout (" M\n")
X penup = .true.
X endif
X
X if (ipen .ge. 0) then
X xold = x
X yold = y
X else
XC
XC Set new origin
XC
X call plsout ("O\n")
X xold = 0.0
X yold = 0.0
X endif
X
XC
XC Close and clean up plot file
XC
X if (ipen .eq. 999) then
X call plsout ("showpage\n")
X call pldone
X endif
X
X return
X end
SHAR_EOF
if test 2119 -ne "`wc -c < 'plot.f'`"
then
echo shar: error transmitting "'plot.f'" '(should have been 2119 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'plots.f'" '(2032 characters)'
if test -f 'plots.f'
then
echo shar: will not over-write existing file "'plots.f'"
else
sed 's/^X//' << \SHAR_EOF > 'plots.f'
X subroutine plots (idum, jdum, kdum)
X integer idum, jdum, kdum
XC
XC Plotter initialisation routine - must be called before any other plotter
XC calls are made
XC
XC Where:
XC idum, jdum, kdum = dummy variables for compatibility
XC
X
X common /cqpbnf/ xold, yold, fac, ires
X save /cqpbnf/
X real xold, yold, fac
X integer ires
X
X logical first
X save first
X data first /.true./
X
XC
XC Initialise plot storage - if we haven't already
XC
X if (first) then
X first = .false.
X call plbegn
XC
XC Scale, rotate and translate PostScript output
XC Units of pixels (300/inch for most laser printers)
XC Origin in lower left corner, landscape mode
XC
X call plsout ("72 300 div dup scale\n")
X call plsout ("90 rotate\n")
X call plsout ("75 -2460 translate\n")
X call plsout ("0 0 moveto\n")
XC
XC Set other line drawing parameters
XC
X call plsout ("1 setlinewidth\n")
X call plsout ("1 setlinejoin\n")
X call plsout ("1 setlinecap\n")
XC
XC Speed up symbol font handling
XC
X call plsout ("/SF /Courier findfont def\n")
XC
XC Set up definitions for other routines:
XC
XC Move
XC
X call plsout ("/M /moveto load def\n")
XC
XC Relative Move
XC
X call plsout ("/RM /rmoveto load def\n")
XC
XC Draw
XC
X call plsout ("/D {lineto currentpoint stroke moveto} def\n")
XC
XC Special support for dgxplt
XC
X call plsout ("/L /lineto load def\n")
XC
XC Set new origin
XC
X call plsout ("/O {currentpoint translate} def\n")
XC
XC Set new linewidth
XC
X call plsout ("/W {currentpoint stroke moveto setlinewidth} def\n")
XC
XC Set character height
XC
X call plsout ("/H {SF exch scalefont setfont} def\n")
XC
XC Show character string
XC
X call plsout ("/S /show load def\n")
XC
XC Start and end rotated text
XC
X call plsout ("/RS {currentpoint gsave translate rotate} def\n")
X call plsout ("/RE /grestore load def\n")
X
X end if
X
XC
XC Initialise common variables
XC
X fac = 1.0
X xold = 0.0
X yold = 0.0
X ires = 300
X
X return
X end
SHAR_EOF
if test 2032 -ne "`wc -c < 'plots.f'`"
then
echo shar: error transmitting "'plots.f'" '(should have been 2032 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'scale.f'" '(1235 characters)'
if test -f 'scale.f'
then
echo shar: will not over-write existing file "'scale.f'"
else
sed 's/^X//' << \SHAR_EOF > 'scale.f'
X subroutine scale (array,axlen,npts,inc)
X save
Xc
Xc compute minimun and delta for line routine
Xc
X dimension array(1),tst(7)
X data tst / 1.0, 2.0, 4.0, 5.0, 8.0, 10.0, 20.0 /
X fad = 0.01
X k = iabs(inc)
X n = npts*k
X y0 = array(1)
X yn = y0
X do 20 i = 1,n,k
X ys = array(i)
X if (y0.le.ys) go to 10
X y0 = ys
X go to 20
X 10 if (ys.gt.yn) yn=ys
X 20 continue
X firstv = y0
X if (y0.lt.0.0) fad=fad-1.0
X deltav =(yn-firstv)/ axlen
X if (deltav.le.0.0) go to 70
X i= alog10(deltav)+1000.0
X p= 10.0**(i-1000)
X deltav= deltav/p - 0.01
X do 30 i = 1,6
X is= i
X if (tst(i).ge.deltav) go to 40
X 30 continue
X 40 deltav= tst(is)*p
X firstv= deltav* aint(y0/deltav+fad)
X t=firstv + (axlen+0.01)*deltav
X if (t.ge.yn) go to 50
X is= is+1
X go to 40
X 50 firstv= firstv-aint((axlen+(firstv-yn)/deltav)/2.0) * deltav
X if((y0*firstv).le.0.0) firstv=0.0
X if (inc.gt.0) go to 60
X firstv= firstv + axlen*deltav
X deltav= -deltav
X 60 n=n+1
X array(n)= firstv
X n= n+k
X array(n)= deltav
X return
X 70 deltav=1.0
X firstv= firstv-0.5
X go to 60
X end
SHAR_EOF
if test 1235 -ne "`wc -c < 'scale.f'`"
then
echo shar: error transmitting "'scale.f'" '(should have been 1235 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'spot.f'" '(4134 characters)'
if test -f 'spot.f'
then
echo shar: will not over-write existing file "'spot.f'"
else
sed 's/^X//' << \SHAR_EOF > 'spot.f'
X subroutine spot (x,y,ht,ich,ang)
Xc **** Modified for Marine Geology Vax Unix system for use with
Xc houston symbol routine.
Xc Purpose: accept parameters from program written with old
Xc Benson-Lehner spot calls and translate symbol code to the
Xc equivalent symbol in the houston 'symbol' routine.
X
Xc Graig McHendrie, March 7, 1984
X
X
Xc ---- Initialize values for conversion from B-L spot integers
Xc ---- to Houston integers. ----
X integer bls2hs (102)
X data bls2hs/
X
Xc A B C D E F G H I J K L M N
Xc (bl) 1 2 3 4 5 6 7 8 9 10 11 12 13 14
X& 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78,
X
X
Xc O P Q R S T U V W X Y Z % @
Xc (bl) 15 16 17 18 19 20 21 22 23 24 25 26 27 28
X& 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 37, 64,
X
Xc & 0 1 2 3 4 5 6 7 8 9 $ ` <
Xc (bl) 29 30 31 32 33 34 35 36 37 38 39 40 41 42
X& 38, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 36, 96, 60,
X
Xc > ( ) ^ | - / ? ! ' ' . = ;
Xc (bl) 43 44 45 46 47 48 49 50 51 52 53 54 55 56
X& 62, 40, 41, 94,124, 45, 47, 63, 33, 39, 39, 46, 61, 59,
X
Xc (decim) 234 225 222 224 223 221 235 235
Xc (octal) 352 341 336 340 337 335 353 354
Xc : , _ th pi +- sa <- -> + * # oc tr
Xc (bl) 57 58 59 60 61 62 63 64 65 66 67 68 69 70
X& 58, 44, 95, 10, 34, 43, 6, 6, 6, 43, 42, 35, 1, 2,
X
Xc (decim)237 238 239
Xc (octal)355 356 357
Xc di sq ?? a b c d e f g h i j k
Xc (bl) 71 72 73 74 75 76 77 78 79 80 81 82 83 84
X& 5, 0, 15, 97, 98, 99,100,101,102,103,104,105,106,107,
X
Xc l m n o p q r s t u v w x y
Xc (bl) 85 86 87 88 89 90 91 92 93 94 95 96 97 98
X& 108,109,110,111,112,113,114,115,116,117,118,119,120,121,
X
Xc z [ ] \
Xc (bl) 99 100 101 102
X& 122, 91, 93, 92/
X
Xc ---- Set codes for '-', '"', '+', '_', '->'
X data ihyph/45/, idbq/34/, iplus/43/, iundr/95/, irarw/6/
X
Xc Define statement function for rotating a symbol. ----
X rotat(angin,amt) = amod((angin+amt),360.)
X
Xc ---- See if single character coming in. Probably most frequent. ----
X if (ich .lt. 0 .or. ich .gt. 239) then
X ic2 = ich
Xc ---- Shift coordinates to bottom left corner.
X rang = .0174533 * ang
X cosa = cos (rang)
X sina = sin (rang)
X xx = x - ht*cosa/3. + 0.5*ht*sina
X yy = y - ht*sina/3. - 0.5*ht*cosa
X call symbol (xx,yy,ht,ic2,ang,1)
X
Xc ---- Must be an integer code ----
X else
X
Xc ---- Get rid of the problem cases first. ----
X if ( (ich.gt. 60 .and. ich.lt. 65) .or.
X& (ich.gt.221 .and. ich.lt.226)) then
X
Xc ---- Special symbols that involve particular treatment:
Xc ---- pi: construct by hyphyn with " under it.
X if (ich.eq.61 .or. ich.eq.225) then
X call symbol (x,y,ht,ihyph,ang,-1)
X call symbol (x,y,ht,idbq,rotat(ang,180.),-1)
X
Xc ---- plus/minus: construct with overlaid '+' and '_'.
X else if (ich.eq.62 .or. ich.eq.222) then
X call symbol (x,y,ht,iplus,ang,-1)
X call symbol (x,y,ht,iundr,ang,-1)
X
Xc ---- arrow to corner: rotate right arrow +45 degrees:
X else if (ich.eq.63 .or. ich.eq.224) then
X call symbol (x,y,ht,irarw,rotat(ang,45.),-1)
X
Xc ---- left arror: rotate right arrow 180 degrees:
X else if (ich.eq.64 .or. ich.eq.223) then
X call symbol (x,y,ht,irarw,rotat(ang,180.),-1)
X
X end if
X
X
Xc ---- The rest can be done by table lookup:
X else
X if (ich.lt.61 .or.
X& (ich.gt.64 .and. ich.lt.103)) then
X ic2 =bls2hs (ich)
X
Xc ---- or by individual exceptions:
X else if (ich .eq. 221) then
X ic2 = 6
X else if (ich .eq. 234) then
X ic2 = 60
X else if (ich .eq. 235) then
X ic2 = 1
X else if (ich .eq. 236) then
X ic2 = 2
X else if (ich .eq. 237) then
X ic2 = 5
X else if (ich .eq. 238) then
X ic2 = 0
X else if (ich .eq. 239) then
X ic2 = 15
X end if
X
X call symbol (x,y,ht,ic2,ang,-1)
X
X end if
X
X end if
X return
X end
SHAR_EOF
if test 4134 -ne "`wc -c < 'spot.f'`"
then
echo shar: error transmitting "'spot.f'" '(should have been 4134 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'symbol.f'" '(10152 characters)'
if test -f 'symbol.f'
then
echo shar: will not over-write existing file "'symbol.f'"
else
sed 's/^X//' << \SHAR_EOF > 'symbol.f'
X subroutine symbol( xin, yin, ht, strin, ang, nchin)
X real xin, yin, ht, ang
X integer*4 strin(256), nchin
XC
XC Symbol subroutine conforming to
XC "Programming CalComp Electromechanical Plotters", 1976
XC For PostScript printers, using Adobe Courier font and font metrics
XC
XC Rex Sanders, USGS, 3/87
XC
X
X common /cqpbnf/ xold, yold, fac, ires
X save /cqpbnf/
X real xold, yold, fac
X integer ires
X
X real x, y, dum1, dum2
X real cosang, sinang
X integer nch, nfwd, i, ic, intang
X
XC cfudge - Courier font fudge factor to get proper height
X real cfudge
X save cfudge
X
XC xoff - X offset for centered chars
XC yoff - Y offset for centered chars
X real xoff(32:126), yoff(32:126)
X save xoff , yoff
X
XC ctable - centered char conversion table
X integer ctable(0:127)
X save ctable
X
X character*1024 cstr
X integer*4 istr(256)
X equivalence (cstr, istr)
X
X
XC htold - saved previous height
X real htold
X save htold
X data htold /0.0/
X
X data cfudge /1.66666666/
XC
XC Offsets for centered symbols - derived from Adobe Courier.AFM file
XC
X data xoff(32), yoff(32) /-0.0000, -0.0000/
X data xoff(33), yoff(33) /-0.3000, -0.3170/
X data xoff(34), yoff(34) /-0.3000, -0.4585/
X data xoff(35), yoff(35) /-0.3000, -0.2915/
X data xoff(36), yoff(36) /-0.3000, -0.2810/
X data xoff(37), yoff(37) /-0.3000, -0.3020/
X data xoff(38), yoff(38) /-0.2915, -0.2525/
X data xoff(39), yoff(39) /-0.2375, -0.4585/
X data xoff(40), yoff(40) /-0.3760, -0.2395/
X data xoff(41), yoff(41) /-0.2290, -0.2395/
X data xoff(42), yoff(42) /-0.3000, -0.4170/
X data xoff(43), yoff(43) /-0.3000, -0.2810/
X data xoff(44), yoff(44) /-0.2375, -0.0000/
X data xoff(45), yoff(45) /-0.3000, -0.2810/
X data xoff(46), yoff(46) /-0.3000, -0.0500/
X data xoff(47), yoff(47) /-0.3000, -0.2915/
X data xoff(48), yoff(48) /-0.3000, -0.3020/
X data xoff(49), yoff(49) /-0.3000, -0.3020/
X data xoff(50), yoff(50) /-0.2810, -0.3095/
X data xoff(51), yoff(51) /-0.2975, -0.3020/
X data xoff(52), yoff(52) /-0.2915, -0.3020/
X data xoff(53), yoff(53) /-0.2975, -0.2945/
X data xoff(54), yoff(54) /-0.3230, -0.3020/
X data xoff(55), yoff(55) /-0.2915, -0.3020/
X data xoff(56), yoff(56) /-0.3000, -0.3020/
X data xoff(57), yoff(57) /-0.3230, -0.3020/
X data xoff(58), yoff(58) /-0.3000, -0.2010/
X data xoff(59), yoff(59) /-0.2445, -0.1380/
X data xoff(60), yoff(60) /-0.3000, -0.2810/
X data xoff(61), yoff(61) /-0.3000, -0.2810/
X data xoff(62), yoff(62) /-0.3000, -0.2810/
X data xoff(63), yoff(63) /-0.3105, -0.2965/
X data xoff(64), yoff(64) /-0.2915, -0.2810/
X data xoff(65), yoff(65) /-0.3000, -0.2815/
X data xoff(66), yoff(66) /-0.2920, -0.2815/
X data xoff(67), yoff(67) /-0.2985, -0.2815/
X data xoff(68), yoff(68) /-0.2815, -0.2815/
X data xoff(69), yoff(69) /-0.2815, -0.2815/
X data xoff(70), yoff(70) /-0.2815, -0.2815/
X data xoff(71), yoff(71) /-0.3125, -0.2815/
X data xoff(72), yoff(72) /-0.3020, -0.2815/
X data xoff(73), yoff(73) /-0.3000, -0.2815/
X data xoff(74), yoff(74) /-0.3335, -0.2740/
X data xoff(75), yoff(75) /-0.3075, -0.2815/
X data xoff(76), yoff(76) /-0.3020, -0.2815/
X data xoff(77), yoff(77) /-0.3020, -0.2815/
X data xoff(78), yoff(78) /-0.2920, -0.2815/
X data xoff(79), yoff(79) /-0.3000, -0.2815/
X data xoff(80), yoff(80) /-0.2710, -0.2815/
X data xoff(81), yoff(81) /-0.3000, -0.2310/
X data xoff(82), yoff(82) /-0.3160, -0.2815/
X data xoff(83), yoff(83) /-0.3000, -0.2815/
X data xoff(84), yoff(84) /-0.3000, -0.2815/
X data xoff(85), yoff(85) /-0.3000, -0.2740/
X data xoff(86), yoff(86) /-0.3000, -0.2815/
X data xoff(87), yoff(87) /-0.3000, -0.2815/
X data xoff(88), yoff(88) /-0.3000, -0.2815/
X data xoff(89), yoff(89) /-0.3000, -0.2815/
X data xoff(90), yoff(90) /-0.3000, -0.2815/
X data xoff(91), yoff(91) /-0.3625, -0.2400/
X data xoff(92), yoff(92) /-0.3000, -0.2915/
X data xoff(93), yoff(93) /-0.2375, -0.2400/
X data xoff(94), yoff(94) /-0.3000, -0.4795/
X data xoff(95), yoff(95) /-0.3000, +0.2500/
X data xoff(96), yoff(96) /-0.3625, -0.4585/
X data xoff(97), yoff(97) /-0.3065, -0.2085/
X data xoff(98), yoff(98) /-0.2815, -0.2945/
X data xoff(99), yoff(99) /-0.3095, -0.2085/
X data xoff(100), yoff(100) /-0.3230, -0.2945/
X data xoff(101), yoff(101) /-0.2915, -0.2085/
X data xoff(102), yoff(102) /-0.3230, -0.3020/
X data xoff(103), yoff(103) /-0.3125, -0.1225/
X data xoff(104), yoff(104) /-0.2970, -0.3020/
X data xoff(105), yoff(105) /-0.3000, -0.3225/
X data xoff(106), yoff(106) /-0.3025, -0.2290/
X data xoff(107), yoff(107) /-0.3020, -0.3020/
X data xoff(108), yoff(108) /-0.3000, -0.3020/
X data xoff(109), yoff(109) /-0.3020, -0.2160/
X data xoff(110), yoff(110) /-0.2970, -0.2160/
X data xoff(111), yoff(111) /-0.3000, -0.2085/
X data xoff(112), yoff(112) /-0.2815, -0.1225/
X data xoff(113), yoff(113) /-0.3230, -0.1225/
X data xoff(114), yoff(114) /-0.3125, -0.2140/
X data xoff(115), yoff(115) /-0.3000, -0.2085/
X data xoff(116), yoff(116) /-0.2710, -0.2735/
X data xoff(117), yoff(117) /-0.2920, -0.2010/
X data xoff(118), yoff(118) /-0.3000, -0.2085/
X data xoff(119), yoff(119) /-0.3000, -0.2085/
X data xoff(120), yoff(120) /-0.3000, -0.2085/
X data xoff(121), yoff(121) /-0.3000, -0.1150/
X data xoff(122), yoff(122) /-0.3020, -0.2085/
X data xoff(123), yoff(123) /-0.3000, -0.2400/
X data xoff(124), yoff(124) /-0.3000, -0.2400/
X data xoff(125), yoff(125) /-0.3000, -0.2400/
X data xoff(126), yoff(126) /-0.3000, -0.2810/
XC
XC Character translation table for centered characters
XC
X data (ctable(i), i = 0, 3) / 35,111, 73, 43/
X data (ctable(i), i = 4, 7) / 88, 72, 94,126/
X data (ctable(i), i = 8, 11) / 90, 89, 36, 42/
X data (ctable(i), i = 12, 15) / 56,124, 37, 43/
X data (ctable(i), i = 16, 19) / 43, 43, 43, 43/
X data (ctable(i), i = 20, 23) / 43, 43, 43, 43/
X data (ctable(i), i = 24, 27) / 43, 43, 43, 43/
X data (ctable(i), i = 28, 31) / 43, 43, 43, 43/
X data (ctable(i), i = 32, 35) / 32, 33, 34, 35/
X data (ctable(i), i = 36, 39) / 36, 37, 38, 39/
X data (ctable(i), i = 40, 43) / 40, 41, 42, 43/
X data (ctable(i), i = 44, 47) / 44, 45, 46, 47/
X data (ctable(i), i = 48, 51) / 48, 49, 50, 51/
X data (ctable(i), i = 52, 55) / 52, 53, 54, 55/
X data (ctable(i), i = 56, 59) / 56, 57, 58, 59/
X data (ctable(i), i = 60, 63) / 60, 61, 62, 63/
X data (ctable(i), i = 64, 67) / 64, 65, 66, 67/
X data (ctable(i), i = 68, 71) / 68, 69, 70, 71/
X data (ctable(i), i = 72, 75) / 72, 73, 74, 75/
X data (ctable(i), i = 76, 79) / 76, 77, 78, 79/
X data (ctable(i), i = 80, 83) / 80, 81, 82, 83/
X data (ctable(i), i = 84, 87) / 84, 85, 86, 87/
X data (ctable(i), i = 88, 91) / 88, 89, 90, 91/
X data (ctable(i), i = 92, 95) / 92, 93, 94, 95/
X data (ctable(i), i = 96, 99) / 96, 97, 98, 99/
X data (ctable(i), i = 100,103) /100,101,102,103/
X data (ctable(i), i = 104,107) /104,105,106,107/
X data (ctable(i), i = 108,111) /108,109,110,111/
X data (ctable(i), i = 112,115) /112,113,114,115/
X data (ctable(i), i = 116,119) /116,117,118,119/
X data (ctable(i), i = 120,123) /120,121,122,123/
X data (ctable(i), i = 124,127) /124,125,126, 43/
XC
XC Bad input check
XC
X if (nchin .lt. -2 .or. ht .le. 0.0) return
X
XC
XC Initialise lots of stuff
XC
X x = xin
X y = yin
X nch = nchin
X if (x .eq. 999.) call where(x, dum1, dum2)
X if (y .eq. 999.) call where(dum1, y, dum2)
X
X if (nchin .ne. -2) then
X call plot (x, y, 3)
X else
X call plot (x, y, 2)
X endif
X
XC
XC Round angle to integer - good to 1 degree
XC
X intang = nint(ang)
X cosang = cos(float(intang) * 0.017453292519)
X sinang = sin(float(intang) * 0.017453292519)
X
XC
XC Set char height
XC
X if (ht .ne. htold) then
X call pliout (nint (ht * cfudge * fac * ires))
X call plsout (" H ")
X htold = ht
X endif
X
X
XC
XC Plot a string of characters
XC
X if (nch .gt. 0) then
XC
XC Set char angle
XC
X if (intang .ne. 0) then
X call pliout (intang)
X call plsout (" RS ")
X end if
X
XC
XC Transfer chars into holding area
XC
X nfwd = nch/4
X if (mod (nch, 4) .ne. 0) nfwd = nfwd + 1
X
X do 10 i = 1, nfwd
X istr(i) = strin(i)
X10 continue
X
XC
XC Output "(string) S ", escape ( ) \
XC
X call plcout(40)
X
X do 20 i = 1, nch
X ic = mod(ichar(cstr(i:i)), 127)
X if (ic .eq. 40) then
X call plsout ("\\050")
X else if (ic .eq. 41) then
X call plsout ("\\051")
X else if (ic .eq. 92) then
X call plsout ("\\134")
X else
X call plcout(ic)
X end if
X20 continue
X
X call plsout(") S ")
X
XC
XC Update our idea of where the pen is.
XC
X xold = x + (nch * ht * fac * cosang)
X yold = y + (nch * ht * fac * sinang)
XC
XC Undo character angle
XC
X if (intang .ne. 0) then
X call plsout ("RE\n")
X else
X call plcout (10)
X endif
X
XC
XC Plot one char in strin
XC
X else if (nch .eq. 0) then
XC
XC Set char angle
XC
X if (intang .ne. 0) then
X call pliout (intang)
X call plsout (" RS ")
X end if
X
XC
XC Output "(c) S ", escape "(" and ")" and "\"
XC
X call plcout (40)
X ic = mod(ichar(char(strin(1))), 127)
X if (ic .eq. 40) then
X call plsout ("\\050")
X else if (ic .eq. 41) then
X call plsout ("\\051")
X else if (ic .eq. 92) then
X call plsout ("\\134")
X else
X call plcout(ic)
X end if
X call plsout (") S ")
X
XC
XC Update our idea of where the pen is.
XC
X xold = x + (ht * fac * cosang)
X yold = y + (ht * fac * sinang)
XC
XC Undo character angle
XC
X if (intang .ne. 0) then
X call plsout ("RE\n")
X else
X call plcout (10)
X endif
X
XC
XC Plot special centered symbols
XC
X else if (nch .eq. -1 .or. nch .eq. -2) then
XC
XC Set char angle
XC
X call pliout (intang)
X call plsout (" RS ")
X
XC
XC Look up character
XC
X ic = ctable(mod(ichar(char(strin(1))), 127))
X
XC
XC Plot centered character -
XC output "xoff yoff RM (c) S ", escape ( ) \
XC
X call pliout (nint (xoff(ic) * ht * cfudge * fac * ires))
X call plcout (32)
X call pliout (nint (yoff(ic) * ht * cfudge * fac * ires))
X call plsout (" RM (")
X if (ic .eq. 40) then
X call plsout ("\\050")
X else if (ic .eq. 41) then
X call plsout ("\\051")
X else if (ic .eq. 92) then
X call plsout ("\\134")
X else
X call plcout(ic)
X end if
X call plsout (") S ")
XC
XC Update our idea of where the pen is
XC
X xold = x
X yold = y
XC
XC Undo character angle
XC
X call plsout ("RE\n")
X
X end if
X
X return
X end
SHAR_EOF
if test 10152 -ne "`wc -c < 'symbol.f'`"
then
echo shar: error transmitting "'symbol.f'" '(should have been 10152 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'where.f'" '(387 characters)'
if test -f 'where.f'
then
echo shar: will not over-write existing file "'where.f'"
else
sed 's/^X//' << \SHAR_EOF > 'where.f'
X subroutine where (x, y, f)
Xc
Xc returns current:
Xc x - pen x position in inches from last origin
Xc y - pen y position in inches from last origin
Xc f - plot sizing factor (see subroutine factor)
Xc
X
X common /cqpbnf/ xold, yold, fac, ires
X save /cqpbnf/
X real xold, yold, fac
X integer ires
X
X x = xold/fac
X y = yold/fac
X f = fac
X
X return
X end
SHAR_EOF
if test 387 -ne "`wc -c < 'where.f'`"
then
echo shar: error transmitting "'where.f'" '(should have been 387 characters)'
fi
fi # end of overwriting check
if test ! -d 'tests'
then
echo shar: creating directory "'tests'"
mkdir 'tests'
fi
echo shar: entering directory "'tests'"
cd 'tests'
echo shar: extracting "'ct6.f'" '(853 characters)'
if test -f 'ct6.f'
then
echo shar: will not over-write existing file "'ct6.f'"
else
sed 's/^X//' << \SHAR_EOF > 'ct6.f'
X program ct6
XC
XC Test numbers, symbol, and spot
XC
XC Rex Sanders, USGS Pacific Marine Geology, 3/87
XC
X character*1 testc
X
X call plots(1,1,1)
X
X call symbol (1.0, 7.0, 0.20,
X& "Test of spot values 0..127", 0., 26)
X
X x = 1.0
X y = 6.0
X nc = 0
X do 20 i = 1, 4
X do 10 j = 1, 32
X call number (x-.07, y+.30, 0.07, real(nc), 0., -1)
X nc = nc + 1
X x = x + .25
X10 continue
X
X x = 1.0
X y = y - 1.0
X20 continue
X
X x = 1.0
X y = 6.0
X nc = 0
X do 40 i = 1, 4
X do 30 j = 1, 32
X testc = char(nc)
X call spot (x, y , 0.20, testc , 0.)
X nc = nc + 1
X x = x + .25
X30 continue
X
X x = 1.0
X y = y - 1.0
X40 continue
X
X x = 1.0
X y = 6.0
X nc = 0
X do 60 i = 1, 4
X do 50 j = 1, 32
X call symbol (x, y , 0.05, 3 , 0., -1)
X nc = nc + 1
X x = x + .25
X50 continue
X
X x = 1.0
X y = y - 1.0
X60 continue
X
X call plot(0.,0., 999)
X end
SHAR_EOF
if test 853 -ne "`wc -c < 'ct6.f'`"
then
echo shar: error transmitting "'ct6.f'" '(should have been 853 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'ct1.f'" '(1704 characters)'
if test -f 'ct1.f'
then
echo shar: will not over-write existing file "'ct1.f'"
else
sed 's/^X//' << \SHAR_EOF > 'ct1.f'
X program ct1
Xc
Xc ct1 - Calcomp Test #1
Xc Tests plots, plot, where, factor, newpen within 9x7 inch area
Xc Rex Sanders, USGS Pacific Marine Geology, 5-12-85
Xc
X
X print *, 'calling plots to start plot'
X call plots(0, 0, 8)
X
X print *, 'drawing 9x7 rectangle'
X call plot(0., 0., 3)
X call plot(0., 7., 2)
X call plot(9., 7., 2)
X call plot(9., 0., 2)
X call plot(0., 0., 2)
X
X print *, 'testing where at box corner'
X x = 9.
X y = 7.
X f = 1.
X print *, 'x, y, f should be:', x, y, f
X call plot(x, y, 3)
X call where(x, y, f)
X print *, 'x, y, f are: ', x, y, f
X call plot(0., 0., 3)
X
X print *, 'new origin at box corner'
X call plot(9., 7.,-3)
X call where(x, y, f)
X print *, 'x, y, f are: ', x, y, f
X
X print *, 'draw back & new origin'
X call plot(-9., -7., -2)
X
X print *, 'new origin at (4.5, 3.5) [center of rectangle]'
X call plot(4.5, 3.5, -3)
X
X print *, 'draw diamond around origin'
X call dimond
X
X print *, 'testing factor: draw 3x diamond'
X x = 0.
X y = 0.
X f = 3.
X call factor(f)
X call dimond
X print *, 'x, y, f should be:', x, y, f
X call where(x, y, f)
X print *, 'x, y, f are: ', x, y, f
X
X print *, 'draw 2/3 diamond'
X x = 0.
X y = 0.
X f = 2./3.
X call factor(f)
X call dimond
X print *, 'x, y, f should be:', x, y, f
X call where(x, y, f)
X print *, 'x, y, f are: ', x, y, f
X call factor(1.)
X call plot(0., 0., 3)
X
X print *, 'check for 10 pens - line with 1/2 inch sections'
X call plot(-2.5, 0., 3)
X do 10 i = 1, 10
X call newpen(i)
X call plot((i/2.)-2.5, 0., 2)
X10 continue
X
X call plot(0., 0., 999)
X print *, 'all done'
X end
X
X subroutine dimond
X call plot(-1., 0., 3)
X call plot(0., 1., 2)
X call plot(1., 0., 2)
X call plot(0., -1., 2)
X call plot(-1., 0., 2)
X call plot(0., 0., 3)
X return
X end
SHAR_EOF
if test 1704 -ne "`wc -c < 'ct1.f'`"
then
echo shar: error transmitting "'ct1.f'" '(should have been 1704 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'ct2.f'" '(2833 characters)'
if test -f 'ct2.f'
then
echo shar: will not over-write existing file "'ct2.f'"
else
sed 's/^X//' << \SHAR_EOF > 'ct2.f'
X program ct2
Xc
Xc ct2 - Calcomp Test #2
Xc Tests symbol within 8x6 inch area
Xc Rex Sanders, USGS Pacific Marine Geology, 5-13-85
X
X real x, y, f
X integer i
X integer test(4)
X integer itext(24)
X character*48 ctext1, ctext2
X
X data test / 'T', 'E', 'S', 'T' /
X data itext /
X & ' !"#', '$%&''', '()*+', ',-./', '0123', '4567',
X & '89:;', '<=>?', '@ABC', 'DEFG', 'HIJK', 'LMNO',
X & 'PQRS', 'TUVW', 'XYZ[', '\\]^_', '`abc', 'defg',
X & 'hijk', 'lmno', 'pqrs', 'tuvw', 'xyz{', '|}~ ' /
X
X ctext1 = ' !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNO'
X ctext2 = 'PQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~ '
X
X call plots(0., 0., 8)
X
X x = 0.
X y = 1.5
Xc print *, 'Draw 1st 48 ASCII chars from character text at ', x, y
X call symbol(x, y, 0.14, ctext1, 0.0, 48)
X x = x + 48*0.14
Xc print *, 'End should be ', x, y
X call where(x, y, f)
Xc print *, 'End is ', x, y
X
X x = 0.0
X y = 1.0
Xc print *, 'Draw 2nd 48 ASCII chars from character text at ', x, y
X call symbol(x, y, 0.14, ctext2, 0.0, 48)
X
X x = 0.0
X y = 0.5
Xc print *, 'Draw 96 ASCII chars from integer text at ', x, y
X call symbol(x, y, 0.07, itext, 0.0, 96)
X
X x = 1.0
X y = 3.0
Xc print *, 'Draw ANGLE rose from literal text around ', x, y
X do 10, i = 0, 315, 45
X call symbol(x, y, 0.14, ' ANGLE', real(i), 6)
X10 continue
X
X x = 3.0
X y = 3.0
Xc print *, 'Draw ANGLE rose from literal text around ', x, y
X do 11, i = 7, 322, 45
X call symbol(x, y, 0.14, ' ANGLE', real(i), 6)
X11 continue
X
X x = 0.5
X y = 4.5
Xc print *, 'Draw centered symbols 0-14 at ', x, y
X do 20, i = 0, 14
X x = real(i+1)/2.0
X call symbol(x, y, 0.14, i, 0.0, -1)
X call symbol(x+0.25, y, 0.14, i, 45.0, -1)
X20 continue
X
X x = 0.5
X y = 5.0
Xc print *, 'Draw connected centered symbols 0-14 at ', x, y
X call symbol(x, y, 0.14, 0, 0.0, -1)
X do 30, i = 1, 14
X x = real(i+1)/2.0
X call symbol(x, y, 0.14, i, 0.0, -2)
X30 continue
Xc print *, 'x, y should be', x, y
X call where(x, y, f)
Xc print *, 'x, y are ', x, y
X
X x = 0.0
X y = 4.0
Xc print *, 'Draw abutted single integer chars at ', x, y
X call symbol(x, y, 0.14, test(1), 0.0, 0)
X call symbol(999.0, y, 0.14, test(2), 0.0, 0)
X call where(x, y, f)
X if (x .gt. 0.30) then
Xc print *, '*** Error - call symbol(999.0, ...) failed'
Xc print *, ' test stopped, DO NOT PLOT'
X stop 1
X end if
X
X x = 0.0
X y = 4.0
X call symbol(999.0, y, 0.14, test(3), 0.0, 0)
X call symbol(999.0, y, 0.14, test(4), 0.0, 0)
X
X x = 1.0
X y = 4.0
X test(1) = 'T'
X test(2) = 'E'
X test(3) = 'S'
X test(4) = 'T'
X call symbol(x, y, 0.14, test(1), 0.0, 0)
X call symbol(999.0, y, 0.14, test(2), 0.0, 0)
X call symbol(999.0, y, 0.14, test(3), 0.0, 0)
X call symbol(999.0, y, 0.14, test(4), 0.0, 0)
Xc
Xc Deliberately not testing other combos of 999 and angles,
Xc because they are rarely used and even more rarely work
Xc
X
X call plot(0., 0., 999)
X end
SHAR_EOF
if test 2833 -ne "`wc -c < 'ct2.f'`"
then
echo shar: error transmitting "'ct2.f'" '(should have been 2833 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'ct3.f'" '(580 characters)'
if test -f 'ct3.f'
then
echo shar: will not over-write existing file "'ct3.f'"
else
sed 's/^X//' << \SHAR_EOF > 'ct3.f'
X program ct3
Xc
Xc ct3 - Calcomp Test #3
Xc Tests number subroutine
Xc Rex Sanders, USGS Pacific Marine Geology, 3/87
Xc
X real n1, n2, n3, n4, x, y
X integer i
X
X call plots(0, 0, 8)
X n1 = 123456789.0
X n2 = 0.00000000123456789
X n3 = 1.234567890
X n4 = 1.000002
X
X x = 0.0
X do 10, i = -9, 9
X ri = real(i)
X y = (ri + 9.0)/4.0
X call number(x , y, 0.07, ri, 0.0, -1)
X call number(x+1.0, y, 0.07, n1, 0.0, i)
X call number(x+3.0, y, 0.07, n2, 0.0, i)
X call number(x+5.0, y, 0.07, n3, 0.0, i)
X call number(x+7.0, y, 0.07, n4, 0.0, i)
X10 continue
X
X call plot(0., 0., 999)
X end
SHAR_EOF
if test 580 -ne "`wc -c < 'ct3.f'`"
then
echo shar: error transmitting "'ct3.f'" '(should have been 580 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'st2.f'" '(445 characters)'
if test -f 'st2.f'
then
echo shar: will not over-write existing file "'st2.f'"
else
sed 's/^X//' << \SHAR_EOF > 'st2.f'
X integer size, ssize
X real pi
X parameter (size=40, ssize=size*size, pi=3.14159)
X real elv(size,size)
X integer iwk(ssize)
X
X do 20, i = 1, size
X do 10, j = 1, size
X elv(i, j) = sin(2.0*pi*real(i)/real(size))
X10 continue
X20 continue
X
X call bgnplt
X call setxyg(size, 0., 1.0, size, 0., 1.)
X call setpag(7.5, 7.5, 0., 0.)
X call setwin(7.5, 7.5, 0., 0.)
X call setvue(10., 20., 325.)
X call mshvue(elv, size, size, iwk, ssize)
X call endplt
X end
SHAR_EOF
if test 445 -ne "`wc -c < 'st2.f'`"
then
echo shar: error transmitting "'st2.f'" '(should have been 445 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'ct4.f'" '(840 characters)'
if test -f 'ct4.f'
then
echo shar: will not over-write existing file "'ct4.f'"
else
sed 's/^X//' << \SHAR_EOF > 'ct4.f'
X program ct4
XC
XC Test numbers and centered symbols
XC
XC Rex Sanders, USGS Pacific Marine Geology, 3/87
XC
X call plots(1,1,1)
X
X call symbol (1.0, 7.0, 0.20,
X& "Test of centered symbols 0..127", 0., 31)
X
X x = 1.0
X y = 6.0
X nc = 0
X do 20 i = 1, 4
X do 10 j = 1, 32
X call number (x-.07, y+.30, 0.07, real(nc), 0., -1)
X nc = nc + 1
X x = x + .25
X10 continue
X
X x = 1.0
X y = y - 1.0
X20 continue
X
X x = 1.0
X y = 6.0
X nc = 0
X do 40 i = 1, 4
X do 30 j = 1, 32
X call symbol (x, y , 0.20, nc , 0., -1)
X nc = nc + 1
X x = x + .25
X30 continue
X
X x = 1.0
X y = y - 1.0
X40 continue
X
X x = 1.0
X y = 6.0
X nc = 0
X do 60 i = 1, 4
X do 50 j = 1, 32
X call symbol (x, y , 0.05, 3 , 0., -1)
X nc = nc + 1
X x = x + .25
X50 continue
X
X x = 1.0
X y = y - 1.0
X60 continue
X
X call plot(0.,0., 999)
X end
SHAR_EOF
if test 840 -ne "`wc -c < 'ct4.f'`"
then
echo shar: error transmitting "'ct4.f'" '(should have been 840 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'Makefile'" '(340 characters)'
if test -f 'Makefile'
then
echo shar: will not over-write existing file "'Makefile'"
else
sed 's/^X//' << \SHAR_EOF > 'Makefile'
XFFLAGS=-g -w
XLIB=ccps.a
XCTPROGS=ct0 ct1 ct2 ct3 ct4 ct5 ct6
XSTPROGS=st1 st2
X
Xall: $(CTPROGS) $(STPROGS)
X
X$(CTPROGS): $(LIB)
X f77 ${FFLAGS} -o $@ $@.f ${LIB}
X $@
X mv ps_plot $@.ps
X
X$(STPROGS): ${LIB}
X f77 ${FFLAGS} -o $@ $@.f -lsdl ${LIB}
X $@
X mv ps_plot $@.ps
X
Xplot:
X ppr *.ps
X
Xclean:
X rm -f *.o *.ps ps_plot make.out $(CTPROGS) $(STPROGS)
SHAR_EOF
if test 340 -ne "`wc -c < 'Makefile'`"
then
echo shar: error transmitting "'Makefile'" '(should have been 340 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'ct5.f'" '(201 characters)'
if test -f 'ct5.f'
then
echo shar: will not over-write existing file "'ct5.f'"
else
sed 's/^X//' << \SHAR_EOF > 'ct5.f'
X program ct5
XC
XC Tests circle
XC
XC Rex Sanders, USGS Pacific Marine Geology, 3/87
XC
X call plots(0,0,8)
X do 10 i = 1, 10
X call circle(5.0, 4.0, real(i)/2.0)
X10 continue
X call plot(0.,0., 999)
X end
SHAR_EOF
if test 201 -ne "`wc -c < 'ct5.f'`"
then
echo shar: error transmitting "'ct5.f'" '(should have been 201 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'ct0.f'" '(598 characters)'
if test -f 'ct0.f'
then
echo shar: will not over-write existing file "'ct0.f'"
else
sed 's/^X//' << \SHAR_EOF > 'ct0.f'
X program ct0
Xc
Xc ct0 - Calcomp Test #0
Xc Tests plots, plot within 9x7 inch area
Xc Rex Sanders, USGS Pacific Marine Geology, 2/87
Xc
X real x, y
X
X print *, 'calling plots to start plot'
X call plots(0, 0, 8)
X
X print *, 'drawing 9x7 rectangle'
X call plot(0., 0., 3)
X call plot(0., 7., 2)
X call plot(9., 7., 2)
X call plot(9., 0., 2)
X call plot(0., 0., 2)
X
X print *, 'drawing grid'
X do 10 y = 0.0, 7.0
X call plot(0.0, y, 3)
X call plot(9.0, y, 2)
X10 continue
X
X do 20 x = 0.0, 9.0
X call plot(x, 0.0, 3)
X call plot(x, 7.0, 2)
X20 continue
X
X call plot(0., 0., 999)
X print *, 'all done'
X end
SHAR_EOF
if test 598 -ne "`wc -c < 'ct0.f'`"
then
echo shar: error transmitting "'ct0.f'" '(should have been 598 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'st1.f'" '(495 characters)'
if test -f 'st1.f'
then
echo shar: will not over-write existing file "'st1.f'"
else
sed 's/^X//' << \SHAR_EOF > 'st1.f'
X integer size, ssize
X real pi
X parameter (size=40, ssize=size*size, pi=3.14159)
X real elv(size,size)
X integer iwk(ssize)
X
X do 20, i = 1, size
X do 10, j = 1, size
X elv(i, j) = sin(2.0*pi*real(i)/real(size))/4.0 +
X& cos(2.0*pi*real(j)/real(size))/4.0
X10 continue
X20 continue
X
X call bgnplt
X call setxyg(size, 0., 1.0, size, 0., 1.)
X call setpag(7.5, 7.5, 0., 0.)
X call setwin(7.5, 7.5, 0., 0.)
X call setcon(-1., .05, 5, 5, 2, 2)
X call conmap(elv, size, size, iwk, ssize)
X call endplt
X end
SHAR_EOF
if test 495 -ne "`wc -c < 'st1.f'`"
then
echo shar: error transmitting "'st1.f'" '(should have been 495 characters)'
fi
fi # end of overwriting check
echo shar: done with directory "'tests'"
cd ..
# End of shell archive
exit 0