/*Translated by FOR_C, v3.4.2 (-), on 07/09/115 at 08:31:16 */
/*FOR_C Options SET: ftn=u io=c no=p op=aimnv s=dbov str=l x=f - prototypes */
#include <math.h>
#include "fcrt.h"
#include "dplot.h"
#include <string.h>
#include <stddef.h>
#include <float.h>
#include <stdio.h>
#include <stdlib.h>
/*++ CODE for .C. is active */
static FILE *inunit, *iotemp, *iotmp1, *iotmp2, *iofil;
#include <string.h>
/* PARAMETER translations */
#define BSLASH '\\'
#define INTERP 2
#define LARROW 1
#define LASTFP (LXYSIZ + 2)
#define LASTIP LDEBUG
#define LBAD 7
#define LBNDC 128
#define LBNDF 32
#define LBNDP 4
#define LBNDT 64
#define LCOOX 3
#define LCOOY 4
#define LDEBUG 18
#define LFDAT LBAD
#define LNY 16
#define LPEN 13
#define LTANNO 10
#define LTYPE 8
#define LVALS 9
#define LWIDRE 6
#define LWIDTH 2
#define LXYSIZ (LVALS + 5)
#define LYDIM 15
#define MAXNY 50
#define MAXPT 101
#define MAXSET 20
#define NEXT 1
/* end of PARAMETER translations */
/* COMMON translations */
struct t_dplotd {
double arrlen, pxo, pxsize, pyo, pysize;
long int iplot, kurpen, laspen;
} dplotd;
struct t_dplotb {
double borloc[6], fill[19], fp[LASTFP], ovlap, phyuse[2][2], setlim[2][2],
ticks[6][4], tlenh, tlenv, topts, vhlen[2], xybase[MAXSET], xylim[MAXSET][2],
xyu2pf[MAXSET];
long int ierr1, ierr2, ierr3, ierr4, iop1, ip[LASTIP], jset[2],
lencap[6], lentxt[18][3], manno, mbord[6][8], ntext, nxylim[MAXSET];
LOGICAL32 klip[MAXSET];
long int mfill[4];
LOGICAL32 noout, opaque;
} dplotb;
struct t_dplotc {
char fmtnum[17][33], captio[6][129], pos[69], text[281], txtdef[18][65];
} dplotc;
/* end of COMMON translations */
void /*FUNCTION*/ dplot(
double xsize,
double ysize,
double x[],
long nx,
double y[],
double opt[],
STRING copt)
{
char _c0[2];
LOGICAL32 badpt, datsav, lklip, moreiy, notout;
byte c;
long int i, i1, iact, iaopt, iax, ierr, inin[MAXNY], iop, iopt,
iy, j, k, k1, k2, kpt, ksymb, kx, ky, l, l1, l3, lfill[4][3],
locf, loci, lpar, ltext, ly, m, mode, ndimy, nmode, ntyp, nxi,
ny;
static long int iosta, lcurve, lset;
double fpin[MAXNY], tp, tp1, tp2, xout[MAXPT], xypos[2], yout[MAXPT];
static double xymax[2], xymin[2];
static long irule[28]={1,2,4,5,8,10,12,16,17,18,18,19,20,21,23,
25,27,28,28,29,30,31,32,33,34,35,35,36};
static long lrule[35]={2,7,7,7,7,15,12,7,-2,7,-2,6,4,9,-2,-2,-2,
-2,-1,-5,-2,6,-3,6,-1,5,-2,-4,-4,-5,-4,-4,-5,5,7};
static long nrule[18]={10,10,10,10,10,10,0,10,100,100,0,100,10,
0,10,10,100,0};
static long linact[34]={1,10,15,19,20,21,22,23,24,25,26,27,31,
40,50,60,70,74,75,80,85,90,95,100,105,106,107,111,111,112,113,
113,114,115};
static long inact[114]={1,14,7,3,NEXT,14,1,1,LTYPE,6,14,2,3,LYDIM,
14,1,2,LPEN,2,3,4,7,5,5,9,10,15,1,2,LARROW,8,15,4,1,LWIDTH,15,
1,2,LWIDRE,15,2,2,LVALS,14,2,2,LTANNO,16,16,15,3,2,LVALS,14,2,
2,LTANNO,16,9,15,1,2,LVALS,14,3,2,LTANNO,16,16,15,2,1,LBAD,17,
15,4,2,LVALS,18,15,4,2,LVALS,18,15,5,2,LVALS,18,15,4,2,LVALS,
18,15,4,2,LVALS,18,15,5,2,LVALS,18,11,17,14,1,1,LDEBUG,17,20,
21,22};
static long last = 0;
static char optlet[39] = "QMIFACBLTRXYWN 123456({[qmifacbltrxywn";
static char bndtst[5] = "[({#";
static char txttst[4][5]={"\\]]]","\\)))","\\{#}","\\{{}"};
static char vlet[7] = "tcbTCB";
static char hlet[7] = "lcrLCR";
static double fpdat[LFDAT]={4.e0,100.e0,.7e0,.5e0,60.e0,30.e0,
-1.e0};
static long lbound[3]={LBNDP,LBNDF,LBNDT};
static double tptset[3]={72.27e0,2.845e0,1.e0};
/* OFFSET Vectors w/subscript range: 1 to dimension */
double *const Fill = &dplotb.fill[0] - 1;
double *const Fp = &dplotb.fp[0] - 1;
double *const Fpdat = &fpdat[0] - 1;
double *const Fpin = &fpin[0] - 1;
long *const Inact = &inact[0] - 1;
long *const Inin = &inin[0] - 1;
long *const Ip = &dplotb.ip[0] - 1;
long *const Irule = &irule[0] - 1;
long *const Jset = &dplotb.jset[0] - 1;
LOGICAL32 *const Klip = &dplotb.klip[0] - 1;
long *const Lbound = &lbound[0] - 1;
long *const Lencap = &dplotb.lencap[0] - 1;
long *const Linact = &linact[0] - 1;
long *const Lrule = &lrule[0] - 1;
long *const Mfill = &dplotb.mfill[0] - 1;
long *const Nrule = &nrule[0] - 1;
long *const Nxylim = &dplotb.nxylim[0] - 1;
double *const Opt = &opt[0] - 1;
double *const Tptset = &tptset[0] - 1;
double *const X = &x[0] - 1;
double *const Xout = &xout[0] - 1;
double *const Xybase = &dplotb.xybase[0] - 1;
double *const Xymax = &xymax[0] - 1;
double *const Xymin = &xymin[0] - 1;
double *const Xypos = &xypos[0] - 1;
double *const Xyu2pf = &dplotb.xyu2pf[0] - 1;
double *const Y = &y[0] - 1;
double *const Yout = &yout[0] - 1;
/* end of OFFSET VECTORS */
/*++ END
* Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
* ALL RIGHTS RESERVED.
* Based on Government Sponsored Research NAS7-03001.
*>> 2009-10-30 DPLOT Krogh -- Initialized ARRLEN & CAPLOC(5:6)
*>> 2009-10-27 DPLOT Krogh -- BSLAS1 => BSLAS1(1:1) for NAG compiler.
*>> 2009-10-18 DPLOT Krogh -- Added "save adjin" in dplota
*>> 2009-06-02 DPLOT Krogh -- Read from file sets number of points.
*>> 2005-12-06 DPLOT Krogh -- Some fixes for conversion to C.
*>> 2005-05-09 DPLOT Krogh -- More debug, fixed parens & bad test
*>> 2001-05-24 DPLOT Krogh -- Added commas to some formats.
*>> 2000-01-02 DPLOT Minor correction to error message text.
*>> 2000-12-30 DPLOT Added an (int) cast in some comments for C.
*>> 2000-10-23 DPLOT Changed ")/)" to "/)" in a format.
*>> 2000-01-05 DPLOT Fixed DPLOTT so IAX is defined before ref.
*>> 1999-12-27 DPLOT "Saved" ADJOUT in DPLOTA
*>> 1999-11-23 DPLOT Fixed so don't get empty mfpic groups at the end.
*>> 1998-10-23 DPLOT Fixed so error index 7 prints.
*>> 1998-02-02 DPLOT Work around for bug in HP Exemplar Compiler.
*>> 1998-01-29 DPLOT Fixed bug when no output file given.
*>> 1998-01-21 DPLOT Work around for \ treated as escape in SGI F77.
*>> 1998-01-14 DPLOT Krogh Initial code.
*--D replaces "?": ?PLOT, ?PLOT0, ?PLOT1, ?PLOT2, ?PLOT4, ?PLOT5,
*-- & ?PLOT6, ?PLOT7, ?PLOT8, ?PLOT9, ?PLOTA, ?PLOTB, ?PLOTC, ?PLOTD,
*-- & ?PLOTE, ?PLOTF, ?PLOTL, ?PLOTN, ?PLOTR, ?PLOTS, ?PLOTT, ?PLOTU,
*-- & ?MESS
*++S Default CTYPE = " (float)"
*++ Default CTYPE = "(double)"
*++ Replace "(double)" = CTYPE
*
* (DPLOTU picked up and modified from earlier code by Van Snyder).
*
* Produce line plots. Present version produces output for MFpic.
*
* *************************** Formal Arguments *************************
*
* XSIZE [in] Physical horizontal size of the plot. Default units are
* inches.
* YSIZE [in] Physical vertical size of the plot. Default units are
* inches.
* X [in] Array of NX abscissae.
* NX [in] Number of abscissae in X and ordinates in Y.
* Y [in] Array of NX ordinates.
* OPT [inout] OPT(1) is status output:
* 0.0 means no problems.
* 0.0 < OPT(1) <= 10000.0 means an option index or parameter at
* OPT(nint(OPT(1))) was out of range, had an improper parameter, or
* was not permitted at the point it was recognized.
* OPT(1) = 10001.0 means the output unit could not be opened.
* OPT(1) $<$ 0.0 means an option code at COPT(-nint(OPT(1))) was not
* recognized, or had an improper parameter.
* Beginning in OPT(2) the user provides option specifications
* as described in the main documentation. (ch16-03.tex)
* COPT[in] Character options, and character data used by numeric
* options.
*
* **************** Suggested Parameter Names for Options ***************
*
* PLOUNI=1.D0 Units, continue?, logs?, type, etc.
* PLONY=2.D0 For more than one curve at a time.
* PLOLIN=3.D0 Type of lines
* PLOBOR=4.D0 Border characteristics.
* PLOTIC=5.D0 Tick marks specs.
* PLOWHT=6.D0 Where the major ticks go.
* PLOMUL=7.D0 Multiple data sets.
* PLOXMX=8.D0 Specify X min and max.
* PLOYMX=9.D0 Specify Y min and max.
* PLOSYM=10.D0 Specify symbols, error bars, etc. for data points.
* PLOSY1=11.D0 Specify a single symbol to output.
* PLOARR=12.D0 Length of arrow head (<0 is leave on till turned off).
* PLOWID=13.D0 Various line widths
* PLOTXT=14.D0 A text annotation.
* PLONUM=15.D0 A number to output.
* PLOANL=16.D0 An annotation and/or line to output on border or axis
* PLOBAD=17.D0 For specifying data points to ignore, etc.
* PLOINP=18.D0 Specifies Fortran input unit.
* PLOLIN=19.D0 Draw a line.
* PLOREC=20.D0 Draw a rectangle.
* PLOELL=21.D0 Draw an ellipse.
* PLOPLI=22.D0 Draw a line in physical coordinates.
* PLOPRE=23.D0 Draw a rectangle in physical coordinates.
* PLOPEL=24.D0 Draw an ellipse in physical coordinates.
* PLOFIL=25.D0 Specifies filling for various cases.
* PLORAW=26.D0 Send text directly to the plot file.
* PLODEB=27.D0 Fortran debugging output.
*
* **************************** Procedure Names *************************
*
* ******* In this file, DPLOT
* DPLOT User entry, defines all actions, processes options, initiator
* for all actions.
* DPLOTA Determines scalings, draws axes and tick marks, and outputs
* axis labels.
* DPLOTF Selects points for plotting from those provided by the user
* for continuous curves to possibly reduce the number of points
* required in the final output. Also checks and takes care of
* clipping.
* DPLOTN Takes care of output of numeric labels.
* DPLOTT Output of text and checking the size required by text.
* DPLOTR Converts XY data for calls to DPLOTS (special symbols) */
/* DPLOTU Opens output and scratch files.
*
* ******* In file DPLOT0 (Almost all of the device dependent code.)
* DPLOT0 Setup for starting a plot.
* DPLOT1 Specify the pen characteristics.
* DPLOT2 Draw a single straight line in physical coordinates.
* DPLOT4 Output an annotation at a given place in physical coordinates.
* DPLOT5 Draw a rectangle (possibly filled), with pen width given.
* DPLOT6 Draw a ellipse (possibly filled), with pen width given.
* DPLOT7 Take care of requests to fill future regions.
* DPLOT8 Output of tick marks.
* DPLOT9 Finish the plot.
* DPLOTL Plot a line through a sequence of points. Also for starting
* and finishing other types of curves.
* DPLOTS Plotting of special symbols, error bars, and vector fields.
*
* *************************** Internal Variables ***********************
*
* (Here and elsewhere in this package, a "*" following a name is used to
* indicate the names is in a common block. Full coverage for variables
* in the common block only appear here.)
*
* ARRLEN* If nonzero, next line or curve is to have an arrow on the end.
* This give the length of the arrow in points.
* BADPT Logical variable set = .true. if got a point that requires the
* curve to be restarted as a result of the bad point.
* BORLOC* Location of border (physical).
* C Temporary single character.
* CAPTIO Character array holding captions for borders/axes.
* DATSAV Set = .true. when NY > 1 and need to save data on second
* scratch file.
* DEGRAD Parameter = pi / 180, converts degrees to radians.
* FILL* Array giving dot size/space, and hatch info. First 6 locs.
* are for 3 pairs of info for dots, next 9 for 3 sets of thatch info.
* FMTNUM Text defining the formatting of numbers (and text). Indexed
* as for LENTXT below.
* FPIN Array where floating point data is unpacked. Also used for
* temporary storage.
* FPDAT Initial values stored in FP.
* I Temporary index.
* I1 Temporary index.
* IACT Index for current action begin processed from LINACT.
* IAOPT absolute value of IOPT. Extra values of:
* 30 Flags that data for the current set follows.
* 31 Data for one abscissa follows.
* 32 Flags a bad data point, next location gives the index for Y.
* 33 Flags the end of a data set. */
/* IAX Used when an axis direction is implied. 1 for x-axis
* (horizontal), 2 for y-axis (vertical).
* IERR Used for an error index.
* IERR1 Value to be printed with error message.
* IERR2 Value of IOP for printing of error messages.
* IERR3 Index of last char. in COPT that is O.K. for error message.
* IERR4 Index of last char. in COPT to print with error message.
* INACT used to define actions to take for a given option. The same
* actions are used when reading options as when reading the scratch
* file but the actions taken may be different. Each action may be
* followed by 0 or more items required by the option.
* = 1 Take care of units/final flag & lines at x,y = 0.
* = 2 Save border characteristics. (Includes val. from A3)
* = 3 Length of tick marks for various borders.
* = 4 Set default ticks for various borders.
* = 5 Set ?MAX / ?MIN for current set.
* = 6 Check NY.
* = 7 Take care of change in data set.
* = 8 Set defaults for values .le. 0 on widths.
* = 9 Special symbol plotting (may be more than 1 N13)
* =10 Single symbol (may require extra args.)
* =11 For filling (may have up to 3 for each curve type) (scratch)
* =14 There follows in INACT, n, w, p, where
* n = number of integers
* w = defines where they go when processing options: 1 storage,
* 2 scratch, 3 both (NOT USED???)
* p = gives index in IP() where integers start.
* =15 As for 14, except for floating point data in FP().
* =16 Processing for text pointer. In all cases here, the text is
* acted upon immediately when read from the scratch file.
* There follows in INACT, t
* t = 9 For option 15, Sets format for next numeric output.
* t = 16 Text output for options 14 and 16.
* On the scratch file this writes, the length of the character
* string, and the character string. If this length is 0, it
* simply means that there is no text, and in the case of t=2
* and t=3, default actions are to be taken.
* =17 Indicates an invalid option index in pass 1. In pass 2, this
* is used for the raw mfpic output.
* =18 Take action as implied by the option index when read from the
* scratch file. Possibilities are, a line, a rectangle, an
* ellipse, or any of the above in physical coordinates.
* Options >17 only occur when reading the scratch file.
* =20 Setup to read data. Following locations give, LKURVE, JSET(1:2)
* =21 Shouldn't see where using INACT in pass 2, gives an error.
* =22 End of a data set.
* Option INACT for the option
* 1 1, 14,7,3,NEXT, 14,1,1,LTYPE
* 2 6, 14,2,3,LYDIM
* 3 14,1,2,LPEN
* 4 2
* 5 3 */
/* 6 4
* 7 7
* 8 5
* 9 5
* 10 9
* 11 10
* 12 15,1,2,LARROW
* 13 8,15,4,1,LWIDTH, 15,1,2,LWIDRE
* 14 15,2,2,LVALS, 14,2,2,LTANNO, 16,16
* 15 15,3,2,LVALS, 14,2,2,LTANNO, 16,9
* 16 15,1,2,LVALS, 14,3,2,LTANNO, 16,16
* 17 15,2,1,LBAD
* 18 17,
* 19 15,4,2,LVALS, 18
* 20 15,4,2,LVALS, 18
* 21 15,5,2,LVALS, 18
* 22 15,4,2,LVALS, 18
* 23 15,4,2,LVALS, 18
* 24 15,5,2,LVALS, 18
* 25 11
* 26 17,
* 27 14,1,1,LDEBUG
* ININ Array where integer point data is unpacked.
* IOFIL* Unit number used for output to be used for plot device.
* IOP Current index in OPT when processing options.
* IOP1 Starting index in OPT for the current option. Set to 0 when
* processing COPT, set to -1 after processing OPT, and set to -100
* - error index on an error.
* IOPT Integer value for an option, nint(OPT(IOPT))
* IOSTA Status of the temporary files.
* = 0 There is only one scratch file. (Needed if digit 10^0 of
* option 1 is a 3.)
* = 1 There is (or will be) a second scratch file, we are currently
* reading from the first one.
* = -1 There is a second scratch file and we are reading from it now.
* IOTEMP Unit number used for scratch file.
* IOTMP1 If IOSTA .ne. 0, this holds unit number of first scratch file.
* IOTMP2 If IOSTA .ne. 0, this is the number of the second scratch file.
* IP* Integer array used to store various values that are indexed by
* parameter names.
* IPLOT* Defines output, 0 for LaTeX, 1 for TeX.
* Temporarily changed to -100 - IPLOT when want to end one mfpic
* group and immediately start another.
* IRULE Constant array mapping option indices to location in LRULE.
* The value in LRULE and following values up to one less than the
* location pointed to by the next location in IRULE indentify actions
* in NRULE to used in unpacking data connected with the option if
* positive, and if negative identify the number of floating point
* numbers for the option.
* IY Index for Y curve being output, when outputting the saved data
* points.
* J Temporary index.
* JSET* JSET(1) gives the current set index for X, and JSET(2) gives
* the current set index for Y. JSET(1) starts at 1 and is incrmented,
* JSET(2) starts at -1 and is decremented.
* K1 Temporary index.
* K2 Temporary index.
* KPT Count of points that have been stored in XOUT and YOUT.
* KX Pointer e.g. to NXYLIM, for the current data set for X.
* KY Pointer e.g. to NXYLIM, for the current data set for Y.
* KURPEN Rule defining the current pen. Defined as for P3 of option 3.
* KURPEN = t + 10*(w + 100*(L1 + 100*L2)), where t is 0, 1, or 2 for
* solid, dotted, or dashed lines. t = 3 or 4 is as for 1 or 2, except
* L1 is given in deci-points instead of points, and t = 5-8, is as for
* 1-4, except L2 if in deci-points instead of in points. w is the
* width of the line in decipoints, L1 and L2 are not used for solid
* lines. Else L1 is the diameter of the dots or the lenght of the
* dashes, and L2 is the distance between the dots or dashes.
* LKLIP Set to .true. if the last point saved will be clipped on the
* next good point.
* LFILL Array with fill pattern info. Rows are for successive
* patterns (usually only one row will be used). Columns are:
* 1 For curves
* 2 For rectangles
* 3 For ellipses
* 4 Temporary for annotations.
* Values are:
* 0 For no action, should not be used?
* 1 For fill with black.
* 2 For erase what preceded.
* 3 For shading with dots.
* 4 For shading with hatch lines.
* LRULE See IRULE (and NRULE).
* K Temporary index.
* KASE 1-4 for bottom, left, top,right borders, 5 and 6 for x and y
* axis, 8 for words, 10-15 for captions, 16 for output text. */
/* Indicees, 1-16, are for: Borders (bottom, left, top, right),
* x-axis, y-axis, word alignment (e.g. for option 14), number
* formatting for option 15, Captions (as for borders), alignment
* rule for option 16.
* KLIP Logical array. Entry is true if this variable set induces
* clipping, i.e. some points are outise the plotting area.
* KSYMB Defines the kind of symbol being plotted. Passed to DPLOTS.
* L1 Temporary index.
* L3 Temporary index.
* LAST Defines how called on the last call. (Low digit of option 1)
* = 0-2 Either not called yet, or a plot was finished with units of
* inches, millimeters, or points in that order.
* = 3 Curve was finished, this MFPIC finished, plot wasn't. */
/* = 4 Curve was finished, plot wasn't.
* = 5 Continuing on curve not finished on last call.
* LBNDC Parameter giving the maximum number of characters inside {...}
* for a caption or a file name.
* LBNDF Parameter giving the maximum number of characters inside (...)
* for formatting numbers or text.
* LBNDP Parameter giving the maximum number of characters inside [...]
* for indicating position info.
* LBNDT Parameter giving the maximum number of characters inside {...}
* for text or number.
* LBOUND Gives lengths allowed for chars. inside [...] (...), { ...no #
* required}.
* LCURVE Count of the number of curves; not really needed anymore.
* LENCAP Array giving the length of the caption for borders and axes.
* LENTXT* Gives the length of various text strings. Rows are for
* FMTNUM, TXTDEF when getting a "#", and after getting all of TXTDEF.
* A value of -1 means use the default value. A value of -2 means the
* default is not needed. Columms are defined as
* follows:
* 1-6 B L T R X Y -- For format of Border/Axis Labels
* 7 W -- For formatting words
* 8 N -- For formatting numbers
* 9 Option 15, format for a number to be output.
* 10-15 1-6 -- For Border/Axis Captions and formatting.
* 16 Options 14 & 16, Text to be output.
* 17 F Output file name or mfpic output
* 18 Used for temporary storage of text.
* LINACT Array giving location in INACT where actions for an option
* begin (and end).
* LOCF Last index used in FPIN when unpacking data.
* LOCI Last index used in ININ when unpacking data.
* LPAR Used to keep track of paren "{}" level.
* LSET Index of the last index available for NXYLIM(), XYLIM(1:2,),
* XYBASE(), XYU2PF().
* LTEXT This location in COPT contains the place where the last text
* ended. Used if annotation has text pointer of 0.
* LY The value of IY if not drawing error bars or vector fieles.
* Else, LY + 1 is the place where the data for the current curve
* starts in FPIN().
* MANNO* Flags nature of text output.
* = -1 Output of annotation in user coordinates.
* = 1 Output of annotation in physical coordinates.
* = 0 Text output is label, or axis annotation.
* MAXPT The dimension of XOUT and YOUT, max value for KPT.
* MAXNY Parameter giving the maximum size for NY, should be > 15.
* MAXSET* Parameter giving the maximum number of data set allowed.
* MFILL* Absolute value gives the number of fill patterns. If < 0,
* then filling is not turned off, otherwise it is.
* MBORD Defines for the various borders and axes the processing to be
* done. Each column corresponds to a different border or axes. Other
* data depends on the row index as follows.
* = 1 From digit 10^0 of option 4 -- Border tick mark actions
* = 2 From digit 10^1 of option 4 -- Length of arrow head, points.
* = 3 From digit 10^{2} of option 4 -- Min. dist. to border, pts.
* = 4 From digit 10^{3:} of option 4 -- Space for labels, points.
* = 5 From digit 10^{1:0} of word 2 option 4 -- Number minor ticks.
* = 6 From digit 10^2 of word 2 option 4 -- Expand range rule.
* = 7 From digit 10^{:3) of word 2 option 4 -- => border caption.
* = 8 Value of JSET(?) at time action for border was taken. Columns
* 5 and 6 here are used to track extra space needed on left and
* right borders needed for annotations.
* MODE Defines what we are doing when processing the saved data.
* = 0 Interpolate with Bezier curve.
* = 1 As for 0, but a closed curve.
* = 2 As for 1, but the curve is closed with a straight line.
* = 3 Connect points with a straight line.
* = 4 As for 2, but close the curve.
* = 5 Points not connected, likely to be plotted with symbols.
* = 6 Set when points have been connected, and now they are to be
* plotted with symbols.
* = 7 Plotting single symbols.
* = 8 Doing rectangles and ellipses.
* = 9 Doing various annotations.
* = 10 Ready to exit.
* MOREIY Set=.true. if have more in a set of multiple curves to output.
* NDIMY Declared dimension of Y (used only when NY > 1)
* NMODE Defines how we start MODE when done with what we are doing now.
* NMODE is intialized to 10, and is never increased, and is never set
* smaller or equal to MODE.
* NOOUT* Set to .true. when there is no output desired (just getting
* size required).
* NOTOUT Set .true. when starting to process an option. Set false when
* first write the option index to the scratch file. Also used when
* checking if input file is opened.
* NRULE() Unpacking rules. Integers are unpacked by taking the mod
* if the integer relative to the value pointed to in NRULE. This
* result is saved, the original integer is divided by this same value
* from NRULE, and the process continues until getting a value of 0, at
* which time the current integer is saved, and the integer has been
* unpacked. This gives integers in the same order as they appear in
* the documentation.
* NTEXT* The length of the text in TEXT.
* NTYP Defines the type of text we are looking for.
* = 1 Position info
* = 2 Format
* = 3 Text/number formatting info, before any "#".
* = 4 Text/number formatting info, after getttng a "#".
* NXYLIM*Array defining what is in the columns of XYLIM and entries in
* XYU2PF and XYBASE.. If > 0, contains the index for an XDATA set.
* If < 0, contains the index for a Y data set. If 0, no data for this */
/* data set has been examined.
* NY Number of curves being plotted.
* OPAQUE* .true. if the label printed is to go into an opaque box.
* OPTLET Constant character string used to decode option letters.
* OVLAP Estimated right end of last output number. If a numeric
* label looks as if it will overlap with a previous one, it is not
* printed.
* PHYUSE* Set by option 7. Columns 1 and 2 for x and y, row 1 gives
* give place in physical units where points are to map, and row 2
* give the corresponding user coordinate. Row < 0 inactivates.
* POS* Character array holding alignment info. POS(4*I-3:4*I) for
* I = 1, 16, holds data for: Borders (bottom, left, top, right),
* x-axis, y-axis, word alignment (e.g. for option 14), number
* formatting for option 15, Captions (as for borders), alignment
* rule for option 16.
* PXO* X origin of logical coordinate system in physical units.
* PXSIZE* Physical X width of the plot, including outward-pointing tick
* marks.
* PYO* Y origin of logical coordinate system in physical units.
* PYSIZE* Physical Y width of the plot, including outward-pointing tick
* marks.
* SETLIM* Col. 1 for x, 2 for y, row 1 for min, 2 for max. Give min and
* max used for current data set. If the log of the data is taken,
* these values will be the logs of the input values.
* TEXT* Text to be output.
* TICKS Columns for different borders/axes. Rows used as follows:
* = 1 Length of major ticks.
* = 2 Length of minor ticks.
* = 3 Offset for major ticks (Ignore if incrment below is .le. 0)
* = 4 Increment for major ticks
* TLENH Set to horizontal length of text in DPLOTN
* TLENV Set to vertical height of text in DPLOTN.
* TOPTS* Multiplies physical coordinates to get them in units of points.
* TP Used for tempoaray floating point storage.
* TP1 Used for tempoaray floating point storage.
* TP2 Used for tempoaray floating point storage.
* TPTSET Data used to set TOPTS.
* TXTDEF Text used to control output of text and numbers.
* TXTTST Constant character array indexed by NTYP used to detect escaped
* characters and to track the level of "{}"'s.
* VHLEN Array giving the vertical and horizontal space required by
* output text, set in DPLOTT.
* XOUT Array used to save absiccas that are ready for output.
* YOUT Array used to save absiccas that are ready for output.
* XYBASE* See XYU2PF and NXYLIM.
* XYLIM* Rows 1 and 2 contain "minimum value", "maximum value" Columns:
* 1 From the current X data and perhaps XYMAX and XYMIN.
* 2 From the current Y data and perhaps XYMAX and XYMIN.
* >k From previous data sets (option 7). See NXYLIM.
* Originally contains min/max determined from the data. Can be
* changed to SETLIM when clipping is active. This is changed to
* physical address value when axis is processed.
* XYMAX Maximum values set by options 8 and 9, used to set SETLIM.
* XYMIN Minimum values set by options 8 and 9, used to set SETLIM.
* XYPOS Use to hold (x,y) position information.
* XYU2PF* Array giving multipliers for converting from user to physical
* coordinates. Entries correspond to either an x or a y data set.
* Let v be the x or y corresponding to XYU2PF(I) (see NXYLIM). Then
* v_{physical} = XYBASE(IAX) + v_{user} * XYU2PF(IAX). If an entry
* here is nonzero, its value has been determined. */
/* Parameter defs (integers) (in IP):
* NEXT 10^0 of Opt. 1 -- Units, continue, etc., sets LAST.
* INTERP 10^1 of Opt. 1 -- Connecting points of a curve
* KSET Opt. 7 -- Current user coordinate set
* LCOOX 10^2 of Opt. 1 -- Type of coordinate X. A value of 3 is
* set to 2 to make checking for log transformations simpler.
* LCOOY 10^3 of Opt. 1 -- Type of coordinate Y. As for X above.
* LDEBUG Opt. 25 -- Debugging print flag.
* LNY Opt. 2 -- Number of y curves being plotted
* LYDIM Opt. 2 -- First dimension of Y when NY > 1.
* LPEN Opt. 3 -- Type of pen
* LTANNO Opts. 14,15 -- Type of coordinates amd OPAQUE, Text pointer
* In the case of Opt. 16, give tick, border index, pointer to text.
* LTYPE 10^5 of Opt. 1 -- LaTeX, or TeX
* LXBORD From Opt. 1 -- For how horizontal borders and axis are labeled.
* = 0 Linear
* = 1 10^{??} For log labeling
* = 2 Polar in radians (Later??)
* = 3 Polar in degrees (Later??)
* LXLINE 10^4 of Opt. 1 -- Drawing extra lines
* LYBORD As for LXBORD, except for vertical case.
* NBORD Opt. 16 -- Index for the border.
* Parameter defs (floating point):
* LARROW Opt. 12 -- Length of arrow head in points
* LBAD(2) Opt. 17 -- Flag on bad data action, and the value.
* LXYSIZ This and next give XSIZE and YSIZE.
* LASTFP Gives Last location used in FP.
* LVALS (5) Options 14-16, 20-23 -- Place to save various temp. values.
* LWIDRE Opt. 13 -- Line width for rectangles and ellipses.
* LWIDTH (4) Opt. 13 -- Type of pen for borders, major ticks, minor
* ticks, and lines drawn at x=0 or y=0.
* LASTFP Size of the array FP().
* LFDAT Size of the array FPDAT.
* Parameters for integers in IP
* INTERP,LCOOX,LCOOY,LXLINE,LTYPE,LXBORD,LYBORD, KSET, LTANNO,
* LPEN,NBORD, LDEBUG
*
* Parameters for floating point
* LARROW, LWIDTH (4), LWIDRE */
/* LVALS (5), LBAD(2)
*
* **************************** Variable Declarations *******************
*
* Formal Args. */
/* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
long ictmp;
/*++ END */
/* Parameter pointers for integers in IP. */
/* Parameter pointers for floats in FP. */
/* Parameter for various sizes. */
/* Locals */
/*++ CODE for .C. is active */
/*++ CODE for ~.C. is inactive
* integer INUNIT, IOTEMP, IOTMP1, IOTMP2, I, I1, IACT, IAOPT,
*++ END */
/* Weird stuff to take care of "\" being treated as an escape character
* on SGI Fortran compilers
*++ CODE for ~.C. is inactive
* character BSLAS1*(*), BSLASH
* parameter (BSLAS1 = '\\')
* parameter (BSLASH = BSLAS1(1:1))
*c
* character*4 TXTTS1, TXTTS2, TXTTS3, TXTTS4
* parameter (TXTTS1=BSLASH//']]]', TXTTS2=BSLASH//')))',
* 1 TXTTS3=BSLASH//'{#}', TXTTS4=BSLASH//'{{}') */
/*c For debug printing
* character DB*1 */
/*++ CODE for .C. is active */
/*++END
*
*++ CODE for .C. is active */
/*++ CODE for ~.C. is inactive
* save INUNIT, IOSTA, IOTEMP, LCURVE, LAST, LSET, XYMAX, XYMIN
*++ END */
/* Option Index: 1 2 3 4 5 6 7 8 9 10 11 12 13 14
* 15 16 17 18 19 20 21 22 23 24 25 26 27 <end flag> */
/* Index from IRULE:1 2 4 5 8 10 12 16 17
* 18 19 20 21 23 25 27 28 29 30 31 32 33 34 35 */
/* 1 2 3 4 5 6 7 8 9 10 11 12 13 14
* 15 16 17 18 */
/* 1 2 3 4 5 6 7 8 9 10 11 12 13
* 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
* 29, 30 31 32 33 end */
/* 11111111112222222222333333333
* 12345678901234567890123456789012345678 */
/* 1234 */
/*++ CODE for ~.C. is inactive
* data TXTTST / TXTTS1, TXTTS2, TXTTS3, TXTTS4 /
*++ CODE for .C. is active */
/*++ END */
/* Initial FP. 1 2 3 4 5 6 7 */
/* To get TOPTS. */
/*++ CODE for ~.C. is inactive
* 10 format(1X, A1, I3, ' IAOPT=',I2,' Len=',I3, ' POS=',A4)
* 20 format(1X, A1, I3, ' IAOPT=',I2,' FMTNUM=', A)
* 30 format(1X, A1, I3, ' IAOPT=',I2,' TEXT=', A)
* 40 format(1X, A1, I3, ' IAOPT=',I2,'LENTXT=',3I4, ' POS=', A4)
* 50 format(1X, A1, I3, ' IAOPT=',I2,' Symbols:', 6I10 / (10X,6I10))
* 60 format(1X, A1, I3, ' IAOPT=',I2, 1P,2E16.7, I10/ (4E16.7))
* 70 format(1X, A1, I3, ' IAOPT=',I2, 3I4, 1P,5E16.7)
* 80 format(1X, A1, I3, ' IAOPT=',I2, ' Integers:', 10I8)
* 90 format(1X, A1, I3, ' IAOPT=',I2, ' F.P.:', 1P,6E17.8)
* 120 format(1X, A1, I3, ' IAOPT=',I2, 1P,4E16.7 / (8X, 4E16.7))
* 130 format(1X, A1, I3, ' New data set, Curve=', I3, ' KX=',I3,
* 1 ' KY=',I3: ' MODE=', I2, ' IY=', I2, ' NY=', I2)
*++ CODE for .C. is active */
const char fmt10[] = "IAOPT=%li Len=%li POS=%.4s\n";
const char fmt20[] = "IAOPT=%li FMTNUM=%.*s\n";
const char fmt30[] = "IAOPT=%li TEXT=%.*s\n";
const char fmt40[] = "IAOPT=%li LENTXT=%4li%4li%4li POS=%.4s\n";
const char fmt50[] = "IAOPT=%li Symbols:";
const char fmt55[] = "%10li";
const char fmt60[] = "IAOPT=%li%16.7e%16.7e %li\n";
const char fmt65[] = "%16.7e";
const char fmt70[] = "IAOPT=%li%4li%4li%4li";
const char fmt80[] = "IAOPT=%li Integers:";
const char fmt85[] = "%8li";
const char fmt90[] = "IAOPT=%li F.P.:";
const char fmt95[] = "%17.8e";
const char fmt120[]= "IAOPT=%li";
const char fmt125[]= "%15.7e";
const char fmt130[]= "New data set, Curve=%3li KX=%3li KY=%3li\
MODE=%2li IY=%2li NY=%2li\n";
Opt[1] = 0.e0;
/*++ END */
/* ************************ Start of Executable Code ********************
*
* Set the defaults as needed.
*++ CODE for ~.C. is inactive
* INUNIT = 0
*++ END */
dplotb.iop1 = 0;
nxi = nx;
if (last <= 4)
{
/* Set the defaults */
if (last <= 2)
{
f_strncpy( dplotc.txtdef[16], "dplot.tex", 64 );
dplotd.arrlen = 0;
lcurve = 100;
Jset[1] = 1;
Jset[2] = -1;
Nxylim[1] = 0;
Nxylim[2] = 0;
Xyu2pf[1] = 0.e0;
Xyu2pf[2] = 0.e0;
Xymin[1] = 0.e0;
Xymax[1] = 0.e0;
Xymin[2] = 0.e0;
Xymax[2] = 0.e0;
dplotb.setlim[0][0] = 0.e0;
dplotb.setlim[0][1] = 0.e0;
dplotb.setlim[1][0] = 0.e0;
dplotb.setlim[1][1] = 0.e0;
dplotb.phyuse[0][0] = -1.e0;
dplotb.phyuse[1][0] = -1.e0;
lset = 2;
/* B L T R X Y W N o15 1 2 3 4
* 5 6 o16 */
f_strncpy( dplotc.pos, "bc..cr..bc..cl..bc..cr..bl..cl..cl..bc..cr..bc..cl..rc..tc..lc.. .."
, 68 );
/* Flag that FMTNUM and TXTDEF are not needed. */
for (i = 1; i <= 17; i++)
{
dplotb.lentxt[i - 1][0] = -1;
dplotb.lentxt[i - 1][1] = 0;
dplotb.lentxt[i - 1][2] = -1;
}
dplotb.lentxt[16][2] = 9;
/* Default border actions */
for (i = 1; i <= 6; i++)
{
for (j = 1; j <= 8; j++)
{
dplotb.mbord[i - 1][j - 1] = 0;
}
}
dplotb.mbord[0][0] = 6;
dplotb.mbord[1][0] = 6;
dplotb.mbord[2][0] = 1;
dplotb.mbord[3][0] = 1;
dplotb.mbord[0][7] = 0;
/* Default tick lengths, no captions */
for (i = 1; i <= 6; i++)
{
dplotb.ticks[i - 1][0] = 4.0e0;
dplotb.ticks[i - 1][1] = 2.5e0;
dplotb.ticks[i - 1][2] = 0.0e0;
dplotb.ticks[i - 1][3] = 0.0e0;
Lencap[i] = 0;
}
/* Initialize IP and FP */
for (i = 1; i <= LASTIP; i++)
{
Ip[i] = 0;
}
Ip[LNY] = 1;
Ip[LPEN] = 50;
for (i = 1; i <= LFDAT; i++)
{
Fp[i] = Fpdat[i];
}
/* Open the scratch file.
*++ CODE for ~.C. is inactive
* call DPLOTU (IOTEMP, ' ')
* if (IOP1 .le. -100) go to 1500
* DB = 'W'
*++ CODE for .C. is active */
iotemp = tmpfile();
if (iotemp == NULL) goto L_1500;
iosta = 0;
/*++ END */
dplotb.manno = 0;
}
else
{
Ip[NEXT] = 0;
}
}
Fp[LXYSIZ] = xsize;
Fp[LXYSIZ + 1] = ysize;
/* ********************** Process the options in COPT *******************
* */
ltext = 0;
L_200:
ltext += 1;
c = copt[ltext - 1];
if (c == ' ')
goto L_200;
k = istrstr( optlet, STR1(_c0,c) );
if (k == 0)
{
/* Error -- Bad option character */
ierr = 10;
goto L_1400;
}
if (k > 20)
k -= 24;
if (k <= 1)
goto L_290;
ntyp = 2;
k -= 6;
/* Enter here when processing text pointed to by options in OPT.
* Remember start at I1 for error messages. */
L_210:
i1 = ltext;
k1 = k;
if (k <= 0)
{
if (k <= -2)
{
/* Getting file name (or mfpic output) */
ntyp = 3;
k1 = 19 + k;
k = 17;
}
else if (k != 0)
{
/* Got an A, set to save data in first border. */
k = 1;
}
else
{
/* Defaults for captions */
k = 10;
}
}
else if (k >= 8)
{
ntyp = 1;
}
/* At this point, K identifies what we are working on as follows.
* = 1-6 B L T R X Y -- For format of Border/Axis Labels
* = 7 W -- For formatting words
* = 8 N -- For formatting numbers
* = 9 Option 15, format for a number to be output.
* =10-15 1-6 -- For Border/Axis Captions (or for "C")
* =16 Options 14 & 16, Text to be output.
* =17 F -- Output file name or mfpic output */
dplotb.lentxt[k - 1][0] = -1;
dplotb.lentxt[k - 1][2] = -1;
L_220:
ltext += 1;
/* Checking */
c = copt[ltext - 1];
k2 = 0;
for (j=0; j<4; j++) {
if (bndtst[j] == c) {
k2 = j + 1;
break;}}
if (k2 == 0)
{
/* K2 = index(BNDTST(NTYP:4), C) */
if (c == ' ')
goto L_220;
/* Error -- Bad start of COPT option */
ierr = 11;
goto L_1400;
}
if (k2 != 1)
{
if (c == '#')
{
if (k < 10)
goto L_260;
/* Error -- Bad start of COPT option */
ierr = 11;
goto L_1400;
}
ntyp += k2 - 1;
}
if ((c == '{') && (k1 >= 10))
{
ntyp = 4;
if (copt[ltext] == BSLASH)
dplotb.lentxt[k - 1][2] = -2;
}
lpar = 1;
j = ltext;
L_240:
ltext += 1;
if (ltext - i1 > 100)
{
/* Error -- Runaway in COPT, unbalanced (), [], or {}? */
j = i1;
ierr = 12;
goto L_1410;
}
/* Get the end tag (LPAR counts "paren" levels) */
c = copt[ltext - 1];
l = istrstr( txttst[ntyp - 1], STR1(_c0,c) );
/* Skip uninteresting characters, and those escaped with '\'. */
if (l == 1)
ltext += 1;
if (l <= 1)
goto L_240;
if (ntyp >= 3)
{
if (l != 3)
{
lpar += -l + 3;
if (lpar != 0)
goto L_240;
if (ntyp == 3)
{
/* Error -- Missing # */
ierr = 13;
goto L_1400;
}
}
else
{
if (ntyp == 3)
{
dplotb.lentxt[k - 1][1] = ltext - j;
ntyp += 1;
}
goto L_240;
}
/* Save the length */
l = ltext - j - 1;
if ((k >= 10) && (k1 != 0))
{
/* Text for file name or border/axis caption or option */
if (l <= 0)
{
/* Error -- File name or caption is empty */
ierr = 14;
goto L_1400;
}
if (l > LBNDC)
{
/* Error -- (J:LTEXT) may only contain LBNDC chars. */
dplotb.ierr1 = LBNDC;
ierr = 15;
goto L_1410;
}
if (k == 17)
{
if (k1 == 17)
{
/* The output file name. */
dplotb.lentxt[16][2] = l;
memcpy(dplotc.txtdef[16], copt+j,(size_t)l);
dplotc.txtdef[16][l]='\0';
}
else if (k1 == 16)
{
/* TXTDEF(17) = COPT(J+1:LTEXT-1)
* The input file name, get the unit number, open if needed.
*++ CODE for ~.C. is inactive
* inquire(FILE=COPT(J+1:LTEXT-1), NUMBER=INUNIT,
* 1 OPENED=NOTOUT)
* if (.not. NOTOUT) then
* call DPLOTU(INUNIT,COPT(J+1:LTEXT-1))
* if (IOP1 .le. -100) go to 1500
* end if
*++ CODE for .C. is active */
c = copt[ltext - 1];
copt[ltext-1] = '\0';
inunit = fopen(copt+j, "r");
if (inunit == NULL) goto L_1500;
copt[ltext - 1] = c;
/*++ END */
}
else
{
/* Data for raw mfpic output. */
ictmp = 29;
fwrite(&ictmp, sizeof(ictmp), (size_t)1, iotemp);
fwrite(&l, sizeof(l), (size_t)1, iotemp);
fwrite(copt+j, (size_t)1, (size_t)l, iotemp);
}
/* write (IOTEMP) 29
* write (IOTEMP) L, COPT(J+1: LTEXT-1) */
goto L_200;
}
if (k >= 16)
{
/* Option 14, or 16, text to output. */
if (notout)
{
notout = FALSE;
fwrite(&iaopt, sizeof(iaopt), (size_t)1, iotemp);
}
/* write (IOTEMP) IAOPT */
fwrite(&dplotb.lentxt[k-1][0],
sizeof(dplotb.lentxt[k-1][0]),(size_t)1,iotemp);
fwrite(&l, sizeof(l), (size_t)1, iotemp);
fwrite(&dplotc.pos[60], (size_t)1, (size_t)4, iotemp);
if (dplotb.ip[LDEBUG-1] > 1) printf (fmt10, iaopt,
dplotb.lentxt[k-1][0], &dplotc.pos[60]);
if (dplotb.lentxt[k - 1][0] > 0)
{
/* write (IOTEMP) LENTXT(1, K), L, POS(61:64)
*++ CODE for .C. is active
*++ CODE for ~.C. is inactive
* if (IP(LDEBUG).gt.1)
* 1 print 10, DB, IOTEMP, IAOPT,LENTXT(1,K),POS(61:64)
*++ END
*++ CODE for ~.C. is inactive
* write (IOTEMP) FMTNUM(K)(1:LENTXT(1,K))
* if (IP(LDEBUG).gt.1)
* 1 print 20, DB,IOTEMP,IAOPT,FMTNUM(K)(1:LENTXT(1,K))
*++ CODE for .C. is active */
fwrite(dplotc.fmtnum[k-1], (size_t)1,
(size_t)dplotb.lentxt[k-1][0], iotemp);
if (dplotb.ip[LDEBUG-1] > 1) printf (fmt20, iaopt,
(int)dplotb.lentxt[k-1][0], dplotc.fmtnum[k-1]);
}
/*++ END */
if (l != 0)
{
fwrite(copt+j, (size_t)1, (size_t)l, iotemp);
if (dplotb.ip[LDEBUG-1] > 1) printf (fmt30, iaopt,
(int)l, copt+j);
}
/* write (IOTEMP) COPT(J+1:LTEXT-1)
*++ CODE for .C. is active
*++ CODE for ~.C. is inactive
* if (IP(LDEBUG).gt.1)
* 1 print 30, DB, IOTEMP, IAOPT,COPT(J+1:LTEXT-1)
*++ END */
goto L_400;
}
else
{
Lencap[k - 9] = l;
memcpy(dplotc.captio[k-10], copt+j,(size_t)(ltext-j-1));
}
/* CAPTIO(K-9) = COPT(J+1:LTEXT-1) */
}
}
else
{
l = ltext - j - 1;
if (l > Lbound[ntyp])
{
/* Error -- (J:LTEXT) may only contain LBOUND(NTYP) chars. */
dplotb.ierr1 = Lbound[ntyp];
ierr = 15;
goto L_1410;
}
if (ntyp == 1)
{
/* Check and save position info. */
if ((l != 2) && (l != 4))
{
/* Error -- [...] must contain 2 or 4 letters */
ierr = 16;
goto L_1410;
}
c = copt[j];
i = istrstr( vlet, STR1(_c0,c) );
if (i == 0)
{
/* Error -- First position must be one of "tcbTCB" */
ierr = 17;
goto L_1410;
}
if (i > 3)
c = vlet[i - 4];
dplotc.pos[k*4 - 4] = c;
c = copt[j + 1];
i = istrstr( hlet, STR1(_c0,c) );
if (i == 0)
{
/* Error -- Second position must be one of "lcrLCR" */
ierr = 18;
goto L_1410;
}
if (i > 3)
c = hlet[i - 4];
dplotc.pos[k*4 - 3] = c;
if (l == 2)
{
f_subscpy( dplotc.pos, k*4 - 2, k*4 - 1, 68, " " );
}
else
{
c = copt[j + 3];
i = istrstr( hlet, STR1(_c0,c) );
if (i > 3)
c = hlet[i - 4];
if ((i == 0) || ((copt[j + 1] != 'S') && (copt[j +
1] != 's')))
{
/* Error -- In third/forth position of [...] */
ierr = 19;
goto L_1410;
}
dplotc.pos[k*4 - 2] = 's';
dplotc.pos[k*4 - 1] = c;
}
goto L_250;
}
dplotb.lentxt[k - 1][ntyp - 2] = l;
if (l != 0)
{
if (ntyp == 2)
{
memcpy(dplotc.fmtnum[k-1], copt+j,(size_t)(ltext-j-1));
}
else
{
/* FMTNUM(K) = COPT(J+1:LTEXT-1) */
memcpy(dplotc.txtdef[k-1], copt+j,(size_t)(ltext-j-1));
}
/* TXTDEF(K) = COPT(J+1:LTEXT-1) */
}
}
L_250:
ntyp += 1;
if (ntyp <= 4)
goto L_220;
L_260:
if (k == 9)
{
/* Just processed formats for option 15 */
if (notout)
{
notout = FALSE;
fwrite(&iaopt, sizeof(iaopt), (size_t)1, iotemp);
}
/* write (IOTEMP) IAOPT */
fwrite(&dplotb.lentxt[8][0], sizeof(dplotb.lentxt[8][0]),
(size_t)2, iotemp);
fwrite(&dplotc.pos[60], (size_t)1, (size_t)4, iotemp);
if (dplotb.ip[LDEBUG-1] > 1) printf (fmt40,iaopt,
dplotb.lentxt[8][0], dplotb.lentxt[8][1],dplotb.lentxt[8][2],
&dplotc.pos[32]);
if (dplotb.lentxt[8][0] > 0)
{
/* write (IOTEMP) LENTXT(1, 9), LENTXT(2, 9), POS(33:36)
*++ CODE for ~.C. is inactive
* if (IP(LDEBUG).gt.1) print 40, DB, IOTEMP, IAOPT,
* 1 (LENTXT(K, 9), K = 1, 3), POS(33:36)
*++ CODE for .C. is active
*++ END */
fwrite(dplotc.fmtnum[8], (size_t)1,
(size_t)dplotb.lentxt[8][0], iotemp);
if (dplotb.ip[LDEBUG-1] > 1) printf (fmt20, iaopt,
(int)dplotb.lentxt[8][0], dplotc.fmtnum[8]);
}
/* write (IOTEMP) FMTNUM(9)(1:LENTXT(1,9))
*++ CODE for .C. is active
*++ CODE for ~.C. is inactive
* if (IP(LDEBUG).gt.1)
* 1 print 20, DB, IOTEMP, IAOPT,FMTNUM(9)(1:LENTXT(1,9))
*++ END */
if (dplotb.lentxt[8][2] > 0)
{
fwrite(dplotc.txtdef[8], (size_t)1,
(size_t)dplotb.lentxt[8][2], iotemp);
if (dplotb.ip[LDEBUG-1] > 1) printf (fmt30, iaopt,
(int)(dplotb.lentxt[8][2]), dplotc.txtdef[8]);
}
/* write (IOTEMP) TXTDEF(9)(1:LENTXT(3,9))
*++ CODE for .C. is active
*++ CODE for ~.C. is inactive
* if (IP(LDEBUG).gt.1)
* 1 print 30, DB, IOTEMP, IAOPT,TXTDEF(9)(1:LENTXT(3,9))
*++ END */
goto L_400;
}
if ((k1 == 0) || (k1 == -1))
{
/* Copy stuff for first border to all of them */
i = 10 + 9*k1;
l1 = dplotb.lentxt[i - 1][0];
l3 = dplotb.lentxt[i - 1][2];
for (j = i + 1; j <= (i + 5); j++)
{
for (l = 1; l <= 3; l++)
{
dplotb.lentxt[j - 1][l - 1] = dplotb.lentxt[i - 1][l - 1];
}
if (l1>0) memcpy(dplotc.fmtnum[j-1],dplotc.fmtnum[i-1],(size_t)l1);
if (l3>0) memcpy(dplotc.txtdef[j-1],dplotc.txtdef[i-1],(size_t)l3);
}
/* if (L1 .gt. 0) FMTNUM(J)(1:L1)=FMTNUM(I)(1:L1)
* if (L3 .gt. 0) TXTDEF(J)(1:L3)=TXTDEF(I)(1:L3) */
}
goto L_200;
/* Reduce count by 1 if not a "Q", then save next text pointer. */
L_290:
if (k != 1)
ltext -= 1;
/* ******************** Process the options in OPT **********************
* */
iop = 1;
/* IOP(1) reserved for exit flag. */
L_300:
iop += 1;
dplotb.iop1 = iop;
iopt = nint( Opt[iop] );
/*++ CODE for ~.C. is inactive
* if (IP(LDEBUG).gt.1) print '('' Option: OPT('', I3,'') ='', I3)',
* 1 IOP, IOPT
*++ CODE for .C. is active */
if (dplotb.ip[LDEBUG-1] > 1) printf (" Option: OPT(%li) = %li\n",
iop, iopt );
if (iopt == 0)
goto L_700;
/*++ END
* */
iaopt = labs( iopt );
if (iaopt > 28)
goto L_520;
/* Unpack associated data */
loci = 0;
locf = 0;
for (j = Irule[iaopt]; j <= (Irule[iaopt + 1] - 1); j++)
{
l = Lrule[j];
if (l < 0)
{
/* Pick up -L floating point numbers */
L_320:
iop += 1;
locf += 1;
Fpin[locf] = Opt[iop];
l += 1;
if (l != 0)
goto L_320;
}
else
{
/* Pick up and unpack an integer. */
iop += 1;
tp = fabs( Opt[iop] );
m = nint( tp );
if (fabs( tp - (double)( m ) ) > .2e0)
{
/* Error -- Number specified not an integer */
ierr = 21;
goto L_1430;
}
/* TP used in later test to see if too big. */
tp = m + 1;
L_330:
loci += 1;
if (Nrule[l] != 0)
{
Inin[loci] = m%Nrule[l];
m /= Nrule[l];
l += 1;
goto L_330;
}
else
{
/* Last one takes the whole integer */
Inin[loci] = m;
if (tp - nint( fabs( Opt[iop] ) ) != 1.e0)
{
/* Error -- Floating number too big for integer */
ierr = 22;
goto L_1430;
}
}
}
}
/* IOPT < 0, means don't process the option. */
if (iopt < 0)
goto L_300;
/* Option unpacked, now process. */
iact = Linact[iaopt] - 1;
notout = TRUE;
loci = 1;
locf = 1;
L_400:
iact += 1;
if (iact >= Linact[iaopt + 1])
goto L_300;
/* 1 2 3 4 5 6 7 8 9 10 11
* 12 13 14 15 16 17 18 */
switch (Inact[iact])
{
case 1: goto L_410;
case 2: goto L_420;
case 3: goto L_430;
case 4: goto L_430;
case 5: goto L_450;
case 6: goto L_460;
case 7: goto L_470;
case 8: goto L_480;
case 9: goto L_490;
case 10: goto L_500;
case 11: goto L_510;
case 12: goto L_520;
case 13: goto L_520;
case 14: goto L_540;
case 15: goto L_550;
case 16: goto L_560;
case 17: goto L_520;
case 18: goto L_400;
}
/* =1, Units / Final flag, and linex as x,y = 0, for option 1 */
L_410:
Ip[NEXT] = Inin[1];
if (Ip[NEXT] > 5)
{
/* Error -- Digit 10^0 of option 1 is too big */
ierr = 23;
goto L_1430;
}
if (Inin[6] > 1)
{
/* Error -- Type flag must be 0 or 1. */
ierr = 24;
goto L_1430;
}
Inin[8] = Inin[6];
if ((Inin[3] >= 4) || (Inin[4] >= 4))
{
/* Polar coordinates or an error.
* An error now since polar code is not yet written. */
ierr = 25;
goto L_1430;
}
for (j = 1; j <= 2; j++)
{
/* Set flags for how the borders/axes are labeled. */
k = Inin[2 + j];
Inin[5 + j] = k%2;
if (k == 3)
Inin[2 + j] = 2;
}
goto L_400;
/* =2 Save border characteristics. Option 4 */
L_420:
k = Inin[1];
L_422:
j = k%10;
if ((j != 0) && (j <= 6))
{
for (i = 1; i <= 6; i++)
{
dplotb.mbord[j - 1][i - 1] = Inin[i + 1];
}
if (Inin[8] != 0)
dplotb.mbord[j - 1][6] = Inin[8];
}
else
{
/* Error -- Only digits 1 to 6 can be used for borders. */
ierr = 26;
goto L_1430;
}
k /= 10;
if (k != 0)
goto L_422;
goto L_300;
/* =3,4 Tick info. for various borders. Options 5 and 6 */
L_430:
i1 = 2*iaopt - 9;
i = Inin[1];
L_436:
j = i%10;
if ((j != 0) && (j <= 6))
{
dplotb.ticks[j - 1][i1 - 1] = Fpin[1];
dplotb.ticks[j - 1][i1] = Fpin[2];
}
else
{
/* Error -- Only digits 1 to 6 can be used for borders. */
ierr = 26;
goto L_1430;
}
i /= 10;
if (i != 0)
goto L_436;
goto L_300;
/* =5 Set ?MAX / ?MIN for current set. Options 8 and 9 */
L_450:
if (Fpin[1] < Fpin[2])
{
k = iaopt - 7;
if (Xymin[k] < Xymax[k])
{
/* Error -- min/max on x or y specified twice. */
ierr = 27;
goto L_1430;
}
Xymin[k] = Fpin[1];
Xymax[k] = Fpin[2];
}
goto L_300;
/* =6 Check NY. Option 2 */
L_460:
if (Ip[LNY] != Inin[2])
{
if (last == 5)
{
/* Error -- NY changed in middle of curve */
ierr = 28;
goto L_1430;
}
}
goto L_400;
/* =7 Change in data set, Option 7 */
L_470:
i = Inin[1];
iax = 2 - (i%2);
if (i <= 4)
{
if (Nxylim[iax] == 0)
{
/* Error -- Attempting to change data set without providing data. */
ierr = 29;
goto L_1430;
}
/* Take care of border being replaced */
dplota( i );
if (dplotb.iop1 <= -100)
goto L_1500;
/* Save data for data set being replaced */
lset += 1;
Nxylim[lset] = Nxylim[iax];
dplotb.xylim[lset - 1][0] = dplotb.xylim[iax - 1][0];
dplotb.xylim[lset - 1][1] = dplotb.xylim[iax - 1][1];
Xybase[lset] = Xybase[iax];
Xyu2pf[lset] = Xyu2pf[iax];
Klip[lset] = Klip[iax];
/* Set up for new data set. */
Nxylim[iax] = 0;
Xyu2pf[iax] = 0.e0;
Xymin[iax] = 0.e0;
Xymax[iax] = 0.e0;
dplotb.mbord[i - 1][7] = iax;
for (i = 1; i <= 7; i++)
{
dplotb.mbord[iax - 1][i - 1] = Inin[i + 2];
}
}
dplotb.phyuse[iax - 1][0] = Fpin[1];
dplotb.phyuse[iax - 1][1] = Fpin[2];
goto L_300;
/* =8 Set defaults for widths on out of range values. */
L_480:
Fpin[LWIDTH + 1] = fmod( Fpin[LWIDTH + 1]/10.e0, 100.e0 )/10.e0;
Fpin[LWIDTH + 2] = fmod( Fpin[LWIDTH + 2]/10.e0, 100.e0 )/10.e0;
for (i = 1; i <= 5; i++)
{
if (Fpin[i] <= 0.e0)
{
Fpin[i] = Fpdat[LWIDTH - 1 + i];
}
}
goto L_400;
/* =9 Special symbol plotting (may be more than 1 N10) */
L_490:
iop += 1;
i = iop;
L_495:
if (Opt[iop] < 0)
{
iop += 1;
goto L_495;
}
j = iop;
if (j - i >= Ip[LNY])
{
/* Error -- More symbols than allowed */
ierr = 30;
goto L_1430;
}
fwrite(&iaopt, sizeof(iaopt), (size_t)1, iotemp);
ictmp = j - i + 1;
fwrite(&ictmp, sizeof(ictmp), (size_t)1, iotemp);
for (k = i; k <= j; k++){
ictmp = abs(nint(opt[k-1]));
fwrite(&ictmp, sizeof(ictmp), (size_t)1, iotemp);}
if (dplotb.ip[LDEBUG-1] > 1) {
printf (fmt50, iaopt);
for (k = i; k <= j; k++){
printf(fmt55, (long)abs(nint(opt[k-1])));}
printf ("\n");}
goto L_300;
/* write (IOTEMP) IAOPT
* write (IOTEMP) J - I + 1, (nint(abs(OPT(K))), K = I, J)
*++ CODE for .C. is active
*++ CODE for ~.C. is inactive
* if (IP(LDEBUG).gt.1)
* 1 print 50, DB, IOTEMP, IAOPT, (nint(abs(OPT(K))), K = I,J)
*++ END */
/* =10 Single symbol (may require extra args.) */
L_500:
j = 1;
k = labs( nint( Opt[iop + 1] ) );
if ((k%10) == 1)
{
j = ((k/10)%10) + 3;
if (j >= 5)
{
if (j > 5)
{
/* Error -- Bad value for symbol plotting */
ierr = 31;
goto L_1430;
}
j = 3;
}
}
if (notout)
{
notout = FALSE;
fwrite(&iaopt, sizeof(iaopt), (size_t)1, iotemp);
}
/* write (IOTEMP) IAOPT
*++ CODE for ~.C. is inactive
* write (IOTEMP) J, FPIN(1), FPIN(2), nint(OPT(IOP+1)),
* 1 (OPT(I),I=IOP+2,IOP+J)
* if (IP(LDEBUG).gt.1) print 60, DB, IOTEMP, IAOPT, FPIN(1),
* 1 FPIN(2), nint(OPT(IOP+1)), (OPT(I),I=IOP+2,IOP+J)
*++ CODE for .C. is active */
fwrite(&j, sizeof(j), (size_t)1, iotemp);
fwrite(fpin, sizeof(fpin[0]), (size_t)2, iotemp);
ictmp = nint(opt[iop]);
fwrite(&ictmp, sizeof(ictmp), (size_t)1, iotemp);
fwrite(&opt[iop+1], sizeof(opt[0]), (size_t)(j-1), iotemp);
if (dplotb.ip[LDEBUG-1] > 1){
printf (fmt60, iaopt, fpin[0], fpin[1], nint(opt[iop]));
for (k=iop+2; k<=iop+j; k++) printf(fmt65,opt[k-1]);
printf ("\n");}
iop += j;
/*++ END */
goto L_300;
/* =11 For filling (may have up to 3 for each curve type) (scratch) */
L_510:
j = 0;
if (Inin[1] > 2)
j = Inin[1] - 1;
if (j > 3)
{
/* Error -- Digit 10^0 for option 19, must be < 5 */
ierr = 32;
goto L_1430;
}
if (notout)
{
notout = FALSE;
fwrite(&iaopt, sizeof(iaopt), (size_t)1, iotemp);
}
/* write (IOTEMP) IAOPT
*++ CODE for ~.C. is inactive
* write (IOTEMP) J,ININ(1),ININ(2),ININ(3), (OPT(I),I=IOP+1,IOP+J)
* if (IP(LDEBUG).gt.1) print 70,
* 1 IOTEMP, IAOPT, ININ(1),ININ(2),ININ(3), (OPT(I),I=IOP+1,IOP+J)
*++ CODE for .C. is active */
fwrite(&j, sizeof(j), (size_t)1, iotemp);
fwrite(&inin[0], sizeof(inin[0]), (size_t)3, iotemp);
fwrite(&opt[iop], sizeof(opt[iop]), (size_t)j, iotemp);
if (dplotb.ip[LDEBUG-1] > 1) {
printf(fmt70, iaopt, inin[0], inin[1], inin[2]);
for (i = iop; i < iop+j; i++) printf(fmt65, opt[i]);
printf ("\n");}
iop += j;
/*++ END */
goto L_300;
/* =? Invalid option (or maybe a bug in this code?) */
L_520:
ierr = 20;
goto L_1430;
/* =14 There follows in INACT, n, w, p, where
* n = number of integers
* w = defines where they go when processing options: 1 storage,
* 2 scratch, 3 both (NOT USED???)
* p = gives index in IP() where integers start. */
L_540:
if (Inact[iact + 2] >= 2)
{
if (notout)
{
notout = FALSE;
fwrite(&iaopt, sizeof(iaopt), (size_t)1, iotemp);
}
/* write (IOTEMP) IAOPT
*++ CODE for ~.C. is inactive
* write(IOTEMP) (ININ(I), I=LOCI,LOCI+INACT(IACT+1)-1)
* if (IP(LDEBUG).gt.1) print 80, DB, IOTEMP, IAOPT,(ININ(I),
* 1 I=LOCI,LOCI+INACT(IACT+1)-1)
*++ CODE for .C. is active */
fwrite(&inin[loci-1], sizeof(inin[0]), (size_t)inact[iact],
iotemp);
if (dplotb.ip[LDEBUG-1] > 1) {
printf(fmt80, iaopt);
for (i = loci-1; i < loci+inact[iact]-2; i++)
printf(fmt85, inin[i]);
printf ("\n");}
}
/*++ END */
if (Inact[iact + 2] != 2)
{
for (i = Inact[iact + 3]; i <= (Inact[iact + 3] + Inact[iact + 1] -
1); i++)
{
Ip[i] = Inin[loci];
loci += 1;
}
}
else
{
loci += Inact[iact + 1];
}
iact += 3;
goto L_400;
/* =15 As for 14, except for floating point data in FPIN(). */
L_550:
if (Inact[iact + 2] >= 2)
{
if (notout)
{
notout = FALSE;
fwrite(&iaopt, sizeof(iaopt), (size_t)1, iotemp);
}
/* write (IOTEMP) IAOPT
*++ CODE for ~.C. is inactive
* write(IOTEMP) (FPIN(I), I=LOCF,LOCF+INACT(IACT+1)-1)
* if (IP(LDEBUG).gt.1) print 90, DB, IOTEMP, IAOPT,(FPIN(I),
* 1 I=LOCF,LOCF+INACT(IACT+1)-1)
*++ CODE for .C. is active */
fwrite(&fpin[locf-1],sizeof(fpin[0]),(size_t)inact[iact],iotemp);
if (dplotb.ip[LDEBUG-1] > 1) {
printf(fmt90, iaopt);
for (i = locf-1; i < locf+inact[iact]-2; i++)
printf(fmt95, fpin[i]);
printf ("\n");}
}
/*++ END */
if (Inact[iact + 2] != 2)
{
for (i = Inact[iact + 3]; i <= (Inact[iact + 3] + Inact[iact + 1] -
1); i++)
{
Fp[i] = Fpin[locf];
locf += 1;
}
}
else
{
locf += Inact[iact + 1];
}
iact += 3;
goto L_400;
/* =16 Processing for text pointer. In all cases here, the text is
* acted upon immediately when read from the scratch file.
* There follows in INACT, k
* k = 9 For option 15, Sets format for next numeric output.
* k = 16 Text output for options 14 and 16. */
L_560:
iact += 1;
k = Inact[iact];
i = Inin[loci - 1];
if (i != 0)
{
ltext = i - 1;
}
else if (iopt != 14)
{
/* If not option 14, just flag that there is no text. */
ictmp = -1;
fwrite(&ictmp, sizeof(ictmp), (size_t)1, iotemp);
ictmp = 0;
fwrite(&ictmp, sizeof(ictmp), (size_t)1, iotemp);
fwrite(" ..", (size_t)1, (size_t)4, iotemp);
if (dplotb.ip[LDEBUG-1] > 1)
printf (fmt10, iaopt, (long)0, " ..");
goto L_400;
/* write (IOTEMP) -1, 0, ' ..'
* if (IP(LDEBUG).gt.1) print 10, DB, IOTEMP, IAOPT, 0, ' ..' */
}
f_subscpy( dplotc.pos, 60, 63, 68, " .." );
goto L_210;
/* *********** Done processing options, take care of X, Y, data ********
* */
L_700:
dplotb.iop1 = -1;
i1 = 1;
/* I1 is count of data to get when getting it from (X, Y). */
ny = Ip[LNY];
ndimy = Ip[LYDIM];
for (k = 1; k <= 2; k++)
{
dplotb.setlim[k - 1][0] = Xymin[k];
dplotb.setlim[k - 1][1] = Xymax[k];
/* Take logs of limmits if necessary. */
if (Xymin[k] < Xymax[k])
{
if (Ip[LCOOX] == 2)
{
dplotb.setlim[k - 1][0] = log10( Xymin[k] );
dplotb.setlim[k - 1][1] = log10( Xymax[k] );
}
}
}
if (nxi == 0)
goto L_780;
ictmp = 30;
fwrite(&ictmp, sizeof(ictmp), (size_t)1, iotemp);
fwrite(&lcurve, sizeof(lcurve), (size_t)1, iotemp);
fwrite(dplotb.jset, sizeof(dplotb.jset[0]), (size_t)2, iotemp);
fwrite(&ny, sizeof(ny), (size_t)1, iotemp);
if (dplotb.ip[LDEBUG-1]>1) printf(fmt130, lcurve, dplotb.jset[0],
dplotb.jset[1], (long)0, (long)0, ny);
L_710:
;
/* write (IOTEMP) 30
* write (IOTEMP) LCURVE, JSET(1), JSET(2), NY
*++ CODE for .C. is active
*++ CODE for ~.C. is inactive
* if (IP(LDEBUG).gt.1)
* 1 print 130, DB, IOTEMP, LCURVE,JSET(1),JSET(2),0,0,NY
*++ END
* Get min/max value and write data */
if (inunit != NULL) {
if (!fread(fpin, sizeof(fpin[0]), (size_t)(ny+1), inunit))
goto L_770;}
else{
Fpin[1] = X[i1];
/* if (INUNIT .gt. 0) then
* Get data off a file.
* read(INUNIT, *, END=770) FPIN(1), (FPIN(I+1), I = 1, NY)
* else */
for (i = 0; i <= (ny - 1); i++)
{
Fpin[i + 2] = Y[ndimy*i + i1];
}
};
if (Fp[LBAD] >= 0.e0)
{
/* end if
* Check for bad data value now to avoid confusion when taking logs.
* Check for and flag bad output points. */
Inin[1] = 0;
for (i = 1; i <= ny; i++)
{
Inin[i + 1] = 0;
if (Fpin[i + 1] == Fp[LBAD + 1])
Inin[i + 1] = 1;
}
if (Inin[1] != 0)
{
ictmp = 30;
fwrite(&ictmp, sizeof(ictmp), (size_t)1, iotemp);
fwrite(inin, sizeof(inin[0]), (size_t)(ny+1), iotemp);
}
/* write (IOTEMP) 32, (dble(ININ(I)), I=1,NY+1)
*++ CODE for .C. is active */
if (dplotb.ip[LDEBUG-1] > 1) {
printf(fmt120, (long)31);
for (i = 0; i <= ny; i++) printf(fmt125, (double) inin[i]);
printf ("\n");}
}
/*++ CODE for ~.C. is inactive
* if (IP(LDEBUG).gt.1)
* 1 print 120, DB, IOTEMP, 32, (dble(ININ(I)), I=1,NY+1)
*++ END
* Check if want logs */
if (Ip[LCOOX] == 2)
Fpin[1] = log10( Fpin[1] );
if (Ip[LCOOY] == 2)
{
for (i = 1; i <= ny; i++)
{
Fpin[i + 1] = log10( Fpin[i + 1] );
}
}
/* Establish initial minimum/maximum values */
tp1 = Fpin[2];
tp2 = tp1;
for (i = 2; i <= ny; i++)
{
tp1 = fmin( tp1, Fpin[i + 1] );
tp2 = fmax( tp2, Fpin[i + 1] );
}
if (Nxylim[1] == 0)
{
dplotb.xylim[0][0] = Fpin[1];
dplotb.xylim[0][1] = Fpin[1];
dplotb.xylim[1][0] = tp1;
dplotb.xylim[1][1] = tp2;
Nxylim[1] = Jset[1];
Nxylim[2] = Jset[2];
}
else
{
dplotb.xylim[0][0] = fmin( dplotb.xylim[0][0], Fpin[1] );
dplotb.xylim[0][1] = fmax( dplotb.xylim[0][1], Fpin[1] );
dplotb.xylim[1][0] = fmin( dplotb.xylim[1][0], tp1 );
dplotb.xylim[1][1] = fmax( dplotb.xylim[1][1], tp2 );
}
ictmp = 31;
fwrite(&ictmp, sizeof(ictmp), (size_t)1, iotemp);
fwrite(fpin, sizeof(fpin[0]), (size_t)(ny+1), iotemp);
if (dplotb.ip[LDEBUG-1] > 1) {
printf(fmt120, (long)31);
for (i = 0; i <= ny;i++) printf(fmt125, fpin[i]);
printf ("\n");}
i1 += 1;
/* write (IOTEMP) 31, (FPIN(I), I= 1, NY+1)
*++ CODE for .C. is active
*++ CODE for ~.C. is inactive
* if (IP(LDEBUG).gt.1)
* 1 print 120, DB, IOTEMP, 31, (FPIN(I), I=1,NY+1)
*++ END */
if (i1 <= nxi)
goto L_710;
/* Data now written, if any -- Write end mark */
L_770:
;
if (inunit != NULL) {
nxi = i1;
/* if (INUNIT .gt. 0) then */
fclose(inunit);
}
if (Ip[NEXT] < 5)
lcurve += 1;
/* close(INUNIT)
* end if */
L_780:
last = Ip[NEXT];
Fpin[1] = last;
ictmp = 33;
fwrite(&ictmp, sizeof(ictmp), (size_t)1, iotemp);
fwrite(fpin, sizeof(fpin[0]), (size_t)(ny+1), iotemp);
if (dplotb.ip[LDEBUG-1] > 1) {
printf(fmt120, (long)33);
for (i = 0; i <= ny; i++) printf(fmt125, fpin[i]);
printf ("\n");}
if (dplotb.ip[LDEBUG-1] > 1) printf(
"**************** End of Inputs ************* LAST = %li\n",last);
if (last > 2)
{
/* write (IOTEMP) 33, (FPIN(I), I = 1, NY+1)
*++ CODE for ~.C. is inactive
* if (IP(LDEBUG).gt.1)
* 1 print 120, DB, IOTEMP, 33, (FPIN(I), I=1,NY+1)
* if (IP(LDEBUG).gt.1) print
* 1 '(''**************** End of Inputs ************* LAST ='',I1)',
* 2 LAST
*++ CODE for .C. is active
*++ END */
if (dplotb.iop1 <= -100)
goto L_1510;
if (last == 3)
iosta = 1;
return;
}
dplotb.topts = Tptset[last + 1];
if (iosta > 0)
{
/*++ CODE for ~.C. is inactive
* IOTMP1 = IOTEMP
* DB = 'B'
* call DPLOTU (IOTMP2, ' ')
* if (IOP1 .le. -100) go to 1500
* rewind(IOTEMP)
*++ CODE for .C. is active */
iotmp1 = iotemp;
iotmp2 = tmpfile();
if (iotmp2 == NULL) goto L_1500;
rewind(iotemp);
if (Ip[LDEBUG] > 1)
{
printf("Rewind IOTEMP\n");
}
/*++ END */
}
/* *********************** Start Processing Saved Data ******************
*
* Take care of axes, get max's and min's, draw lines a x=0, y=0, etc. */
L_800:
for (i = 1; i <= 6; i++)
{
dplota( i );
}
/*++ CODE for ~.C. is inactive
* DB = 'R'
*++ END */
if (dplotb.iop1 <= -100)
goto L_1500;
dplotb.noout = FALSE;
L_830:
kx = 1;
ky = 1;
/* Set "17" (file name) as already output. */
dplotb.lentxt[16][0] = -1;
dplotb.lentxt[16][2] = -1;
iy = 1;
ksymb = -1;
mode = 0;
L_840:
nmode = 10;
/* Points are connected, take care of them. */
L_860:
moreiy = FALSE;
Ip[INTERP] = 0;
if (iosta <= 0)
{
if (Ip[LDEBUG] > 1)
{
printf("Rewind IOTEMP\n");
}
rewind(iotemp);
}
/* rewind(IOTEMP) */
L_890:
;
fread(&iaopt, sizeof(iaopt), (size_t)1, iotemp);
if (iosta != 0)
{
/* read (IOTEMP) IAOPT */
if (iosta > 0)
{
fwrite(&iaopt, sizeof(iaopt), (size_t)1, iotmp2);
}
else if (iaopt >= 30)
{
/* write (IOTMP2) IAOPT */
if (iaopt == 33)
goto L_1300;
if (iy <= 1)
goto L_890;
}
}
iact = Linact[iaopt] - 1;
loci = 1;
locf = 1;
L_900:
iact += 1;
if (iact >= Linact[iaopt + 1])
goto L_890;
/* 9 10 11 12 13 14 15 16 17 18 19 20 21 22 */
switch (Inact[iact] - 8)
{
case 1: goto L_920;
case 2: goto L_930;
case 3: goto L_940;
case 4: goto L_910;
case 5: goto L_910;
case 6: goto L_950;
case 7: goto L_960;
case 8: goto L_970;
case 9: goto L_990;
case 10: goto L_980;
case 11: goto L_910;
case 12: goto L_1000;
case 13: goto L_1200;
case 14: goto L_1300;
}
L_910:
goto L_900;
/* Special Symbol plotting -- 9 */
L_920:
;
/*++ CODE for ~.C. is inactive
* read (IOTEMP) L, (ININ(I), I = 1, L)
* if (IOSTA .gt. 0) write (IOTMP2) L, (ININ(I), I = 1, L)
* if (IP(LDEBUG).gt.1)
* 1 print 50, DB, IOTEMP, IAOPT, (ININ(I), I = 1, L)
*++ CODE for .C. is active */
fread(&l, sizeof(l), (size_t)1, iotemp);
fread(inin, sizeof(inin[0]), (size_t)l, iotemp);
if (iosta > 0) {
fwrite(&l, sizeof(l), (size_t)1, iotmp2);
fwrite(inin, sizeof(inin[0]), (size_t)l, iotmp2);}
if (dplotb.ip[LDEBUG-1] > 1) {
printf (fmt50, iaopt);
for (i = 0; i < l; i++) printf(fmt55, inin[i]);
printf ("\n");}
ksymb = labs( Inin[min( l, iy )] );
/*++ END */
goto L_900;
/* Single symbol to plot -- 10 */
L_930:
;
/*++ CODE for ~.C. is inactive
* read (IOTEMP) L, FPIN(1), FPIN(2), J, (FPIN(I-1), I = 4, L+2)
* if (IOSTA .gt. 0) write (IOTMP2) L, FPIN(1), FPIN(2), J,
* 1 (FPIN(I-1), I = 4, L+2)
* if (IP(LDEBUG).gt.1) print 60, DB, IOTEMP, IAOPT, FPIN(1),
* 1 FPIN(2), J, (FPIN(I-1), I = 4, L+2)
*++ CODE for .C. is active */
fread(&l, sizeof(l), (size_t)1, iotemp);
fread(fpin, sizeof(fpin[0]), (size_t)2, iotemp);
fread(&j, sizeof(j), (size_t)1, iotemp);
fread(&fpin[2], sizeof(fpin[0]), (size_t)(l-1), iotemp);
if (iosta > 0) {
fwrite(&l, sizeof(l), (size_t)1, iotmp2);
fwrite(fpin, sizeof(fpin[0]), (size_t)2, iotmp2);
fwrite(&j, sizeof(j), (size_t)1, iotmp2);
fwrite(&fpin[2], sizeof(fpin[0]), (size_t)(l-1), iotmp2);}
if (dplotb.ip[LDEBUG-1] > 1){
printf (fmt60, iaopt, fpin[0], fpin[1], j);
for (i=2; i<=l+2; i++) printf(fmt65,fpin[i]);
printf ("\n");}
if (mode < 7)
{
/*++ END */
nmode = min( nmode, 7 );
}
else
{
kx = 1;
ky = 2;
dplotr( fpin, j, kx, ky );
}
goto L_900;
/* For Filling -- 11 */
L_940:
;
/*++ CODE for ~.C. is inactive
* read (IOTEMP) L,ININ(1),ININ(2),ININ(3),(FPIN(I),I=1, L)
* if (IOSTA .gt. 0) write (IOTMP2) L, ININ(1), ININ(2),
* 1 ININ(3), (FPIN(I), I=1, L)
* if (IP(LDEBUG).gt.1)
* 1 print 70, DB, IOTEMP, IAOPT, ININ(1),ININ(2),ININ(3),
* 2 (FPIN(I),I=1, L)
*++ CODE for .C. is active */
fread(&l, sizeof(l), (size_t)1, iotemp);
fread(inin, sizeof(inin[0]), (size_t)3, iotemp);
fread(fpin, sizeof(fpin[0]), (size_t)l, iotemp);
if (iosta > 0) {
fwrite(&l, sizeof(l), (size_t)1, iotmp2);
fwrite(inin, sizeof(inin[0]), (size_t)3, iotmp2);
fwrite(fpin, sizeof(fpin[0]), (size_t)l, iotmp2);}
if (dplotb.ip[LDEBUG-1] > 1) {
printf(fmt70, iaopt, inin[0], inin[1], inin[2]);
for (i = iop; i < iop+l; i++) printf(fmt65, opt[i]);
printf ("\n");}
j = Inin[2];
/*++ END */
if (Inin[1] == 0)
{
Mfill[j] = 0;
}
else
{
Mfill[j] = min( Mfill[j] + 1, 3 );
lfill[Inin[2] - 1][Mfill[j] - 1] = Inin[1];
if (Inin[3] > 0)
Mfill[j] = -Mfill[j];
if (l > 0)
{
k = 1;
if (l == 3)
k = 7;
Fill[k] = Fpin[1];
Fill[k + 1] = Fpin[2];
if (l == 3)
Fill[k + 2] = Fpin[3];
}
}
goto L_900;
/* Integers to restore. */
L_950:
if (Inact[iact + 2] != 1)
{
l = Inact[iact + 1];
j = Inact[iact + 3];
/*++ CODE for ~.C. is inactive
* read(IOTEMP) (IP(J+I-1), I=1, L)
* if (IOSTA .gt. 0) write (IOTMP2) (IP(J+I-1), I=1, L)
* if (IP(LDEBUG).gt.1)
* 1 print 80, DB, IOTEMP, IAOPT, (IP(J+I-1), I=1, L)
*++ CODE for .C. is active */
fread(&dplotb.ip[j], sizeof(dplotb.ip[0]), (size_t)l, iotemp);
if (iosta > 0) fwrite(dplotb.ip, sizeof(dplotb.ip[0]),
(size_t)l, iotmp2);
if (dplotb.ip[LDEBUG-1] > 1) {
printf(fmt80, iaopt);
for (i = j-1; i < j+l-2; i++) printf(fmt85, dplotb.ip[i]);
printf ("\n");}
}
/*++ END */
iact += 3;
if (iaopt == 1)
{
if (mode <= 5)
{
mode = Ip[INTERP];
if (dplotb.ip[LDEBUG-1]>1) printf("MODE set to %li", mode);
}
/* if (IP(LDEBUG).gt.1) print '('' MODE set to'', I2)', MODE */
}
goto L_900;
/* Floating point to restore */
L_960:
if (Inact[iact + 2] != 1)
{
l = Inact[iact + 1];
j = Inact[iact + 3];
/*++ CODE for ~.C. is inactive
* read(IOTEMP) (FP(J+I-1), I=1, L)
* if (IOSTA .gt. 0) write (IOTMP2) (FP(J+I-1), I=1, L)
* if (IP(LDEBUG).gt.1)
* 1 print 90, DB, IOTEMP, IAOPT, (FP(J+I-1), I=1, L)
*++ CODE for .C. is active */
fread(&dplotb.fp[j-1], sizeof(dplotb.fp[0]),(size_t)l,iotemp);
if (iosta > 0) fwrite(&dplotb.fp[j-1], sizeof(dplotb.fp[0]),
(size_t)l, iotmp2);
if (dplotb.ip[LDEBUG-1] > 1) {
printf(fmt90, iaopt);
for (i = j-1; i < j+l-2; i++) printf(fmt95, dplotb.fp[i]);
printf ("\n");}
}
/*++ END */
iact += 3;
goto L_900;
/* Text to restore */
L_970:
iact += 1;
k = Inact[iact];
if (k != 9)
{
/*++ CODE for ~.C. is inactive
* read (IOTEMP) LENTXT(1,16), NTEXT, POS(61:64)
* if (IOSTA .gt. 0) write (IOTMP2) LENTXT(1,16), NTEXT,
* 1 POS(61:64)
* if (IP(LDEBUG).gt.1)
* 1 print 10, DB, IOTEMP, IAOPT, LENTXT(1,16), POS(61:64)
*++ CODE for .C. is active */
fread (&dplotb.lentxt[15][0], sizeof(dplotb.lentxt[0][0]),
(size_t)1, iotemp);
fread(&dplotb.ntext, sizeof(dplotb.ntext), (size_t)1, iotemp);
fread(&dplotc.pos[60], (size_t)1, (size_t)4, iotemp);
if (iosta > 0) {
fwrite(&dplotb.lentxt[15][0],
sizeof(dplotb.lentxt[0][0]),(size_t)1,iotmp2);
fwrite(&dplotb.ntext,sizeof(dplotb.ntext),(size_t)1,iotmp2);
fwrite(&dplotc.pos[60], (size_t)1, (size_t)4, iotmp2);}
if (dplotb.ip[LDEBUG-1] > 1) printf (fmt10, iaopt,
dplotb.lentxt[15][0], &dplotc.pos[60]);
if (dplotb.lentxt[15][0] > 0)
{
/*++ END
*++ CODE for ~.C. is inactive
* read (IOTEMP) FMTNUM(16)(1:LENTXT(1,16))
* if (IOSTA .gt. 0) write (IOTMP2) FMTNUM(16)(1:LENTXT(1,16))
* if (IP(LDEBUG).gt.1) print 20,
* 1 IOTMP2, IAOPT,FMTNUM(16)(1:LENTXT(1,16))
*++ CODE for .C. is active */
fread(dplotc.fmtnum[15], (size_t)1,
(size_t)dplotb.lentxt[15][0], iotemp);
if (iosta > 0) fwrite(dplotc.fmtnum[15], (size_t)1,
(size_t)dplotb.lentxt[15][0], iotemp);
if (dplotb.ip[LDEBUG-1] > 0) printf (fmt20, iaopt,
(int)dplotb.lentxt[15][0], dplotc.fmtnum[15]);
}
/*++ END */
if (dplotb.ntext != 0)
{
/*++ CODE for ~.C. is inactive
* read (IOTEMP) TEXT(1:NTEXT)
* if (IOSTA .gt. 0) write (IOTMP2) TEXT(1:NTEXT)
* if (IP(LDEBUG).gt.1)
* 1 print 30, DB, IOTEMP, IAOPT, TEXT(1:NTEXT)
*++ CODE for .C. is active */
fread(dplotc.text, (size_t)1, (size_t)dplotb.ntext, iotemp);
if (iosta > 0) fwrite(dplotc.text, (size_t)1,
(size_t)dplotb.ntext, iotmp2);
if (dplotb.ip[LDEBUG-1] > 1) printf (fmt30, iaopt,
(int)(dplotb.ntext), dplotc.text);
}
/*++ END */
}
else if (iaopt != 14)
{
/*++ CODE for ~.C. is inactive
* read(IOTEMP) LENTXT(1, 9), LENTXT(2, 9), POS(33:36)
* if (IOSTA .gt. 0) write (IOTMP2) LENTXT(1, 9),
* 1 LENTXT(2, 9), POS(33:36)
* if (IP(LDEBUG).gt.1) print 10, DB, IOTEMP, IAOPT, 0, ' ..'
*++ CODE for .C. is active */
fread(&dplotb.lentxt[8][0], sizeof(dplotb.lentxt[8][0]),
(size_t)2, iotemp);
fread(&dplotc.pos[32], (size_t)1, (size_t)4, iotemp);
if (iosta > 0) {
fwrite(&dplotb.lentxt[8][0], sizeof(dplotb.lentxt[8][0]),
(size_t)2, iotmp2);
fwrite(&dplotc.pos[32], (size_t)1, (size_t)4, iotmp2);}
if (dplotb.ip[LDEBUG-1] > 1) printf (fmt10, iaopt,
(long)0, " ..");
}
else
{
/*++ END
*++ CODE for ~.C. is inactive
* read (IOTEMP) (LENTXT(K, 9), K = 1, 3), POS(33:36)
* if (IOSTA .gt. 0) write (IOTMP2)
* 1 (LENTXT(K, 9), K = 1, 3), POS(33:36)
* if (IP(LDEBUG).gt.1) print 40, DB, IOTEMP, IAOPT,
* 1 (LENTXT(K, 9), K = 1, 3), POS(33:36)
*++ CODE for .C. is active */
fread(&dplotb.lentxt[8][0], sizeof(dplotb.lentxt[8][0]),
(size_t)3, iotemp);
fread(&dplotc.pos[32], (size_t)1, (size_t)4, iotemp);
if (iosta > 0) {
fwrite(&dplotb.lentxt[8][0], sizeof(dplotb.lentxt[8][0]),
(size_t)3, iotmp2);
fwrite(&dplotc.pos[32], (size_t)1, (size_t)4, iotmp2);}
if (dplotb.ip[LDEBUG-1] > 1) printf (fmt40, iaopt,
dplotb.lentxt[8][0], dplotb.lentxt[8][1],dplotb.lentxt[8][2],
&dplotc.pos[32]);
if (dplotb.lentxt[8][0] > 0)
{
/*++ END
*++ CODE for ~.C. is inactive
* read (IOTEMP) FMTNUM(9)(1:LENTXT(1,9))
* if (IOSTA .gt. 0) write (IOTMP2)
* 1 FMTNUM(9)(1:LENTXT(1,9))
* if (IP(LDEBUG).gt.1)
* 1 print 20, DB, IOTEMP, IAOPT,FMTNUM(9)(1:LENTXT(1,9))
*++ CODE for .C. is active */
fread(dplotc.fmtnum[8], (size_t)1,
(size_t)dplotb.lentxt[15][0], iotemp);
if (iosta > 0) fwrite(dplotc.fmtnum[8], (size_t)1,
(size_t)dplotb.lentxt[15][0], iotemp);
if (dplotb.ip[LDEBUG-1] > 0) printf (fmt20, iaopt,
(int)dplotb.lentxt[15][0], dplotc.fmtnum[8]);
}
/*++ END */
if (dplotb.lentxt[8][2] > 0)
{
/*++ CODE for ~.C. is inactive
* read (IOTEMP) TXTDEF(9)(1:LENTXT(3,9))
* if (IOSTA .gt. 0) write (IOTMP2) TXTDEF(9)(1:LENTXT(3,9))
* if (IP(LDEBUG).gt.1)
* 1 print 30, DB, IOTEMP, IAOPT,TXTDEF(9)(1:LENTXT(3,9))
*++ CODE for .C. is active */
fread(dplotc.txtdef[8], (size_t)1,
(size_t)dplotb.lentxt[8][2], iotemp);
if (iosta > 0) fwrite(dplotc.txtdef[8], (size_t)1,
(size_t)dplotb.lentxt[8][2], iotmp2);
if (dplotb.ip[LDEBUG-1] > 1) printf (fmt30, iaopt,
(int)(dplotb.lentxt[8][2]), dplotc.txtdef[8]);
}
/*++ END */
}
if (mode < 9)
{
nmode = min( nmode, 9 );
}
else if (mode == 9)
{
/* Output the text */
if (iaopt != 16)
{
if ((dplotb.ntext == 0) && (iaopt == 14))
goto L_900;
i = Ip[LTANNO];
dplotb.opaque = FALSE;
if (i > 3)
{
/* Want placed in an opaque box. */
dplotb.opaque = TRUE;
i -= 4;
}
/* Set up for differences between output of numbers and text */
k1 = 4*k;
l1 = 7;
if (k == 9)
{
l1 = 8;
Fp[LVALS + 3] = Fp[LVALS];
Fp[LVALS] = Fp[LVALS + 1];
Fp[LVALS + 1] = Fp[LVALS + 2];
}
k2 = 4*l1;
if (memcmp(dplotc.pos+k1-4, " ..", (size_t)4) == 0)
memcpy(dplotc.pos+k1-4, dplotc.pos+k2-4,(size_t)4);
if (i >= 2)
{
/* if (POS(K1-3:K1) .eq. ' ..') POS(K1-3:K1) = POS(K2-3:K2)
* Set to avoid the formatting. */
i -= 2;
k = 17;
memcpy(dplotc.pos+64, dplotc.pos+k1-4,(size_t)4);
}
else
{
/* POS(65:68) = POS(K1-3:K1)
* Set up the formatting */
if (dplotb.lentxt[k - 1][0] < 0)
{
dplotb.lentxt[k - 1][0] = dplotb.lentxt[l1 - 1][0];
/*++ CODE for .C. is active */
if (dplotb.lentxt[l1 - 1][0] > 0)
memcpy(dplotc.fmtnum[k-1],dplotc.fmtnum[l1-1],
dplotb.lentxt[l1 - 1][0]);
}
/*++ CODE for ~.C. is inactive
* if (LENTXT(1,L1).gt. 0) FMTNUM(K)(1:LENTXT(1,K)) =
* 1 FMTNUM(L1)(1:LENTXT(1, L1))
*++ END */
dplotb.lentxt[k - 1][2] = dplotb.lentxt[l1 - 1][2];
if (dplotb.lentxt[l1 - 1][2] > 0)
{
dplotb.lentxt[k - 1][1] = dplotb.lentxt[l1 - 1][1];
memcpy(dplotc.txtdef[k-1],dplotc.txtdef[l1-1],
dplotb.lentxt[l1-1][2]);
}
/* TXTDEF(K)(1:) = TXTDEF(L1)(1:LENTXT(3, L1)) */
}
for (j = 0; j <= 1; j++)
{
if (Ip[LCOOX + j] == 2)
{
Fp[LVALS + j] = log10( Fp[LVALS + j] );
}
}
if (i == 0)
{
/* Convert to physical coordinates */
dplotb.manno = -1;
Xypos[1] = Xybase[kx] + Xyu2pf[kx]*Fp[LVALS];
Xypos[2] = Xybase[ky] + Xyu2pf[ky]*Fp[LVALS + 1];
}
else
{
dplotb.manno = 1;
Xypos[1] = dplotb.topts*Fp[LVALS];
Xypos[2] = dplotb.topts*Fp[LVALS + 1];
}
if (l1 == 7)
{
dplott( k, xypos );
}
else
{
dplotn( Fp[LVALS + 3], k, xypos );
}
dplotb.manno = 0;
}
else
{
/* Text for Axis/Border Annotation -- Must be processed in DPLOTA. */
dplota( Ip[LTANNO + 1] + 10 );
if (dplotb.iop1 <= -100)
goto L_1500;
}
}
goto L_900;
/* Rectangles ellipses and lines. */
L_980:
if (mode < 8)
{
nmode = min( nmode, 8 );
goto L_900;
}
if (iaopt <= 21)
{
/* Convert to physical coordinates (only first two for ellipse */
Xout[1] = Xybase[kx] + Xyu2pf[kx]*Fp[LVALS];
Yout[1] = Xybase[ky] + Xyu2pf[ky]*Fp[LVALS + 1];
if (iaopt != 21)
{
Xout[2] = Xybase[kx] + Xyu2pf[kx]*Fp[LVALS + 2];
Yout[2] = Xybase[ky] + Xyu2pf[ky]*Fp[LVALS + 3];
}
}
else
{
/* Conver physical coordinates to points. */
iaopt -= 3;
Xout[1] = dplotb.topts*Fp[LVALS];
Yout[1] = dplotb.topts*Fp[LVALS + 1];
Xout[2] = dplotb.topts*Fp[LVALS + 2];
Yout[2] = dplotb.topts*Fp[LVALS + 3];
if (iaopt == 21)
{
Fp[LVALS + 2] = Xout[3];
Fp[LVALS + 3] = Xout[4];
}
}
if (iaopt == 19)
{
/* Draw a line */
dplotd.kurpen = Ip[LPEN];
dplot2( Xout[1], Yout[1], Xout[2], Yout[2] );
}
else if (iaopt == 20)
{
/* Draw a rectangle */
dplotd.kurpen = Fp[LWIDRE];
if (Mfill[2] != 0)
dplot7( &Mfill[2], &lfill[1][0], dplotb.fill );
dplot5( Xout[1], Yout[1], Xout[2], Yout[2] );
}
else
{
/* Draw an ellipse */
dplotd.kurpen = Fp[LWIDRE];
if (Mfill[3] != 0)
dplot7( &Mfill[3], &lfill[2][0], dplotb.fill );
dplot6( Xout[1], Yout[1], Fp[LVALS + 2], Fp[LVALS + 3], Fp[LVALS + 4] );
}
goto L_900;
/* Raw MFPIC output */
L_990:
;
fread(&dplotb.ntext, sizeof(dplotb.ntext), (size_t)1, iotemp);
fread(dplotc.text, (size_t)1, (size_t)(dplotb.ntext), iotemp);
if (iosta > 0) {
fwrite(&dplotb.ntext, sizeof(dplotb.ntext), (size_t)1, iotemp);
fwrite(dplotc.text, (size_t)1, (size_t)(dplotb.ntext), iotemp);}
if (dplotb.ip[LDEBUG-1] > 1) printf (fmt30, iaopt,
(int)(dplotb.ntext), dplotc.text);
if (mode < 9)
{
/* read(IOTEMP) NTEXT, TEXT(1:NTEXT)
* if (IOSTA .gt. 0) write (IOTMP2) NTEXT, TEXT(1:NTEXT)
* if (IP(LDEBUG).gt.1) print 30, DB, IOTEMP, IAOPT, TEXT(1:NTEXT) */
nmode = min( nmode, 9 );
}
else if (mode == 9)
{
/* Output the text */
fprintf(iofil, "%.*s\n", (int)dplotb.ntext, dplotc.text);
}
/* write (IOFIL, '(A)') TEXT(1:NTEXT) */
goto L_900;
/* New data start */
L_1000:
;
fread(&i, sizeof(i), (size_t)1, iotemp);
fread(&j, sizeof(j), (size_t)1, iotemp);
fread(&k, sizeof(k), (size_t)1, iotemp);
fread(&ny, sizeof(ny), (size_t)1, iotemp);
if (dplotb.ip[LDEBUG-1] > 1) printf(fmt130,i, j, k, mode, iy, ny);
if (iy <= ny)
{
/* read (IOTEMP) I, J, K, NY
*++ CODE for .C. is active
*++ CODE for ~.C. is inactive
* if (IP(LDEBUG) .gt. 1)
* 1 print 130, DB, IOTEMP, I, J, K, MODE, IY, NY
*++ END */
ly = iy;
/* Keep track of last that needs to be done again. */
datsav = FALSE;
if (iy < ny)
{
moreiy = TRUE;
if (iosta > 0)
{
fwrite(&i, sizeof(i), (size_t)1, iotmp2);
fwrite(&j, sizeof(j), (size_t)1, iotmp2);
fwrite(&k, sizeof(k), (size_t)1, iotmp2);
fwrite(&ny, sizeof(ny), (size_t)1, iotmp2);
datsav = TRUE;
/* write (IOTMP2) I, J, K, NY */
}
}
if (mode <= 4)
{
if (ksymb >= 0)
{
nmode = 6;
ksymb = -1;
}
goto L_1020;
}
else if (mode <= 6)
{
if (ksymb >= 0)
{
/* Adjust LY in some cases */
if ((ksymb%10) == 1)
{
ly = 3;
if (((ksymb/10)%10) == 0)
ly = 2;
ly = 1 + ly*(iy - 1);
}
if ((mode != 6) || (Ip[INTERP] < 5))
goto L_1025;
}
else if (mode != 6)
{
/* Points have been provided, but they are not plotted. */
dplote( 1, opt, copt );
}
}
}
/* Consume till get to the end of a data set. */
L_1010:
;
fread(&iaopt, sizeof(iaopt), (size_t)1, iotemp);
fread(fpin, sizeof(fpin[0]), (size_t)(ny+1), iotemp);
if (dplotb.ip[LDEBUG-1] > 1) {
printf(fmt120, iaopt);
for (i = 0; i <= ny; i++) printf(fmt125, fpin[i]);
printf ("\n");}
if (iaopt != 33)
goto L_1010;
/* read (IOTEMP) IAOPT, (FPIN(J), J = 1, NY+1)
*++ CODE for .C. is active
*++ CODE for ~.C. is inactive
* if (IP(LDEBUG) .gt. 1)
* 1 print 120, DB, IOTEMP, IAOPT, (FPIN(J), J = 1,NY+1)
*++ END */
goto L_1170;
/* Get pen set */
L_1020:
dplotd.kurpen = Ip[LPEN];
dplot1();
/* Process the data */
L_1025:
for (i = 1; i <= lset; i++)
{
if (Nxylim[i] == j)
goto L_1040;
}
puts( "Error -- Internal bug, couldn't find X index" );
exit(0);
L_1040:
kx = i;
/* stop 'Error -- Internal bug, couldn''t find X index' */
for (i = 1; i <= lset; i++)
{
if (Nxylim[i] == k)
goto L_1070;
}
puts( "Error -- Internal bug, couldn't find Y index" );
exit(0);
L_1070:
if (last == 5)
goto L_1120;
/* stop 'Error -- Internal bug, couldn''t find Y index' */
kpt = 0;
ky = i;
/* Set up for type of curve, clipping, etc. */
L_1080:
badpt = FALSE;
lklip = FALSE;
if (mode < 5)
{
dplotl( -1 - mode, xout, yout );
if (mode <= 2)
{
/* Initialize DPLOTF */
k = -1;
if (Klip[kx] || Klip[ky])
k = -3;
dplotf( k, xout, &dplotb.xylim[kx - 1][0], &dplotb.xylim[ky - 1][0] );
if (dplotb.iop1 <= -100)
goto L_1500;
}
}
if (iaopt == 31)
goto L_1180;
L_1120:
;
/*++ CODE for ~.C. is inactive
* read (IOTEMP) IAOPT, (FPIN(J), J = 1, NY+1)
* if (DATSAV) write (IOTMP2) IAOPT, (FPIN(J), J = 1, NY+1)
* if (IP(LDEBUG) .gt. 1)
* 1 print 120, DB, IOTEMP, IAOPT, (FPIN(J), J = 1, NY+1)
*++ CODE for .C. is active */
fread(&iaopt, sizeof(iaopt), (size_t)1, iotemp);
fread(fpin, sizeof(fpin[0]), (size_t)(ny+1), iotemp);
if (datsav) {
fwrite(&iaopt, sizeof(iaopt), (size_t)1, iotmp2);
fwrite(fpin, sizeof(fpin[0]), (size_t)(ny+1), iotmp2);}
if (dplotb.ip[LDEBUG-1] > 1) {
printf(fmt120, iaopt);
for (i = 0; i <= ny; i++) printf(fmt125, fpin[i]);
printf ("\n");}
if (iaopt == 31)
goto L_1180;
/*++ END
* Check cases: 31 => good data, 32 => bad data. */
if (iaopt == 32)
{
if (Fpin[ly + 1] == 0.e0)
goto L_1120;
/* Have a bad Y, skip the data points.
*++ CODE for ~.C. is inactive
* read (IOTEMP) IAOPT, (FPIN(J), J = 1, NY+1)
* if (DATSAV) write (IOTMP2) IAOPT, (FPIN(J), J = 1, NY+1)
* if (IP(LDEBUG) .gt. 1)
* 1 print 120, DB, IOTEMP, IAOPT, (FPIN(J), J=1,NY+1)
*++ CODE for .C. is active */
fread(&iaopt, sizeof(iaopt), (size_t)1, iotemp);
fread(fpin, sizeof(fpin[0]), (size_t)(ny+1), iotemp);
if (datsav) {
fwrite(&iaopt, sizeof(iaopt), (size_t)1, iotmp2);
fwrite(fpin, sizeof(fpin[0]), (size_t)(ny+1), iotmp2);}
if (dplotb.ip[LDEBUG-1] > 1) {
printf(fmt120, iaopt);
for (i = 0; i <= ny; i++) printf(fmt125, fpin[i]);
printf ("\n");}
if ((Fp[LBAD] == 0.e0) || (ksymb > 0))
goto L_1120;
/*++ END
* Point is not simply ignored. End this curve and start a new one. */
badpt = TRUE;
}
else
{
/* Curve is being continued */
last = nint( Fpin[1] );
if (last == 5)
goto L_890;
}
/* Finish current curve segment. */
if (mode <= 2)
{
if (kpt > 0)
dplotf( kpt, xout, xout, yout );
dplotf( 0, xout, xout, yout );
if (dplotb.iop1 <= -100)
goto L_1500;
}
else
{
if (kpt > 0)
dplotl( kpt, xout, yout );
dplotl( 0, xout, yout );
}
if (badpt)
{
/* Consume till we get a good point. */
L_1160:
;
/*++ CODE for ~.C. is inactive
* read (IOTEMP) IAOPT, (FPIN(J), J = 1, NY+1)
* if (DATSAV) write (IOTMP2) IAOPT, (FPIN(J), J = 1, NY+1)
* if (IP(LDEBUG) .gt. 1)
* 1 print 120, DB, IOTEMP, IAOPT, (FPIN(J), J=1,NY+1)
*++ CODE for .C. is active */
fread(&iaopt, sizeof(iaopt), (size_t)1, iotemp);
fread(fpin, sizeof(fpin[0]), (size_t)(ny+1), iotemp);
if (datsav) {
fwrite(&iaopt, sizeof(iaopt), (size_t)1, iotmp2);
fwrite(fpin, sizeof(fpin[0]), (size_t)(ny+1), iotmp2);}
if (dplotb.ip[LDEBUG-1] > 1) {
printf(fmt120, iaopt);
for (i = 0; i <= ny; i++) printf(fmt125, fpin[i]);
printf ("\n");}
if (iaopt == 32)
{
/*++ END */
if (Fpin[ly + 1] != 0.e0)
{
/*++ CODE for ~.C. is inactive
* read (IOTEMP) IAOPT, (FPIN(J), J = 1, NY+1)
* if (DATSAV) write (IOTMP2) IAOPT, (FPIN(J), J = 1, NY+1)
* if (IP(LDEBUG).gt.1)
* 1 print 120, DB, IOTEMP, IAOPT,(FPIN(J),J=1,NY+1)
*++ CODE for .C. is active */
fread(&iaopt, sizeof(iaopt), (size_t)1, iotemp);
fread(fpin, sizeof(fpin[0]), (size_t)(ny+1), iotemp);
if (datsav) {
fwrite(&iaopt, sizeof(iaopt), (size_t)1, iotmp2);
fwrite(fpin, sizeof(fpin[0]), (size_t)(ny+1), iotmp2);}
if (dplotb.ip[LDEBUG-1] > 1) {
printf(fmt120, iaopt);
for (i = 0; i <= ny; i++) printf(fmt125, fpin[i]);
printf ("\n");}
goto L_1160;
/*++ END */
}
}
}
/* If IAOPT .eq. 31, we have a point for a new curve. */
if (iaopt == 31)
goto L_1080;
/* Done with the current curve. */
L_1170:
ksymb = -1;
last = nint( Fpin[1] );
if (last <= 3)
{
if (moreiy)
{
iy += 1;
if (datsav)
{
iosta = -1;
iotemp = iotmp2;
}
else
{
/* IOTEMP = IOTMP2 */
if (Ip[LDEBUG] > 1)
{
printf("Rewind IOTEMP\n");
}
rewind(iotemp);
}
/* rewind(IOTEMP) */
goto L_860;
}
/* Done with one mfpic segment. */
if (iosta > 0)
{
/* Switch to second scratch file. */
iosta = -1;
/* Following write serves as an endfile. */
fwrite(&iaopt, sizeof(iaopt), (size_t)1, iotmp2);
iotemp = iotmp2;
}
/* write(IOTMP2) IAOPT
* IOTEMP = IOTMP2 */
mode = nmode;
if (mode != 10)
goto L_840;
goto L_1300;
}
if (mode <= 5)
{
mode = 0;
Ip[INTERP] = 0;
}
goto L_890;
/* Convert to physical coordinates and send point out. */
L_1180:
kpt += 1;
Xout[kpt] = Xybase[kx] + Xyu2pf[kx]*Fpin[1];
Yout[kpt] = Xybase[ky] + Xyu2pf[ky]*Fpin[ly + 1];
if (mode >= 2)
{
/* Check for clipping */
if (Klip[kx] || Klip[ky])
{
if ((((Xout[kpt] < dplotb.xylim[kx - 1][0]) || (Xout[kpt] >
dplotb.xylim[kx - 1][1])) || (Yout[kpt] < dplotb.xylim[ky - 1][0])) ||
(Xout[kpt] > dplotb.xylim[ky - 1][1]))
{
if (ksymb >= 0)
goto L_1120;
if (lklip)
{
Xout[1] = Xout[2];
Yout[1] = Yout[2];
goto L_1120;
}
lklip = TRUE;
if (kpt == 1)
goto L_1120;
k1 = kpt - 1;
k2 = kpt;
}
else if (lklip)
{
lklip = FALSE;
k1 = 2;
k2 = 1;
}
else
{
goto L_1190;
}
/* Make up fake point */
Fpin[1] = Xout[k2];
Fpin[2] = Yout[k2];
if ((Fpin[1] < dplotb.xylim[kx - 1][0]) || (Fpin[1] >
dplotb.xylim[kx - 1][1]))
{
Xout[k2] = fmax( dplotb.xylim[kx - 1][0], fmin( Fpin[1],
dplotb.xylim[kx - 1][1] ) );
Yout[k2] = Yout[k1] + (Xout[k2] - Xout[k1])*(Fpin[2] -
Yout[k1])/(Fpin[1] - Xout[k1]);
}
Fpin[3] = Xout[kpt];
Fpin[4] = Yout[kpt];
if ((Fpin[4] < dplotb.xylim[ky - 1][0]) || (Fpin[4] >
dplotb.xylim[ky - 1][1]))
{
Yout[k2] = fmax( dplotb.xylim[ky - 1][0], fmin( Fpin[4],
dplotb.xylim[ky - 1][1] ) );
Xout[k2] = Xout[k1] + (Yout[k2] - Yout[k1])*(Fpin[3] -
Xout[k1])/(Fpin[4] - Yout[k1]);
}
if (lklip)
{
dplotl( kpt, xout, yout );
dplotl( 0, xout, yout );
kpt = 1;
Xout[1] = Fpin[1];
Yout[1] = Fpin[2];
/* Start a new curve. */
goto L_1080;
}
}
L_1190:
if (ksymb >= 0)
{
kpt = 0;
Fp[ly] = Fp[1];
dplotr( &Fpin[ly], ksymb, kx, ky );
goto L_1120;
}
}
if (kpt < MAXPT)
goto L_1120;
kpt = 0;
if (mode <= 2)
{
dplotf( MAXPT, xout, xout, yout );
if (dplotb.iop1 <= -100)
goto L_1500;
goto L_1120;
}
else
{
dplotl( MAXPT - 1, xout, yout );
Xout[1] = Xout[MAXPT];
Yout[1] = Yout[MAXPT];
goto L_1120;
}
L_1200:
;
puts( "Bad action index in processing scratch file." );
exit(0);
L_1300:
mode = nmode;
/* stop 'Bad action index in processing scratch file.'
*
* Got to end of current processing */
if (mode != 10)
goto L_840;
k = dplotb.mbord[4][7] + dplotb.mbord[5][7];
if (iosta < 0)
{
if ((k != 0) || (last >= 3))
{
/* Close out this mfpic group and start next. */
dplotd.iplot = -100 - dplotd.iplot;
dplot9();
}
iosta = 1;
if (Ip[LDEBUG] > 1)
{
printf("Rewind IOTEMP\n");
}
/*++ CODE for ~.C. is inactive
* rewind (IOTEMP)
* IOTEMP = IOTMP1
*++ CODE for .C. is active */
rewind(iotemp);
iotemp = iotmp1;
if (last >= 3)
goto L_830;
/*++ END */
if (k == 0)
{
fclose(iotmp2);
}
else
{
/* close (IOTMP2) */
if (Ip[LDEBUG] > 1)
{
printf("Rewind IOTMP2\n");
}
rewind(iotmp2);
}
/* rewind (IOTMP2) */
}
if (k != 0)
{
if (dplotb.mbord[4][7] != 0)
dplotb.mbord[1][2] += dplotb.mbord[4][7] + 2;
if (dplotb.mbord[5][7] != 0)
dplotb.mbord[3][2] += dplotb.mbord[5][7] + 2;
for (i = 1; i <= 6; i++)
{
dplotb.mbord[i - 1][7] = 0;
}
if (Ip[LDEBUG] > 1)
{
printf("Rewind IOTMP1,IOTMP2,IOFIL\n");
}
/*++ CODE for ~.C. is inactive
* rewind(IOTMP1)
* rewind(IOTMP2)
* rewind(IOFIL)
*++ CODE for .C. is active */
rewind(iotmp1);
rewind(iotmp2);
rewind(iofil);
dplotb.lentxt[16][2] = 0;
/*++ END */
goto L_800;
}
/* All done, exit. */
dplot9();
fclose(iofil);
fclose(iotemp);
last = 0;
/* close (IOFIL)
* close (IOTEMP) */
if (dplotb.iop1 <= -100)
goto L_1500;
return;
/* **************************** Error Processing **********************
*
* Set Limits for COPT error message. */
L_1400:
j = ltext - 1;
L_1410:
dplotb.ierr3 = j;
dplotb.ierr4 = ltext;
/* Set limit for OPT error message */
L_1430:
dplotb.ierr2 = iop;
/* Output Fatal Error Message */
dplote( ierr, opt, copt );
/* Error on inner subroutine */
L_1500:
last = 0;
L_1510:
Opt[1] = -100 - dplotb.iop1;
return;
} /* end of function */
/* PARAMETER translations */
#define ARREXT 3.e0
#define CAPSEP 2.e0
#define LXBORD 6
#define LXLINE 5
#define SEPLAB 3.5e0
/* end of PARAMETER translations */
void /*FUNCTION*/ dplota(
long ib)
{
char _c0[2];
long int i, i1, i2, iax, iaxp, ibcap[6], j, k, kb, kdig, klog,
mintic;
double sizep, tbase, ticlen, ticlog, ticmaj, ticmin, tlen, tp,
tp1, tp2, tp3, tpmax, tpmin, val, xfac, xypos[2], xypos1[2],
xypos2[2];
static double adjin[6], adjout[6], caploc[6], poslab[6];
static double axadj[6]={1.e0,1.e0,-1.e0,-1.e0,1.e0,1.e0};
static double fac[4]={24.e0,20.e0,24.e0,0.e0};
static double fdig[4]={1.e0,2.e0,5.e0,10.e0};
static double logint[10]={0.e0,.3010299957e0,.47771212547e0,.6020599913e0,
.6989700043e0,.7781512503e0,.8450980400e0,.9030899870e0,.9542425094e0,
1.e0};
/* OFFSET Vectors w/subscript range: 1 to dimension */
double *const Adjin = &adjin[0] - 1;
double *const Adjout = &adjout[0] - 1;
double *const Axadj = &axadj[0] - 1;
double *const Borloc = &dplotb.borloc[0] - 1;
double *const Caploc = &caploc[0] - 1;
double *const Fac = &fac[0] - 1;
double *const Fdig = &fdig[0] - 1;
double *const Fp = &dplotb.fp[0] - 1;
long *const Ibcap = &ibcap[0] - 1;
long *const Ip = &dplotb.ip[0] - 1;
long *const Jset = &dplotb.jset[0] - 1;
LOGICAL32 *const Klip = &dplotb.klip[0] - 1;
long *const Lencap = &dplotb.lencap[0] - 1;
double *const Logint = &logint[0] - 1;
long *const Nxylim = &dplotb.nxylim[0] - 1;
double *const Poslab = &poslab[0] - 1;
double *const Vhlen = &dplotb.vhlen[0] - 1;
double *const Xybase = &dplotb.xybase[0] - 1;
double *const Xypos = &xypos[0] - 1;
double *const Xypos1 = &xypos1[0] - 1;
double *const Xypos2 = &xypos2[0] - 1;
double *const Xyu2pf = &dplotb.xyu2pf[0] - 1;
/* end of OFFSET VECTORS */
/* Output the single border or axes with index IB, including tick marks,
* labels and captions. Do any preliminary checks on scaling required
* and open the output file if it is not open yet.
*
* ************************* Usage of internal variables ****************
*
* ADJIN Space required around borders so points and curves don't
* interfere with tick marks.
* ADJOUT Length of space outside of borders. (Not counting captions.)
* ARREXT Parameter giving the amount added to border or axis when there
* an arrow head. (All numbers like this are in points.)
* AXADJ Array used to define direction to move from the border when
* placing labels.
* CAPLOC Array giving caption locations relative to various borders. If
* > 0, caption is centered on its associated axis, else it goes on an
* end of the associated axis.
* CAPSEP Separation between caption and labels.
* FAC Gives the lower limit on number of points per major tick that
* are required when the leading digit of the increment is 1, 2,
* 5, and 10.
* FDIG Gives the first digit as a function of KDIG.
* IAXP 3-IAX, opposite from the horiz/vert. dirction implied by IB.
* IBCAP The index of the border where the caption for border I goes.
* KB Initially set from MBORD(6, IB). This is used in deciding
* whether the endpoint should be expanded, and if so, whether to a
* minor or major tick mark. If < 3 there is no range expansion, if
* 2 expansion is to a major tick, it 1 it is to the first minor or
* major tick, and 0 is the same as 1, unless the first major tick
* is at 0 in which case it expands to 0.
* KDIG Values of 1, 2, 3, 4, correspond to starting digits of 1, 2, 5,
* 10.
* KLOG Value from IP(LXBORD or LYBORD), with values from there
* incremented by 1 if this value is not zero. A value of 1 is then
* used to indicate that we don't have room for ticks with logarithmic
* spacing.
* MINTIC Number of minor tick intervals per major tick interval. -9 is
* used to flag logarithmic spacing of the minor tick marks.
* POSLAB Offset of label from border/axis for the 17 usual cases.
* SEPLAB Separation of labels from border or tickmarks.
* SIZEP Physical size available for plotting in the current direction.
* TICLOG When have logarithmically spaced minor tick marks, give the
* location of the first minor tick in user coordinates.
* TICMAJ Distance between major tick marks, first in user coordinates,
* later converted to physcial coordinates in points.
* TICLEN Temp. used to hold tick length.
* TICMIN As for TICMAJ, but for minor tick marks.
* TBASE Base point for major ticks (nominally 0). Major ticks are
* all at TBASE + k * TICMAJ, where k is an integer. Starts in
* user coordinates and later is in physical coordinates.
* TP1 Temporary use.
* TP2 Temporary use.
* TP3 Temporary use.
* TLEN Length of the variable range is user coordinates.
* TPMIN Used tracking a temporary value for the minimum.
* TPMAX Used tracking a temporary value for the maximum.
* VAL Numeric value of label being output.
* XFAC Physical space available / Length in user coordinates.
* XYPOS Gives a point (x, y).
* XYPOS1 Gives a point (x_1, y_1).
* XYPOS2 Gives a point (x_2, y_2).
*
* *************************** Variable Declarations ********************
*
* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/* Parameter pointers for integers in IP. */
/* Parameter pointers for floats in FP. */
/* Parameter for various sizes. */
/* Locals */
/* ************************ Start of Executable Code ********************
* */
if (dplotb.mbord[0][7] == 0)
{
/* First time this routine has been called for this figure. */
if (dplotb.lentxt[16][2] > 0)
{
/*++ CODE for ~.C. is inactive
* call DPLOTU (IOFIL, TXTDEF(17)(1:LENTXT(3,17)))
* if (IOP1 .le. -10) return
*++ CODE for .C. is active */
iofil = fopen(dplotc.txtdef[16], "w");
if (iofil == NULL) return;
}
/*++ END */
Caploc[1] = 0.e0;
Caploc[2] = 0.e0;
Caploc[3] = 0.e0;
Caploc[4] = 0.e0;
Caploc[5] = 0.e0;
Caploc[6] = 0.e0;
i1 = 1;
i2 = 6;
}
else
{
if (ib > 10)
goto L_300;
i1 = ib;
i2 = ib;
}
for (i = i1; i <= i2; i++)
{
/* Get initial border characteristics */
iax = 2 - (i%2);
if (dplotb.mbord[i - 1][7] != 0)
goto L_30;
if (i <= 4)
dplotb.mbord[i - 1][7] = Jset[iax];
dplotb.noout = TRUE;
/* Adjustment for tick marks */
Adjout[i] = -fmin( 0.e0, fmin( dplotb.ticks[i - 1][0], dplotb.ticks[i - 1][1] ) );
k = dplotb.mbord[i - 1][0];
if ((k > 1) && (i <= 4))
{
/* Get space for labels. */
if (k > 2)
{
tpmin = dplotb.xylim[iax - 1][0];
tpmax = dplotb.xylim[iax - 1][1];
if (dplotb.setlim[iax - 1][0] < dplotb.setlim[iax - 1][1])
{
tpmin = dplotb.setlim[iax - 1][0];
tpmax = dplotb.setlim[iax - 1][1];
}
tp = fmax( fabs( tpmin ), fabs( tpmax ) );
if (Ip[LXBORD + iax - 1] == 1)
{
tp1 = fnint( tp );
j = -i;
}
else
{
k = log10( tp );
tp1 = powi(10.e0,k);
tlen = tpmax - tpmin;
j = log10( tp/tlen );
if (j > 1)
{
tp1 *= powi(1.1e0,j);
}
j = i;
}
dplotn( sign( tp1, tpmin ), j, xypos );
tp1 = dplotb.tlenv;
if (iax == 2)
tp1 = dplotb.tlenh;
Poslab[i] = Adjout[i] + SEPLAB;
Adjout[i] = Poslab[i] + tp1;
if ((i == 1) || (i == 5))
{
Adjout[i] -= 2.e0;
Poslab[i] += -2.e0 + tp1;
}
}
}
/* Remember info. on arrows. */
if (dplotb.mbord[i - 1][1] > 0)
{
tp1 = dplotb.mbord[i - 1][1] + ARREXT;
if (Lencap[i] != 0)
tp1 += CAPSEP;
/* Remember adjustment for caption if needed. */
if (Caploc[i] <= 0.e0)
Caploc[i] -= tp1;
}
if (Lencap[i] != 0)
{
/* Have a caption need to get space required */
dplotb.ntext = Lencap[i];
memcpy(dplotc.text,dplotc.captio[i-1],(size_t)dplotb.ntext);
dplott( i + 10, xypos );
/* TEXT(1:NTEXT) = CAPTIO(I)(1:NTEXT) */
iaxp = 3 - iax;
k = 4*i + 32;
Ibcap[i] = i;
L_5:
if (dplotc.pos[k + iaxp - 1] == 'c')
{
if (i >= 5)
{
/* Error -- Can't center on x or y axis */
dplote( 2, xypos, " " );
dplotc.pos[k + iaxp - 1] = 'r';
if (i == 6)
dplotc.pos[k + iaxp - 1] = 't';
goto L_5;
}
Caploc[i] = Poslab[i] + Vhlen[iax] + CAPSEP;
Adjout[i] = Caploc[i];
}
else
{
j = istrstr( "bltr", STR1(_c0,dplotc.pos[k + iaxp -
1]) );
Ibcap[i] = j;
tp1 = Vhlen[iaxp] + CAPSEP;
if ((j%2) == 1)
tp1 -= 2.e0;
Caploc[i] -= tp1;
}
}
Adjin[i] = dplotb.mbord[i - 1][2];
if (dplotb.mbord[i - 1][3] != 0)
{
tp = Adjout[i];
Adjout[i] = dplotb.mbord[i - 1][3];
if (Caploc[i] > 0.e0)
{
Caploc[i] = Adjout[i];
Poslab[i] += .5e0*(Adjout[i] - tp);
}
else
{
Poslab[i] = Adjout[i];
}
}
if (Adjout[i] + Adjin[i] > 100.e0)
{
/* Error -- too much space wasted at border I */
dplotb.ierr1 = i;
dplote( 3, xypos, " " );
}
}
if (i1 != i2)
{
/* Special setting the first time. */
for (i = 1; i <= 6; i++)
{
if (Caploc[i] < 0)
Adjout[Ibcap[i]] = fmax( Adjout[Ibcap[i]], -Caploc[i] );
}
Borloc[1] = 0.e0;
Borloc[2] = 0.e0;
Borloc[3] = dplotb.topts*Fp[LXYSIZ + 1] - Adjout[1];
Borloc[4] = dplotb.topts*Fp[LXYSIZ] - Adjout[2];
/* Initialize mfpic */
dplotd.iplot = Ip[LTYPE];
dplotd.pxo = Adjout[2];
dplotd.pyo = Adjout[1];
dplotd.pxsize = Borloc[4];
dplotd.pysize = Borloc[3];
dplot0();
Borloc[3] -= Adjout[3];
Borloc[4] -= Adjout[4];
iax = 2 - (ib%2);
/*++ CODE for ~.C. is inactive
* if (IP(LDEBUG).gt.0) print '(/'' ADJOUT(1:4)='',1P,4G17.10/)',
* 1 (ADJOUT(I), I = 1, 4)
*++ CODE for .C. is active */
if (dplotb.ip[LDEBUG-1] > 0) printf(
"\n ADJOUT(1:4)=%17.10g%17.10g%17.10g%17.10g\n", adjout[0],
adjout[1], adjout[2], adjout[3]);
}
/*++ END
* Process the border or axis */
L_30:
Adjin[ib] = dplotb.mbord[ib - 1][2];
sizep = Borloc[5 - iax] - Borloc[3 - iax] - Adjin[5 - iax] - Adjin[3 - iax];
if (sizep <= 10.e0)
{
/* Error -- not enough room for plot */
dplote( 33, xypos, " " );
return;
}
if (ib > 4)
{
if (ib == 6)
{
/* Take care of drawing lines at X = 0 and Y = 0, if any. */
if (Ip[LXLINE] != 1)
{
i = Ip[LXLINE];
if (i <= 6)
{
i -= 1;
if (i < 0)
i = 6;
}
i -= 1;
L_40:
j = (i%4) + 1;
/* If 0 in range, draw line off axis J */
k = dplotb.mbord[j - 1][7];
for (i1 = 1; i1 <= MAXSET; i1++)
{
if (Nxylim[i1] == k)
goto L_60;
}
goto L_70;
L_60:
tp = Xybase[i1];
i2 = 1 + (i1%2);
if (((Ip[LXBORD + i1 - 1] == 0) && (tp > Borloc[i2])) &&
(tp < Borloc[i2 + 2]))
{
/* Draw the line */
dplotd.kurpen = Fp[LWIDTH + 3];
if (i2 == 2)
{
dplot2( tp, Borloc[1], tp, Borloc[3] );
}
else
{
dplot2( Borloc[2], tp, Borloc[4], tp );
}
}
i -= 5;
if (i > 0)
goto L_40;
if (i == 0)
{
i = 4;
goto L_40;
}
}
}
/* Ignore request for axis if it is not in range of data. */
L_70:
if ((dplotb.setlim[iax - 1][0] >= 0.e0) || (dplotb.setlim[iax - 1][1] <
0.e0))
return;
/* Get physical location of axis. */
Borloc[ib] = Xybase[iax];
}
else if ((Xyu2pf[iax] == 0.e0) || (dplotb.mbord[ib - 1][0] > 1))
{
Klip[iax] = FALSE;
if (dplotb.setlim[iax - 1][0] < dplotb.setlim[iax - 1][1])
{
Klip[iax] = (dplotb.setlim[iax - 1][0] > dplotb.xylim[iax - 1][0]) ||
(dplotb.setlim[iax - 1][1] < dplotb.xylim[iax - 1][1]);
dplotb.xylim[iax - 1][0] = dplotb.setlim[iax - 1][0];
dplotb.xylim[iax - 1][1] = dplotb.setlim[iax - 1][1];
}
else
{
dplotb.setlim[iax - 1][0] = dplotb.xylim[iax - 1][0];
dplotb.setlim[iax - 1][1] = dplotb.xylim[iax - 1][1];
}
if (dplotb.setlim[iax - 1][1] > dplotb.setlim[iax - 1][0])
{
/* Usual case, other branch protects against divide by 0. */
xfac = sizep/(dplotb.setlim[iax - 1][1] - dplotb.setlim[iax - 1][0]);
}
else
{
xfac = 1.e0;
}
}
/* ******* Get location of ticks and adjust limits if necessary *********
* */
if (dplotb.phyuse[iax - 1][0] >= 0.e0)
{
/* User coordinate must map to given physical coordinate.
* TP1 = minimum x_physical, TP2 = loc. user, TP3 = loc. physical */
tp1 = Borloc[3 - iax] + Adjin[3 - iax];
tp2 = dplotb.phyuse[iax - 1][1];
tp3 = dplotb.phyuse[iax - 1][0]*dplotb.topts;
/* Convert to logs if requested */
if (Ip[LCOOX + iax - 1] == 2)
tp2 = log10( tp2 );
/* TP = maps loc. user to loc. physical with current settings. */
tp = tp1 + xfac*(tp2 - dplotb.xylim[iax - 1][0]);
if (tp > tp3)
{
xfac = (tp3 - tp1)/(tp2 - dplotb.xylim[iax - 1][0]);
dplotb.xylim[iax - 1][1] = tp1 + xfac*(dplotb.xylim[iax - 1][1] -
dplotb.xylim[iax - 1][0]);
}
else if (tp < tp3)
{
dplotb.xylim[iax - 1][0] = tp2 + (tp3 - tp1)/xfac;
}
/* No range expansion in this case (otherwise above adjustment fails) */
dplotb.mbord[ib - 1][5] = 3;
}
tpmax = dplotb.xylim[iax - 1][1];
tpmin = dplotb.xylim[iax - 1][0];
tlen = tpmax - tpmin;
if (tlen == 0.e0)
{
/* Expand the range */
if (tpmax == 0)
{
tpmax = 1.e0;
tpmin = -1.e0;
tlen = 2.e0;
}
else if (tpmax > 0)
{
tpmin = 0.e0;
tpmax *= 2.e0;
}
else
{
tpmax = 0.e0;
tpmin *= 2.e0;
}
}
if (dplotb.mbord[ib - 1][0] < 2)
goto L_170;
/* There are some kind of tick marks. */
klog = Ip[LXBORD + ib - 1];
if (klog != 0)
klog += 1;
ticmaj = dplotb.ticks[ib - 1][3];
if (ticmaj != 0.e0)
{
/* Major ticks all specified */
tbase = dplotb.ticks[ib - 1][2];
if (klog == 2)
{
kdig = ticmaj;
if (kdig != 1)
klog = 1;
}
else
{
kdig = log10( .98e0*tbase );
kdig = ticmaj/ipow(10,kdig);
}
kb = 3;
}
else
{
/* If the increment between ticks is 0, we need to compute it. */
tbase = 0.e0;
if (klog == 2)
{
/* Logarithmic spacing with minor ticks. */
ticmaj = 1.e0;
ticmin = 1.e0;
mintic = -9.e0;
if (sizep >= 24.e0*tlen)
goto L_90;
/* Not enough room for minor log ticks */
klog = 1;
}
k = log10( .4*tlen );
/* TICMAJ = first candidate increment (no bigger than needed) */
ticmaj = powi(10.e0,k);
if (ticmaj*sizep > Fac[3]*tlen)
{
k -= 1;
ticmaj /= 10.e0;
}
kdig = 1;
tp2 = ticmaj;
/* Now TP2 is smallest increment (in user coordinates) for major ticks.
* We now decide whether to increase initial size it by 1, 2, 5, or 10. */
L_80:
tp1 = tlen/ticmaj;
if (sizep < Fac[kdig]*tp1)
{
/* There are less than FAC(KDIG) points per major interval, want more */
kdig += 1;
ticmaj = Fdig[kdig]*tp2;
if (kdig == 2)
{
tp = tlen/(5.e0*tp2);
if (fabs( fnint( tp ) - tp ) < 1.e-5)
{
if (fmod( fnint( tp ), 2.e0 ) != 0.e0)
{
/* Using 5.D0 * TP2 breaks even and 2.D0*TP2 doesn't. */
kdig = 3;
ticmaj = 5.e0*tp2;
}
}
}
goto L_80;
}
}
/* Have now established TICMAJ as the major tick increment */
mintic = dplotb.mbord[ib - 1][4];
if (mintic == 0)
{
if ((kdig == 2) || (kdig == 3))
{
mintic = Fdig[kdig];
}
else
{
tp1 = sizep*ticmaj/tlen;
if (tp1 >= 90.e0)
{
mintic = 10;
}
else if (tp1 >= 60.e0)
{
mintic = 5;
}
else if (tp1 >= 40.e0)
{
mintic = 4;
}
else if (tp1 >= 20.e0)
{
mintic = 2;
}
else
{
mintic = 1;
}
}
}
/* And TICMIN is established as the minor tick increment. */
ticmin = ticmaj/(double)( mintic );
/* Adjust the endpoints -- First insure we don't get points too close */
L_90:
tp3 = (tpmax - tpmin)/sizep;
/* TP3 used to convert from physical to user coordinates
* Now get the the tick marks on borders if that is desired. */
kb = dplotb.mbord[ib - 1][5];
if (kb <= 2)
{
tp = ticmin;
if (kb == 2)
tp = ticmaj;
if (kb == 0)
{
if (tpmin > 0.e0)
{
kb = 1;
if (tpmin <= ticmaj)
tp = ticmaj;
}
}
if (klog == 2)
{
/* Minor ticks are spaced logarithmically, tricky to end on a tick mark. */
j = (tpmin - tbase)/ticmaj;
if (tpmin < tbase)
j -= 1;
tp1 = tbase + j*ticmaj;
tp2 = tp1;
j = 1;
L_100:
if (tp1 + Logint[j] < tpmin)
{
tp2 = tp1 + Logint[j];
j += 1;
goto L_100;
}
ticlog = tp2;
goto L_120;
}
j = (tpmin - tbase)/tp;
tp2 = tbase + (double)( j )*tp;
L_110:
if (tp2 > tpmin)
{
tp2 -= tp;
goto L_110;
}
L_120:
tpmin = fmin( tp2, tpmin - tp3*Adjin[3 - iax] );
if (kb <= 1)
{
/* If get here, TP = TICMIN */
if (kb == 0)
{
if (tpmax < 0.e0)
{
if (tpmax >= -ticmaj)
{
tp = ticmaj;
kb = 2;
}
}
}
else
{
tp = ticmin;
}
}
if (klog == 2)
{
/* Logarithmic minor ticks. */
j = (tpmax - tbase)/ticmaj;
if (tpmax < tbase)
j -= 1;
tp1 = tbase + j*ticmaj;
tp2 = tp1;
j = 1;
L_140:
if (tp2 < tpmax)
{
j += 1;
tp2 = tp1 + Logint[j];
goto L_140;
}
goto L_160;
}
j = (tpmax - tbase)/tp;
tp2 = tbase + (double)( j )*tp;
L_150:
if (tp2 < tpmax)
{
tp2 += tp;
goto L_150;
}
}
L_160:
tpmax = fmax( tp2, tpmax + tp3*Adjin[5 - iax] );
/* Set transformation parameters */
L_170:
if (Xyu2pf[iax] != 0.e0)
{
if (dplotb.mbord[ib - 1][0] <= 1)
goto L_180;
}
Xyu2pf[iax] = (Borloc[5 - iax] - Borloc[3 - iax])/(tpmax - tpmin);
Xybase[iax] = -Xyu2pf[iax]*tpmin;
/* Let v=x if IAX = 1, and v=y otherwise. V is mapped to physical
* coordinates by v_{physical) = XYBASE(IAX) + v * XYU2PF(IAX) */
tbase = Xybase[iax] + Xyu2pf[iax]*tbase;
ticmin *= Xyu2pf[iax];
ticmaj *= Xyu2pf[iax];
if (Klip[iax])
{
dplotb.xylim[iax - 1][0] = Xybase[iax] + Xyu2pf[iax]*dplotb.setlim[iax - 1][0];
dplotb.xylim[iax - 1][1] = Xybase[iax] + Xyu2pf[iax]*dplotb.setlim[iax - 1][1];
}
else
{
dplotb.xylim[iax - 1][0] = Xybase[iax] + Xyu2pf[iax]*dplotb.xylim[iax - 1][0];
dplotb.xylim[iax - 1][1] = Xybase[iax] + Xyu2pf[iax]*dplotb.xylim[iax - 1][1];
}
/* ***************** Output Caption, Border/axis, labels ****************
*
* First the caption */
L_180:
dplotb.noout = FALSE;
if (Lencap[ib] != 0)
{
/* Have a caption */
j = Ibcap[ib];
if (j == ib)
{
/* Caption is being centered */
Xypos[iax] = .5e0*Borloc[5 - iax];
Xypos[3 - iax] = Borloc[ib] - Axadj[ib]*Caploc[ib];
}
else
{
Xypos[iax] = Borloc[j] + Axadj[j]*Caploc[ib];
Xypos[3 - iax] = Borloc[ib];
}
dplotb.ntext = Lencap[ib];
memcpy(dplotc.text, dplotc.captio[ib-1],(size_t)dplotb.ntext);
dplott( ib + 9, xypos );
/* TEXT(1:NTEXT) = CAPTIO(IB)(1:NTEXT) */
}
if (dplotb.mbord[ib - 1][0] == 0)
return;
/* Now the Border/axis line */
dplotd.kurpen = Fp[LWIDTH];
Xypos1[1] = Borloc[2];
Xypos1[2] = Borloc[1];
Xypos2[1] = Borloc[4];
Xypos2[2] = Borloc[3];
ticlen = fmin( dplotb.ticks[ib - 1][0], Borloc[iax + 2] - Borloc[iax] );
if (ib <= 2)
{
Xypos2[3 - iax] = Borloc[ib];
}
else if (ib <= 4)
{
Xypos1[3 - iax] = Borloc[ib];
ticlen = -ticlen;
}
else
{
Xypos1[3 - iax] = Borloc[ib];
Xypos2[3 - iax] = Borloc[ib];
}
if (dplotb.mbord[ib - 1][1] != 0)
{
dplotd.arrlen = dplotb.mbord[ib - 1][1];
Xypos2[iax] += dplotd.arrlen + ARREXT;
}
dplot2( Xypos1[1], Xypos1[2], Xypos2[1], Xypos2[2] );
k = dplotb.mbord[ib - 1][0];
if (k > 1)
{
/*## Code for polar cases yet to be written.
* Major ticks */
tp1 = fmod( tbase - Borloc[3 - iax], ticmaj );
if (tp1 < 0)
tp1 += ticmaj;
if (tp1 > .99999*ticmaj)
tp1 -= ticmaj;
tp1 += Borloc[3 - iax];
dplot8( Fp[LWIDTH + 1], tp1 + Adjout[3 - iax], ticmaj, Borloc[5 - iax] +
Adjout[3 - iax] + .1e0, Borloc[ib] + Adjout[iax], Borloc[ib] +
ticlen + Adjout[iax], iax, -1.e0 );
if (mintic > 1)
{
/* Minor ticks */
tp2 = fmod( tbase - Borloc[3 - iax], ticmin );
if (tp2 < 0)
tp2 += ticmin;
tp2 += Borloc[3 - iax];
ticlen = fmin( dplotb.ticks[ib - 1][1], Borloc[iax + 2] -
Borloc[iax] );
if ((ib == 3) || (ib == 4))
ticlen = -ticlen;
dplot8( Fp[LWIDTH + 2], tp2 + Adjout[3 - iax], ticmin,
Borloc[5 - iax] + Adjout[3 - iax] + .1e0, Borloc[ib] +
Adjout[iax], Borloc[ib] + ticlen + Adjout[iax], iax,
-1.e0 );
}
else if (klog == 2)
{
/* Logarithmic minor ticks */
ticlen = fmin( dplotb.ticks[ib - 1][1], Borloc[iax + 2] -
Borloc[iax] );
dplot8( Fp[LWIDTH + 2], tp1 + Adjout[3 - iax], ticmaj,
Borloc[5 - iax] + Adjout[3 - iax] + .1e0, Borloc[ib] +
Adjout[iax], Borloc[ib] + ticlen + Adjout[iax], iax,
Xybase[iax] + ticlog*Xyu2pf[iax] + Adjout[3 - iax] -
.1e0 );
}
/* Labels */
if (k > 2)
{
j = 4*ib - iax - 1;
if (k <= 4)
{
tp1 += ticmaj;
}
else if (tp1 - Borloc[3 - iax] < 4.e0)
{
dplotc.pos[j - 1] = 'l';
if (iax == 2)
dplotc.pos[j - 1] = 'b';
}
tp2 = Borloc[5 - iax] - ticmaj + .1e0;
dplotb.opaque = FALSE;
dplotb.ovlap = -10.e4;
Xypos[3 - iax] = Borloc[ib] - Axadj[ib]*Poslab[ib];
L_200:
Xypos[iax] = tp1;
val = (tp1 - Xybase[iax])/Xyu2pf[iax];
if (fabs( val ) < 1.e-5*ticmaj)
val = 0;
i = ib;
if (Ip[LXBORD - 1 + iax] == 1)
i = -i;
dplotn( val, i, xypos );
tp1 += ticmaj;
dplotc.pos[j - 1] = 'c';
if (tp1 <= tp2)
goto L_200;
if (labs( k - 4 ) != 1)
{
if (tp1 <= Borloc[5 - iax] + .1e0)
{
if (tp1 >= Borloc[5 - iax] - 4.e0)
{
dplotc.pos[j - 1] = 'r';
if (iax == 2)
dplotc.pos[j - 1] = 't';
}
goto L_200;
}
}
}
}
return;
/* ************ Option 16 -- Lines and border/axis annotations **********
* */
L_300:
j = Ip[LTANNO];
i = ib - 10;
iax = 2 - (i%2);
/* Convert to physical coordinates */
if (Ip[LCOOX + iax - 1] == 2)
Fp[LVALS] = log10( Fp[LVALS] );
Xypos1[iax] = Xybase[iax] + Xyu2pf[iax]*Fp[LVALS];
if (j != 0)
{
/* Want a tick or some kind of line. */
dplotd.kurpen = Fp[LWIDTH + min( Ip[LTANNO], 3 )];
if (Ip[LTANNO] == 4)
dplotd.kurpen += 203001;
i1 = i + 2;
if (i1 > 4)
i1 -= 4;
Xypos2[iax] = Xypos1[iax];
Xypos1[3 - iax] = Borloc[i];
if (j > 2)
{
Xypos2[3 - iax] = Borloc[i1];
}
else
{
Xypos2[3 - iax] = Xypos1[iax] + dplotb.ticks[i - 1][j - 1]*
Axadj[iax];
}
dplot2( Xypos1[1], Xypos1[2], Xypos2[1], Xypos2[2] );
}
if (dplotb.ntext == 0)
return;
/* Have an annotation. */
Xypos1[3 - iax] = Borloc[i] - Axadj[i]*Poslab[i];
dplott( i, xypos1 );
return;
} /* end of function */
/* PARAMETER translations */
#define LTXTAB 8
#define LTXTAC 59
#define LTXTAD 109
#define LTXTAE 158
#define LTXTAF 199
#define LTXTAG 242
#define LTXTAH 302
#define LTXTAJ 8
#define LTXTAK 31
#define LTXTAL 58
#define LTXTAM 102
#define LTXTAN 116
#define LTXTAO 150
#define LTXTAP 207
#define LTXTAQ 243
#define LTXTAR 285
#define LTXTAS 326
#define LTXTAU 8
#define LTXTAV 27
#define LTXTAW 60
#define LTXTAX 103
#define LTXTAY 139
#define LTXTAZ 166
#define LTXTBA 228
#define LTXTBB 273
#define LTXTBC 309
#define LTXTBD 341
#define LTXTBF 419
#define LTXTBG 451
#define LTXTBI 8
#define LTXTBJ 35
#define LTXTBK 86
#define LTXTBL 116
#define LTXTBM 184
#define LTXTBN 229
#define LTXTBO 291
#define MECONT 50
#define MEEMES 52
#define MEFVEC 61
#define MERET 51
#define METEXT 53
/* end of PARAMETER translations */
void /*FUNCTION*/ dplote(
long ierr,
double opt[],
STRING copt)
{
char txtcop[1][201];
long int i, iearr[1], j, j1, j2, k;
static char mtxtaa[2][181]={"DPLOT$BWarning -- Points provided are not being plotted.$EWarning -- Centering on x or y axis not allowed.$EWarning --$ Too much space wasted at border $I.$EWarning -- Format numbe",
"r$ out of range.$EWarning -- Unknown format specification: $BWarning -- Caption doesn't have balanced {...} or $$...$$:$EWarning -- Caption in physical coordinates does not fit.$E "};
static char mtxtab[2][184]={"DPLOT$BBad option character.$EBad start of COPT option.$ERunaway in COPT, unbalanced (), [], or {}?$EMissing #?, $EFile name or caption is empty. $EText inside (), {}, [], may contai",
"n at most $I chars. $E[...] must contain 2 or 4 letters.$EFirst$ position must be one of \"tcbTCB\".$ESecond position must be one of \"lcrLCR.$EError in third/forth position of [...].$E"};
static char mtxtac[2][246]={"DPLOT$BBad option index.$EOption value is not an integer.$EOption value is too big to be an integer.$EDigit 10^0 of option 1 is too big.$EType flag must be 0 or 1.$EPolar coordinates (not implemented) or bad 10^2, 10^3 digit.$EOnly digits 1 to 6",
" can be used for borders.$EMin/max on x or y specified twice.$ENY changed in middle of curve.$EAttempting to change data set without providing data.$EMore than NY symbols.$EBad value for symbol plotting.$EDigit 10^0 for option 19, must be < 5.$E"};
static char mtxtad[2][175]={"DPLOT$BNot enough room for plot.$EUnable to find unused I/O unit number in 10..100.$EUnable to open output file: $BInternal Error -- Adding point (in DPLOTF) without initiali",
"zation.$EInternal Error -- N < -4 on call to DPLOTF.$EInternal Error -- N$ < 0 and not in initial state in DPLOTF.$EInternal Error -- S values must be increasing in DPLOTF.$E"};
static char txtopt[1][41]={" O.K. part of OPT:$BError part of OPT:$B"};
static long lwarn[7]={LTXTAB,LTXTAC,LTXTAD,LTXTAE,LTXTAF,LTXTAG,
LTXTAH};
static long lcopt[19-(10)+1]={LTXTAJ,LTXTAK,LTXTAL,LTXTAM,LTXTAN,
LTXTAO,LTXTAP,LTXTAQ,LTXTAR,LTXTAS};
static long lopt[31-(20)+1]={LTXTAU,LTXTAV,LTXTAW,LTXTAX,LTXTAY,
LTXTAZ,LTXTBA,LTXTBB,LTXTBC,LTXTBD,LTXTBF,LTXTBG};
static long lother[39-(33)+1]={LTXTBI,LTXTBJ,LTXTBK,LTXTBL,LTXTBM,
LTXTBN,LTXTBO};
static long mact1[5]={MEEMES,0,0,0,MERET};
static long mact2[5]={MEEMES,47,0,0,MECONT};
static long mact3[2]={METEXT,MECONT};
static long mact4[2]={METEXT,MERET};
static long mact5[7]={METEXT,MEFVEC,0,METEXT,MEFVEC,0,MERET};
/* OFFSET Vectors w/subscript range: 1 to dimension */
long *const Iearr = &iearr[0] - 1;
long *const Lwarn = &lwarn[0] - 1;
long *const Mact1 = &mact1[0] - 1;
long *const Mact2 = &mact2[0] - 1;
long *const Mact3 = &mact3[0] - 1;
long *const Mact4 = &mact4[0] - 1;
long *const Mact5 = &mact5[0] - 1;
double *const Opt = &opt[0] - 1;
/* end of OFFSET VECTORS */
/* Prints Error Messages
* IERR indicates the error as follows.
* 1 Warning -- Points provided are not being plotted.
* 2 Warning -- Centering on x or y axis not allowed.
* 3 Warning -- Too much space wasted at border I.
* 4 Warning -- Format number out of range.
* 5 Warning -- Unknown format specification:
* 6 Warning -- Caption doesn''t have balanced {...} or $...$:
* 10 Bad option character.
* 11 Bad start of COPT option.
* 12 Runaway in COPT, unbalanced (), [], or {}?.
* 13 Missing #?,
* 14 File name or caption is empty.
* 15 Text inside (), {}, [], may contain at most $I chars.
* 16 [...] must contain 2 or 4 letters.
* 17 First position must be one of "tcbTCB".
* 18 Second position must be one of "lcrLCR.
* 19 Error in third/forth position of [...].
* 20 Bad option index.
* 21 Option value is not an integer.
* 22 Option value is too big to be an integer.
* 23 Digit 10^0 of option 1 is too big.
* 24 Type flag must be 0 or 1.
* 25 Polar coordinates (not implemented) or bad 10^2, 10^3 digit.
* 26 Only digits 1 to 6 can be used for borders.
* 27 Min/max on x or y specified twice.
* 28 NY changed in middle of curve.
* 29 Attempting to change data set without providing data.
* 30 More than NY symbols.
* 31 Bad value for symbol plotting.
* 32 Digit 10^0 for option 19, must be < 5.
* 33 Not enough room for plot.
* 34 Unable to find unused I/O unit number in 10..100.
* 35 Unable to open output file:
* 40 Internal -- Adding points (in DPLOTF) without initialization.
* 41 Internal -- N < -4 on call to DPLOTF.
* 42 Internal -- N < 0 and not in initial state in DPLOTF.
* 43 Internal -- S values must be increasing in DPLOTF.
* OPT OPT passed in by user. Only used if 10 < IERR < 33.
* COPT COPT passed in by user. Only used if 9 < IERR < 20
*
* Formal Args. */
/* Common variables
*
* Parameter pointers for integers in IP. */
/* Parameter pointers for floats in FP. */
/* Parameter for various sizes. */
/* Locals */
/* Parameters for error messages */
/* ********* Error message text ***************
*[Last 2 letters of Param. name] [Text generating message.]
*AA DPLOT$B
*AB Warning -- Points provided are not being plotted.$E
*AC Warning -- Centering on x or y axis not allowed.$E
*AD Warning -- Too much space wasted at border $I.$E
*AE Warning -- Format number out of range.$E
*AF Warning -- Unknown format specification: $B
*AG Warning -- Caption doesn't have balanced {...} or $$...$$:$E
*AH Warning -- Caption in physical coordinates does not fit.$E
* $
*AI DPLOT$B
*AJ Bad option character.$E
*AK Bad start of COPT option.$E
*AL Runaway in COPT, unbalanced (), [], or {}?$E
*AM Missing #?, $E
*AN File name or caption is empty. $E
*AO Text inside (), {}, [], may contain at most $I chars. $E
*AP [...] must contain 2 or 4 letters.$E
*AQ First position must be one of "tcbTCB".$E
*AR Second position must be one of "lcrLCR.$E
*AS Error in third/forth position of [...].$E
* $
*AT DPLOT$B
*AU Bad option index.$E
*AV Option value is not an integer.$E
*AW Option value is too big to be an integer.$E
*AX Digit 10^0 of option 1 is too big.$E
*AY Type flag must be 0 or 1.$E
*AZ Polar coordinates (not implemented) or bad 10^2, 10^3 digit.$E
*BA Only digits 1 to 6 can be used for borders.$E
*BB Min/max on x or y specified twice.$E
*BC NY changed in middle of curve.$E
*BD Attempting to change data set without providing data.$E
*BE More than NY symbols.$E
*BF Bad value for symbol plotting.$E
*BG Digit 10^0 for option 19, must be < 5.$E
* $
*BH DPLOT$B
*BI Not enough room for plot.$E
*BJ Unable to find unused I/O unit number in 10..100.$E
*BK Unable to open output file: $B
*BL Internal Error -- Adding point (in DPLOTF) without initialization.$E
*BM Internal Error -- N < -4 on call to DPLOTF.$E
*BN Internal Error -- N < 0 and not in initial state in DPLOTF.$E
*BO Internal Error -- S values must be increasing in DPLOTF.$E */
/* ********* End of Error message text ***************
*
* 123456789012345678901 */
/* 1 2 3 4 5 */
/* ************************ Start of Executable Code ********************
* */
if ((ierr == 5) || (ierr == 35))
Mact1[5] = MECONT;
Iearr[1] = dplotb.ierr1;
if (ierr <= 19)
{
if (ierr <= 7)
{
Mact1[2] = 25;
Mact1[3] = ierr;
Mact1[4] = Lwarn[ierr];
mess( mact1, (char*)mtxtaa,181, iearr );
goto L_250;
}
else if (ierr >= 10)
{
Mact2[3] = ierr;
Mact2[4] = lcopt[ierr-(10)];
mess( mact2, (char*)mtxtab,184, iearr );
}
else
{
goto L_300;
}
}
else if (ierr <= 32)
{
Mact2[3] = ierr;
Mact2[4] = lopt[ierr-(20)];
mess( mact2, (char*)mtxtac,246, iearr );
goto L_100;
}
else
{
Mact1[2] = 47;
Mact1[3] = ierr;
i = ierr;
if (i > 35)
i -= 4;
if (i > 39)
goto L_300;
Mact1[4] = lother[i-(33)];
mess( mact1, (char*)mtxtad,175, iearr );
goto L_250;
}
/* Take care of COPT part of message. */
j1 = 1;
j2 = dplotb.ierr3;
if (j2 <= 0)
j2 = dplotb.ierr4;
L_10:
f_subscpy( txtcop[0], 0, 19, 200, " O.K. part of COPT: " );
if (dplotb.ierr3 <= 0)
f_subscpy( txtcop[0], 0, 5, 200, "Error " );
k = 21;
L_20:
for (j = j1; j <= j2; j++)
{
txtcop[0][k - 1] = copt[j - 1];
if (txtcop[0][k - 1] == '$')
{
k += 1;
txtcop[0][k - 1] = '$';
}
k += 1;
if (k > 196)
{
f_subscpy( txtcop[0], k - 1, k, 200, "$B" );
mess( mact3, (char*)txtcop,201, iearr );
k = 1;
j1 = j + 1;
goto L_20;
}
}
f_subscpy( txtcop[0], k - 1, k, 200, "$E" );
if ((dplotb.ierr3 < 0) || ((dplotb.iop1 <= 0) && (dplotb.ierr3 ==
0)))
{
mess( mact4, (char*)txtcop,201, iearr );
goto L_200;
}
mess( mact3, (char*)txtcop,201, iearr );
if (dplotb.ierr3 > 0)
{
dplotb.ierr3 = 0;
j1 = j;
j2 = dplotb.ierr4;
goto L_10;
}
/* Take care of OPT part of message. */
L_100:
Mact5[3] = dplotb.iop1 - 1;
Mact5[6] = -dplotb.ierr2;
dmess( mact5, (char*)txtopt,41, iearr, opt );
L_200:
dplotb.iop1 = -100 - ierr;
return;
/* Check for special case */
L_250:
if (Mact1[5] == MERET)
goto L_200;
/* Set up for output of format spec. or file name. */
Mact1[5] = MERET;
j1 = 1;
j2 = dplotb.ierr1;
dplotb.ierr3 = -1;
k = 1;
goto L_20;
/* An internal error */
L_300:
;
puts( "Internal error in DPLOT, bad error index." );
exit(0);
return;
} /* end of function */
/* stop 'Internal error in DPLOT, bad error index.' */
/* PARAMETER translations */
#define KORD 2
#define KORD1 (KORD + 1)
#define KORD2 (KORD + 2)
#define MX 101
#define TOL 1.e-3
#define TOLLO (.25e0*TOL)
/* end of PARAMETER translations */
void /*FUNCTION*/ dplotf(
long n,
double s[],
double x[],
double y[])
{
static LOGICAL32 gets;
long int i, i1, i2, iklip, ilast, j, k, l, loc[4], ni, _i, _r;
static long int klips;
double errmax, errmxl, hmax, hmin, s1, tp, tp1, tp2, x1, xd, y1,
yd;
static double ds[KORD2], dx[KORD2], dy[KORD2], h, si[MX-(0)+1],
xi[MX], xmin, xscal, yi[MX], ymin, yscal;
static long last = -1;
static long klip = 0;
static double xmax = 0.e0;
static double ymax = 0.e0;
static int _aini = 1;
/* OFFSET Vectors w/subscript range: 1 to dimension */
double *const Ds = &ds[0] - 1;
double *const Dx = &dx[0] - 1;
double *const Dy = &dy[0] - 1;
long *const Loc = &loc[0] - 1;
double *const S = &s[0] - 1;
double *const X = &x[0] - 1;
double *const Xi = &xi[0] - 1;
double *const Y = &y[0] - 1;
double *const Yi = &yi[0] - 1;
/* end of OFFSET VECTORS */
if( _aini ){ /* Do 1 TIME INITIALIZATIONS! */
si[0] = 0.e0;
_aini = 0;
}
/*### Want to add provision for polar coordinates.
*
* Selects points for plotting so as to get nice curves without using
* too many points.
*
* N Indicates action desired. One must have provided a negative
* value for N (to start a new curve) before supplying a positive value.
* > 0 Number of points provided for plotting.
* = 0 End of current curve (if any).
* < 0 Start a new curve as follows:
* = -1 Just providing pairs of points (X, Y). X(1:2) give the
* maximum and minimum value expecter for X with Y(1:2)
* similarly defined, except for Y.
* = -2 As for -2, except, providing X and Y as functions of S.
* Values of S must be monotone increasing or monotone
* decreasing.
* = -3 As for -1, except the min and max values are limits and the
* curve is to be clipped if it exceeds these limits.
* = -4 As for -2, with the clipping as with -3.
* S() Only used when the initial value for N = -2, -4, -22, and -24,
* in which case it is the independent variable.
* X(), Y() The point pairs being provided, in physical units.
* If N < -10 gives the range of values for the independent
* variable.
*
* When S is not provided, an internal value for S is constructed based
* on a polygonal approximation to the length of the curve. In all cases
* X and Y are thought of as functions of S. Points are selected in such
* a way that piecewise cubic approximations for X(S) and Y(S) are
* thought to be accurate to within TOL * max|X(S)| and TOL * max|Y(S)|
* respectively, where TOL is 0.01.
*
* ******************* External Reference *******************************
*
* DPLOTL is called for the final stage of outputting points.
*
* ******************* Variable Definitions *****************************
*
* DS Array used to old S values for computing divided differences.
* DX Array used to hold divided differences for X.
* DY Array used to hold divided differences for Y.
* ERRMXL Previous estimate for ERRMAX.
* ERRMAX Estimate for largest error.
* GETS Logical variable that is true if DPLOTF computes S.
* H Current step size. If < 0, then H has not yet been selected.
* HMAX Maximum value to be considered for H.
* HMIN Minimum value to be considered for H.
* I Temporary index.
* I1 Starting index for loop processing new points.
* I2 Final index for loop processing new points.
* IKLIP Index of input point that causes points to be processed due
* to clipping.
* ILAST Index into XI, YI arrays for last values to send out.
* J Temporary index.
* K Temporary index.
* KLIP Used to indicate whether clipping (X or Y values out of bounds)
* is active.
* = 0 No checking being done for clipping.
* =-1 Currently out of range, check for getting in range.
* = 1 Currently in range, check for getting point out of range.
* = 2 Got a point our of range in process of getting next one,
* or processing the points up to the clipping point.
* =-2 Initialize for clipping.
* KLIPS If 0, the start of the data is not clipped, else if -1 it is.
* KORD Parameter giving the degree assumed for the interpolating
* polynomial.
* KORD1 = KORD + 1
* KORD2 = KORD + 2
* L Temporary index.
* LOC Array mapping index of selected point into SI, XI, YI arrays.
* LAST Flag to be interpreted as follows.
* -1 Not yet initialized.
* >-1 Number of points in internal buffer ready for processing.
* MX Parameter giving the maximum number of points that can be
* examined at one time.
* N Formal argument, see above.
* NI Internal value for N.
* S Formal argument, see above.
* S1 Value of S for which one is getting interpolated values.
* SI Internal saved values for S. (Either input values for S, or
* ones that have been generated.
* TOL Parameter giving requested relative accuracy in the
* intepolation for X and Y.
* TOLLO Low value for tolerance = TOL / 8.
* TP Temporary real variable.
* TP1 Temporary real variable.
* TP2 Temporary real variable.
* X Formal argument, see above.
* X1 Value interpolated for X(S1).
* XD Temporary storage for difference between X values.
* XI Internal saved values for X.
* XMAX Interpolated values with X > XMAX cause clipping. See N = -5
* above.
* XMIN As for XMAX, except for X < XMIN.
* YMAX As for XMAX, except for value of Y.
* YMIN As for YMAX, except for Y < YMIN.
* XSCAL (Largest X - Smallest X) in the graph.
* Y Formal argument, see above.
* Y1 Value interpolated for Y(S1).
* YD Temporary storage for difference between Y values. */
/* YI Internal saved values for Y.
* YSCAL (Largest Y - Smallest Y) in the graph.
*
* ******************* Variable Declarations ****************************
* */
/*++ Default KORD = 2
*++ Substitute for KORD below */
/* ******************* Start of Executable Code *************************
* */
ni = n;
L_100:
if (last == -1)
{
/* Initial State */
h = 0.e0;
if (ni >= 0)
{
if (ni == 0)
return;
/* Trying to add points without initialization */
dplote( 40, s, " " );
return;
}
if (ni < -4)
{
/* N < -4 on call to DPLOTF */
dplote( 41, s, " " );
return;
}
last = 0;
xmin = X[1];
xmax = X[2];
ymin = Y[1];
ymax = Y[2];
xscal = fmax( fabs( xmin ), fabs( xmax ) );
yscal = fmax( fabs( xmin ), fabs( xmax ) );
klip = 0;
if (ni < -2)
{
klip = -2;
ni += 2;
}
gets = ni == -1;
return;
}
else if (ni < 0)
{
/* N < 0 and not in initial state */
dplote( 42, s, " " );
return;
}
iklip = 0;
i1 = 1;
L_380:
if (klip == -2)
{
klip = 1;
klips = 0;
if ((((X[i1] < xmin) || (X[i1] > xmax)) || (Y[i1] < ymin)) ||
(Y[i1] > ymax))
{
klip = -1;
klips = -1;
}
}
/* Add points to list */
L_400:
i2 = min( ni, MX - last );
for (i = i1; i <= i2; i++)
{
if (klip != 0)
{
/* Check clipping -- First check if in range */
if ((((X[i] < xmin) || (X[i] > xmax)) || (Y[i] < ymin)) ||
(Y[i] > ymax))
{
/* Current point is out of range. */
if (klip == -1)
{
/* We are getting points that are out of range. */
last = 0;
}
else
{
/* We have got a point out of range after being in range. */
if (last + klips == 1)
{
/* No points used if only one is inside the region. */
klip = -1;
last = 0;
klips = -1;
}
else if (klip == 1)
{
/* Flag that this is the last I for the current set. */
klip = 2;
iklip = i;
}
}
}
else if (klip != 1)
{
/* Just got a point in range */
if (klip == -1)
{
/* Flag that we are now getting points in range. */
klip = 1;
}
}
}
/* End of test for clipping */
last += 1;
Xi[last] = X[i];
Yi[last] = Y[i];
if (gets)
{
if (last == 1)
{
si[1] = 0.e0;
}
else
{
xd = fabs( Xi[last] - Xi[last - 1] );
yd = fabs( Yi[last] - Yi[last - 1] );
if (xd < yd)
{
si[last] = si[last - 1] + yd*sqrt( 1.e0 + powi(xd/
yd,2) );
}
else if (xd == 0.e0)
{
/* Skip the input */
last -= 1;
}
else
{
si[last] = si[last - 1] + xd*sqrt( 1.e0 + powi(yd/
xd,2) );
}
}
}
else
{
si[last] = S[i];
if (last != 1)
{
if (si[last] == si[last - 1])
{
last -= 1;
}
else if (si[last] - si[last - 1] < 0.e0)
{
/* S values must be increasing */
dplote( 43, s, " " );
return;
}
}
}
if (klip == 2)
goto L_430;
}
i1 = i;
if (ni > 0)
{
if (last < MX)
return;
}
else
{
if (last == 0)
return;
}
/* Code to take care of clipping */
L_430:
if (klip != 0)
{
/* If LAST is < 3 just skip the output. */
if (last < 3)
goto L_880;
if ((klips < 0) || (klip > 1))
{
if (klips < 0)
{
/* Setup to fit quadratic to first three points to get replacement value. */
for (j = 1; j <= 3; j++)
{
Ds[j] = si[4 - j];
Dx[j] = Xi[4 - j];
Dy[j] = Yi[4 - j];
}
i2 = 1;
goto L_470;
}
/* Setup to fit quadratic to last three points to get replacement value. */
L_450:
for (j = 1; j <= 3; j++)
{
Ds[j] = si[last + j - 3];
Dx[j] = Xi[last + j - 3];
Dy[j] = Yi[last + j - 3];
}
i1 = i + 1;
i2 = last;
klip = -1;
/* Get divided differences, and interpolated values for boundary values. */
L_470:
for (k = 1; k <= 2; k++)
{
for (j = 1; j <= (3 - k); j++)
{
Dx[j] = (Dx[j + 1] - Dx[j])/(Ds[j + k] - Ds[j]);
Dy[j] = (Dy[j + 1] - Dy[j])/(Ds[j + k] - Ds[j]);
}
}
/* At this point either DX(3), or DY(3) is out of range, and we would
* like to replace the "worst" one with a value on the boundary. */
Ds[2] -= Ds[3];
Ds[1] -= Ds[3];
x1 = 0.e0;
y1 = 0.e0;
if ((Dy[3] < ymin) || (Dy[3] > ymax))
{
/* Get TP and TP1 for quadratic: DY(1)*s^2 - TP1 * s + TP = 0
* Where s is the increment from DS(3) */
tp = -ymin;
if (Dy[3] > ymax)
tp = -ymax;
yd = tp;
tp += Dy[3];
tp1 = Dy[2] - Dy[1]*Ds[2];
/* Get Y1 = smallest root */
tp2 = SQ(tp1) - 4.e0*Dy[1]*tp;
if (tp2 >= 0.e0)
{
/* Have real roots, else just ignore problem */
y1 = -2.e0*tp/(tp1 + sign( sqrt( tp2 ), tp1 ));
if (y1*(y1 - Ds[2]) > 0.e0)
{
/* Smallest root not in desired interval try the big one. */
y1 = tp/y1;
if (y1*(y1 - Ds[2]) > 0.e0)
y1 = 0.e0;
}
}
}
if ((Dx[3] < xmin) || (Dx[3] > xmax))
{
/* Same as above except for X */
tp = -xmin;
if (Dx[3] > xmax)
tp = -xmax;
xd = tp;
tp += Dx[3];
tp1 = Dx[2] - Dx[1]*Ds[2];
/* Get X1 = smallest root */
tp2 = SQ(tp1) - 4.e0*Dx[1]*tp;
if (tp2 >= 0.e0)
{
/* Have real roots, else just ignore problem */
x1 = -2.e0*tp/(tp1 + sign( sqrt( tp2 ), tp1 ));
if (x1*(x1 - Ds[2]) > 0.e0)
{
/* Smallest root not in desired interval try the big one. */
x1 = tp/x1;
if (x1*(x1 - Ds[2]) > 0.e0)
x1 = 0.e0;
}
}
}
tp = y1;
/* Pick value that is nearest middle of region */
if (Ds[2]*(tp - x1) < 0.e0)
{
tp = x1;
Xi[i2] = -xd;
/* Insure that high difference doesn't give a bulge. */
tp1 = (tp - Ds[2])*Dy[1];
if (Dy[2] < 0.e0)
{
tp1 = fmin( tp1, -.75e0*Dy[2] );
}
else
{
tp1 = fmax( tp1, -.75e0*Dy[2] );
}
Yi[i2] = Dy[3] + tp*(Dy[2] + tp1);
}
else
{
Yi[i2] = -yd;
/* Insure that high difference doesn't give a bulge. */
tp1 = (tp - Ds[2])*Dx[1];
if (Dx[2] < 0.e0)
{
tp1 = fmin( tp1, -.75e0*Dx[2] );
}
else
{
tp1 = fmax( tp1, -.75e0*Dx[2] );
}
Xi[i2] = Dx[3] + tp*(Dx[2] + tp1);
}
si[i2] += tp;
if (klips < 0)
{
klips = 0;
if (klip > 1)
goto L_450;
}
}
}
if (h != 0.e0)
{
i = KORD1;
j = KORD1;
goto L_800;
}
/*####
*#### If polar coodinates, this is place to do the transformation.
*#### Remember last point transformed. Think we don't want to touch
*#### points much beyond the half way point until we know we have
*#### seen the end. Need to recompute s, x, and y.
*####
* Need to get the starting H */
errmxl = -1.e0;
/* Process the points -- First get the starting step size */
hmax = .25e0*(si[last] - si[1]);
hmin = 0.e0;
h = .25e0*(si[min( last, 8 )] - si[1]);
L_520:
tp = si[1];
i = 0;
j = 1;
goto L_550;
/* Just selected a new point. */
L_540:
if (j > Loc[i] + 1)
j -= 1;
L_550:
i += 1;
/* I is index for points we are planning to test
* J is index from which we get the points. */
Loc[i] = j;
if (i < KORD1)
{
tp += h;
for (j = j + 1; j <= last; j++)
{
/* Save and process next if gone too far */
if (si[j] > tp)
goto L_540;
}
/* Didn't get a full set of points. */
j = last;
if (Loc[i] != j)
{
/* Take the last point if we can. */
i += 1;
Loc[i] = j;
}
if (i != KORD1)
{
if (j > i)
{
/* We could have got more in the initial set. */
hmax = .875e0*h;
h = .5e0*(h + hmin);
goto L_520;
}
goto L_750;
}
}
/* Check if error is about right */
for (j = 1; j <= KORD1; j++)
{
k = Loc[j];
Ds[j] = si[k];
Dx[j] = Xi[k];
Dy[j] = Yi[k];
}
/* Get divided differences */
for (k = 1; k <= KORD; k++)
{
for (j = 1; j <= (KORD1 - k); j++)
{
Dx[j] = (Dx[j + 1] - Dx[j])/(Ds[j + k] - Ds[j]);
Dy[j] = (Dy[j + 1] - Dy[j])/(Ds[j + k] - Ds[j]);
}
}
/* Check accuracy -- First for the starting stepsize. */
errmax = 0.e0;
j = 2;
tp = si[last];
for (k = 2; k <= last; k++)
{
if (k == Loc[j])
{
if (j < KORD1)
{
j += 1;
}
else
{
tp = si[k] + h;
}
}
else
{
s1 = si[k];
if (s1 > tp)
goto L_680;
/*++ CODE for KORD == 3 is inactive
* X1 = DX(4) + (S1 - DS(4)) * (DX(3) + (S1 - DS(3)) *
* 1 (DX(2) + (S1 - DS(2)) * DX(1)))
* ERRMAX = max(ERRMAX, abs(X1 - XI(K)) / XSCAL)
* Y1 = DY(4) + (S1 - DS(4)) * (DY(3) + (S1 - DS(3)) *
* 1 (DY(2) + (S1 - DS(2)) * DY(1)))
* ERRMAX = max(ERRMAX, abs(Y1 - YI(K)) / YSCAL)
*++ CODE for KORD == 2 is active */
x1 = Dx[3] + (s1 - Ds[3])*(Dx[2] + (s1 - Ds[2])*Dx[1]);
errmax = fmax( errmax, fabs( x1 - Xi[k] )/xscal );
y1 = Dy[3] + (s1 - Ds[3])*(Dy[2] + (s1 - Ds[2])*Dy[1]);
errmax = fmax( errmax, fabs( y1 - Yi[k] )/yscal );
/*++ END */
}
}
L_680:
if (errmax == errmxl)
hmin = h;
errmxl = errmax;
if (errmax > TOL)
{
if (h > hmin)
{
hmax = .857e0*h;
h = fmax( hmin, h*sqrt( sqrt( .5e0*TOL/errmax ) ) );
goto L_520;
}
}
else if (errmax < TOLLO)
{
if (errmax != 0.e0)
{
if (h < hmax)
{
hmin = 1.125e0*h;
h = fmin( hmax, h*sqrt( sqrt( .5e0*TOL/errmax ) ) );
goto L_520;
}
}
if ((ni > 0) && (Loc[KORD1] != KORD1))
{
k = 0;
for (l = 1; l <= i; l++)
{
j = Loc[l];
k += 1;
Xi[k] = Xi[j];
Yi[k] = Yi[j];
si[k] = si[j];
}
/* Set up to get more points before output. */
for (k = k + 1; k <= (last + k - j); k++)
{
j += 1;
Xi[k] = Xi[j];
Yi[k] = Yi[j];
si[k] = si[j];
}
last = k - 1;
/* Flag that we didn't see enough points. */
h = 0.e0;
if (i1 > ni)
return;
goto L_400;
}
}
/* Shift data to output place. */
L_750:
for (k = 1; k <= i; k++)
{
j = Loc[k];
Xi[k] = Xi[j];
Yi[k] = Yi[j];
si[k] = si[j];
}
/* Get rest of data, checking accuracy as we go. */
L_800:
l = j;
tp = si[i] + .3333333e0*(si[i] - si[i - KORD]);
tp1 = 1.e0;
L_830:
if (j < last)
{
j += 1;
s1 = si[j];
if (s1 > tp)
tp1 = powi((s1 - si[i])/(tp - si[i]),KORD1);
if (KORD == 3)
{
x1 = Dx[4] + (s1 - Ds[4])*(Dx[3] + (s1 - Ds[3])*(Dx[2] +
(s1 - Ds[2])*Dx[1]));
y1 = Dy[4] + (s1 - Ds[4])*(Dy[3] + (s1 - Ds[3])*(Dy[2] +
(s1 - Ds[2])*Dy[1]));
}
else if (KORD == 2)
{
x1 = Dx[3] + (s1 - Ds[3])*(Dx[2] + (s1 - Ds[2])*Dx[1]);
y1 = Dy[3] + (s1 - Ds[3])*(Dy[2] + (s1 - Ds[2])*Dy[1]);
}
errmax = tp1*fmax( fabs( x1 - Xi[j] )/xscal, fabs( y1 - Yi[j] )/
yscal );
if (errmax <= TOL)
goto L_830;
if (j > l + 1)
j -= 1;
i += 1;
/* Save data */
si[i] = si[j];
Xi[i] = Xi[j];
Yi[i] = Yi[j];
/* Update the differences */
for (l = 1; l <= KORD; l++)
{
Ds[l] = Ds[l + 1];
Dx[l] = Dx[l + 1];
Dy[l] = Dy[l + 1];
}
Ds[KORD1] = si[i];
Dx[KORD1] = Xi[i];
Dy[KORD1] = Yi[i];
for (l = KORD; l >= 1; l--)
{
Dx[l] = (Dx[l + 1] - Dx[l])/(Ds[KORD1] - Ds[l]);
Dy[l] = (Dy[l + 1] - Dy[l])/(Ds[KORD1] - Ds[l]);
}
goto L_800;
}
ilast = i - KORD1;
if (l < j)
{
/* Save last point if not saved yet. */
i += 1;
si[i] = si[j];
Xi[i] = Xi[j];
Yi[i] = Yi[j];
}
L_880:
if (klip == -1)
{
if (i > 1)
{
ilast = i;
}
else
{
ilast = 0;
}
}
else if (ni == 0)
{
ilast = i;
}
/* Get output for points I = 1 to I = ILAST */
if (ilast != 0)
dplotl( ilast, xi, yi );
if (iklip != 0)
{
/* Continue with point causing clipping. */
i1 = iklip;
last = 0;
klip = -2;
dplotl( -1, xi, yi );
goto L_380;
}
if (ni == 0)
{
/* End of a data set, get into initial state. */
last = -1;
dplotl( 0, xi, yi );
goto L_100;
}
last = 0;
for (j = ilast + 1; j <= i; j++)
{
/* Set up to start over. */
last += 1;
si[last] = si[j];
Xi[last] = Xi[j];
Yi[last] = Yi[j];
}
if (i1 > ni)
return;
goto L_400;
} /* end of function */
/* PARAMETER translations */
#define BTIMES "\\times "
/* end of PARAMETER translations */
void /*FUNCTION*/ dplotn(
double val,
long ikase,
double xypos[])
{
char _c0[2], align[3], dig[41], fmtsav[21];
LOGICAL32 dol;
static LOGICAL32 needd;
byte c;
long int _l0, i, k, kase, kten, ndig;
static long int maxdig, nchar0;
double ptsiz, v;
static double eps1;
static long ltextf = -2;
static long lkase = -1;
static long nlbnd[5]={0,5,1,0,0};
static long nubnd[5]={9,30,20,20,1};
static double hadj[3]={0.e0,.5e0,1.e0};
/* EQUIVALENCE translations */
static long _es0[6];
long int *const intval = (long*)_es0;
long int *const lexp = (long*)_es0;
long int *const lzero = (long*)((long*)_es0 + 4);
long int *const mindig = (long*)((long*)_es0 + 2);
long int *const naft = (long*)((long*)_es0 + 3);
long int *const nptsiz = (long*)((long*)_es0 + 1);
/* end of EQUIVALENCE translations */
/* OFFSET Vectors w/subscript range: 1 to dimension */
double *const Hadj = &hadj[0] - 1;
long *const Intval = &intval[0] - 1;
long *const Nlbnd = &nlbnd[0] - 1;
long *const Nubnd = &nubnd[0] - 1;
double *const Xypos = &xypos[0] - 1;
/* end of OFFSET VECTORS */
/* For output of numeric labels, F. T. Krogh, JPL, July 18, 1997.
*
* ************************* Arguments passed in ************************
*
* VAL Value to be printed.
* IKASE The label case. See comments for LENTXT in DPLOT above. If
* < 0, the value provided is the log10 of the number.
* OPAQUE .true. if the label is to go into an opaque box.
* XYPOS (Physical coordinate of the absicssa, Etc. for coordinate)
* FMTNUM See main comments in DPLOT.
* LENTXT Length of various strings in FMTNUM and TXTDEF.
*
* ************************* Usage of internal variables ****************
*
* ALIGN Alignment for the label -- passed into DPLOT4.
* C Temporary character*1 variable.
* DOL =.true. if a "$" has been output, =.false. otherwise.
* DIG Character string for storage of digits.
* EPS1 1 + 4 * machine eps. -- Used to avoid some round off problems.
* FMTSAV Saved value of string used to define the last format.
* HADJ Used to adjust for different hoizontal positioning when testing
* for overlap of numeric labels and drawing opaque boxes.
* I Temorary index.
* INTVAL Equivalenced to: LEXP, NPTSIZ, MINDIG, NAFTU, LZERO
* K Temorary index.
* KTEN integer part of log10(|VAL|). Also used for option values.
* LEXP Amount to bias in favor of exponent. > 0 favors exponents, <
* discourages them. LEXP = 4 always uses exponents.
* KASE abs(IKASE)
* LKASE Last value for KASE
* NTEXT* Index of last character deposited in TEXT.
* LTEXTF Length of the last format def. processed. -1 initially.
* LZERO Number of digits that must precede the decimal point.
* MAXDIG Maximum number of digits printed.
* MINDIG Minimum number of digits that need to be output.
* NAFT Number of digits required after the decimal point
* NCHAR0 Integer value associated with a '0', i.e. ichar('0').
* NDIG Number of characters stored in DIG.
* NEEDD Is .true. if the number must contain a decimal point.
* NLBND Lower bounds for options: X, F, D, A, and B. These options
* define:
* . Always print a decimal point.
* Fn Fontsize in points.
* Dn Number of significant digits which must be printed.
* An Number of digits which are required after the decimal point.
* Bn Number of digits which are required before the decimal point,
* Xn 0 < n < 10, bias for selecting the exponent notation. If n
* is not zero, it is replaced with n-5. The exponent notation is
* used if there are 4-(final value of n) or more zeros that are
* serving as place holders, else the usual format is used. Note
* that with an input n of 9, which is converted to n=4, there
* will always be at least 0 zeros, and exponent notation is used.
* NPTSIZ Default point size for this kind of label.
* NUBND Upper bounds for options: X, F, D, A, and B.
* OVLAP Estimated right end of last number with KASE = 1, 2, or 5.
* PTSIZ Real value of NPTSIZ.
* TEXT The final output TEXT sent to DPLOT4.
* TLENH Estimated space in units of space required by a single digit.
* Later the horizontal space required in points.
* TLENV Estimated vertical space in points.
* V Initially VAL, then |V|, then contains the tail of V, i.e.
* digits left to be output.
*
* ************************ Variable Declarations ***********************
*
* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/* Parameter pointers for integers in IP. */
/* Parameter pointers for floats in FP. */
/* Parameter for various sizes. */
/* Locals */
/* Save statement below, instead of just putting INTVAL above, is to get
* around a bug in the HP Exepmlar Fortran 77 compiler. */
/* Weird stuff to take care of "\" being treated as an escape character
* on SGI Fortran compilers */
/*++ CODE for ~.C. is inactive
* character BSLAS1*(*), BSLASH
* parameter (BSLAS1 = '\\')
* parameter (BSLASH = BSLAS1(1:1))
*c
* parameter (BTIMES=BSLASH//'times ')
*++ CODE for .C. is active */
/*++END
* */
/* X F D A B */
/* l c r */
/* ********************** Start of Executable Code **********************
*
* Alignment is in ALIGN */
kase = labs( ikase );
memcpy(align, dplotc.pos+kase*4 - 4, (size_t)2);
if (ltextf == dplotb.lentxt[kase - 1][0])
goto L_100;
/* ALIGN = POS(4*KASE-3:4*KASE-2)
* Take care of the format. */
if (ltextf == -2)
{
/* Get environmental parameters */
v = DBL_EPSILON;
maxdig = -log10( v );
eps1 = 1.e0 + 8.e0*v;
nchar0 = '0';
}
/* Process the format */
ltextf = dplotb.lentxt[kase - 1][0];
/* Set the default values. */
*lzero = 0;
*lexp = 0;
*mindig = 1;
*naft = 0;
*nptsiz = 9;
needd = FALSE;
if (ltextf > 0)
{
memcpy(fmtsav, dplotc.fmtnum[kase-1], (size_t)ltextf);
k = 0;
/* FMTSAV(1:LTEXTF) = FMTNUM(KASE)(1:LTEXTF) */
L_20:
k += 1;
L_30:
if (k < ltextf)
{
/* 12345678901 */
i = istrstr( ".XxFfDdAaBb", STR1(_c0,fmtsav[k - 1]) );
if (i != 0)
{
if (i == 1)
{
needd = TRUE;
goto L_20;
}
/* Get the following number */
kten = 0;
L_40:
k += 1;
if (k <= ltextf)
{
c = fmtsav[k - 1];
if ((c >= '0') && (c <= '9'))
{
kten = 10*kten + ( c ) - nchar0;
goto L_40;
}
}
if (kten != 0)
{
/* Want something other than the default. */
i /= 2;
if ((kten < Nlbnd[i]) || (kten > Nubnd[i]))
{
/* Print error message, ignore the option
* Format number out of range */
dplote( 4, xypos, " " );
}
else
{
Intval[i] = kten;
if (i == 1)
*lexp = kten - 5;
}
}
goto L_30;
}
else
{
/* Unknown format specification */
dplotb.ierr1 = k;
dplote( 5, xypos, fmtsav );
}
/* call DPLOTE(5, XYPOS, FMTSAV(1:K)) */
}
}
/* Convert value to string */
L_100:
dplotb.tlenh = 0.e0;
v = val;
dol = FALSE;
dplotb.ntext = 0;
if (ikase < 0)
{
ndig = 1;
kten = nint( v );
dig[0] = '1';
}
else
{
if (v == 0.e0)
{
kten = 0;
}
else
{
if (v < 0.e0)
{
/* Output the "-" sign */
dplotb.ntext += 2;
f_subscpy( dplotc.text, dplotb.ntext - 2, dplotb.ntext -
1, 280, "$-" );
dplotb.tlenh = 1.2e0;
dol = TRUE;
v = -v;
}
/* Boost up a tiny bit so things close to integers come out as integers. */
v *= eps1;
kten = log10( v );
if (v < 1.e0)
kten -= 1;
}
v *= powi(10.e0,-kten);
ndig = 0;
L_120:
if (ndig < *mindig)
{
L_130:
ndig += 1;
dig[ndig - 1] = (nchar0 + (long)( v ));
v = 10.e0*fmod( v, 1.e0 );
if ((v > 1.e-2) && (ndig < maxdig))
goto L_130;
if (kten - ndig <= 2 - *lexp)
{
/* NDIG - KTEN - 1 is number of digits after the decimal. */
if (ndig - kten <= *naft)
goto L_120;
}
}
}
/* At this point the number requires NDIG significant digits. */
if ((kten < -3 + *lexp) || (kten - ndig > 2 - *lexp))
{
/* Use the exponent form */
if (!dol)
{
dol = TRUE;
dplotb.ntext += 1;
dplotc.text[dplotb.ntext - 1] = '$';
}
if ((ndig != 1) || (dig[0] != '1'))
{
dplotb.ntext += 1;
dplotb.tlenh += (double)( ndig );
dplotc.text[dplotb.ntext - 1] = dig[0];
if (ndig > 1)
{
dplotb.tlenh += .4e0;
dplotc.text[dplotb.ntext] = '.';
memcpy(dplotc.text+dplotb.ntext+1,dig+1,(size_t)(ndig-1));
}
/* TEXT(NTEXT+2:NTEXT+NDIG) = DIG(2:NDIG) */
dplotb.ntext += ndig + 7;
f_subscpy( dplotc.text, dplotb.ntext - 7, dplotb.ntext -
1, 280, BTIMES );
dplotb.tlenh += 1.4;
}
f_subscpy( dplotc.text, dplotb.ntext, dplotb.ntext + 3, 280, "10^{"
);
dplotb.tlenh += 2.e0;
dplotb.ntext += 4;
if (kten < 0)
{
dplotb.ntext += 1;
dplotc.text[dplotb.ntext - 1] = '-';
kten = -kten;
dplotb.tlenh += 1.2e0;
}
k = 10;
L_140:
if (k <= kten)
{
k *= 10;
goto L_140;
}
L_150:
k /= 10;
if (k != 0)
{
/* Numbers on the exponent. */
dplotb.tlenh += .75e0;
i = kten/k;
dplotb.ntext += 1;
dplotc.text[dplotb.ntext - 1] = (nchar0 + i);
kten += -10*i;
goto L_150;
}
dplotb.ntext += 1;
dplotc.text[dplotb.ntext - 1] = '}';
}
else
{
/* Numbers without exponents */
if (kten < 0)
{
/* Number is < 1
* K introduced here due to bug in Lahey compiler. */
for (k = dplotb.ntext + 1; k <= (dplotb.ntext + *lzero); k++)
{
dplotb.tlenh += 1.e0;
dplotc.text[k - 1] = '0';
}
dplotb.ntext += *lzero + 1;
dplotc.text[dplotb.ntext - 1] = '.';
dplotb.tlenh += .4e0;
for (k = dplotb.ntext + 1; k <= (dplotb.ntext - kten -
1); k++)
{
dplotb.tlenh += 1.e0;
dplotc.text[k - 1] = '0';
}
dplotb.ntext -= kten;
memcpy(dplotc.text+dplotb.ntext-1, dig, (size_t)ndig);
dplotb.ntext += ndig - 1;
/* TEXT(NTEXT:NTEXT+NDIG-1) = DIG(1:NDIG) */
}
else
{
/* Number is >= 1. */
k = min( ndig, kten + 1 );
memcpy(dplotc.text+dplotb.ntext, dig, (size_t)k);
dplotb.ntext += k;
/* TEXT(NTEXT+1:NTEXT+K) = DIG(1:K) */
dplotb.tlenh += (double)( k );
if (ndig > k)
{
dplotb.ntext += 1;
dplotb.tlenh += .4e0 + (double)( ndig - k );
dplotc.text[dplotb.ntext - 1] = '.';
memcpy(dplotc.text+dplotb.ntext, dig+k, (size_t)(ndig-k));
dplotb.ntext += ndig - k;
/* TEXT(NTEXT+1:NTEXT+NDIG-K) = DIG(K+1:NDIG) */
}
else
{
if (kten >= k)
{
for (dplotb.ntext = dplotb.ntext; dplotb.ntext <= (dplotb.ntext +
kten - k); dplotb.ntext++)
{
dplotb.tlenh += 1.e0;
dplotc.text[dplotb.ntext] = '0';
}
}
if (needd)
{
dplotb.tlenh += .4e0;
dplotb.ntext += 1;
dplotc.text[dplotb.ntext - 1] = '.';
}
}
}
}
if (dol)
{
dplotb.ntext += 1;
dplotc.text[dplotb.ntext - 1] = '$';
}
/* Convert TLENH to physical distance */
ptsiz = *nptsiz;
dplotb.tlenh *= .5e0*ptsiz;
dplotb.tlenv = ptsiz;
if ((kase <= 2) || (kase == 5))
{
if (kase == lkase)
{
/* Check for overlap */
if ((lkase%2) == 1)
{
k = istrstr( "lLcCrR", STR1(_c0,align[1]) );
if (k != 0)
{
k = (k + 1)/2;
if (dplotb.ovlap > Xypos[1] - dplotb.tlenh*Hadj[k])
return;
/* Set the new overlap */
dplotb.ovlap = Xypos[1] + Hadj[4 - k]*dplotb.tlenh;
}
}
}
}
if (dplotb.noout)
return;
dplott( kase, xypos );
lkase = kase;
return;
} /* end of function */
/* PARAMETER translations */
#define BSHORT "\\shortstack[ ]{"
#define BSLAS2 "\\\\"
#define BSMALL "\\small "
/* end of PARAMETER translations */
void /*FUNCTION*/ dplott(
long kase,
double xypos[])
{
char _c0[2], outtxt[257];
static char fmtsav[33];
LOGICAL32 getsiz, vert;
byte c;
long int i, iax, j, k, l, lpar;
double hlen, hlens, hlsav, tp1, tp2, vlen;
static double ptsiz;
static long lastl = -2;
static long lfill2[3]={2,0,0};
static char adjv[4] = "tcb";
static char adjh[4] = "rcl";
static double adj1[3]={-1.e0,-.5e0,0.e0};
static double adj2[3]={0.e0,.5e0,1.e0};
/* OFFSET Vectors w/subscript range: 1 to dimension */
double *const Adj1 = &adj1[0] - 1;
double *const Adj2 = &adj2[0] - 1;
double *const Borloc = &dplotb.borloc[0] - 1;
double *const Fill = &dplotb.fill[0] - 1;
long *const Ip = &dplotb.ip[0] - 1;
long *const Lfill2 = &lfill2[0] - 1;
double *const Vhlen = &dplotb.vhlen[0] - 1;
double *const Xypos = &xypos[0] - 1;
/* end of OFFSET VECTORS */
/* Copyright (c) 1997, California Institute of Technology. U.S.
* Government Sponsorship under NASA Contract NAS7-1260 is acknowledged.
*
* For output ot text, and getting size of such output.
*
* ************************* Calling Sequence variables *****************
*
* KASE 1-4 for bottom, left, top,right borders, 5 and 6 for x and y
* axis, 8 for words, 10-15 for captions, 16 for output text. */
/* Indices, 1-16, are for: Borders (bottom, left, top, right),
* x-axis, y-axis, word alignment (e.g. for option 14), number
* formatting for option 15, Captions (as for borders), alignment
* rule for option 16. */
/* XYPOS Gives (x,y), the position for the text in physical coordinates.
* TEXT The Text to output.
*
* ************************* Usage of internal variables ****************
*
* ADJ1 Used for first point ajustment on box.
* ADJ2 Used for second point ajustment on box.
* ADJH Used to get index for horizontal adjustment of boxes.
* ADJV Used to get index for vertical adjustment of boxes.
* FMTSAV Saved value for the last format specification.
* GETSIZ Logical variable that is .true. if need to get size.
* HLEN Largest horizontal space required if not stacked, and the final
* value required in any case.
* HLENS Largest horizontal space required for various vertical cases.
* Also used as a temp.
* HLSAV Horizontal space required at the start of a "{" or "$" group.
* LASTL Length of text for the last format specification.
* LFILL2 Used to pass a length 3 array with a two in the first position,
* to DPLOT7.
* OUTTXT Final output form (aside from prefix and postfix, which are
* added in DPLOT
* PTSIZ Gives the size in points for the text being output.
* VERT Logical variable that is true if "stacking" the text.
* VLEN Vertical space required so far.
*
* *************************** Variable Declarations ********************
*
* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/* Parameter pointers for integers in IP. */
/* Parameter pointers for floats in FP. */
/* Parameter for various sizes. */
/* Locals */
/* Weird stuff to take care of "\" being treated as an escape character
* on SGI Fortran compilers */
/*++ CODE for ~.C. is inactive
* character BSLAS1*(*), BSLASH
* parameter (BSLAS1 = '\\')
* parameter (BSLASH = BSLAS1(1:1))
*c
* parameter (BSHORT=BSLASH//'shortstack[ ]{')
* parameter (BSLAS2=BSLAS1(1:1)//BSLAS1(1:1))
* parameter (BSMALL=BSLASH//'small ')
*++ CODE for .C. is active */
/*++END
* */
/* *************************** Start of Executable Code *****************
* */
iax = 2 - (kase%2);
vert = dplotc.pos[kase*4 - 2] == 's';
getsiz = (dplotb.noout || dplotb.opaque) || (dplotb.manno != 0);
if (getsiz || vert)
{
if (getsiz)
{
vert = vert || (((iax == 2) && (dplotb.manno == 0)) &&
(dplotc.pos[kase*4 - 4] == 'c'));
l = dplotb.lentxt[kase - 1][0];
if (l == lastl)
{
/* Format hasn't changed */
if (memcmp(dplotc.fmtnum[kase-1],fmtsav,(size_t)l)==0) goto L_60;
}
/* if (FMTNUM(KASE)(1:L) .eq. FMTSAV(1:L)) go to 60 */
lastl = l;
ptsiz = 9.e0;
if (l > 0)
{
memcpy(fmtsav, dplotc.fmtnum[kase-1], (size_t)l);
k = 0;
/* FMTSAV(1:L) = FMTNUM(KASE)(1:L) */
L_20:
if (k < l)
{
if ((dplotc.fmtnum[kase - 1][k - 1] == 'F') ||
(dplotc.fmtnum[kase - 1][k - 1] == 'f'))
{
/* Get the following number */
j = 0;
L_40:
k += 1;
if (k <= lastl)
{
c = fmtsav[k - 1];
if ((c >= '0') && (c <= '9'))
{
j = 10*j + ( c ) - '0';
goto L_40;
}
}
if ((j >= 5) && (j <= 30))
ptsiz = j;
}
k += 1;
goto L_20;
}
}
}
/* Accumlate sizes and text */
L_60:
vlen = 0.e0;
hlen = 0.e0;
hlens = 0.e0;
lpar = 0;
i = 0;
j = LBNDT - 1;
if (vert)
{
j = LBNDT + 16;
f_subscpy( outtxt, LBNDT - 1, j - 1, 256, BSHORT );
}
memcpy(outtxt+j-5, dplotc.pos+kase*4-4, (size_t)2);
L_80:
i += 1;
/* OUTTXT(J-4:J-3) = POS(4*KASE-3:4*KASE-2) */
if (i <= dplotb.ntext)
{
c = dplotc.text[i - 1];
if (c == BSLASH)
{
j += 1;
outtxt[j - 1] = BSLASH;
/* Skip '\' commands. */
L_90:
i += 1;
c = dplotc.text[i - 1];
if (((c >= 'a') && (c <= 'z')) || ((c >= 'A') && (c <=
'Z')))
{
j += 1;
outtxt[j - 1] = c;
goto L_90;
}
}
if (c == '{')
{
lpar += 1;
if (lpar == 1)
{
hlsav = hlen;
}
goto L_100;
}
else if (c == '}')
{
lpar -= 1;
if (lpar == 0)
hlens = fmax( hlens, hlen - hlsav );
goto L_100;
/* if (LPAR .ne. 0) go to 100
* HLENS = max(HLENS, HLEN - HLSAV)
* go to 80 */
}
else if (c == '$')
{
if (lpar >= 100)
{
lpar -= 100;
}
else
{
if (lpar == 0)
hlsav = hlen;
lpar += 100;
}
if (lpar == 0)
hlens = fmax( hlens, hlen - hlsav );
goto L_100;
}
else if (c == '^')
{
hlen -= .3e0;
goto L_100;
}
if (vert && (lpar == 0))
{
j += 2;
f_subscpy( outtxt, j - 2, j - 1, 256, BSLAS2 );
vlen += 1.e0;
}
hlen += 1.e0;
L_100:
j += 1;
outtxt[j - 1] = c;
goto L_80;
}
if (lpar != 0)
{
/* Error -- Caption doesn''t have balanced {...} or $...$. */
dplote( 6, xypos, dplotc.text );
}
if (dplotb.noout)
{
if ((iax == 2) && (dplotc.pos[kase*4 - 1] == '.'))
{
if (hlens < hlen - 2)
f_subscpy( dplotc.pos, kase*4 - 2, kase*4 - 1, 68, "sc"
);
}
if (dplotc.pos[kase*4 - 2] == 's')
{
hlen = hlens;
}
else
{
vlen = 1;
}
Vhlen[1] = ptsiz*vlen;
Vhlen[2] = .5e0*ptsiz*hlen;
return;
}
if (vert)
{
j += 1;
outtxt[j - 1] = '}';
}
if (dplotb.manno != 0)
{
/* Some kind of annotation. */
k = istrstr( adjv, STR1(_c0,dplotc.pos[kase*4 - 4]) );
l = istrstr( adjh, STR1(_c0,dplotc.pos[kase*4 - 3]) );
hlens = .5e0*ptsiz*hlen;
tp1 = Xypos[1] + Adj1[l]*hlens - .5e0;
tp2 = Xypos[1] + Adj2[l]*hlens + .5e0;
if (dplotb.manno > 0)
{
if ((tp1 < Borloc[2]) || (tp2 > Borloc[4]))
dplote( 7, xypos, dplotc.text );
}
else
{
if ((tp1 >= 0.e0) && (tp1 < Borloc[2] - dplotb.mbord[4][7]))
dplotb.mbord[4][7] = Borloc[2] - tp1;
if ((tp2 >= 0.e0) && (tp2 > Borloc[4] + dplotb.mbord[5][7]))
dplotb.mbord[5][7] = tp2 - Borloc[4];
}
}
if (dplotb.opaque)
{
i = 1;
dplot7( &i, lfill2, dplotb.fill );
dplot5( Xypos[1] + Adj1[l]*hlens - .5e0, Xypos[2] + ptsiz*
Adj1[k], Xypos[1] + Adj2[l]*hlens + .5e0, Xypos[2] +
ptsiz*Adj2[k] );
}
}
else
{
/* Just copy the text -- easy case. */
j = LBNDT;
memcpy(outtxt+j-1, dplotc.text, (size_t)dplotb.ntext);
j += dplotb.ntext - 1;
/* OUTTXT(J:J+NTEXT-1) = TEXT(1:NTEXT) */
}
/* Take care of prefix and postfix. */
i = LBNDT;
l = dplotb.lentxt[kase - 1][1];
k = dplotb.lentxt[kase - 1][2];
if (k < 0)
{
if ((Ip[LTYPE] == 0) && (k == -1))
{
/* The default prefix for LaTeX. */
f_subscpy( outtxt, i - 8, i - 2, 256, BSMALL );
i -= 7;
}
}
else
{
if (l > 0)
{
/* Prefix is specified. */
memcpy(outtxt+i-l-1, dplotc.txtdef[kase-1], (size_t)l);
i -= l;
/* OUTTXT(I-L:I) = TXTDEF(KASE)(1:L) */
}
if (k != 0)
{
/* Postfix is specified. */
memcpy(outtxt+j, dplotc.txtdef[kase-1]+l+1,(size_t)(k-l-l));
j += k - l - 1;
/* OUTTXT(J+1:J+K-L-1) = TXTDEF(KASE)(L+2:K) */
}
}
/* Output the text */
*(outtxt+j) = '\0';
dplot4( Xypos[1], Xypos[2], outtxt+i-1, dplotc.pos+kase*4-4);
return;
/* call DPLOT4(XYPOS(1),XYPOS(2),OUTTXT(I:J),POS(4*KASE-3:4*KASE-2)) */
} /* end of function */
void /*FUNCTION*/ dplotr(
double xy[],
long ksymb,
long kx,
long ky)
{
long int k;
/* OFFSET Vectors w/subscript range: 1 to dimension */
double *const Xy = &xy[0] - 1;
double *const Xybase = &dplotb.xybase[0] - 1;
double *const Xyu2pf = &dplotb.xyu2pf[0] - 1;
/* end of OFFSET VECTORS */
/* Gets XY converted for call to DPLOTS (Symbols, error bars, arrows) */
/* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/* Parameter pointers for integers in IP. */
/* Parameter pointers for floats in FP. */
/* Parameter for various sizes. */
k = labs( ksymb )%10;
if (k == 1)
{
k = (labs( ksymb )/10)%10;
if (k <= 1)
{
Xy[6] = Xy[2] + Xy[3];
if (k == 1)
Xy[2] += Xy[4];
Xy[4] = Xy[2] - Xy[3];
Xy[5] = Xy[1];
Xy[3] = Xy[1];
k = 3;
}
else
{
Xy[4] += Xy[2];
Xy[3] += Xy[1];
}
}
else
{
k = 1;
}
for (k = 1; k <= (2*k); k += 2)
{
if (ksymb >= 0)
{
/* Convert to physical and plot */
Xy[k] = Xybase[kx] + Xyu2pf[kx]*Xy[k];
Xy[k + 1] = Xybase[ky] + Xyu2pf[ky]*Xy[k + 1];
}
else
{
/* Convert to points. */
Xy[k] *= dplotb.topts;
Xy[k + 1] *= dplotb.topts;
}
}
dplots( xy, labs( ksymb ) );
return;
} /* end of function */
/*++ CODE for ~.C. is inactive
* subroutine DPLOTU (NEWU, FILNAM)
*c Get an unused unit number, open it for unformatted sequential scratch
*c usage if FILNAM is ' ', else open for formatted sequential output.
* integer NEWU
* character FILNAM*(*)
* double precision SPACE(1)
* logical OPENED
* integer IORES, NEXTU
* save NEXTU
*c Common Variables
*c
*c Parameter pointers for integers in IP.
* integer NEXT, INTERP, LCOOX,LCOOY,LXLINE,LXBORD,LYBORD, LTYPE,
* 1 KSET, LTANNO, LPEN, NBORD, LYDIM, LNY, LDEBUG,
* 2 LASTIP
* parameter (NEXT=1, INTERP=2, LCOOX=3, LCOOY=4, LXLINE=5,
* 1 LXBORD=6, LYBORD=7, LTYPE=8, KSET=9, LTANNO=10, LPEN=13,
* 2 NBORD=14, LYDIM=15, LNY=16, LDEBUG=18, LASTIP=LDEBUG)
*c Parameter pointers for floats in FP.
* integer LARROW,LWIDTH,LWIDRE,LBAD,LVALS,LXYSIZ,LASTFP,LFDAT
* parameter (LARROW=1, LWIDTH=2, LWIDRE=6, LBAD=7,
* 1 LVALS=9, LXYSIZ=LVALS+5, LASTFP=LXYSIZ+2,LFDAT=LBAD)
*c Parameter for various sizes.
* integer LBNDC, LBNDF, LBNDP, LBNDT, MAXSET
* parameter (LBNDC=128, LBNDF=32, LBNDP=4, LBNDT=64, MAXSET=20)
* double precision BORLOC(6), FILL(19), FP(LASTFP), OVLAP,
* 1 PHYUSE(2,2), SETLIM(2,2), TLENH, TLENV, TICKS(4,6), TOPTS,
* 2 VHLEN(2), XYBASE(MAXSET), XYLIM(2,MAXSET), XYU2PF(MAXSET)
* integer IERR1, IERR2, IERR3, IERR4, IOP1, IP(LASTIP), JSET(2),
* 1 LENCAP(6), LENTXT(3,18), MANNO, MBORD(8,6), MFILL(4), NTEXT,
* 2 NXYLIM(MAXSET)
* logical KLIP(MAXSET), NOOUT, OPAQUE
* common / DPLOTB / BORLOC, FILL, FP, OVLAP, PHYUSE, SETLIM, TICKS,
* 1 TLENH, TLENV, TOPTS, VHLEN, XYBASE, XYLIM, XYU2PF, IERR1,
* 2 IERR2, IERR3, IERR4, IOP1, IP, JSET, LENCAP, LENTXT, MANNO,
* 3 MBORD, NTEXT, NXYLIM, KLIP, MFILL, NOOUT, OPAQUE
*c
* data NEXTU / 10 / */
/*c
* do 100 NEWU = NEXTU, 100
* inquire (unit=NEWU, opened=OPENED)
* if (.not. OPENED) then
* if (FILNAM(1:1) .eq. ' ') then
* open (unit=NEWU, status='SCRATCH', access='SEQUENTIAL'
* 1, form='UNFORMATTED', iostat=IORES)
* if (IORES .eq. 0) go to 300
* close (unit=NEWU)
* else
* open (unit=NEWU, FILE=FILNAM, status='UNKNOWN'
* 1, form='FORMATTED', access='SEQUENTIAL', iostat=IORES
* 2, err=200)
* go to 300
* end if
* end if
* 100 continue
*c Unable to find unused I/O unit number in 10..100
* call DPLOTE(34, SPACE, ' ')
* return
*c Unable to open output file
* 200 IERR1 = len(FILNAM)
* call DPLOTE(35, SPACE, FILNAM)
* return
*c "Success" exit
* 300 NEXTU = NEWU + 1
* return
*++ END */
void /*FUNCTION*/ dplot0()
{
static char start[20] = "\\begin{mfpic}\\mfpic";
static long istart[2-(0)+1]={1,14,20};
/* end */
/* Copyright (c) 1996, California Institute of Technology. U.S.
* Government Sponsorship under NASA Contract NAS7-1260 is acknowledged.
*>> 1997-01-09 DPLOT0 Krogh Initial code.
*++ Current has HOW=MFPIC
*
* Much modified from earlier code by Van Snyder.
* Most dependencies of the plot package on mfpic are captured in this
* file. This code was originally in a separate file. Files combined
* because of problems in C with iofil being external.
*
* Start the plot.
*
* ***************************** Common Block ***************************
*
* ARRLEN If nonzero, next line or curve is to have an arrow on the end.
* This give the length of the arrow in points.
* PXO, PYO Origin of logical coordinate system in physical units.
* PXSIZE, PYSIZE Physical X and Y width of the plot, including outward-
* pointing tick marks.
* IOFIL Unit number used for output to be used for plot device.
* Temporarily increased by 1000 when want to end one mfpic group and
* immediately start another.
* IPLOT Defines output, 0 for LaTeX, 1 for TeX.
* KURPEN Rule defining the current pen. Defined as for P3 of option 3.
* KURPEN = t + 10*(w + 100*(L1 + 100*L2)), where t is 0, 1, or 2 for
* solid, dotted, or dashed lines. t = 3 or 4 is as for 1 or 2, except
* L1 is given in deci-points instead of points, and t = 5-8, is as for
* 1-4, except L2 if in deci-points instead of in points. w is the
* width of the line in decipoints, L1 and L2 are not used for solid
* lines. Else L1 is the diameter of the dots or the lenght of the
* dashes, and L2 is the distance between the dots or dashes.
* LASPEN The last value assigned to KURPEN.
*
* *************************** Internal Variables ***********************
*
* ISTART Points to place where text in START starts for a give value
* in IPLOT. (Only 0 and 1 supported.)
* START TeX command to write at the beginning -- \begin{mfpic} or
* \mfpic.
*
* **************************** Variable Declarations *******************
*
* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/* Locals */
/* Weird stuff to take care of "\" being treated as an escape character
* on SGI Fortran compilers */
/*++ CODE for ~.C. is inactive
* character BSLAS1*(*), BSLASH
* parameter (BSLAS1 = '\\')
* parameter (BSLASH = BSLAS1(1:1))
* character PSTART*19
* parameter (PSTART=BSLASH//'begin{mfpic}'//BSLASH//'mfpic')
* data START / PSTART /
*++ CODE for .C. is active
* 12345678901234567890 */
/*++END
* Data */
const char fmt10[] = " %.*s[ 1.0 ]{%9.3f}{%9.3f}{%9.3f}{%9.3f}\n";
fprintf(iofil, fmt10, (int)(istart[dplotd.iplot+1]-
istart[dplotd.iplot]), start+istart[dplotd.iplot]-1,
-dplotd.pxo, dplotd.pxsize, -dplotd.pyo, dplotd.pysize );
dplotd.laspen = 50;
/* 10 format (1x, a ,'[ 1.0 ]',4('{',f9.3,'}'))
*
* ********* Executable Statements ******************************
*++ CODE for ~.C. is inactive
* write (IOFIL, 10) START(ISTART(IPLOT):ISTART(IPLOT+1)-1),
* 1 -PXO, PXSIZE, -PYO, PYSIZE
*++ CODE for .C. is active
*++ END */
return;
} /* end of function */
/*================================================== DPLOT1 ===== */
void /*FUNCTION*/ dplot1()
{
long int l;
static long int it;
double tp1, tp2;
static double dash = -1.e0;
static double dashsp = -1.e0;
static double dotsz = -1.e0;
static double dotsp = -1.e0;
static double penwid = .5e0;
/* Specify the pen characteristics
*
* **** Variable Definitions (<name*> means variable is in common) ******
*
* ARRLEN* Length of arrow head to be drawn on next curve.
* DASH Length of dashes
* DASHSP Length of space between dashes.
* DOTSP Length of space between dots.
* DOTSZ Size of the dots.
* IOFIL* Output unit.
* IT Type of Line. Low digit of KURPEN.
* 0 Solid line
* 1 Dashed line
* 2 Dotted line
* 3:4 As for 1:2, except units for the length of the dashes or
* dots are given in deci-points instead of in points.
* 5:8 As for 1:4, except units for the length of the spaces are
* in deci-points instead of in points
* KURPEN* A packed integer, giving information on the kind of curve or
* line to draw, = IT + 10*(PENWID+10*(length or size + 10*(space
* between dots or dashes))).
* L Temp., used for the integer resulting from unpacking KURPEN.
* LASPEN The previous value of KURPEN.
* PENWID The width of the last line drawn.
* TP1 For temporary storage and to distinguish point/deci-points.
* TP2 For temporary storage and to distinguish point/deci-points.
*
* **************************** Variable Declarations *******************
*
* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/* Locals */
/*++ CODE for ~.C. is inactive
*c Weird stuff to take care of "\" being treated as an escape character
*c on SGI Fortran compilers
* character BSLAS1*(*), BSLASH
* parameter (BSLAS1 = '\\')
* parameter (BSLASH = BSLAS1(1:1))
* character*(*) BFMT1, BFMT2, BFMT3, BFMT4, BFMT5, BFMT6
* parameter (BFMT1='('''//BSLASH//'arrow[l '',f6.3,''pt]'')',
* 1 BFMT2='('''//BSLASH//'pen{'',F6.3,''pt}'')',
* 2 BFMT3='( '''//BSLASH//'dashlen='',F6.3,''pt'')',
* 3 BFMT4='( '''//BSLASH//'dashspace='',F6.3,''pt'')',
* 4 BFMT5='( '''//BSLASH//'dotsize='',F6.3,''pt'')',
* 5 BFMT6='( '''//BSLASH//'dotspace='',F6.3,''pt'')')
* character*(*) BDASH, BDOT
* parameter (BDASH='('''//BSLASH//'dashed'')',
* 1 BDOT='('''//BSLASH//'dashed'')') */
/*++ CODE for .C. is active */
const char fmt10[] = "\\arrow[l %6.3fpt]\n";
const char fmt20[] = "\\pen{%6.3fpt}\n";
const char fmt30[] = " \\dashlen{%6.3fpt}\n";
const char fmt40[] = " \\dashspace{%6.3fpt}\n";
const char fmt50[] = " \\dotsize{%6.3fpt}\n";
const char fmt60[] = " \\dotspace{%6.3fpt}\n";
if (dplotd.kurpen == dplotd.laspen)
goto L_100;
/*++ END
*
* ********* Executable Statements ******************************
* */
dplotd.laspen = dplotd.kurpen;
l = dplotd.laspen;
it = l%10;
l /= 10;
tp1 = (double)( l%100 )/10.e0;
if (tp1 == 0.e0)
tp1 = .5e0;
if (tp1 != penwid) fprintf(iofil, fmt20, tp1);
penwid = tp1;
/* if (TP1 .ne. PENWID) write(IOFIL, BFMT2) TP1 */
if (tp1 == 0.e0)
return;
l /= 100;
tp1 = (double)( l%100 );
tp2 = (double)( l/100 );
if (it > 0)
{
if (it > 4)
{
it -= 4;
tp2 /= 10.e0;
}
if (it > 2)
{
it -= 2;
tp1 /= 10.e0;
}
if (it == 1)
{
if (tp1 == 0.e0)
tp1 = 4.e0;
if (tp2 == 0.e0)
tp2 = .5e0*tp1;
if (tp1 != dash) fprintf(iofil, fmt30, tp1);
dash = tp1;
/* if (TP1 .ne. DASH) write(IOFIL, BFMT3) TP1 */
if (tp2 != dashsp) fprintf(iofil, fmt40, tp2);
dashsp = tp2;
/* if (TP2 .ne. DASHSP) write(IOFIL, BFMT4) TP2 */
}
else
{
if (tp1 == 0.e0)
tp1 = 1.5;
if (tp2 == 0.e0)
tp2 = .75e0*tp1;
tp2 += tp1;
if (tp1 != dotsz) fprintf(iofil, fmt50, tp1);
dotsz = tp1;
/* if (TP1 .ne. DOTSZ) write(IOFIL, BFMT5) TP1 */
if (tp2 != dotsp) fprintf(iofil, fmt60, tp2);
dotsp = tp2;
/* if (TP2 .ne. DOTSP) write(IOFIL, BFMT6) TP2 */
}
}
L_100:
if (dplotd.arrlen != 0)
{
/* Want an arrow on the next curve. */
fprintf(iofil, fmt10, dplotd.arrlen);
dplotd.arrlen = 0;
/* write (IOFIL, BFMT1) ARRLEN */
}
if (it == 0)
return;
if (it == 1)
{
fprintf(iofil, "\\dashed\n");
}
else
{
/* write(IOFIL, BDASH) */
fprintf(iofil, "\\dotted\n");
}
/* write(IOFIL, BDOT) */
return;
} /* end of function */
/*================================================== DPLOT2 ===== */
void /*FUNCTION*/ dplot2(
double x1,
double y1,
double x2,
double y2)
{
/* Draw a single straight line from (X1,Y1) to (X2,Y2) in physical
* coordinates. */
/* IOFIL* (In common) Gives Fortran I/O unit number for output file
* */
/* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/*++ CODE for ~.C. is inactive
*c Weird stuff to take care of "\" being treated as an escape character
*c on SGI Fortran compilers
* character BSLAS1*(*), BSLASH
* parameter (BSLAS1 = '\\')
* parameter (BSLASH = BSLAS1(1:1))
* character*(*) BFMT1
* parameter (BFMT1='('' '//BSLASH//
* 1 'lines{('',F9.3,'','',F9.3,''),('',F9.3,'','',F9.3,'')}'')')
*++ CODE for .C. is active */
const char fmt10[] = " \\lines{(%9.3f,%9.3f),(%9.3f,%9.3f)}\n";
dplot1();
/*++ END
*
* ********* Executable Statements ******************************
* */
fprintf(iofil, fmt10,x1, y1, x2, y2);
return;
/* write (IOFIL, BFMT1) X1, Y1, X2, Y2 */
} /* end of function */
/*================================================== DPLOT4 ===== */
void /*FUNCTION*/ dplot4(
double x,
double y,
char *otext,
char *align)
{
/* Output an annotation at (X,Y) in physical coordinates. */
/* X, Y Physical coordinates of the annotation.
* OTEXT The annotation
* ALIGN Characters to control alignment. The first is for vertical
* alignment, and may be t (top), c (center) or b (bottom). The
* second is for horizontal alignment, and may be l (left),
* r (right) or c (center). Otherwise, ALIGN is blank. */
/* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/*++ CODE for ~.C. is inactive
*c Weird stuff to take care of "\" being treated as an escape character
*c on SGI Fortran compilers
* character BSLAS1*(*), BSLASH
* parameter (BSLAS1 = '\\')
* parameter (BSLASH = BSLAS1(1:1))
* character*(*) BFMT1, BFMT2
* parameter (BFMT1='('' '//BSLASH//
* 1 'tlabel['',A2, '']('', F9.3, '','', F9.3, ''){'', A, ''}'')',
* 2 BFMT2='('' '//BSLASH//
* 3 'tlabel('', f9.3, '','', f9.3, ''){'', A,''}'')')
*++ CODE for .C. is active */
const char fmt10[] = " \\tlabel[%2.2s](%9.3f,%9.3f){%s}\n";
const char fmt20[] = " \\tlabel(%9.3f,%9.3f){%s}\n";
if (*align != ' ' || *(align+1) != ' ')
fprintf(iofil, fmt10, align, x, y, otext);
else
fprintf(iofil, fmt20, x, y, otext);
return;
/*++ END
*
* ********* Executable Statements ******************************
*
*++ CODE for ~.C. is inactive
* if (ALIGN .ne. ' ') then
* write (IOFIL, BFMT1) ALIGN, X, Y, OTEXT
* else
* write (IOFIL, BFMT2) X, Y, OTEXT
* end if
*++ CODE for .C. is active
*++ END */
} /* end of function */
/*================================================== DPLOT5 ===== */
void /*FUNCTION*/ dplot5(
double x1,
double y1,
double x2,
double y2)
{
/* Draw a rectangle with corners at (X1,Y1) and (X2,Y2) in physical
* coordinates, with the fill type, and PENWID given. */
/* (X1,Y1), (X2,Y2) Physical coordinates of corners of rectangle. */
/* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/*++ CODE for ~.C. is inactive
*c Weird stuff to take care of "\" being treated as an escape character
*c on SGI Fortran compilers
* character BSLAS1*(*), BSLASH
* parameter (BSLAS1 = '\\')
* parameter (BSLASH = BSLAS1(1:1))
* character*(*) BFMT1
* parameter (BFMT1='('' '//BSLASH//
* 1 'rect{('',F9.3,'','',F9.3,''),('',F9.3,'','',F9.3,'')}'')')
*++ CODE for .C. is active */
const char fmt10[] = " \\rect{(%9.3f,%9.3f),(%9.3f,%9.3f)}\n";
dplot1();
/*++ END */
/* ********* Executable Statements ****************************** */
fprintf(iofil, fmt10, x1, y1, x2, y2);
return;
/* write (IOFIL,BFMT1) x1, y1, x2, y2 */
} /* end of function */
/*================================================== DPLOT6 ===== */
void /*FUNCTION*/ dplot6(
double x,
double y,
double a,
double b,
double angle)
{
/* Draw an ellipse with center at (X,Y) with axes A and B in physical
* coordinates, with axis A rotated ANGLE degrees counterclockwise from
* the positive X-axis direction. */
/* (X,Y) Physical coordinates of the center of the ellipse
* A, B Axis lengths of the ellipse
* ANGLE A axis is rotated ANGLE degrees counterclockwise from
* the positive X-axis direction */
/* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/*++ CODE for ~.C. is inactive
*c Weird stuff to take care of "\" being treated as an escape character
*c on SGI Fortran compilers
* character BSLAS1*(*), BSLASH
* parameter (BSLAS1 = '\\')
* parameter (BSLASH = BSLAS1(1:1))
* character*(*) BFMT1, BFMT2
* parameter (BFMT1='('' '//BSLASH//
* 1'ellipse['',f9.3,'']{('',f9.3,'','',f9.3,''),'',f9.3,'','',f9.3,
* 2''}'')',
* 3 BFMT2='('' '//BSLASH//
* 4 'ellipse{('',f9.3,'','',f9.3,''),'',f9.3,'','',f9.3,''}'')')
*++ CODE for .C. is active */
const char fmt10[]=" \\ellipse[%9.3f]{(%9.3f,%9.3f),%9.3f,%9.3f}\n";
const char fmt20[]=" \\ellipse{(%9.3f,%9.3f),%9.3f,%9.3f}\n";
dplot1();
/*++ END
*
* ********* Executable Statements ******************************
* */
if (angle != 0)
{
fprintf(iofil, fmt10, angle, x, y, a, b);
}
else
{
/* write (IOFIL,BFMT1) ANGLE, X, Y, A, B */
fprintf(iofil, fmt20, x, y, a, b);
}
/* write (IOFIL,BFMT2) X, Y, A, B */
return;
} /* end of function */
/* ================================================= DPLOT7 ===== */
void /*FUNCTION*/ dplot7(
long *m,
long locfil[],
double fildef[])
{
long int j, k;
static char sfill[14] = "\\gfill\\gclear";
static long jfill[3]={1,7,14};
static double shadew = -1.e0;
static double hatchw = -1.e0;
/* OFFSET Vectors w/subscript range: 1 to dimension */
double *const Fildef = &fildef[0] - 1;
long *const Jfill = &jfill[0] - 1;
long *const Locfil = &locfil[0] - 1;
/* end of OFFSET VECTORS */
/* Takes care of fill requests
*
* HATCHW Size of lines used for hatch lines.
* FILDEF Vector giving giving dot size/space, and hatch info. First 6
* locs. are for 3 pairs of info for dots, next 9 for 3 sets of thatch
* info.
* J Temp. to track index for fill pattern.
* JFILL Data telling where to find things in SFILL.
* K Temp. used to hold a value from LFILL.
* LOCFIL* Array with fill pattern info. Entries 1 to m of LOCFIL
* contain actions indices as follows.
* 0 For no action, should not be used?
* 1 For fill with black.
* 2 For erase what preceded.
* 3 For shading with dots.
* 4 For shading with hatch lines.
* M Absolute value gives the number of fill patterns. M is set to
* min (M, 0) on exit which has the effect of turning off filling after
* a call when M > 0.
* SFILL Text for output when LFILL( ,1:2) is 1 or 2.
* SHADEW Size of dots for shading.
*
* **************************** Variable Declarations *******************
*
* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/* Locals */
/*++ CODE for ~.C. is inactive
*c Weird stuff to take care of "\" being treated as an escape character
*c on SGI Fortran compilers
* character BSLAS1*(*), BSLASH
* parameter (BSLAS1 = '\\')
* parameter (BSLASH = BSLAS1(1:1))
* character*(*) BFMT1, BFMT2, BFMT3, BFMT4
* parameter (BFMT1='('' '//BSLASH//
* 1 'thatch['', F9.3, '','', F9.3,'']'')',
* 2 BFMT2='('' '//BSLASH//
* 3 'shadewd{'', F9.3, ''}'')',
* 4 BFMT3='('' '//BSLASH//
* 5 'shade['', F9.3, '']'')',
* 6 BFMT4='('' '//BSLASH//
* 7 'hatchwd{'', F9.3, ''}'')')
* character PSFILL*13
* parameter (PSFILL=BSLASH//'gfill'//BSLASH//'gclear')
* data SFILL / PSFILL /
*++ CODE for .C. is active
* 12345678901234 */
const char fmt10[]=" \\thatch[%9.3f,%9.3f]\n";
/*++ END */
/* ********* Executable Statements ******************************
* */
for (j = 1; j <= labs( *m ); j++)
{
k = Locfil[j];
if (k <= 2)
{
fprintf(iofil, " %.*s\n",(int)(jfill[k]-jfill[k-1]),
sfill+jfill[k-1]-1);
}
else if (k == 3)
{
/* write (IOFIL, '(1X, A)') SFILL(JFILL(K):JFILL(K+1)-1) */
if (Fildef[2*j - 1] != shadew)
{
shadew = Fildef[2*j - 1];
fprintf(iofil, " \\shadewd{%9.3f}\n", shadew);
}
/* write (IOFIL, BFMT2) SHADEW */
fprintf(iofil, " \\shade[%9.3f]\n", fildef[2*j-1]);
}
else if (k == 4)
{
/* write (IOFIL, BFMT3) FILDEF(2*J) */
if (Fildef[3*j + 4] != hatchw)
{
hatchw = Fildef[3*j + 4];
fprintf(iofil, " \\hatchwd{%9.3f}\n", hatchw);
}
/* write (IOFIL, BFMT4) HATCHW */
fprintf(iofil, fmt10, fildef[3*j + 4], fildef[3*j + 5]);
}
/* write (IOFIL, BFMT1) FILDEF(3*J+5), FILDEF(3*J+6) */
}
*m = min( *m, 0 );
return;
} /* end of function */
/* ========================== DPLOT8 ============================ */
void /*FUNCTION*/ dplot8(
double penwid,
double base,
double step,
double till,
double tbeg,
double tend,
long iax,
double strlog)
{
/* Outputs tick marks for MFPIC (actually for METAFONT)
* F. T. Krogh -- JPL -- August 6, 1997
* PENWID The pen width
* BASE The starting point for the thing that varies.
* STEP The increment for the above.
* TILL The final point for the above.
* TBEG The location where the ticks start (constant for all ticks)
* TEND Where the ticks end (like TBEG).
* IAX = 1 for horizontal case, = 2 for vertical.
* STRLOG < 0 for usual case. Else give minimum location for logs.
* IOFIL* The output unit
*## Maybe use IAX > 2 for polar cases??
*
* **************************** Variable Declarations *******************
* */
/* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/*++ CODE for ~.C. is inactive
*c Weird stuff to take care of "\" being treated as an escape character
*c on SGI Fortran compilers
* character BSLAS1*(*), BSLASH
* parameter (BSLAS1 = '\\')
* parameter (BSLASH = BSLAS1(1:1))
* character*(*) BFMT1
* parameter (BFMT1='('' '//BSLASH//
* 1'mfsrc{''/'' pickup pencircle scaled '',F6.3,''pt;''/'' for x='',
* 2F10.3, '' step '', F10.3, '' until '', F11.3, '':'')')
*c
* 20 format(' draw(x, ',F11.3,')*pt..(x, ',F11.3,')*pt;'/' endfor;}')
* 30 format(' draw(',F11.3,', x)*pt..(',F11.3,', x)*pt;'/' endfor;}')
* 40 format(' for j = 2 upto 9:'/' y:=x+',F11.3,'*mlog j;'/
* 1 ' exitif y>', F11.3, ';' /' if y>=', F11.3, ':')
* 50 format(' draw(y, ',F11.3,')*pt..(y, ',F11.3,')*pt;'/
* 1 ' fi' / ' endfor;'/' endfor;}')
* 60 format(' draw(',F11.3,', y)*pt..(',F11.3,', y)*pt;'/
* 1 ' fi' / ' endfor;'/' endfor;}')
*++ CODE for .C. is active */
const char fmt10[]=" \\mfsrc{\n pickup pencircle scaled %6.3fpt;\n\
for x=%10.3f step %10.3f until %11.3f:\n";
const char fmt20[]=" draw(x, %11.3f)*pt..(x, %11.3f)*pt;\n\
endfor;}\n";
const char fmt30[]=" draw(%11.3f, x)*pt..(%11.3f, x)*pt;\n\
endfor;}\n";
const char fmt40[]=" for j = 2 upto 9:\n y:=x+%11.3f*mlog j;\n\
exitif y>%11.3f;\n if y>=%11.3f:\n";
const char fmt50[]=" draw(y, %11.3f)*pt..(y, %11.3f)*pt;\n fi\n\
endfor;\n endfor;}\n";
const char fmt60[]=" draw(%11.3f, y)*pt..(%11.3f, y)*pt;\n fi\n\
endfor;\n endfor;}\n";
if (strlog < 0.e0)
{
/*++ END */
/* Regular ticks */
fprintf(iofil, fmt10, penwid, base, step, till);
if (iax == 1)
{
/* write(IOFIL, BFMT1) PENWID, BASE, STEP, TILL */
fprintf(iofil, fmt20, tbeg, tend);
}
else
{
/* write (IOFIL, 20) TBEG, TEND */
fprintf(iofil, fmt30, tbeg, tend);
}
/* write (IOFIL, 30) TBEG, TEND */
}
else
{
/* Logarithmic ticks */
fprintf(iofil, fmt10, penwid, base - step, step, till);
fprintf(iofil, fmt40, .00169646282*step, till, strlog);
if (iax == 1)
{
/* write(IOFIL, BFMT1) PENWID, BASE-STEP, STEP, TILL
* write(IOFIL, 40) .00169646282*STEP, TILL, STRLOG */
fprintf(iofil, fmt50, tbeg, tend);
}
else
{
/* write (IOFIL, 50) TBEG, TEND */
fprintf(iofil, fmt60, tbeg, tend);
}
/* write (IOFIL, 60) TBEG, TEND */
}
return;
} /* end of function */
/*================================================== DPLOT9 ===== */
void /*FUNCTION*/ dplot9()
{
static char fin[21] = "\\end{mfpic}\\endmfpic";
static long ifin[2-(0)+1]={1,12,21};
/* Finish the plot.
*
* *************************** Internal Variables ***********************
*
* IFIN Points to place where text in START starts for a give value
* in IPLOT. (Only 0 and 1 supported.)
* FIN TeX command to write at the end -- \end{mfpic} or \endmfpic.
*
* **************************** Variable Declarations *******************
* */
/* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/*++ CODE for ~.C. is inactive
*c Weird stuff to take care of "\" being treated as an escape character
*c on SGI Fortran compilers
* character BSLAS1*(*), BSLASH
* parameter (BSLAS1 = '\\')
* parameter (BSLASH = BSLAS1(1:1))
*c
* character*(*) BFMT1
* parameter (BFMT1='(1X,A,''{'//BSLASH//
* 1 'hskip '',F9.3,''pt'//BSLASH//'relax}%'')')
* character PFIN*20
* parameter (PFIN=BSLASH//'end{mfpic}'//BSLASH//'endmfpic')
* data FIN / PFIN /
*++ CODE for .C. is active
* 123456789012345678901 */
const char fmt10[]=" %.*s{\\hskip %9.3fpt\\relax}%%\n";
/*++ END
* Format below works for both TeX and LaTeX (LaTeX could use \hspace).
*
* ********* Executable Statements ****************************** */
if (dplotd.iplot < 0)
{
dplotd.iplot = -100 - dplotd.iplot;
if (dplotd.iplot > 1)
return;
fprintf(iofil, fmt10, (int)(ifin[dplotd.iplot+1]-
ifin[dplotd.iplot]), fin+ifin[dplotd.iplot]-1,
-dplotd.pxo - dplotd.pxsize);
dplot0();
/* write (IOFIL, BFMT1) FIN(IFIN(IPLOT):IFIN(IPLOT+1)-1),-PXO-PXSIZE */
}
else
{
fprintf(iofil, " %.*s\n", (int)(ifin[dplotd.iplot+1] -
ifin[dplotd.iplot]), fin + ifin[dplotd.iplot] - 1);
}
/* write (IOFIL, '(1X,A)') FIN(IFIN(IPLOT):IFIN(IPLOT+1)-1) */
return;
} /* end of function */
/*================================================== DPLOTL ===== */
void /*FUNCTION*/ dplotl(
long many,
double x[],
double y[])
{
long int i, k;
static long int ixpref;
static double oldx[3], oldy[3];
static char prefix[49] = "\\polygon{\\lines{\\lclosed \\curve{\\cyclic{\\curve{,";
static long state = -1;
static long lprefx[1-(-5)+1]={1,10,17,33,41,48,49};
/* OFFSET Vectors w/subscript range: 1 to dimension */
double *const Oldx = &oldx[0] - 1;
double *const Oldy = &oldy[0] - 1;
double *const X = &x[0] - 1;
double *const Y = &y[0] - 1;
/* end of OFFSET VECTORS */
/* Plot a line through a sequence of points. */
/*>> 1996-12-18 DPLOTL Snyder Initial code for MFPIC */
/* MANY [in] Defines action
* .le. 0 End previous curve if any -- X and Y not used. Then
* if -1 start a new open curve.
* if -2 start a new closed curve.
* if -3 start a curve that is closed with a straight line.
* if -4 start a new polyline.
* if -5 start a new polygon.
* > 0 Output for plotting of MANY points.
* No message is produced if MANY <= 0 twice in a row -- the second
* MANY is used silently.
* X [in] is an array of one or more abscissae.
* Y [in] is an array of one or more ordinates. The number of ordinates
* must be the same as the number of abscissae. */
/* ***** External References ******************************** */
/* ERMSG Print error messages. */
/* ***** Local Variables ************************************ */
/* FORMAT output format when finishing a curve.
* I is a loop inductor and subscript.
* IXPREF index of PREFIX and LPREFX to use.
* K count of items to print.
* LPREFX Points to start of text in PREFIX, for various cases.
* IOFIL* The logical unit number to use for plot output.
* OLDX, OLDY the last X and Y value on the previous call.
* PREFIX Character strings used for headers.
* STATE The number of points saved. If -1, no curve is started.
* Else 0 <= STATE <= 3. */
/* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/* ***** Data Statements ************************************ */
/*++ CODE for ~.C. is inactive
* character*(62) FORMAT(3)
* save FORMAT
* data FORMAT /
* 1'(a,''('',f9.4,'','',f9.4,'')}'')' ,
* 2'(a,''('',f9.4,'','',f9.4,''),('',f9.4,'','',f9.4,'')}'')',
* 3'(a,''('',f9.4,'','',f9.4,'')'',2('',('',f9.4,'','',f9.4,'')''),
* 4''}'')'/
*++ END
* */
/*++ CODE for (HOW==MFPIC) & ~.C. is INACTIVE
*c Weird stuff to take care of "\" being treated as an escape character
*c on SGI Fortran compilers
* character BSLAS1*(*), BSLASH
* parameter (BSLAS1 = '\\')
* parameter (BSLASH = BSLAS1(1:1))
*c
* character PPREFX*48
* parameter (PPREFX=BSLASH//'polygon{'//BSLASH//'lines{'//BSLASH//
* 1 'lclosed '//BSLASH//'curve{'//BSLASH//'cyclic{'//BSLASH//
* 2 'curve{,')
* data PREFIX / PPREFX /
*++ CODE for (HOW==MFPIC) & .C. is ACTIVE
* 1111111111222222222233333333334444444444
* 1234567890123456789012345678901234567890123456789 */
/*++ END */
/*++ CODE for ~.C. is inactive
* 10 format (a, '(', f9.4, ',', f9.4, ')',2(',(', f9.4, ',', f9.4, ')'
* 1:)/(3(',(', f9.4, ',', f9.4, ')')))
*++ END */
/* ***** Executable Statements ****************************** */
if (many <= 0)
{
/*++ CODE for ~.C. is inactive
* if (STATE .gt. 0) write (IOFIL, FORMAT(STATE))
* 1 PREFIX(LPREFX(IXPREF):LPREFX(IXPREF+1)-1),
* 2 (OLDX(I), OLDY(I), I = 1, STATE)
*++ CODE for .C. is active */
if (state > 0){
fprintf(iofil, "%.*s", (int)(lprefx[ixpref+6] -
lprefx[ixpref+5]), prefix+lprefx[ixpref+5]-1);
for (i = 0; i < state; i++) {
if (i != 0) fprintf(iofil, ",");
fprintf(iofil, "(%9.4f,%9.4f)", oldx[i], oldy[i]);}
fprintf(iofil, "}\n");}
ixpref = many;
/*++ END */
state = 0;
if (many == 0)
state = -1;
}
else if (state >= 0)
{
k = many - 1 - ((many + state - 1)%3);
if (state + k >= 3)
{
/*++ CODE for ~.C. is inactive
* write (IOFIL, 10) PREFIX(LPREFX(IXPREF):LPREFX(IXPREF+1)-1),
* 1 (OLDX(I), OLDY(I), I = 1, STATE), (X(I), Y(I), I = 1, K)
*++ CODE for .C. is active */
fprintf(iofil, "%.*s", (int)(lprefx[ixpref+6] -
lprefx[ixpref+5]), prefix+lprefx[ixpref+5]-1);
for (i = 0; i < state; i++) {
if (i != 0) {
if (i%3 == 0) fprintf(iofil, "\n");
fprintf(iofil, ",");}
fprintf(iofil, "(%9.4f,%9.4f)", oldx[i], oldy[i]);}
for (i = 0; i < k; i++) {
if (i + state != 0) {
if ((i+state)%3 == 0) fprintf(iofil, "\n");
fprintf(iofil, ",");}
fprintf(iofil, "(%9.4f,%9.4f)", x[i], y[i]);}
fprintf(iofil, "\n");
ixpref = 0;
/*++ END */
state = 0;
}
for (i = max( k, 0 ) + 1; i <= many; i++)
{
state += 1;
Oldx[state] = X[i];
Oldy[state] = Y[i];
}
}
else
{
puts( "DPLOTL (Internal bug) Adding points without initialization." );
exit(0);
}
return;
} /* end of function */
/*================================================== DPLOTS ===== */
/* PARAMETER translations */
#define D2R .01745329251994329576923690768488612713442871889e0
#define KPENDF 30
/* end of PARAMETER translations */
void /*FUNCTION*/ dplots(
double xy[],
long ksymb)
{
LOGICAL32 clear;
static LOGICAL32 cleari;
byte comma;
long int i, igcd, j, k, np;
static long int locpen, lpena, lpenc, lpenh, lpenv, nskip, nvert;
double a, a0, ai, r, ww, xa, xmax, xmin, xw, ya, ymax, ymin, yw;
static double arrloc, barmid, btbars, diamet, rotate, sizcir;
static long lsymb = -1;
/* OFFSET Vectors w/subscript range: 1 to dimension */
double *const Xy = &xy[0] - 1;
/* end of OFFSET VECTORS */
/* Plot a symbol or error bars or vectors at (XY(1), XY(2). XY contains
* extra data for error bars or vectors as follows:
* For error bars:
* XY(1:2) is the mid point.
* XY(3:4) is the bottom.
* XY(5:6) is the top.
* For Arrows:
* XY(1:2) is the tail.
* XY(3:4) is the head.
*
* KSYMB is an integer with digit defining what is to be drawn.
* KSYMB = i1 + 10 * (i2 + 10 * (i3 + 10 * (i4 + 10*i5)))
* if (i2 is not 1) then
* i1 is number of vertices for a polygon
* i2 is the number to "skip" when drawing the symbol
* i3 defines angle of rotation for the first point - 45 * i3 / i1.
* i4 width of line to use in drawing, in deci-points.
* i5 The diameter of the circle, if 0, 6 is used.
* else if (i1 is 0 or 1) then (let i5 = i6 = 10 * i7)
* i3 length of horizontal line for top/bottom error bar in points.
* i4 length of horizontal line in middle in points.
* i6 width in deci-points for the cross hatch lines.
* i7 width in deic-points for the vertical line, if 0, 3 is used.
* else (let i5 = i6 = 10 * i7)
* i3 length of the arrow head for an arrow.
* i4 size of circle in points to be drawn at the tail of the arrow.
* i6 width in decipoints for line used to draw the circle.
* i7 width in decipoints of the line use to draw the arrow.
* end if
*
* **************** Variables Definitions ******************************
*
* A Angle of current vertex, in degrees.
* A0 Angle of initial vertex, in degrees.
* AI Angle increment, in degrees.
* ARRLEN* Length of an arrow head.
* ARRLOC Local length of arrow head.
* BARMID Length of middle bar for error bars.
* BTBARS Legth of top and bottom bars for error bars.
* CLEAR Logical variable set = .true. when symbol is drawn twice, the
* time to clear the space, before drawing the symbol.
* CLEARI The initial value used for CLEAR.
* COMMA Either ',' or ' ', depending on whether the last point in a
* polygon or line is being emitted.
* D2R Degrees to radians.
* IGCD The gcd of (NVERT, NSKIP).
* I, J, K Loop inductors.
* KPENDF Default value used for KURPEN.
* KURPEN* Line width parameter, from KSYMB.
* LOCPEN The pen width saved for symbols.
* LPENA Value of KURPEN for line used to draw an arrow.
* LPENC Value of KURPEN for line used to draw an circle for vector
* fields.
* LPENH Value of KURPEN for line used to draw an horizontal lines for
* error bars.
* LPENV Value of KURPEN for line used to draw an vertical lines for
* error bars.
* NP Number of points to plot.
* NSKIP Number of vertices to skip, from KSYMB.
* NVERT Number of vertices, from KSYMB.
* R Circumcircle radius, 0.5 * max(W, SIZE-W)
* ROTATE Amount the first point is rotated from the positive x-axis.
* SIZCIR Diameter of circle use for vector fields.
* WW 0.01 * KURPEN = line width in points.
* XA, YA Average of XMAX, XMIN etc.
* XMAX, XMIN, YMAX, YMIN Obvious.
* XW, YW Working values for X and Y.
*
* Formals */
/* Common
* For DPLOT0 */
/*++ CODE for ~.C. is inactive
* integer IOFIL, IPLOT, KURPEN, LASPEN
* common / DPLOTD / ARRLEN, PXO, PXSIZE, PYO, PYSIZE,
* 1 IOFIL, IPLOT, KURPEN, LASPEN
*++ CODE for .C. is active */
/*++ END */
/* Locals */
/*++ CODE for ~.C. is inactive
*c Weird stuff to take care of "\" being treated as an escape character
*c on SGI Fortran compilers
* character BSLAS1*(*), BSLASH
* parameter (BSLAS1 = '\\')
* parameter (BSLASH = BSLAS1(1:1))
* character*(*) BFMT1, BFMT3
* parameter (BFMT1='('' '//BSLASH//
* 1 'circle{('', F10.3, '','', F10.3, ''),'', F10.3,''}'')',
* 2 BFMT3='('' '//BSLASH//
* 3 'lines{('',F12.5,'','',F12.5,''),'',''('',F12.5,'','',F12.5,
* 4'')}'')')
* 20 format (2x, '(', f12.5, ',', f12.5, ')', a)
* character*(*) BFILL, BCLEAR, BPOLY, BLINES
* parameter (BFILL='('' '//BSLASH//'gfill'')',
* 1 BCLEAR= '('' '//BSLASH//'gclear'')',
* 2 BPOLY= '('' '//BSLASH//'polygon{'')',
* 2 BLINES= '('' '//BSLASH//'lines{'')')
*++ CODE for .C. is active */
const char fmt10[]=" \\circle{(%10.3f,%10.3f),%10.3f}\n";
const char fmt20[]=" (%12.5f,%12.5f)%c\n";
const char fmt30[]=" \\lines{(%12.5f,%12.5f),(%12.5f,%12.5f)}\n";
if (ksymb != lsymb)
{
/*++ END
*
* ********* Executable Statements *****************************
*
* Unpack the data. */
lsymb = ksymb;
k = lsymb;
nvert = k%10;
k /= 10;
nskip = k%10;
k /= 10;
if (nvert != 1)
{
/* Got a symbol */
if (nvert != 0)
rotate = (double)( (k%10)*45 )/(double)( nvert );
k /= 10;
locpen = 10*(k%10);
if (locpen == 0)
{
locpen = KPENDF;
}
else if (locpen == 90)
{
locpen = 0;
}
diamet = (double)( k/10 );
cleari = FALSE;
if (diamet >= 100.e0)
{
diamet = fmod( diamet, 100.e0 );
cleari = TRUE;
}
if (diamet == 0.e0)
diamet = 6.e0;
}
else if (nskip <= 1)
{
/* Error Bars -- two types */
btbars = k%10;
k /= 10;
barmid = k%10;
k /= 10;
lpenh = 10*(k%10);
lpenv = 10*(k/10);
}
else if (nskip == 2)
{
/* Vector field */
arrloc = k%10;
k /= 10;
sizcir = k%10;
k /= 10;
lpenc = 10*(k%10);
if (lpenc == 0)
lpenc = 20;
lpena = 10*(k/10);
}
else
{
/* Perhaps do text in the future? */
return;
}
}
if (nvert != 1)
{
clear = cleari;
dplotd.kurpen = locpen;
dplot1();
L_100:
ww = .01e0*(double)( locpen );
r = .5e0*fmax( ww, diamet - ww );
if (nvert == 0)
{
if (locpen == 0)
{
fprintf(iofil, " \\gfill\n");
clear = FALSE;
/* write (IOFIL, BFILL) */
}
else if (clear)
{
fprintf(iofil, " \\gclear\n");
}
/* write (IOFIL, BCLEAR) */
fprintf(iofil, fmt10, xy[0], xy[1], r);
}
else
{
/* write (IOFIL, BFMT1) XY(1), XY(2), R */
ai = (double)( (nskip + 1)*360 )/(double)( nvert );
if (nskip > nvert)
{
nskip = nvert;
igcd = nvert;
}
else
{
/* Get the GCD of NSKIP, NVERT */
igcd = nskip + 1;
k = nvert;
L_120:
i = k%igcd;
if (i != 0)
{
k = igcd;
igcd = i;
goto L_120;
}
}
np = nvert/igcd;
xa = 0.0;
ya = 0.0;
xmax = 0.0;
xmin = 0.0;
ymax = 0.0;
ymin = 0.0;
for (k = 1; k <= 2; k++)
{
/* K = 1 => get XMIN etc; K = 2 => draw. */
a0 = rotate;
for (i = 1; i <= igcd; i++)
{
if (k == 2)
{
if (nskip != nvert)
{
if (np != 2)
{
if (locpen == 0)
{
fprintf(iofil, " \\gfill\n");
}
else if (clear)
{
/* write (IOFIL, BFILL) */
fprintf(iofil, " \\gclear\n");
}
/* write (IOFIL, BCLEAR) */
fprintf(iofil, " \\polygon\n");
}
else if (clear)
{
/* write (IOFIL, BPOLY) */
fprintf(iofil, " \\gclear\n");
fprintf(iofil, fmt10, xy[0], xy[1], r);
goto L_400;
/* write (IOFIL, BCLEAR)
* write (IOFIL, BFMT1) XY(1), XY(2), R */
}
else
{
fprintf(iofil, " \\lines\n");
}
/* write (IOFIL, BLINES) */
}
else if (clear)
{
fprintf(iofil, fmt10, xy[0], xy[1], r);
goto L_400;
/* write (IOFIL, BFMT1) XY(1), XY(2), R */
}
}
a = a0;
comma = ',';
for (j = 1; j <= np; j++)
{
xw = xa + r*cos( D2R*a );
yw = ya + r*sin( D2R*a );
if (k == 1)
{
xmin = fmin( xmin, xw );
xmax = fmax( xmax, xw );
ymin = fmin( ymin, yw );
ymax = fmax( ymax, yw );
}
else
{
if (nskip != nvert)
{
if (j == np)
comma = ' ';
fprintf(iofil, fmt20, xw, yw, comma);
}
else
{
/* write (IOFIL, 20) XW, YW, COMMA */
fprintf(iofil, fmt30, xa, ya, xw, yw );
}
/* write (IOFIL, BFMT3) XA, YA, XW, YW */
}
a += ai;
}
if ((k == 2) && (nskip != nvert))
{
fprintf(iofil, " }\n");
}
/* write (IOFIL, '(2X,''}'')') */
a0 += 360.e0/nvert;
}
xa = Xy[1] - 0.5e0*(xmin + xmax);
ya = Xy[2] - 0.5e0*(ymin + ymax);
L_400:
;
}
}
if (clear && (locpen != 0))
{
clear = FALSE;
goto L_100;
}
}
else if (nskip <= 1)
{
/* Error bars. */
dplotd.kurpen = lpenv;
dplot2( Xy[3], Xy[4], Xy[5], Xy[6] );
if (lpenh != 0)
{
dplotd.kurpen = lpenh;
xa = Xy[1] - .5e0*btbars;
xw = Xy[1] + .5e0*btbars;
dplot2( xa, Xy[4], xw, Xy[4] );
dplot2( xa, Xy[6], xw, Xy[6] );
dplot2( Xy[1] - .5e0*barmid, Xy[2], Xy[1] + .5e0*barmid,
Xy[2] );
}
}
else
{
/* Draw arrows. */
dplotd.arrlen = arrloc;
dplotd.kurpen = lpena;
xw = Xy[1];
yw = Xy[2];
if (sizcir != 0.e0)
{
r = sizcir/sqrt( powi(Xy[3] - xw,2) + powi(Xy[4] - yw,2) );
xw += r*(Xy[3] - xw);
yw += r*(Xy[4] - yw);
}
dplot2( xw, xw, Xy[3], Xy[4] );
if (sizcir != 0.e0)
{
/* Add a little circle. */
dplotd.kurpen = lpenc;
if (lpenc == 90)
{
fprintf(iofil, " \\gfill\n");
dplotd.kurpen = 0;
/* write (IOFIL, BFILL) */
}
dplot1();
fprintf(iofil, fmt10, xy[0], xy[1], sizcir);
}
/* write (IOFIL, BFMT1) XY(1), XY(2), SIZCIR */
}
return;
} /* end of function */