/*Translated by FOR_C, v3.4.2 (-), on 07/09/115 at 08:31:21 */ /*FOR_C Options SET: ftn=u io=c no=p op=aimnv s=dbov str=l x=f - prototypes */ #include #include "fcrt.h" #include "splot.h" #include #include #include #include #include /*++ CODE for .C. is active */ static FILE *inunit, *iotemp, *iotmp1, *iotmp2, *iofil; #include /* 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_splotd { float arrlen, pxo, pxsize, pyo, pysize; long int iplot, kurpen, laspen; } splotd; struct t_splotb { float 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; } splotb; struct t_splotc { char fmtnum[17][33], captio[6][129], pos[69], text[281], txtdef[18][65]; } splotc; /* end of COMMON translations */ void /*FUNCTION*/ splot( float xsize, float ysize, float x[], long nx, float y[], float 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; float fpin[MAXNY], tp, tp1, tp2, xout[MAXPT], xypos[2], yout[MAXPT]; static float 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 float fpdat[LFDAT]={4.e0,100.e0,.7e0,.5e0,60.e0,30.e0,-1.e0}; static long lbound[3]={LBNDP,LBNDF,LBNDT}; static float tptset[3]={72.27e0,2.845e0,1.e0}; /* OFFSET Vectors w/subscript range: 1 to dimension */ float *const Fill = &splotb.fill[0] - 1; float *const Fp = &splotb.fp[0] - 1; float *const Fpdat = &fpdat[0] - 1; float *const Fpin = &fpin[0] - 1; long *const Inact = &inact[0] - 1; long *const Inin = &inin[0] - 1; long *const Ip = &splotb.ip[0] - 1; long *const Irule = &irule[0] - 1; long *const Jset = &splotb.jset[0] - 1; LOGICAL32 *const Klip = &splotb.klip[0] - 1; long *const Lbound = &lbound[0] - 1; long *const Lencap = &splotb.lencap[0] - 1; long *const Linact = &linact[0] - 1; long *const Lrule = &lrule[0] - 1; long *const Mfill = &splotb.mfill[0] - 1; long *const Nrule = &nrule[0] - 1; long *const Nxylim = &splotb.nxylim[0] - 1; float *const Opt = &opt[0] - 1; float *const Tptset = &tptset[0] - 1; float *const X = &x[0] - 1; float *const Xout = &xout[0] - 1; float *const Xybase = &splotb.xybase[0] - 1; float *const Xymax = &xymax[0] - 1; float *const Xymin = &xymin[0] - 1; float *const Xypos = &xypos[0] - 1; float *const Xyu2pf = &splotb.xyu2pf[0] - 1; float *const Y = &y[0] - 1; float *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 SPLOT Krogh -- Initialized ARRLEN & CAPLOC(5:6) *>> 2009-10-27 SPLOT Krogh -- BSLAS1 => BSLAS1(1:1) for NAG compiler. *>> 2009-10-18 SPLOT Krogh -- Added "save adjin" in splota *>> 2009-06-02 SPLOT Krogh -- Read from file sets number of points. *>> 2005-12-06 SPLOT Krogh -- Some fixes for conversion to C. *>> 2005-05-09 SPLOT Krogh -- More debug, fixed parens & bad test *>> 2001-05-24 SPLOT Krogh -- Added commas to some formats. *>> 2000-01-02 SPLOT Minor correction to error message text. *>> 2000-12-30 SPLOT Added an (int) cast in some comments for C. *>> 2000-10-23 SPLOT Changed ")/)" to "/)" in a format. *>> 2000-01-05 SPLOT Fixed SPLOTT so IAX is defined before ref. *>> 1999-12-27 SPLOT "Saved" ADJOUT in SPLOTA *>> 1999-11-23 SPLOT Fixed so don't get empty mfpic groups at the end. *>> 1998-10-23 SPLOT Fixed so error index 7 prints. *>> 1998-02-02 SPLOT Work around for bug in HP Exemplar Compiler. *>> 1998-01-29 SPLOT Fixed bug when no output file given. *>> 1998-01-21 SPLOT Work around for \ treated as escape in SGI F77. *>> 1998-01-14 SPLOT Krogh Initial code. *--S 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 " (float)" = CTYPE * * (SPLOTU 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.E0 Units, continue?, logs?, type, etc. * PLONY=2.E0 For more than one curve at a time. * PLOLIN=3.E0 Type of lines * PLOBOR=4.E0 Border characteristics. * PLOTIC=5.E0 Tick marks specs. * PLOWHT=6.E0 Where the major ticks go. * PLOMUL=7.E0 Multiple data sets. * PLOXMX=8.E0 Specify X min and max. * PLOYMX=9.E0 Specify Y min and max. * PLOSYM=10.E0 Specify symbols, error bars, etc. for data points. * PLOSY1=11.E0 Specify a single symbol to output. * PLOARR=12.E0 Length of arrow head (<0 is leave on till turned off). * PLOWID=13.E0 Various line widths * PLOTXT=14.E0 A text annotation. * PLONUM=15.E0 A number to output. * PLOANL=16.E0 An annotation and/or line to output on border or axis * PLOBAD=17.E0 For specifying data points to ignore, etc. * PLOINP=18.E0 Specifies Fortran input unit. * PLOLIN=19.E0 Draw a line. * PLOREC=20.E0 Draw a rectangle. * PLOELL=21.E0 Draw an ellipse. * PLOPLI=22.E0 Draw a line in physical coordinates. * PLOPRE=23.E0 Draw a rectangle in physical coordinates. * PLOPEL=24.E0 Draw an ellipse in physical coordinates. * PLOFIL=25.E0 Specifies filling for various cases. * PLORAW=26.E0 Send text directly to the plot file. * PLODEB=27.E0 Fortran debugging output. * * **************************** Procedure Names ************************* * * ******* In this file, SPLOT * SPLOT User entry, defines all actions, processes options, initiator * for all actions. * SPLOTA Determines scalings, draws axes and tick marks, and outputs * axis labels. * SPLOTF 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. * SPLOTN Takes care of output of numeric labels. * SPLOTT Output of text and checking the size required by text. * SPLOTR Converts XY data for calls to SPLOTS (special symbols) */ /* SPLOTU Opens output and scratch files. * * ******* In file SPLOT0 (Almost all of the device dependent code.) * SPLOT0 Setup for starting a plot. * SPLOT1 Specify the pen characteristics. * SPLOT2 Draw a single straight line in physical coordinates. * SPLOT4 Output an annotation at a given place in physical coordinates. * SPLOT5 Draw a rectangle (possibly filled), with pen width given. * SPLOT6 Draw a ellipse (possibly filled), with pen width given. * SPLOT7 Take care of requests to fill future regions. * SPLOT8 Output of tick marks. * SPLOT9 Finish the plot. * SPLOTL Plot a line through a sequence of points. Also for starting * and finishing other types of curves. * SPLOTS 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 SPLOTS. * 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 SPLOTN * TLENV Set to vertical height of text in SPLOTN. * 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 SPLOTT. * 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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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 */ /* 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 */ splotb.iop1 = 0; nxi = nx; if (last <= 4) { /* Set the defaults */ if (last <= 2) { f_strncpy( splotc.txtdef[16], "splot.tex", 64 ); splotd.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; splotb.setlim[0][0] = 0.e0; splotb.setlim[0][1] = 0.e0; splotb.setlim[1][0] = 0.e0; splotb.setlim[1][1] = 0.e0; splotb.phyuse[0][0] = -1.e0; splotb.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( splotc.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++) { splotb.lentxt[i - 1][0] = -1; splotb.lentxt[i - 1][1] = 0; splotb.lentxt[i - 1][2] = -1; } splotb.lentxt[16][2] = 9; /* Default border actions */ for (i = 1; i <= 6; i++) { for (j = 1; j <= 8; j++) { splotb.mbord[i - 1][j - 1] = 0; } } splotb.mbord[0][0] = 6; splotb.mbord[1][0] = 6; splotb.mbord[2][0] = 1; splotb.mbord[3][0] = 1; splotb.mbord[0][7] = 0; /* Default tick lengths, no captions */ for (i = 1; i <= 6; i++) { splotb.ticks[i - 1][0] = 4.0e0; splotb.ticks[i - 1][1] = 2.5e0; splotb.ticks[i - 1][2] = 0.0e0; splotb.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 SPLOTU (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 */ splotb.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 */ splotb.lentxt[k - 1][0] = -1; splotb.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) splotb.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) { splotb.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. */ splotb.ierr1 = LBNDC; ierr = 15; goto L_1410; } if (k == 17) { if (k1 == 17) { /* The output file name. */ splotb.lentxt[16][2] = l; memcpy(splotc.txtdef[16], copt+j,(size_t)l); splotc.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 SPLOTU(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(&splotb.lentxt[k-1][0], sizeof(splotb.lentxt[k-1][0]),(size_t)1,iotemp); fwrite(&l, sizeof(l), (size_t)1, iotemp); fwrite(&splotc.pos[60], (size_t)1, (size_t)4, iotemp); if (splotb.ip[LDEBUG-1] > 1) printf (fmt10, iaopt, splotb.lentxt[k-1][0], &splotc.pos[60]); if (splotb.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(splotc.fmtnum[k-1], (size_t)1, (size_t)splotb.lentxt[k-1][0], iotemp); if (splotb.ip[LDEBUG-1] > 1) printf (fmt20, iaopt, (int)splotb.lentxt[k-1][0], splotc.fmtnum[k-1]); } /*++ END */ if (l != 0) { fwrite(copt+j, (size_t)1, (size_t)l, iotemp); if (splotb.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(splotc.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. */ splotb.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]; splotc.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]; splotc.pos[k*4 - 3] = c; if (l == 2) { f_subscpy( splotc.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; } splotc.pos[k*4 - 2] = 's'; splotc.pos[k*4 - 1] = c; } goto L_250; } splotb.lentxt[k - 1][ntyp - 2] = l; if (l != 0) { if (ntyp == 2) { memcpy(splotc.fmtnum[k-1], copt+j,(size_t)(ltext-j-1)); } else { /* FMTNUM(K) = COPT(J+1:LTEXT-1) */ memcpy(splotc.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(&splotb.lentxt[8][0], sizeof(splotb.lentxt[8][0]), (size_t)2, iotemp); fwrite(&splotc.pos[60], (size_t)1, (size_t)4, iotemp); if (splotb.ip[LDEBUG-1] > 1) printf (fmt40,iaopt, splotb.lentxt[8][0], splotb.lentxt[8][1],splotb.lentxt[8][2], &splotc.pos[32]); if (splotb.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(splotc.fmtnum[8], (size_t)1, (size_t)splotb.lentxt[8][0], iotemp); if (splotb.ip[LDEBUG-1] > 1) printf (fmt20, iaopt, (int)splotb.lentxt[8][0], splotc.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 (splotb.lentxt[8][2] > 0) { fwrite(splotc.txtdef[8], (size_t)1, (size_t)splotb.lentxt[8][2], iotemp); if (splotb.ip[LDEBUG-1] > 1) printf (fmt30, iaopt, (int)(splotb.lentxt[8][2]), splotc.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 = splotb.lentxt[i - 1][0]; l3 = splotb.lentxt[i - 1][2]; for (j = i + 1; j <= (i + 5); j++) { for (l = 1; l <= 3; l++) { splotb.lentxt[j - 1][l - 1] = splotb.lentxt[i - 1][l - 1]; } if (l1>0) memcpy(splotc.fmtnum[j-1],splotc.fmtnum[i-1],(size_t)l1); if (l3>0) memcpy(splotc.txtdef[j-1],splotc.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; splotb.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 (splotb.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 = fabsf( Opt[iop] ); m = nint( tp ); if (fabsf( tp - (float)( 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( fabsf( 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++) { splotb.mbord[j - 1][i - 1] = Inin[i + 1]; } if (Inin[8] != 0) splotb.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)) { splotb.ticks[j - 1][i1 - 1] = Fpin[1]; splotb.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 */ splota( i ); if (splotb.iop1 <= -100) goto L_1500; /* Save data for data set being replaced */ lset += 1; Nxylim[lset] = Nxylim[iax]; splotb.xylim[lset - 1][0] = splotb.xylim[iax - 1][0]; splotb.xylim[lset - 1][1] = splotb.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; splotb.mbord[i - 1][7] = iax; for (i = 1; i <= 7; i++) { splotb.mbord[iax - 1][i - 1] = Inin[i + 2]; } } splotb.phyuse[iax - 1][0] = Fpin[1]; splotb.phyuse[iax - 1][1] = Fpin[2]; goto L_300; /* =8 Set defaults for widths on out of range values. */ L_480: Fpin[LWIDTH + 1] = fmodf( Fpin[LWIDTH + 1]/10.e0, 100.e0 )/10.e0; Fpin[LWIDTH + 2] = fmodf( 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 (splotb.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 (splotb.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 (splotb.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 (splotb.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 (splotb.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 (splotb.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( splotc.pos, 60, 63, 68, " .." ); goto L_210; /* *********** Done processing options, take care of X, Y, data ******** * */ L_700: splotb.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++) { splotb.setlim[k - 1][0] = Xymin[k]; splotb.setlim[k - 1][1] = Xymax[k]; /* Take logs of limmits if necessary. */ if (Xymin[k] < Xymax[k]) { if (Ip[LCOOX] == 2) { splotb.setlim[k - 1][0] = log10f( Xymin[k] ); splotb.setlim[k - 1][1] = log10f( 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(splotb.jset, sizeof(splotb.jset[0]), (size_t)2, iotemp); fwrite(&ny, sizeof(ny), (size_t)1, iotemp); if (splotb.ip[LDEBUG-1]>1) printf(fmt130, lcurve, splotb.jset[0], splotb.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, (real(ININ(I)), I=1,NY+1) *++ CODE for .C. is active */ if (splotb.ip[LDEBUG-1] > 1) { printf(fmt120, (long)31); for (i = 0; i <= ny; i++) printf(fmt125, (float ) inin[i]); printf ("\n");} } /*++ CODE for ~.C. is inactive * if (IP(LDEBUG).gt.1) * 1 print 120, DB, IOTEMP, 32, (real(ININ(I)), I=1,NY+1) *++ END * Check if want logs */ if (Ip[LCOOX] == 2) Fpin[1] = log10f( Fpin[1] ); if (Ip[LCOOY] == 2) { for (i = 1; i <= ny; i++) { Fpin[i + 1] = log10f( Fpin[i + 1] ); } } /* Establish initial minimum/maximum values */ tp1 = Fpin[2]; tp2 = tp1; for (i = 2; i <= ny; i++) { tp1 = fminf( tp1, Fpin[i + 1] ); tp2 = fmaxf( tp2, Fpin[i + 1] ); } if (Nxylim[1] == 0) { splotb.xylim[0][0] = Fpin[1]; splotb.xylim[0][1] = Fpin[1]; splotb.xylim[1][0] = tp1; splotb.xylim[1][1] = tp2; Nxylim[1] = Jset[1]; Nxylim[2] = Jset[2]; } else { splotb.xylim[0][0] = fminf( splotb.xylim[0][0], Fpin[1] ); splotb.xylim[0][1] = fmaxf( splotb.xylim[0][1], Fpin[1] ); splotb.xylim[1][0] = fminf( splotb.xylim[1][0], tp1 ); splotb.xylim[1][1] = fmaxf( splotb.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 (splotb.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 (splotb.ip[LDEBUG-1] > 1) { printf(fmt120, (long)33); for (i = 0; i <= ny; i++) printf(fmt125, fpin[i]); printf ("\n");} if (splotb.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 (splotb.iop1 <= -100) goto L_1510; if (last == 3) iosta = 1; return; } splotb.topts = Tptset[last + 1]; if (iosta > 0) { /*++ CODE for ~.C. is inactive * IOTMP1 = IOTEMP * DB = 'B' * call SPLOTU (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++) { splota( i ); } /*++ CODE for ~.C. is inactive * DB = 'R' *++ END */ if (splotb.iop1 <= -100) goto L_1500; splotb.noout = FALSE; L_830: kx = 1; ky = 1; /* Set "17" (file name) as already output. */ splotb.lentxt[16][0] = -1; splotb.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 (splotb.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 (splotb.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; splotr( 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 (splotb.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(&splotb.ip[j], sizeof(splotb.ip[0]), (size_t)l, iotemp); if (iosta > 0) fwrite(splotb.ip, sizeof(splotb.ip[0]), (size_t)l, iotmp2); if (splotb.ip[LDEBUG-1] > 1) { printf(fmt80, iaopt); for (i = j-1; i < j+l-2; i++) printf(fmt85, splotb.ip[i]); printf ("\n");} } /*++ END */ iact += 3; if (iaopt == 1) { if (mode <= 5) { mode = Ip[INTERP]; if (splotb.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(&splotb.fp[j-1], sizeof(splotb.fp[0]),(size_t)l,iotemp); if (iosta > 0) fwrite(&splotb.fp[j-1], sizeof(splotb.fp[0]), (size_t)l, iotmp2); if (splotb.ip[LDEBUG-1] > 1) { printf(fmt90, iaopt); for (i = j-1; i < j+l-2; i++) printf(fmt95, splotb.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 (&splotb.lentxt[15][0], sizeof(splotb.lentxt[0][0]), (size_t)1, iotemp); fread(&splotb.ntext, sizeof(splotb.ntext), (size_t)1, iotemp); fread(&splotc.pos[60], (size_t)1, (size_t)4, iotemp); if (iosta > 0) { fwrite(&splotb.lentxt[15][0], sizeof(splotb.lentxt[0][0]),(size_t)1,iotmp2); fwrite(&splotb.ntext,sizeof(splotb.ntext),(size_t)1,iotmp2); fwrite(&splotc.pos[60], (size_t)1, (size_t)4, iotmp2);} if (splotb.ip[LDEBUG-1] > 1) printf (fmt10, iaopt, splotb.lentxt[15][0], &splotc.pos[60]); if (splotb.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(splotc.fmtnum[15], (size_t)1, (size_t)splotb.lentxt[15][0], iotemp); if (iosta > 0) fwrite(splotc.fmtnum[15], (size_t)1, (size_t)splotb.lentxt[15][0], iotemp); if (splotb.ip[LDEBUG-1] > 0) printf (fmt20, iaopt, (int)splotb.lentxt[15][0], splotc.fmtnum[15]); } /*++ END */ if (splotb.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(splotc.text, (size_t)1, (size_t)splotb.ntext, iotemp); if (iosta > 0) fwrite(splotc.text, (size_t)1, (size_t)splotb.ntext, iotmp2); if (splotb.ip[LDEBUG-1] > 1) printf (fmt30, iaopt, (int)(splotb.ntext), splotc.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(&splotb.lentxt[8][0], sizeof(splotb.lentxt[8][0]), (size_t)2, iotemp); fread(&splotc.pos[32], (size_t)1, (size_t)4, iotemp); if (iosta > 0) { fwrite(&splotb.lentxt[8][0], sizeof(splotb.lentxt[8][0]), (size_t)2, iotmp2); fwrite(&splotc.pos[32], (size_t)1, (size_t)4, iotmp2);} if (splotb.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(&splotb.lentxt[8][0], sizeof(splotb.lentxt[8][0]), (size_t)3, iotemp); fread(&splotc.pos[32], (size_t)1, (size_t)4, iotemp); if (iosta > 0) { fwrite(&splotb.lentxt[8][0], sizeof(splotb.lentxt[8][0]), (size_t)3, iotmp2); fwrite(&splotc.pos[32], (size_t)1, (size_t)4, iotmp2);} if (splotb.ip[LDEBUG-1] > 1) printf (fmt40, iaopt, splotb.lentxt[8][0], splotb.lentxt[8][1],splotb.lentxt[8][2], &splotc.pos[32]); if (splotb.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(splotc.fmtnum[8], (size_t)1, (size_t)splotb.lentxt[15][0], iotemp); if (iosta > 0) fwrite(splotc.fmtnum[8], (size_t)1, (size_t)splotb.lentxt[15][0], iotemp); if (splotb.ip[LDEBUG-1] > 0) printf (fmt20, iaopt, (int)splotb.lentxt[15][0], splotc.fmtnum[8]); } /*++ END */ if (splotb.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(splotc.txtdef[8], (size_t)1, (size_t)splotb.lentxt[8][2], iotemp); if (iosta > 0) fwrite(splotc.txtdef[8], (size_t)1, (size_t)splotb.lentxt[8][2], iotmp2); if (splotb.ip[LDEBUG-1] > 1) printf (fmt30, iaopt, (int)(splotb.lentxt[8][2]), splotc.txtdef[8]); } /*++ END */ } if (mode < 9) { nmode = min( nmode, 9 ); } else if (mode == 9) { /* Output the text */ if (iaopt != 16) { if ((splotb.ntext == 0) && (iaopt == 14)) goto L_900; i = Ip[LTANNO]; splotb.opaque = FALSE; if (i > 3) { /* Want placed in an opaque box. */ splotb.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(splotc.pos+k1-4, " ..", (size_t)4) == 0) memcpy(splotc.pos+k1-4, splotc.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(splotc.pos+64, splotc.pos+k1-4,(size_t)4); } else { /* POS(65:68) = POS(K1-3:K1) * Set up the formatting */ if (splotb.lentxt[k - 1][0] < 0) { splotb.lentxt[k - 1][0] = splotb.lentxt[l1 - 1][0]; /*++ CODE for .C. is active */ if (splotb.lentxt[l1 - 1][0] > 0) memcpy(splotc.fmtnum[k-1],splotc.fmtnum[l1-1], splotb.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 */ splotb.lentxt[k - 1][2] = splotb.lentxt[l1 - 1][2]; if (splotb.lentxt[l1 - 1][2] > 0) { splotb.lentxt[k - 1][1] = splotb.lentxt[l1 - 1][1]; memcpy(splotc.txtdef[k-1],splotc.txtdef[l1-1], splotb.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] = log10f( Fp[LVALS + j] ); } } if (i == 0) { /* Convert to physical coordinates */ splotb.manno = -1; Xypos[1] = Xybase[kx] + Xyu2pf[kx]*Fp[LVALS]; Xypos[2] = Xybase[ky] + Xyu2pf[ky]*Fp[LVALS + 1]; } else { splotb.manno = 1; Xypos[1] = splotb.topts*Fp[LVALS]; Xypos[2] = splotb.topts*Fp[LVALS + 1]; } if (l1 == 7) { splott( k, xypos ); } else { splotn( Fp[LVALS + 3], k, xypos ); } splotb.manno = 0; } else { /* Text for Axis/Border Annotation -- Must be processed in SPLOTA. */ splota( Ip[LTANNO + 1] + 10 ); if (splotb.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] = splotb.topts*Fp[LVALS]; Yout[1] = splotb.topts*Fp[LVALS + 1]; Xout[2] = splotb.topts*Fp[LVALS + 2]; Yout[2] = splotb.topts*Fp[LVALS + 3]; if (iaopt == 21) { Fp[LVALS + 2] = Xout[3]; Fp[LVALS + 3] = Xout[4]; } } if (iaopt == 19) { /* Draw a line */ splotd.kurpen = Ip[LPEN]; splot2( Xout[1], Yout[1], Xout[2], Yout[2] ); } else if (iaopt == 20) { /* Draw a rectangle */ splotd.kurpen = Fp[LWIDRE]; if (Mfill[2] != 0) splot7( &Mfill[2], &lfill[1][0], splotb.fill ); splot5( Xout[1], Yout[1], Xout[2], Yout[2] ); } else { /* Draw an ellipse */ splotd.kurpen = Fp[LWIDRE]; if (Mfill[3] != 0) splot7( &Mfill[3], &lfill[2][0], splotb.fill ); splot6( Xout[1], Yout[1], Fp[LVALS + 2], Fp[LVALS + 3], Fp[LVALS + 4] ); } goto L_900; /* Raw MFPIC output */ L_990: ; fread(&splotb.ntext, sizeof(splotb.ntext), (size_t)1, iotemp); fread(splotc.text, (size_t)1, (size_t)(splotb.ntext), iotemp); if (iosta > 0) { fwrite(&splotb.ntext, sizeof(splotb.ntext), (size_t)1, iotemp); fwrite(splotc.text, (size_t)1, (size_t)(splotb.ntext), iotemp);} if (splotb.ip[LDEBUG-1] > 1) printf (fmt30, iaopt, (int)(splotb.ntext), splotc.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)splotb.ntext, splotc.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 (splotb.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. */ splote( 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 (splotb.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: splotd.kurpen = Ip[LPEN]; splot1(); /* 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) { splotl( -1 - mode, xout, yout ); if (mode <= 2) { /* Initialize SPLOTF */ k = -1; if (Klip[kx] || Klip[ky]) k = -3; splotf( k, xout, &splotb.xylim[kx - 1][0], &splotb.xylim[ky - 1][0] ); if (splotb.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 (splotb.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 (splotb.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) splotf( kpt, xout, xout, yout ); splotf( 0, xout, xout, yout ); if (splotb.iop1 <= -100) goto L_1500; } else { if (kpt > 0) splotl( kpt, xout, yout ); splotl( 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 (splotb.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 (splotb.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] < splotb.xylim[kx - 1][0]) || (Xout[kpt] > splotb.xylim[kx - 1][1])) || (Yout[kpt] < splotb.xylim[ky - 1][0])) || (Xout[kpt] > splotb.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] < splotb.xylim[kx - 1][0]) || (Fpin[1] > splotb.xylim[kx - 1][1])) { Xout[k2] = fmaxf( splotb.xylim[kx - 1][0], fminf( Fpin[1], splotb.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] < splotb.xylim[ky - 1][0]) || (Fpin[4] > splotb.xylim[ky - 1][1])) { Yout[k2] = fmaxf( splotb.xylim[ky - 1][0], fminf( Fpin[4], splotb.xylim[ky - 1][1] ) ); Xout[k2] = Xout[k1] + (Yout[k2] - Yout[k1])*(Fpin[3] - Xout[k1])/(Fpin[4] - Yout[k1]); } if (lklip) { splotl( kpt, xout, yout ); splotl( 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]; splotr( &Fpin[ly], ksymb, kx, ky ); goto L_1120; } } if (kpt < MAXPT) goto L_1120; kpt = 0; if (mode <= 2) { splotf( MAXPT, xout, xout, yout ); if (splotb.iop1 <= -100) goto L_1500; goto L_1120; } else { splotl( 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 = splotb.mbord[4][7] + splotb.mbord[5][7]; if (iosta < 0) { if ((k != 0) || (last >= 3)) { /* Close out this mfpic group and start next. */ splotd.iplot = -100 - splotd.iplot; splot9(); } 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 (splotb.mbord[4][7] != 0) splotb.mbord[1][2] += splotb.mbord[4][7] + 2; if (splotb.mbord[5][7] != 0) splotb.mbord[3][2] += splotb.mbord[5][7] + 2; for (i = 1; i <= 6; i++) { splotb.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); splotb.lentxt[16][2] = 0; /*++ END */ goto L_800; } /* All done, exit. */ splot9(); fclose(iofil); fclose(iotemp); last = 0; /* close (IOFIL) * close (IOTEMP) */ if (splotb.iop1 <= -100) goto L_1500; return; /* **************************** Error Processing ********************** * * Set Limits for COPT error message. */ L_1400: j = ltext - 1; L_1410: splotb.ierr3 = j; splotb.ierr4 = ltext; /* Set limit for OPT error message */ L_1430: splotb.ierr2 = iop; /* Output Fatal Error Message */ splote( ierr, opt, copt ); /* Error on inner subroutine */ L_1500: last = 0; L_1510: Opt[1] = -100 - splotb.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*/ splota( long ib) { char _c0[2]; long int i, i1, i2, iax, iaxp, ibcap[6], j, k, kb, kdig, klog, mintic; float sizep, tbase, ticlen, ticlog, ticmaj, ticmin, tlen, tp, tp1, tp2, tp3, tpmax, tpmin, val, xfac, xypos[2], xypos1[2], xypos2[2]; static float adjin[6], adjout[6], caploc[6], poslab[6]; static float axadj[6]={1.e0,1.e0,-1.e0,-1.e0,1.e0,1.e0}; static float fac[4]={24.e0,20.e0,24.e0,0.e0}; static float fdig[4]={1.e0,2.e0,5.e0,10.e0}; static float logint[10]={0.e0,.3010299957e0,.47771212547e0,.6020599913e0, .6989700043e0,.7781512503e0,.8450980400e0,.9030899870e0,.9542425094e0, 1.e0}; /* OFFSET Vectors w/subscript range: 1 to dimension */ float *const Adjin = &adjin[0] - 1; float *const Adjout = &adjout[0] - 1; float *const Axadj = &axadj[0] - 1; float *const Borloc = &splotb.borloc[0] - 1; float *const Caploc = &caploc[0] - 1; float *const Fac = &fac[0] - 1; float *const Fdig = &fdig[0] - 1; float *const Fp = &splotb.fp[0] - 1; long *const Ibcap = &ibcap[0] - 1; long *const Ip = &splotb.ip[0] - 1; long *const Jset = &splotb.jset[0] - 1; LOGICAL32 *const Klip = &splotb.klip[0] - 1; long *const Lencap = &splotb.lencap[0] - 1; float *const Logint = &logint[0] - 1; long *const Nxylim = &splotb.nxylim[0] - 1; float *const Poslab = &poslab[0] - 1; float *const Vhlen = &splotb.vhlen[0] - 1; float *const Xybase = &splotb.xybase[0] - 1; float *const Xypos = &xypos[0] - 1; float *const Xypos1 = &xypos1[0] - 1; float *const Xypos2 = &xypos2[0] - 1; float *const Xyu2pf = &splotb.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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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 (splotb.mbord[0][7] == 0) { /* First time this routine has been called for this figure. */ if (splotb.lentxt[16][2] > 0) { /*++ CODE for ~.C. is inactive * call SPLOTU (IOFIL, TXTDEF(17)(1:LENTXT(3,17))) * if (IOP1 .le. -10) return *++ CODE for .C. is active */ iofil = fopen(splotc.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 (splotb.mbord[i - 1][7] != 0) goto L_30; if (i <= 4) splotb.mbord[i - 1][7] = Jset[iax]; splotb.noout = TRUE; /* Adjustment for tick marks */ Adjout[i] = -fminf( 0.e0, fminf( splotb.ticks[i - 1][0], splotb.ticks[i - 1][1] ) ); k = splotb.mbord[i - 1][0]; if ((k > 1) && (i <= 4)) { /* Get space for labels. */ if (k > 2) { tpmin = splotb.xylim[iax - 1][0]; tpmax = splotb.xylim[iax - 1][1]; if (splotb.setlim[iax - 1][0] < splotb.setlim[iax - 1][1]) { tpmin = splotb.setlim[iax - 1][0]; tpmax = splotb.setlim[iax - 1][1]; } tp = fmaxf( fabsf( tpmin ), fabsf( tpmax ) ); if (Ip[LXBORD + iax - 1] == 1) { tp1 = fnint( tp ); j = -i; } else { k = log10f( tp ); tp1 = powif(10.e0,k); tlen = tpmax - tpmin; j = log10f( tp/tlen ); if (j > 1) { tp1 *= powif(1.1e0,j); } j = i; } splotn( signf( tp1, tpmin ), j, xypos ); tp1 = splotb.tlenv; if (iax == 2) tp1 = splotb.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 (splotb.mbord[i - 1][1] > 0) { tp1 = splotb.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 */ splotb.ntext = Lencap[i]; memcpy(splotc.text,splotc.captio[i-1],(size_t)splotb.ntext); splott( i + 10, xypos ); /* TEXT(1:NTEXT) = CAPTIO(I)(1:NTEXT) */ iaxp = 3 - iax; k = 4*i + 32; Ibcap[i] = i; L_5: if (splotc.pos[k + iaxp - 1] == 'c') { if (i >= 5) { /* Error -- Can't center on x or y axis */ splote( 2, xypos, " " ); splotc.pos[k + iaxp - 1] = 'r'; if (i == 6) splotc.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,splotc.pos[k + iaxp - 1]) ); Ibcap[i] = j; tp1 = Vhlen[iaxp] + CAPSEP; if ((j%2) == 1) tp1 -= 2.e0; Caploc[i] -= tp1; } } Adjin[i] = splotb.mbord[i - 1][2]; if (splotb.mbord[i - 1][3] != 0) { tp = Adjout[i]; Adjout[i] = splotb.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 */ splotb.ierr1 = i; splote( 3, xypos, " " ); } } if (i1 != i2) { /* Special setting the first time. */ for (i = 1; i <= 6; i++) { if (Caploc[i] < 0) Adjout[Ibcap[i]] = fmaxf( Adjout[Ibcap[i]], -Caploc[i] ); } Borloc[1] = 0.e0; Borloc[2] = 0.e0; Borloc[3] = splotb.topts*Fp[LXYSIZ + 1] - Adjout[1]; Borloc[4] = splotb.topts*Fp[LXYSIZ] - Adjout[2]; /* Initialize mfpic */ splotd.iplot = Ip[LTYPE]; splotd.pxo = Adjout[2]; splotd.pyo = Adjout[1]; splotd.pxsize = Borloc[4]; splotd.pysize = Borloc[3]; splot0(); 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 (splotb.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] = splotb.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 */ splote( 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 = splotb.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 */ splotd.kurpen = Fp[LWIDTH + 3]; if (i2 == 2) { splot2( tp, Borloc[1], tp, Borloc[3] ); } else { splot2( 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 ((splotb.setlim[iax - 1][0] >= 0.e0) || (splotb.setlim[iax - 1][1] < 0.e0)) return; /* Get physical location of axis. */ Borloc[ib] = Xybase[iax]; } else if ((Xyu2pf[iax] == 0.e0) || (splotb.mbord[ib - 1][0] > 1)) { Klip[iax] = FALSE; if (splotb.setlim[iax - 1][0] < splotb.setlim[iax - 1][1]) { Klip[iax] = (splotb.setlim[iax - 1][0] > splotb.xylim[iax - 1][0]) || (splotb.setlim[iax - 1][1] < splotb.xylim[iax - 1][1]); splotb.xylim[iax - 1][0] = splotb.setlim[iax - 1][0]; splotb.xylim[iax - 1][1] = splotb.setlim[iax - 1][1]; } else { splotb.setlim[iax - 1][0] = splotb.xylim[iax - 1][0]; splotb.setlim[iax - 1][1] = splotb.xylim[iax - 1][1]; } if (splotb.setlim[iax - 1][1] > splotb.setlim[iax - 1][0]) { /* Usual case, other branch protects against divide by 0. */ xfac = sizep/(splotb.setlim[iax - 1][1] - splotb.setlim[iax - 1][0]); } else { xfac = 1.e0; } } /* ******* Get location of ticks and adjust limits if necessary ********* * */ if (splotb.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 = splotb.phyuse[iax - 1][1]; tp3 = splotb.phyuse[iax - 1][0]*splotb.topts; /* Convert to logs if requested */ if (Ip[LCOOX + iax - 1] == 2) tp2 = log10f( tp2 ); /* TP = maps loc. user to loc. physical with current settings. */ tp = tp1 + xfac*(tp2 - splotb.xylim[iax - 1][0]); if (tp > tp3) { xfac = (tp3 - tp1)/(tp2 - splotb.xylim[iax - 1][0]); splotb.xylim[iax - 1][1] = tp1 + xfac*(splotb.xylim[iax - 1][1] - splotb.xylim[iax - 1][0]); } else if (tp < tp3) { splotb.xylim[iax - 1][0] = tp2 + (tp3 - tp1)/xfac; } /* No range expansion in this case (otherwise above adjustment fails) */ splotb.mbord[ib - 1][5] = 3; } tpmax = splotb.xylim[iax - 1][1]; tpmin = splotb.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 (splotb.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 = splotb.ticks[ib - 1][3]; if (ticmaj != 0.e0) { /* Major ticks all specified */ tbase = splotb.ticks[ib - 1][2]; if (klog == 2) { kdig = ticmaj; if (kdig != 1) klog = 1; } else { kdig = log10f( .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 = log10f( .4*tlen ); /* TICMAJ = first candidate increment (no bigger than needed) */ ticmaj = powif(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 (fabsf( fnint( tp ) - tp ) < 1.e-5) { if (fmodf( fnint( tp ), 2.e0 ) != 0.e0) { /* Using 5.E0 * TP2 breaks even and 2.E0*TP2 doesn't. */ kdig = 3; ticmaj = 5.e0*tp2; } } } goto L_80; } } /* Have now established TICMAJ as the major tick increment */ mintic = splotb.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/(float)( 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 = splotb.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 + (float)( j )*tp; L_110: if (tp2 > tpmin) { tp2 -= tp; goto L_110; } L_120: tpmin = fminf( 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 + (float)( j )*tp; L_150: if (tp2 < tpmax) { tp2 += tp; goto L_150; } } L_160: tpmax = fmaxf( tp2, tpmax + tp3*Adjin[5 - iax] ); /* Set transformation parameters */ L_170: if (Xyu2pf[iax] != 0.e0) { if (splotb.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]) { splotb.xylim[iax - 1][0] = Xybase[iax] + Xyu2pf[iax]*splotb.setlim[iax - 1][0]; splotb.xylim[iax - 1][1] = Xybase[iax] + Xyu2pf[iax]*splotb.setlim[iax - 1][1]; } else { splotb.xylim[iax - 1][0] = Xybase[iax] + Xyu2pf[iax]*splotb.xylim[iax - 1][0]; splotb.xylim[iax - 1][1] = Xybase[iax] + Xyu2pf[iax]*splotb.xylim[iax - 1][1]; } /* ***************** Output Caption, Border/axis, labels **************** * * First the caption */ L_180: splotb.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]; } splotb.ntext = Lencap[ib]; memcpy(splotc.text, splotc.captio[ib-1],(size_t)splotb.ntext); splott( ib + 9, xypos ); /* TEXT(1:NTEXT) = CAPTIO(IB)(1:NTEXT) */ } if (splotb.mbord[ib - 1][0] == 0) return; /* Now the Border/axis line */ splotd.kurpen = Fp[LWIDTH]; Xypos1[1] = Borloc[2]; Xypos1[2] = Borloc[1]; Xypos2[1] = Borloc[4]; Xypos2[2] = Borloc[3]; ticlen = fminf( splotb.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 (splotb.mbord[ib - 1][1] != 0) { splotd.arrlen = splotb.mbord[ib - 1][1]; Xypos2[iax] += splotd.arrlen + ARREXT; } splot2( Xypos1[1], Xypos1[2], Xypos2[1], Xypos2[2] ); k = splotb.mbord[ib - 1][0]; if (k > 1) { /*## Code for polar cases yet to be written. * Major ticks */ tp1 = fmodf( tbase - Borloc[3 - iax], ticmaj ); if (tp1 < 0) tp1 += ticmaj; if (tp1 > .99999*ticmaj) tp1 -= ticmaj; tp1 += Borloc[3 - iax]; splot8( 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 = fmodf( tbase - Borloc[3 - iax], ticmin ); if (tp2 < 0) tp2 += ticmin; tp2 += Borloc[3 - iax]; ticlen = fminf( splotb.ticks[ib - 1][1], Borloc[iax + 2] - Borloc[iax] ); if ((ib == 3) || (ib == 4)) ticlen = -ticlen; splot8( 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 = fminf( splotb.ticks[ib - 1][1], Borloc[iax + 2] - Borloc[iax] ); splot8( 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) { splotc.pos[j - 1] = 'l'; if (iax == 2) splotc.pos[j - 1] = 'b'; } tp2 = Borloc[5 - iax] - ticmaj + .1e0; splotb.opaque = FALSE; splotb.ovlap = -10.e4; Xypos[3 - iax] = Borloc[ib] - Axadj[ib]*Poslab[ib]; L_200: Xypos[iax] = tp1; val = (tp1 - Xybase[iax])/Xyu2pf[iax]; if (fabsf( val ) < 1.e-5*ticmaj) val = 0; i = ib; if (Ip[LXBORD - 1 + iax] == 1) i = -i; splotn( val, i, xypos ); tp1 += ticmaj; splotc.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) { splotc.pos[j - 1] = 'r'; if (iax == 2) splotc.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] = log10f( Fp[LVALS] ); Xypos1[iax] = Xybase[iax] + Xyu2pf[iax]*Fp[LVALS]; if (j != 0) { /* Want a tick or some kind of line. */ splotd.kurpen = Fp[LWIDTH + min( Ip[LTANNO], 3 )]; if (Ip[LTANNO] == 4) splotd.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] + splotb.ticks[i - 1][j - 1]* Axadj[iax]; } splot2( Xypos1[1], Xypos1[2], Xypos2[1], Xypos2[2] ); } if (splotb.ntext == 0) return; /* Have an annotation. */ Xypos1[3 - iax] = Borloc[i] - Axadj[i]*Poslab[i]; splott( 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*/ splote( long ierr, float opt[], STRING copt) { char txtcop[1][201]; long int i, iearr[1], j, j1, j2, k; static char mtxtaa[2][181]={"SPLOT$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]={"SPLOT$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]={"SPLOT$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]={"SPLOT$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 SPLOTF) without initiali", "zation.$EInternal Error -- N < -4 on call to SPLOTF.$EInternal Error -- N$ < 0 and not in initial state in SPLOTF.$EInternal Error -- S values must be increasing in SPLOTF.$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; float *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 SPLOTF) without initialization. * 41 Internal -- N < -4 on call to SPLOTF. * 42 Internal -- N < 0 and not in initial state in SPLOTF. * 43 Internal -- S values must be increasing in SPLOTF. * 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 SPLOT$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 SPLOT$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 SPLOT$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 SPLOT$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 SPLOTF) without initialization.$E *BM Internal Error -- N < -4 on call to SPLOTF.$E *BN Internal Error -- N < 0 and not in initial state in SPLOTF.$E *BO Internal Error -- S values must be increasing in SPLOTF.$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] = splotb.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 = splotb.ierr3; if (j2 <= 0) j2 = splotb.ierr4; L_10: f_subscpy( txtcop[0], 0, 19, 200, " O.K. part of COPT: " ); if (splotb.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 ((splotb.ierr3 < 0) || ((splotb.iop1 <= 0) && (splotb.ierr3 == 0))) { mess( mact4, (char*)txtcop,201, iearr ); goto L_200; } mess( mact3, (char*)txtcop,201, iearr ); if (splotb.ierr3 > 0) { splotb.ierr3 = 0; j1 = j; j2 = splotb.ierr4; goto L_10; } /* Take care of OPT part of message. */ L_100: Mact5[3] = splotb.iop1 - 1; Mact5[6] = -splotb.ierr2; smess( mact5, (char*)txtopt,41, iearr, opt ); L_200: splotb.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 = splotb.ierr1; splotb.ierr3 = -1; k = 1; goto L_20; /* An internal error */ L_300: ; puts( "Internal error in SPLOT, bad error index." ); exit(0); return; } /* end of function */ /* stop 'Internal error in SPLOT, 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*/ splotf( long n, float s[], float x[], float y[]) { static LOGICAL32 gets; long int i, i1, i2, iklip, ilast, j, k, l, loc[4], ni, _i, _r; static long int klips; float errmax, errmxl, hmax, hmin, s1, tp, tp1, tp2, x1, xd, y1, yd; static float 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 float xmax = 0.e0; static float ymax = 0.e0; static int _aini = 1; /* OFFSET Vectors w/subscript range: 1 to dimension */ float *const Ds = &ds[0] - 1; float *const Dx = &dx[0] - 1; float *const Dy = &dy[0] - 1; long *const Loc = &loc[0] - 1; float *const S = &s[0] - 1; float *const X = &x[0] - 1; float *const Xi = &xi[0] - 1; float *const Y = &y[0] - 1; float *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 ******************************* * * SPLOTL 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 SPLOTF 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 */ splote( 40, s, " " ); return; } if (ni < -4) { /* N < -4 on call to SPLOTF */ splote( 41, s, " " ); return; } last = 0; xmin = X[1]; xmax = X[2]; ymin = Y[1]; ymax = Y[2]; xscal = fmaxf( fabsf( xmin ), fabsf( xmax ) ); yscal = fmaxf( fabsf( xmin ), fabsf( 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 */ splote( 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 = fabsf( Xi[last] - Xi[last - 1] ); yd = fabsf( Yi[last] - Yi[last - 1] ); if (xd < yd) { si[last] = si[last - 1] + yd*sqrtf( 1.e0 + powif(xd/ yd,2) ); } else if (xd == 0.e0) { /* Skip the input */ last -= 1; } else { si[last] = si[last - 1] + xd*sqrtf( 1.e0 + powif(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 */ splote( 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 + signf( sqrtf( 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 + signf( sqrtf( 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 = fminf( tp1, -.75e0*Dy[2] ); } else { tp1 = fmaxf( 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 = fminf( tp1, -.75e0*Dx[2] ); } else { tp1 = fmaxf( 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 = fmaxf( errmax, fabsf( x1 - Xi[k] )/xscal ); y1 = Dy[3] + (s1 - Ds[3])*(Dy[2] + (s1 - Ds[2])*Dy[1]); errmax = fmaxf( errmax, fabsf( y1 - Yi[k] )/yscal ); /*++ END */ } } L_680: if (errmax == errmxl) hmin = h; errmxl = errmax; if (errmax > TOL) { if (h > hmin) { hmax = .857e0*h; h = fmaxf( hmin, h*sqrtf( sqrtf( .5e0*TOL/errmax ) ) ); goto L_520; } } else if (errmax < TOLLO) { if (errmax != 0.e0) { if (h < hmax) { hmin = 1.125e0*h; h = fminf( hmax, h*sqrtf( sqrtf( .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 = powif((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*fmaxf( fabsf( x1 - Xi[j] )/xscal, fabsf( 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) splotl( ilast, xi, yi ); if (iklip != 0) { /* Continue with point causing clipping. */ i1 = iklip; last = 0; klip = -2; splotl( -1, xi, yi ); goto L_380; } if (ni == 0) { /* End of a data set, get into initial state. */ last = -1; splotl( 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*/ splotn( float val, long ikase, float 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; float ptsiz, v; static float 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 float 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 */ float *const Hadj = &hadj[0] - 1; long *const Intval = &intval[0] - 1; long *const Nlbnd = &nlbnd[0] - 1; long *const Nubnd = &nubnd[0] - 1; float *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 SPLOT 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 SPLOT. * LENTXT Length of various strings in FMTNUM and TXTDEF. * * ************************* Usage of internal variables **************** * * ALIGN Alignment for the label -- passed into SPLOT4. * 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 SPLOT4. * 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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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, splotc.pos+kase*4 - 4, (size_t)2); if (ltextf == splotb.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 = FLT_EPSILON; maxdig = -log10f( v ); eps1 = 1.e0 + 8.e0*v; nchar0 = '0'; } /* Process the format */ ltextf = splotb.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, splotc.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 */ splote( 4, xypos, " " ); } else { Intval[i] = kten; if (i == 1) *lexp = kten - 5; } } goto L_30; } else { /* Unknown format specification */ splotb.ierr1 = k; splote( 5, xypos, fmtsav ); } /* call SPLOTE(5, XYPOS, FMTSAV(1:K)) */ } } /* Convert value to string */ L_100: splotb.tlenh = 0.e0; v = val; dol = FALSE; splotb.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 */ splotb.ntext += 2; f_subscpy( splotc.text, splotb.ntext - 2, splotb.ntext - 1, 280, "$-" ); splotb.tlenh = 1.2e0; dol = TRUE; v = -v; } /* Boost up a tiny bit so things close to integers come out as integers. */ v *= eps1; kten = log10f( v ); if (v < 1.e0) kten -= 1; } v *= powif(10.e0,-kten); ndig = 0; L_120: if (ndig < *mindig) { L_130: ndig += 1; dig[ndig - 1] = (nchar0 + (long)( v )); v = 10.e0*fmodf( 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; splotb.ntext += 1; splotc.text[splotb.ntext - 1] = '$'; } if ((ndig != 1) || (dig[0] != '1')) { splotb.ntext += 1; splotb.tlenh += (float)( ndig ); splotc.text[splotb.ntext - 1] = dig[0]; if (ndig > 1) { splotb.tlenh += .4e0; splotc.text[splotb.ntext] = '.'; memcpy(splotc.text+splotb.ntext+1,dig+1,(size_t)(ndig-1)); } /* TEXT(NTEXT+2:NTEXT+NDIG) = DIG(2:NDIG) */ splotb.ntext += ndig + 7; f_subscpy( splotc.text, splotb.ntext - 7, splotb.ntext - 1, 280, BTIMES ); splotb.tlenh += 1.4; } f_subscpy( splotc.text, splotb.ntext, splotb.ntext + 3, 280, "10^{" ); splotb.tlenh += 2.e0; splotb.ntext += 4; if (kten < 0) { splotb.ntext += 1; splotc.text[splotb.ntext - 1] = '-'; kten = -kten; splotb.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. */ splotb.tlenh += .75e0; i = kten/k; splotb.ntext += 1; splotc.text[splotb.ntext - 1] = (nchar0 + i); kten += -10*i; goto L_150; } splotb.ntext += 1; splotc.text[splotb.ntext - 1] = '}'; } else { /* Numbers without exponents */ if (kten < 0) { /* Number is < 1 * K introduced here due to bug in Lahey compiler. */ for (k = splotb.ntext + 1; k <= (splotb.ntext + *lzero); k++) { splotb.tlenh += 1.e0; splotc.text[k - 1] = '0'; } splotb.ntext += *lzero + 1; splotc.text[splotb.ntext - 1] = '.'; splotb.tlenh += .4e0; for (k = splotb.ntext + 1; k <= (splotb.ntext - kten - 1); k++) { splotb.tlenh += 1.e0; splotc.text[k - 1] = '0'; } splotb.ntext -= kten; memcpy(splotc.text+splotb.ntext-1, dig, (size_t)ndig); splotb.ntext += ndig - 1; /* TEXT(NTEXT:NTEXT+NDIG-1) = DIG(1:NDIG) */ } else { /* Number is >= 1. */ k = min( ndig, kten + 1 ); memcpy(splotc.text+splotb.ntext, dig, (size_t)k); splotb.ntext += k; /* TEXT(NTEXT+1:NTEXT+K) = DIG(1:K) */ splotb.tlenh += (float)( k ); if (ndig > k) { splotb.ntext += 1; splotb.tlenh += .4e0 + (float)( ndig - k ); splotc.text[splotb.ntext - 1] = '.'; memcpy(splotc.text+splotb.ntext, dig+k, (size_t)(ndig-k)); splotb.ntext += ndig - k; /* TEXT(NTEXT+1:NTEXT+NDIG-K) = DIG(K+1:NDIG) */ } else { if (kten >= k) { for (splotb.ntext = splotb.ntext; splotb.ntext <= (splotb.ntext + kten - k); splotb.ntext++) { splotb.tlenh += 1.e0; splotc.text[splotb.ntext] = '0'; } } if (needd) { splotb.tlenh += .4e0; splotb.ntext += 1; splotc.text[splotb.ntext - 1] = '.'; } } } } if (dol) { splotb.ntext += 1; splotc.text[splotb.ntext - 1] = '$'; } /* Convert TLENH to physical distance */ ptsiz = *nptsiz; splotb.tlenh *= .5e0*ptsiz; splotb.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 (splotb.ovlap > Xypos[1] - splotb.tlenh*Hadj[k]) return; /* Set the new overlap */ splotb.ovlap = Xypos[1] + Hadj[4 - k]*splotb.tlenh; } } } } if (splotb.noout) return; splott( kase, xypos ); lkase = kase; return; } /* end of function */ /* PARAMETER translations */ #define BSHORT "\\shortstack[ ]{" #define BSLAS2 "\\\\" #define BSMALL "\\small " /* end of PARAMETER translations */ void /*FUNCTION*/ splott( long kase, float xypos[]) { char _c0[2], outtxt[257]; static char fmtsav[33]; LOGICAL32 getsiz, vert; byte c; long int i, iax, j, k, l, lpar; float hlen, hlens, hlsav, tp1, tp2, vlen; static float ptsiz; static long lastl = -2; static long lfill2[3]={2,0,0}; static char adjv[4] = "tcb"; static char adjh[4] = "rcl"; static float adj1[3]={-1.e0,-.5e0,0.e0}; static float adj2[3]={0.e0,.5e0,1.e0}; /* OFFSET Vectors w/subscript range: 1 to dimension */ float *const Adj1 = &adj1[0] - 1; float *const Adj2 = &adj2[0] - 1; float *const Borloc = &splotb.borloc[0] - 1; float *const Fill = &splotb.fill[0] - 1; long *const Ip = &splotb.ip[0] - 1; long *const Lfill2 = &lfill2[0] - 1; float *const Vhlen = &splotb.vhlen[0] - 1; float *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 SPLOT7. * OUTTXT Final output form (aside from prefix and postfix, which are * added in SPLOT * 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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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 = splotc.pos[kase*4 - 2] == 's'; getsiz = (splotb.noout || splotb.opaque) || (splotb.manno != 0); if (getsiz || vert) { if (getsiz) { vert = vert || (((iax == 2) && (splotb.manno == 0)) && (splotc.pos[kase*4 - 4] == 'c')); l = splotb.lentxt[kase - 1][0]; if (l == lastl) { /* Format hasn't changed */ if (memcmp(splotc.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, splotc.fmtnum[kase-1], (size_t)l); k = 0; /* FMTSAV(1:L) = FMTNUM(KASE)(1:L) */ L_20: if (k < l) { if ((splotc.fmtnum[kase - 1][k - 1] == 'F') || (splotc.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, splotc.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 <= splotb.ntext) { c = splotc.text[i - 1]; if (c == BSLASH) { j += 1; outtxt[j - 1] = BSLASH; /* Skip '\' commands. */ L_90: i += 1; c = splotc.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 = fmaxf( 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 = fmaxf( 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 $...$. */ splote( 6, xypos, splotc.text ); } if (splotb.noout) { if ((iax == 2) && (splotc.pos[kase*4 - 1] == '.')) { if (hlens < hlen - 2) f_subscpy( splotc.pos, kase*4 - 2, kase*4 - 1, 68, "sc" ); } if (splotc.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 (splotb.manno != 0) { /* Some kind of annotation. */ k = istrstr( adjv, STR1(_c0,splotc.pos[kase*4 - 4]) ); l = istrstr( adjh, STR1(_c0,splotc.pos[kase*4 - 3]) ); hlens = .5e0*ptsiz*hlen; tp1 = Xypos[1] + Adj1[l]*hlens - .5e0; tp2 = Xypos[1] + Adj2[l]*hlens + .5e0; if (splotb.manno > 0) { if ((tp1 < Borloc[2]) || (tp2 > Borloc[4])) splote( 7, xypos, splotc.text ); } else { if ((tp1 >= 0.e0) && (tp1 < Borloc[2] - splotb.mbord[4][7])) splotb.mbord[4][7] = Borloc[2] - tp1; if ((tp2 >= 0.e0) && (tp2 > Borloc[4] + splotb.mbord[5][7])) splotb.mbord[5][7] = tp2 - Borloc[4]; } } if (splotb.opaque) { i = 1; splot7( &i, lfill2, splotb.fill ); splot5( 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, splotc.text, (size_t)splotb.ntext); j += splotb.ntext - 1; /* OUTTXT(J:J+NTEXT-1) = TEXT(1:NTEXT) */ } /* Take care of prefix and postfix. */ i = LBNDT; l = splotb.lentxt[kase - 1][1]; k = splotb.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, splotc.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, splotc.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'; splot4( Xypos[1], Xypos[2], outtxt+i-1, splotc.pos+kase*4-4); return; /* call SPLOT4(XYPOS(1),XYPOS(2),OUTTXT(I:J),POS(4*KASE-3:4*KASE-2)) */ } /* end of function */ void /*FUNCTION*/ splotr( float xy[], long ksymb, long kx, long ky) { long int k; /* OFFSET Vectors w/subscript range: 1 to dimension */ float *const Xy = &xy[0] - 1; float *const Xybase = &splotb.xybase[0] - 1; float *const Xyu2pf = &splotb.xyu2pf[0] - 1; /* end of OFFSET VECTORS */ /* Gets XY converted for call to SPLOTS (Symbols, error bars, arrows) */ /* Common * For SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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] *= splotb.topts; Xy[k + 1] *= splotb.topts; } } splots( xy, labs( ksymb ) ); return; } /* end of function */ /*++ CODE for ~.C. is inactive * subroutine SPLOTU (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*(*) * real 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) * real 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 / SPLOTB / 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 SPLOTE(34, SPACE, ' ') * return *c Unable to open output file * 200 IERR1 = len(FILNAM) * call SPLOTE(35, SPACE, FILNAM) * return *c "Success" exit * 300 NEXTU = NEWU + 1 * return *++ END */ void /*FUNCTION*/ splot0() { 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 SPLOT0 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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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[splotd.iplot+1]- istart[splotd.iplot]), start+istart[splotd.iplot]-1, -splotd.pxo, splotd.pxsize, -splotd.pyo, splotd.pysize ); splotd.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 */ /*================================================== SPLOT1 ===== */ void /*FUNCTION*/ splot1() { long int l; static long int it; float tp1, tp2; static float dash = -1.e0; static float dashsp = -1.e0; static float dotsz = -1.e0; static float dotsp = -1.e0; static float penwid = .5e0; /* Specify the pen characteristics * * **** Variable Definitions ( 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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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 (splotd.kurpen == splotd.laspen) goto L_100; /*++ END * * ********* Executable Statements ****************************** * */ splotd.laspen = splotd.kurpen; l = splotd.laspen; it = l%10; l /= 10; tp1 = (float)( 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 = (float)( l%100 ); tp2 = (float)( 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 (splotd.arrlen != 0) { /* Want an arrow on the next curve. */ fprintf(iofil, fmt10, splotd.arrlen); splotd.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 */ /*================================================== SPLOT2 ===== */ void /*FUNCTION*/ splot2( float x1, float y1, float x2, float 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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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"; splot1(); /*++ END * * ********* Executable Statements ****************************** * */ fprintf(iofil, fmt10,x1, y1, x2, y2); return; /* write (IOFIL, BFMT1) X1, Y1, X2, Y2 */ } /* end of function */ /*================================================== SPLOT4 ===== */ void /*FUNCTION*/ splot4( float x, float 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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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 */ /*================================================== SPLOT5 ===== */ void /*FUNCTION*/ splot5( float x1, float y1, float x2, float 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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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"; splot1(); /*++ END */ /* ********* Executable Statements ****************************** */ fprintf(iofil, fmt10, x1, y1, x2, y2); return; /* write (IOFIL,BFMT1) x1, y1, x2, y2 */ } /* end of function */ /*================================================== SPLOT6 ===== */ void /*FUNCTION*/ splot6( float x, float y, float a, float b, float 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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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"; splot1(); /*++ 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 */ /* ================================================= SPLOT7 ===== */ void /*FUNCTION*/ splot7( long *m, long locfil[], float fildef[]) { long int j, k; static char sfill[14] = "\\gfill\\gclear"; static long jfill[3]={1,7,14}; static float shadew = -1.e0; static float hatchw = -1.e0; /* OFFSET Vectors w/subscript range: 1 to dimension */ float *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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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 */ /* ========================== SPLOT8 ============================ */ void /*FUNCTION*/ splot8( float penwid, float base, float step, float till, float tbeg, float tend, long iax, float 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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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 */ /*================================================== SPLOT9 ===== */ void /*FUNCTION*/ splot9() { 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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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 (splotd.iplot < 0) { splotd.iplot = -100 - splotd.iplot; if (splotd.iplot > 1) return; fprintf(iofil, fmt10, (int)(ifin[splotd.iplot+1]- ifin[splotd.iplot]), fin+ifin[splotd.iplot]-1, -splotd.pxo - splotd.pxsize); splot0(); /* write (IOFIL, BFMT1) FIN(IFIN(IPLOT):IFIN(IPLOT+1)-1),-PXO-PXSIZE */ } else { fprintf(iofil, " %.*s\n", (int)(ifin[splotd.iplot+1] - ifin[splotd.iplot]), fin + ifin[splotd.iplot] - 1); } /* write (IOFIL, '(1X,A)') FIN(IFIN(IPLOT):IFIN(IPLOT+1)-1) */ return; } /* end of function */ /*================================================== SPLOTL ===== */ void /*FUNCTION*/ splotl( long many, float x[], float y[]) { long int i, k; static long int ixpref; static float 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 */ float *const Oldx = &oldx[0] - 1; float *const Oldy = &oldy[0] - 1; float *const X = &x[0] - 1; float *const Y = &y[0] - 1; /* end of OFFSET VECTORS */ /* Plot a line through a sequence of points. */ /*>> 1996-12-18 SPLOTL 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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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( "SPLOTL (Internal bug) Adding points without initialization." ); exit(0); } return; } /* end of function */ /*================================================== SPLOTS ===== */ /* PARAMETER translations */ #define D2R .01745329251994329576923690768488612713442871889e0 #define KPENDF 30 /* end of PARAMETER translations */ void /*FUNCTION*/ splots( float 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; float a, a0, ai, r, ww, xa, xmax, xmin, xw, ya, ymax, ymin, yw; static float arrloc, barmid, btbars, diamet, rotate, sizcir; static long lsymb = -1; /* OFFSET Vectors w/subscript range: 1 to dimension */ float *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 SPLOT0 */ /*++ CODE for ~.C. is inactive * integer IOFIL, IPLOT, KURPEN, LASPEN * common / SPLOTD / 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 = (float)( (k%10)*45 )/(float)( nvert ); k /= 10; locpen = 10*(k%10); if (locpen == 0) { locpen = KPENDF; } else if (locpen == 90) { locpen = 0; } diamet = (float)( k/10 ); cleari = FALSE; if (diamet >= 100.e0) { diamet = fmodf( 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; splotd.kurpen = locpen; splot1(); L_100: ww = .01e0*(float)( locpen ); r = .5e0*fmaxf( 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 = (float)( (nskip + 1)*360 )/(float)( 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*cosf( D2R*a ); yw = ya + r*sinf( D2R*a ); if (k == 1) { xmin = fminf( xmin, xw ); xmax = fmaxf( xmax, xw ); ymin = fminf( ymin, yw ); ymax = fmaxf( 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. */ splotd.kurpen = lpenv; splot2( Xy[3], Xy[4], Xy[5], Xy[6] ); if (lpenh != 0) { splotd.kurpen = lpenh; xa = Xy[1] - .5e0*btbars; xw = Xy[1] + .5e0*btbars; splot2( xa, Xy[4], xw, Xy[4] ); splot2( xa, Xy[6], xw, Xy[6] ); splot2( Xy[1] - .5e0*barmid, Xy[2], Xy[1] + .5e0*barmid, Xy[2] ); } } else { /* Draw arrows. */ splotd.arrlen = arrloc; splotd.kurpen = lpena; xw = Xy[1]; yw = Xy[2]; if (sizcir != 0.e0) { r = sizcir/sqrtf( powif(Xy[3] - xw,2) + powif(Xy[4] - yw,2) ); xw += r*(Xy[3] - xw); yw += r*(Xy[4] - yw); } splot2( xw, xw, Xy[3], Xy[4] ); if (sizcir != 0.e0) { /* Add a little circle. */ splotd.kurpen = lpenc; if (lpenc == 90) { fprintf(iofil, " \\gfill\n"); splotd.kurpen = 0; /* write (IOFIL, BFILL) */ } splot1(); fprintf(iofil, fmt10, xy[0], xy[1], sizcir); } /* write (IOFIL, BFMT1) XY(1), XY(2), SIZCIR */ } return; } /* end of function */