/* .\pgxtal.f -- translated by f2c (version 20000704).
   You must link the resulting object file with the libraries:
	-lf2c -lm   (in that order)
*/

#ifdef WIN
#pragma warning (disable: 4244) // disable warning for conversion from double to float, possible loss of data
#pragma warning (disable: 4554) // disable warning for check operator precedence for possible error
#pragma warning (disable: 4715) // disable warning for not all control paths return a value
#pragma warning (disable: 4716) // disable warning for must return a value
#endif /* WIN */

#include "f2c.h"

/* Common Block Declarations */

struct {
    integer grcide, grgtyp, grstat[8];
    logical grpltd[8];
    integer grunit[8], grfnln[8], grtype[8], grxmxa[8], grymxa[8];
    real grxmin[8], grymin[8], grxmax[8], grymax[8];
    integer grwidt[8], grccol[8], grstyl[8];
    real grxpre[8], grypre[8], grxorg[8], gryorg[8], grxscl[8], gryscl[8], 
	    grcscl[8], grcfac[8];
    logical grdash[8];
    real grpatn[64]	/* was [8][8] */, grpoff[8];
    integer gripat[8], grcfnt[8], grcmrk[8];
    real grpxpi[8], grpypi[8];
    logical gradju[8];
    integer grmnci[8], grmxci[8];
} grcm00_;

#define grcm00_1 grcm00_

struct {
    char grfile[720], grgcap[88];
} grcm01_;

#define grcm01_1 grcm01_

struct {
    real sbbuff[2000000];
    integer nxp, nyp, ibfmod, kstart, ir[256], ig[256], ib[256];
    logical lps, lcolor;
    real xoff, xlen, xorg, xscale, xperin, xblc, xtrc, yoff, ylen, yorg, 
	    yscale, yperin, yblc, ytrc;
} sftbuf_;

#define sftbuf_1 sftbuf_

struct {
    real grdcub[24]	/* was [3][8] */, mtrx[9]	/* was [3][3] */, 
	    orig[3], xl2, col0, colscl;
} srfcom_;

#define srfcom_1 srfcom_

/* Table of constant values */

static integer c__4 = 4;
static real c_b11 = (float)-1e20;
static real c_b13 = (float).5;
static real c_b14 = (float)0.;
static real c_b15 = (float)1.;
static integer c__1 = 1;
static integer c__3 = 3;
static integer c__9 = 9;
static integer c__26 = 26;
static logical c_false = FALSE_;
static integer c__6 = 6;
static integer c__0 = 0;
static integer c__5 = 5;
static integer c__2 = 2;
static real c_b334 = (float).75;

/* CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC */

/* Subroutine */ int sbfint_(rgb, ic, ibmode, ibuf, maxbuf)
real *rgb;
integer *ic, *ibmode, *ibuf, *maxbuf;
{
    /* Initialized data */

    static logical lpsint = FALSE_;
    static real rinit[16] = { (float)1.,(float)0.,(float)1.,(float)0.,(float)
	    0.,(float)0.,(float)1.,(float)1.,(float)1.,(float).5,(float)0.,(
	    float)0.,(float).5,(float)1.,(float).33,(float).67 };
    static real ginit[16] = { (float)1.,(float)0.,(float)0.,(float)1.,(float)
	    0.,(float)1.,(float)0.,(float)1.,(float).5,(float)1.,(float)1.,(
	    float).5,(float)0.,(float)0.,(float).33,(float).67 };
    static real binit[16] = { (float)1.,(float)0.,(float)0.,(float)0.,(float)
	    1.,(float)1.,(float)1.,(float)0.,(float)0.,(float)0.,(float).5,(
	    float)1.,(float)1.,(float).5,(float).33,(float).67 };

    /* System generated locals */
    integer i__1;
    real r__1;

    /* Builtin functions */
    integer s_cmp(), i_nint(), i_len();
    /* Subroutine */ int s_stop();

    /* Local variables */
    static integer lchr, nbuf;
    static real rbuf;
    static char type__[16];
    static integer ntot, i__, ndots;
    extern /* Subroutine */ int sbfin0_(), grbpic_();
    static integer icsave;
    extern /* Subroutine */ int grexec_(), pgqinf_(), sbrcop_();
    extern logical pgnoto_();
    static integer izsave;
    extern /* Subroutine */ int sbrfil_(), colint_();
    static char chr[16];

/*     -------------------------------------------- */


/* ----------------------------------------------------------------------- */
/*            Include file for GRPCKG */
/* Modifications: */
/*   29-Jan-1985 - add HP2648 (KS/TJP). */
/*   16-Sep-1985 - remove tabs (TJP). */
/*   30-Dec-1985 - add PS, VPS (TJP). */
/*   27-May-1987 - remove ARGS, NULL, PS, VPS, QMS, VQMS, HIDMP, */
/*                 HP7221, GRINL (TJP). */
/*    6-Jun-1987 - remove PRTX, TRILOG, VERS, VV (TJP). */
/*   11-Jun-1987 - remove remaining built-in devices (TJP). */
/*    5-Jul-1987 - replace GRINIT, GRPLTD by GRSTAT. */
/*   16-Aug-1987 - remove obsolete variables. */
/*    9-Sep-1989 - add SAVE statement. */
/*   26-Nov-1990 - remove GRCTYP. */
/*    5-Jan-1993 - add GRADJU. */
/*    1-Sep-1994 - add GRGCAP. */
/*   21-Dec-1995 - increase GRIMAX to 8. */
/*   30-Apr-1997 - remove GRC{XY}SP */
/* ----------------------------------------------------------------------- */

/* Parameters: */
/*   GRIMAX : maximum number of concurrent devices */
/*   GRFNMX : maximum length of file names */
/*   GRCXSZ : default width of chars (pixels) */
/*   GRCYSZ : default height of chars (pixels) */


/* Common blocks: */
/*   GRCIDE : identifier of current plot */
/*   GRGTYP : device type of current plot */
/* The following are qualified by a plot id: */
/*   GRSTAT : 0 => workstation closed */
/*            1 => workstation open */
/*            2 => picture open */
/*   GRPLTD : */
/*   GRDASH : software dashing in effect? */
/*   GRUNIT : unit associated with id */
/*   GRFNLN : length of filename */
/*   GRTYPE : device type */
/*   GRXMXA : x size of plotting surface */
/*   GRYMXA : y size of plotting surface */
/*   GRXMIN : blc of plotting window */
/*   GRYMIN : ditto */
/*   GRXMAX : trc of plotting window */
/*   GRYMAX : ditto */
/*   GRSTYL : line style (integer code) */
/*   GRWIDT : line width (integer code) */
/*   GRCCOL : current color index (integer code) */
/*   GRMNCI : minimum color index on this device */
/*   GRMXCI : maximum color index on this device */
/*   GRCMRK : marker number */
/*   GRXPRE : previous (current) pen position (x) */
/*   GRYPRE : ditto (y) */
/*   GRXORG : transformation variables (GRTRAN) */
/*   GRYORG : ditto */
/*   GRXSCL : ditto */
/*   GRYSCL : ditto */
/*   GRCSCL : character scaling factor */
/*   GRCFAC : */
/*   GRCFNT : character font */
/*   GRFILE : file name (character) */
/*   GRGCAP : device capabilities (character) */
/*   GRPXPI : pixels per inch in x */
/*   GRPYPI : pixels per inch in y */
/*   GRADJU : TRUE if GRSETS (PGPAP) has been called */


/* ----------------------------------------------------------------------- */
    /* Parameter adjustments */
    --rgb;

    /* Function Body */

/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      Initialises the software buffer for crystal-plotting. It should */
/*    be called just once per plot (buffer), after PGWINDOW but before */
/*    any crystal-related routines. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    RGB      R*4    I       3      The RGB values for the background. */
/*    IC       I*4    I       -      The index for the background colour. */
/*    IBMODE   I*4    I       -      Buffering mode for initialisation: */
/*                                     1 = Ordinary, default. */
/*                                     2 = Will want to save later. */
/*                                     3 = Initialise from saved buffers. */
/*    IBUF     I*4    I       -      Software buffer to be used (>=1). */
/*    MAXBUF   I*4    O       -      Maximum number of buffers available. */

/* Globals */
/*    SFTBUF */
/*    GRPCKG1.INC */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     PGNOTO     Logical function to test if a PGPLOT device is open. */
/*     GRBPIC     Sends a "begin picture" command to the device driver. */
/*     PGQINF     Inquires about general PGPLOT information. */
/*     GREXEC     Dispatches command to appropriate device driver. */
/*     COLINT     Sets up a colour table. */
/*     SBRFIL     Fills a real aray with a constant. */
/*     SBRCOP     Copies the contents of one real array to another. */
/*     SBFIN0     Inquires about viewport and window dimensions. */

/* History */
/*   D. S. Sivia       4 Apr 1995  Initial release. */
/*   D. S. Sivia      14 Sep 1995  Set up default colour indicies for PS. */
/*   D. S. Sivia      20 Oct 1995  Ignore NBUNCH and fix to one! */
/*   D. S. Sivia      15 Nov 1995  Allow initialisation to/from saved */
/*                                 buffers. */
/*   D. S. Sivia       2 Aug 1996  Replaced pgplot.inc with SBFIN0, and */
/*                                 made appropriate additions to SFTBUF. */
/*   D. S. Sivia      16 Jul 1999  Added a couple of PGPLOT calls to */
/*                                 force proper initialisation. */
/* ----------------------------------------------------------------------- */

/* A PGPLOT initialisation precaution. */

    if (pgnoto_("SBFINT", (ftnlen)6)) {
	return 0;
    }
    if (! grcm00_1.grpltd[grcm00_1.grcide - 1]) {
	grbpic_();
    }

/* Begin SBFINT proper. */

    sbfin0_(&sftbuf_1.xoff, &sftbuf_1.xlen, &sftbuf_1.xorg, &sftbuf_1.xscale, 
	    &sftbuf_1.xperin, &sftbuf_1.xblc, &sftbuf_1.xtrc, &sftbuf_1.yoff, 
	    &sftbuf_1.ylen, &sftbuf_1.yorg, &sftbuf_1.yscale, &
	    sftbuf_1.yperin, &sftbuf_1.yblc, &sftbuf_1.ytrc);
    sftbuf_1.lps = TRUE_;
    ndots = 100;
    pgqinf_("TYPE", type__, &lchr, (ftnlen)4, (ftnlen)16);
    if (s_cmp(type__, "PS", (ftnlen)16, (ftnlen)2) == 0 || s_cmp(type__, 
	    "VPS", (ftnlen)16, (ftnlen)3) == 0) {
	sftbuf_1.lcolor = FALSE_;
	r__1 = (real) ndots * sftbuf_1.xlen / sftbuf_1.xperin;
	sftbuf_1.nxp = i_nint(&r__1);
	r__1 = (real) ndots * sftbuf_1.ylen / sftbuf_1.yperin;
	sftbuf_1.nyp = i_nint(&r__1);
    } else if (s_cmp(type__, "CPS", (ftnlen)16, (ftnlen)3) == 0 || s_cmp(
	    type__, "VCPS", (ftnlen)16, (ftnlen)4) == 0) {
	sftbuf_1.lcolor = TRUE_;
	r__1 = (real) ndots * sftbuf_1.xlen / sftbuf_1.xperin;
	sftbuf_1.nxp = i_nint(&r__1);
	r__1 = (real) ndots * sftbuf_1.ylen / sftbuf_1.yperin;
	sftbuf_1.nyp = i_nint(&r__1);
    } else {
	sftbuf_1.lps = FALSE_;
	nbuf = 0;
	lchr = i_len(chr, (ftnlen)16);
	grexec_(&grcm00_1.grgtyp, &c__4, &rbuf, &nbuf, chr, &lchr, (ftnlen)16)
		;
	if (*(unsigned char *)&chr[6] == 'P') {
	    sftbuf_1.nxp = i_nint(&sftbuf_1.xlen) + 1;
	    sftbuf_1.nyp = i_nint(&sftbuf_1.ylen) + 1;
	} else {
	    s_stop(" Sorry, SFBINT does not support this device !", (ftnlen)
		    45);
	}
    }
    sftbuf_1.ibfmod = *ibmode;
    ntot = sftbuf_1.nxp * sftbuf_1.nyp;
    *maxbuf = 2000000 / ntot - 1;
    if (sftbuf_1.ibfmod == 2 || sftbuf_1.ibfmod == 3) {
	*maxbuf += -2;
    }
/* Computing MAX */
    i__1 = min(*ibuf,*maxbuf);
    sftbuf_1.kstart = ntot * max(i__1,1);
    if (sftbuf_1.kstart + ntot <= 2000000 && *maxbuf >= 1) {
	if (sftbuf_1.ibfmod == 3) {
	    izsave = ntot * (*maxbuf + 1) + 1;
	    icsave = izsave + ntot;
	    sbrcop_(&sftbuf_1.sbbuff[izsave - 1], sftbuf_1.sbbuff, &ntot);
	    sbrcop_(&sftbuf_1.sbbuff[icsave - 1], &sftbuf_1.sbbuff[
		    sftbuf_1.kstart], &ntot);
	} else {
	    sbrfil_(sftbuf_1.sbbuff, &c_b11, &ntot);
	    r__1 = (real) (*ic);
	    sbrfil_(&sftbuf_1.sbbuff[sftbuf_1.kstart], &r__1, &ntot);
	}
    } else {
	s_stop(" Sorry, the software buffer is too small !", (ftnlen)42);
    }
    colint_(&rgb[1], ic, ic, &c_b13, &c_b14, &c_b15);
    if (sftbuf_1.lps && ! lpsint) {
	for (i__ = 0; i__ <= 15; ++i__) {
	    if (sftbuf_1.lcolor) {
		r__1 = rinit[i__] * (float)255.;
		sftbuf_1.ir[i__] = i_nint(&r__1);
		r__1 = ginit[i__] * (float)255.;
		sftbuf_1.ig[i__] = i_nint(&r__1);
		r__1 = binit[i__] * (float)255.;
		sftbuf_1.ib[i__] = i_nint(&r__1);
	    } else {
		r__1 = (rinit[i__] + ginit[i__] + binit[i__]) * (float)85.;
		sftbuf_1.ir[i__] = i_nint(&r__1);
	    }
/* L10: */
	}
	lpsint = TRUE_;
    }
} /* sbfint_ */


/* Subroutine */ int sbfin0_(xoff, xlen, xorg, xscale, xperin, xblc, xtrc, 
	yoff, ylen, yorg, yscale, yperin, yblc, ytrc)
real *xoff, *xlen, *xorg, *xscale, *xperin, *xblc, *xtrc, *yoff, *ylen, *yorg,
	 *yscale, *yperin, *yblc, *ytrc;
{
    /* Initialized data */

    static real big = (float)1e20;
    static real small = (float)1e-20;

    /* System generated locals */
    real r__1;

    /* Local variables */
    static real xwdif, ywdif;
    extern /* Subroutine */ int pgqvp_();
    static real axwdif, aywdif;
    extern /* Subroutine */ int pgqwin_();
    static real xi1, xi2, yi1, yi2, xp2, yp2;

/*     --------------------------------------------------------- */


/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      Obtain some viewport and window information about the current */
/*    PGPLOT device, without directly accessing the common blocks in */
/*    pgplot.inc. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    XPERIN   R*4    O       -      Plot X scale in dots/inch. */
/*    YPERIN   R*4    O       -      Plot Y scale in dots/inch. */
/*    XOFF     R*4    O       -      Absolute coord of blc of viewport. */
/*    YOFF     R*4    O       -      Absolute coord of blc of viewport. */
/*    XLEN     R*4    O       -      Width of viewport in absolute coord. */
/*    YLEN     R*4    O       -      Height of viewport in absolute coord. */
/*    XORG     R*4    O       -      Absolute coord of world X=0. */
/*    YORG     R*4    O       -      Absolute coord of world Y=0. */
/*    XSCALE   R*4    O       -      Absolute units per world coord in X. */
/*    YSCALE   R*4    O       -      Absolute units per world coord in Y. */
/*    XBLC     R*4    O       -      World X coord at blc of window. */
/*    XTRC     R*4    O       -      World X coord at trc of window. */
/*    YBLC     R*4    O       -      World Y coord at blc of window. */
/*    YTRC     R*4    O       -      World Y coord at trc of window. */

/* Globals */
/*     None. */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     PGQVP      Inquires about viewport dimensions. */
/*     PGQWIN     Inquires about world coords of window. */

/* History */
/*   D. S. Sivia       2 Aug 1996  Initial release. */
/* ----------------------------------------------------------------------- */

    pgqwin_(xblc, xtrc, yblc, ytrc);
    pgqvp_(&c__1, &xi1, &xi2, &yi1, &yi2);
    pgqvp_(&c__3, xoff, &xp2, yoff, &yp2);
    *xlen = (r__1 = xp2 - *xoff, dabs(r__1));
    *ylen = (r__1 = yp2 - *yoff, dabs(r__1));
    *xperin = *xlen / ((r__1 = xi2 - xi1, dabs(r__1)) + small);
    *yperin = *ylen / ((r__1 = yi2 - yi1, dabs(r__1)) + small);
    xwdif = *xtrc - *xblc;
    ywdif = *ytrc - *yblc;
    axwdif = big;
    aywdif = big;
    if (dabs(xwdif) > small) {
	axwdif = (float)1. / xwdif;
    }
    if (dabs(ywdif) > small) {
	aywdif = (float)1. / ywdif;
    }
    *xscale = *xlen * axwdif;
    *yscale = *ylen * aywdif;
    *xorg = (*xoff * *xtrc - xp2 * *xblc) * axwdif;
    *yorg = (*yoff * *ytrc - yp2 * *yblc) * aywdif;
} /* sbfin0_ */


/* Subroutine */ int sbfsav_(ibuf)
integer *ibuf;
{
    static integer ntot, ibuf1, icsave, maxbuf;
    extern /* Subroutine */ int sbrcop_();
    static integer izsave;

/*     ----------------------- */


/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      Save a rendered picture-buffer, and its Z-buffer, for subsequent */
/*    use in re-initialisation with SBFINT. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    IBUF     I*4    I       -      Software buffer to be saved (>=1). */

/* Globals */
/*    SFTBUF */
/*    GRPCKG1.INC */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     SBRCOP     Copies the contents of one real array to another. */

/* History */
/*   D. S. Sivia      15 Nov 1995  Initial release. */
/* ----------------------------------------------------------------------- */

    ntot = sftbuf_1.nxp * sftbuf_1.nyp;
    maxbuf = 2000000 / ntot - 3;
    ibuf1 = max(*ibuf,1);
    if (ibuf1 > maxbuf) {
	return 0;
    }
    sftbuf_1.kstart = ntot * ibuf1;
    izsave = ntot * (maxbuf + 1) + 1;
    icsave = izsave + ntot;
    sbrcop_(sftbuf_1.sbbuff, &sftbuf_1.sbbuff[izsave - 1], &ntot);
    sbrcop_(&sftbuf_1.sbbuff[sftbuf_1.kstart], &sftbuf_1.sbbuff[icsave - 1], &
	    ntot);
} /* sbfsav_ */


/* Subroutine */ int colint_(rgb, ic1, ic2, difuse, shine, polish)
real *rgb;
integer *ic1, *ic2;
real *difuse, *shine, *polish;
{
    /* System generated locals */
    integer i__1;
    real r__1;
    doublereal d__1, d__2;

    /* Builtin functions */
    integer s_wsle(), do_lio(), e_wsle(), i_nint();
    double pow_dd();

    /* Local variables */
    static real grey, b, g, r__;
    static integer icmin, icmax;
    static real dgrey;
    extern /* Subroutine */ int pgscr_();
    static real db, polsh2, dg;
    static integer ic, nc;
    static real dr;
    extern /* Subroutine */ int pgqcol_();
    static real polshn, red, blu, grn;

    /* Fortran I/O blocks */
    static cilist io___34 = { 0, 6, 0, 0, 0 };


/*     -------------------------------------------------- */



/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      Initialises a colour table for a geometrical object. In general, */
/*    it is recommended that SHINE = 0.0 if DIFUSE > 0.0 and vice versa. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    RGB      R*4    I       3      Red, green and blue intenisty for */
/*                                   fully-lit non-shiny object (0-1). */
/*    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be */
/*                                   used for shading. */
/*    DIFUSE   R*4    I       -      Diffusiveness of object (0-1). */
/*    SHINE    R*4    I       -      Whiteness of bright spot (0-1). */
/*    POLISH   R*4    I       -      Controls size of bright spot. */

/* Globals */
/*    SFTBUF */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     PGQCOL     Inquires about the colour capability. */
/*     PGSCR      Assigns an RGB value to a colour index. */

/* History */
/*   D. S. Sivia       4 Apr 1995  Initial release. */
/* ----------------------------------------------------------------------- */

    /* Parameter adjustments */
    --rgb;

    /* Function Body */
    if (rgb[1] < (float)0. || rgb[1] > (float)1.) {
	return 0;
    }
    if (rgb[2] < (float)0. || rgb[2] > (float)1.) {
	return 0;
    }
    if (rgb[3] < (float)0. || rgb[3] > (float)1.) {
	return 0;
    }
    if (*difuse < (float)0. || *difuse > (float)1.) {
	return 0;
    }
    if (*shine < (float)0. || *shine > (float)1.) {
	return 0;
    }
    if (*ic2 < *ic1) {
	return 0;
    }
    if (sftbuf_1.lps) {
	icmin = 0;
	icmax = 255;
    } else {
	pgqcol_(&icmin, &icmax);
    }
    if (*ic1 < icmin || *ic2 > icmax) {
	s_wsle(&io___34);
	do_lio(&c__9, &c__1, " Invalid colour-indicies for the chosen device\
 !", (ftnlen)48);
	e_wsle();
	return 0;
    }
/* Computing MAX */
    r__1 = *polish / (float)2.;
    polsh2 = dmax(r__1,(float).5);
    nc = *ic2 - *ic1;
    if (nc == 0) {
	red = rgb[1];
	grn = rgb[2];
	blu = rgb[3];
    } else {
	grey = (float)0.;
	dgrey = (float)1. / (real) nc;
	dr = *difuse * rgb[1] / (real) nc;
	dg = *difuse * rgb[2] / (real) nc;
	db = *difuse * rgb[3] / (real) nc;
/* Computing MAX */
	r__1 = rgb[1] * ((float)1. - *difuse);
	red = dmax(r__1,(float)0.);
/* Computing MAX */
	r__1 = rgb[2] * ((float)1. - *difuse);
	grn = dmax(r__1,(float)0.);
/* Computing MAX */
	r__1 = rgb[3] * ((float)1. - *difuse);
	blu = dmax(r__1,(float)0.);
	r__ = red;
	g = grn;
	b = blu;
    }
    i__1 = *ic2;
    for (ic = *ic1; ic <= i__1; ++ic) {
	if (! sftbuf_1.lps) {
	    pgscr_(&ic, &red, &grn, &blu);
	} else {
	    if (sftbuf_1.lcolor) {
		r__1 = red * (float)255.;
		sftbuf_1.ir[ic] = i_nint(&r__1);
		r__1 = grn * (float)255.;
		sftbuf_1.ig[ic] = i_nint(&r__1);
		r__1 = blu * (float)255.;
		sftbuf_1.ib[ic] = i_nint(&r__1);
	    } else {
		r__1 = (red + grn + blu) * (float)85.;
		sftbuf_1.ir[ic] = i_nint(&r__1);
	    }
	}
	r__ += dr;
	g += dg;
	b += db;
	grey += dgrey;
	d__1 = (doublereal) grey;
	d__2 = (doublereal) polsh2;
	polshn = *shine * pow_dd(&d__1, &d__2);
/* Computing MIN */
	r__1 = r__ + polshn;
	red = dmin(r__1,(float)1.);
/* Computing MIN */
	r__1 = g + polshn;
	grn = dmin(r__1,(float)1.);
/* Computing MIN */
	r__1 = b + polshn;
	blu = dmin(r__1,(float)1.);
/* L10: */
    }
} /* colint_ */


/* Subroutine */ int coltab_(rgb, ncol, alfa, ic1, ic2)
real *rgb;
integer *ncol;
real *alfa;
integer *ic1, *ic2;
{
    /* System generated locals */
    integer i__1, i__2;
    real r__1;
    doublereal d__1, d__2;

    /* Builtin functions */
    integer s_wsle(), do_lio(), e_wsle();
    double pow_dd();
    integer i_nint();

    /* Local variables */
    static real dcol;
    static integer icol;
    static real b, g;
    static integer i__;
    static real r__, dicol;
    static integer icmin, icmax;
    extern /* Subroutine */ int pgscr_();
    static real bl;
    static integer nc;
    static real gl, rl, colalf;
    extern /* Subroutine */ int pgqcol_();
    static real col;

    /* Fortran I/O blocks */
    static cilist io___52 = { 0, 6, 0, 0, 0 };


/*     ---------------------------------------- */



/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      Initialises a colour table for a "grey-scale" map. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    RGB      R*4    I   3 X NCOL   Red, green and blue intenisty for */
/*                                   the colour table. */
/*    NCOL     I*4    I       -      No. of colours in the input table. */
/*    ALFA     R*4    I       -      Contrast-factor (linear=1). */
/*    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be */
/*                                   used for the output. */

/* Globals */
/*    SFTBUF */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     PGQCOL     Inquires about the colour capability. */
/*     PGSCR      Assigns an RGB value to a colour index. */

/* History */
/*   D. S. Sivia      30 Apr 1995  Initial release. */
/* ----------------------------------------------------------------------- */

    /* Parameter adjustments */
    rgb -= 4;

    /* Function Body */
    if (*ic2 <= *ic1) {
	return 0;
    }
    if (sftbuf_1.lps) {
	icmin = 0;
	icmax = 255;
    } else {
	pgqcol_(&icmin, &icmax);
    }
    if (*ic1 < icmin || *ic2 > icmax) {
	s_wsle(&io___52);
	do_lio(&c__9, &c__1, " Invalid colour-indicies for the chosen device\
 !", (ftnlen)48);
	e_wsle();
	return 0;
    }
    nc = *ic2 - *ic1;
    col = (float)0.;
    dcol = (float)1. / (real) nc;
    i__1 = nc;
    for (i__ = 0; i__ <= i__1; ++i__) {
/* Computing MIN */
	d__1 = (doublereal) col;
	d__2 = (doublereal) (*alfa);
	r__1 = pow_dd(&d__1, &d__2);
	colalf = (real) (*ncol - 1) * dmin(r__1,(float).99999);
	icol = (integer) colalf;
	dicol = colalf - (real) icol;
	rl = rgb[(icol + 1) * 3 + 1] + dicol * (rgb[(icol + 2) * 3 + 1] - rgb[
		(icol + 1) * 3 + 1]);
	gl = rgb[(icol + 1) * 3 + 2] + dicol * (rgb[(icol + 2) * 3 + 2] - rgb[
		(icol + 1) * 3 + 2]);
	bl = rgb[(icol + 1) * 3 + 3] + dicol * (rgb[(icol + 2) * 3 + 3] - rgb[
		(icol + 1) * 3 + 3]);
/* Computing MIN */
	r__1 = dmax(rl,(float)0.);
	r__ = dmin(r__1,(float)1.);
/* Computing MIN */
	r__1 = dmax(gl,(float)0.);
	g = dmin(r__1,(float)1.);
/* Computing MIN */
	r__1 = dmax(bl,(float)0.);
	b = dmin(r__1,(float)1.);
	if (sftbuf_1.lps) {
	    if (sftbuf_1.lcolor) {
		r__1 = r__ * (float)255.;
		sftbuf_1.ir[*ic1 + i__] = i_nint(&r__1);
		r__1 = g * (float)255.;
		sftbuf_1.ig[*ic1 + i__] = i_nint(&r__1);
		r__1 = b * (float)255.;
		sftbuf_1.ib[*ic1 + i__] = i_nint(&r__1);
	    } else {
		r__1 = (r__ + g + b) * (float)85.;
		sftbuf_1.ir[*ic1 + i__] = i_nint(&r__1);
	    }
	} else {
	    i__2 = *ic1 + i__;
	    pgscr_(&i__2, &r__, &g, &b);
	}
	col += dcol;
/* L10: */
    }
} /* coltab_ */


/* Subroutine */ int colsrf_(rgb, ncol, alfa, ic1, ic2, ncband, difuse, shine,
	 polish)
real *rgb;
integer *ncol;
real *alfa;
integer *ic1, *ic2, *ncband;
real *difuse, *shine, *polish;
{
    /* System generated locals */
    integer i__1, i__2;
    real r__1;
    doublereal d__1, d__2;

    /* Builtin functions */
    integer s_wsle(), do_lio(), e_wsle();
    double pow_dd();

    /* Local variables */
    static real dcol;
    static integer icol, i__;
    static real dicol;
    static integer icmin, icmax, ic;
    static real bl, gl, rl, colalf;
    static integer nshads;
    extern /* Subroutine */ int pgqcol_(), colint_();
    static real rgbout[3], col;

    /* Fortran I/O blocks */
    static cilist io___68 = { 0, 6, 0, 0, 0 };


/*     ------------------------------------------------------------ */



/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      Initialises a colour table for a 3-D surface rendering of a 2-D */
/*   array of "data". */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    RGB      R*4    I   3 X NCOL   Red, green and blue intenisty for */
/*                                   the colour table. */
/*    NCOL     I*4    I       -      No. of colours in the input table. */
/*    ALFA     R*4    I       -      Contrast-factor (linear=1). */
/*    IC1,IC2  I*4    I       -      Lowest and highest colour-index to */
/*                                   be used for the rendering. */
/*    NCBAND   I*4    I       -      Number of colour-bands for the */
/*                                   height, so that the number of shades */
/*                                   per band = (IC2-IC1+1)/NCBAND. */
/*    DIFUSE   R*4    I       -      Diffusiveness of object (0-1). */
/*    SHINE    R*4    I       -      Whiteness of bright spot (0-1). */
/*    POLISH   R*4    I       -      Controls size of bright spot. */

/* Globals */
/*    SFTBUF */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     PGQCOL     Inquires about the colour capability. */

/* History */
/*   D. S. Sivia      30 Oct 1995  Initial release. */
/* ----------------------------------------------------------------------- */

    /* Parameter adjustments */
    rgb -= 4;

    /* Function Body */
    if (*ic2 <= *ic1) {
	return 0;
    }
    if (sftbuf_1.lps) {
	icmin = 0;
	icmax = 255;
    } else {
	pgqcol_(&icmin, &icmax);
    }
    if (*ic1 < icmin || *ic2 > icmax) {
	s_wsle(&io___68);
	do_lio(&c__9, &c__1, " Invalid colour-indicies for the chosen device\
 !", (ftnlen)48);
	e_wsle();
	return 0;
    }
/* Computing MAX */
    i__1 = (*ic2 - *ic1 + 1) / max(*ncband,1);
    nshads = max(i__1,1);
    col = (float)0.;
/* Computing MAX */
    i__1 = *ncband - 1;
    dcol = (float)1. / (real) max(i__1,1);
    ic = *ic1;
    i__1 = *ncband;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MIN */
	d__1 = (doublereal) col;
	d__2 = (doublereal) (*alfa);
	r__1 = pow_dd(&d__1, &d__2);
	colalf = (real) (*ncol - 1) * dmin(r__1,(float).99999);
	icol = (integer) colalf;
	dicol = colalf - (real) icol;
	rl = rgb[(icol + 1) * 3 + 1] + dicol * (rgb[(icol + 2) * 3 + 1] - rgb[
		(icol + 1) * 3 + 1]);
	gl = rgb[(icol + 1) * 3 + 2] + dicol * (rgb[(icol + 2) * 3 + 2] - rgb[
		(icol + 1) * 3 + 2]);
	bl = rgb[(icol + 1) * 3 + 3] + dicol * (rgb[(icol + 2) * 3 + 3] - rgb[
		(icol + 1) * 3 + 3]);
/* Computing MIN */
	r__1 = dmax(rl,(float)0.);
	rgbout[0] = dmin(r__1,(float)1.);
/* Computing MIN */
	r__1 = dmax(gl,(float)0.);
	rgbout[1] = dmin(r__1,(float)1.);
/* Computing MIN */
	r__1 = dmax(bl,(float)0.);
	rgbout[2] = dmin(r__1,(float)1.);
	i__2 = ic + nshads - 1;
	colint_(rgbout, &ic, &i__2, difuse, shine, polish);
	ic += nshads;
	col += dcol;
/* L10: */
    }
} /* colsrf_ */


/* Subroutine */ int sbfcls_(ibuf)
integer *ibuf;
{
    /* Initialized data */

    static integer lodd = 37614625;
    static real rndscl = (float).96;
    static real rndoff = (float)-.5;
    static integer nrnd = 3000;
    static logical lstart = FALSE_;

    /* Format strings */
    static char fmt_100[] = "(i6,i6,\002 moveto \002,i6,\002 0 rlineto  0\
 \002,i6,\002 rlineto \002,i6,\002 0 rlineto\002)";
    static char fmt_110[] = "(2i4,\002 8 [\002,6(1pe10.3,\002 \002),\002]\
\002)";
    static char fmt_120[] = "(33z2.2)";

    /* System generated locals */
    integer i__1, i__2, i__3, i__4, i__5;
    real r__1;

    /* Builtin functions */
    integer s_wsfi(), i_nint(), do_fio(), e_wsfi();

    /* Local variables */
    static integer kend, lchr, ntot;
    static real rnd900;
    static integer i__, j, k, l;
    extern /* Subroutine */ int gresc_();
    static integer value[33];
    extern /* Subroutine */ int sbcls0_();
    static integer ic;
    static real at, bt, ct, dt;
    extern /* Subroutine */ int pgbbuf_();
    static real buffer[2050], rndbuf[3051];
    static char inline__[80];
    static integer maxbuf;
    static real tx, ty;
    extern /* Subroutine */ int grterm_(), grexec_(), pgebuf_();
    static char chr[16];
    extern doublereal ran_();
    static integer nxp2;

    /* Fortran I/O blocks */
    static icilist io___98 = { 0, inline__, 0, fmt_100, 80, 1 };
    static icilist io___99 = { 0, inline__, 0, "(A,I5,A)", 80, 1 };
    static icilist io___100 = { 0, inline__, 0, fmt_110, 80, 1 };
    static icilist io___105 = { 0, inline__, 0, fmt_120, 80, 1 };
    static icilist io___106 = { 0, inline__, 0, fmt_120, 80, 1 };


/*     ----------------------- */

/* ----------------------------------------------------------------------- */
/*            Include file for GRPCKG */
/* Modifications: */
/*   29-Jan-1985 - add HP2648 (KS/TJP). */
/*   16-Sep-1985 - remove tabs (TJP). */
/*   30-Dec-1985 - add PS, VPS (TJP). */
/*   27-May-1987 - remove ARGS, NULL, PS, VPS, QMS, VQMS, HIDMP, */
/*                 HP7221, GRINL (TJP). */
/*    6-Jun-1987 - remove PRTX, TRILOG, VERS, VV (TJP). */
/*   11-Jun-1987 - remove remaining built-in devices (TJP). */
/*    5-Jul-1987 - replace GRINIT, GRPLTD by GRSTAT. */
/*   16-Aug-1987 - remove obsolete variables. */
/*    9-Sep-1989 - add SAVE statement. */
/*   26-Nov-1990 - remove GRCTYP. */
/*    5-Jan-1993 - add GRADJU. */
/*    1-Sep-1994 - add GRGCAP. */
/*   21-Dec-1995 - increase GRIMAX to 8. */
/*   30-Apr-1997 - remove GRC{XY}SP */
/* ----------------------------------------------------------------------- */

/* Parameters: */
/*   GRIMAX : maximum number of concurrent devices */
/*   GRFNMX : maximum length of file names */
/*   GRCXSZ : default width of chars (pixels) */
/*   GRCYSZ : default height of chars (pixels) */


/* Common blocks: */
/*   GRCIDE : identifier of current plot */
/*   GRGTYP : device type of current plot */
/* The following are qualified by a plot id: */
/*   GRSTAT : 0 => workstation closed */
/*            1 => workstation open */
/*            2 => picture open */
/*   GRPLTD : */
/*   GRDASH : software dashing in effect? */
/*   GRUNIT : unit associated with id */
/*   GRFNLN : length of filename */
/*   GRTYPE : device type */
/*   GRXMXA : x size of plotting surface */
/*   GRYMXA : y size of plotting surface */
/*   GRXMIN : blc of plotting window */
/*   GRYMIN : ditto */
/*   GRXMAX : trc of plotting window */
/*   GRYMAX : ditto */
/*   GRSTYL : line style (integer code) */
/*   GRWIDT : line width (integer code) */
/*   GRCCOL : current color index (integer code) */
/*   GRMNCI : minimum color index on this device */
/*   GRMXCI : maximum color index on this device */
/*   GRCMRK : marker number */
/*   GRXPRE : previous (current) pen position (x) */
/*   GRYPRE : ditto (y) */
/*   GRXORG : transformation variables (GRTRAN) */
/*   GRYORG : ditto */
/*   GRXSCL : ditto */
/*   GRYSCL : ditto */
/*   GRCSCL : character scaling factor */
/*   GRCFAC : */
/*   GRCFNT : character font */
/*   GRFILE : file name (character) */
/*   GRGCAP : device capabilities (character) */
/*   GRPXPI : pixels per inch in x */
/*   GRPYPI : pixels per inch in y */
/*   GRADJU : TRUE if GRSETS (PGPAP) has been called */


/* ----------------------------------------------------------------------- */

/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      Closes the software buffer for crystal-plotting, by outputing it */
/*    to the screen or writing out a postscript file (as appropriate). */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    IBUF     I*4    I       -      Software buffer to be output (>=1). */

/* Globals */
/*    SFTBUF */
/*    GRPCKG1.INC */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     GREXEC     Dispatches command to appropriate device driver. */
/*     PGBBUF     Recommended initial call (to start a PGPLOT buffer). */
/*     PGEBUF     Recommended final call (to end a PGPLOT buffer). */

/* History */
/*   D. S. Sivia       4 Apr 1995  Initial release. */
/*   D. S. Sivia      20 Oct 1995  Hardwire assumption that NGANG=1. */
/*   D. S. Sivia      21 Oct 1997  Made slightly friendlier for NT. */
/*   D. S. Sivia      30 Jan 1998  Explicitly SAVE array RNDBUF. */
/* ----------------------------------------------------------------------- */

    ntot = sftbuf_1.nxp * sftbuf_1.nyp;
    maxbuf = 2000000 / ntot - 1;
    if (sftbuf_1.ibfmod == 2 || sftbuf_1.ibfmod == 3) {
	maxbuf += -2;
    }
    if (*ibuf > maxbuf) {
	return 0;
    }
    kend = ntot * max(*ibuf,1);
    if (! lstart) {
	i__1 = nrnd - 1;
	for (i__ = 0; i__ <= i__1; ++i__) {
/* L10: */
	    rndbuf[i__] = rndscl * (ran_(&lodd) + rndoff);
	}
	lstart = TRUE_;
    }
    if (sftbuf_1.lps) {
	at = (real) sftbuf_1.nxp / sftbuf_1.xlen;
	bt = (float)0.;
	ct = (float)0.;
	dt = (real) sftbuf_1.nyp / sftbuf_1.ylen;
	tx = -at * sftbuf_1.xoff;
	ty = -dt * sftbuf_1.yoff;
	s_wsfi(&io___98);
	i__1 = i_nint(&sftbuf_1.xoff);
	do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
	i__2 = i_nint(&sftbuf_1.yoff);
	do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
	i__3 = i_nint(&sftbuf_1.xlen);
	do_fio(&c__1, (char *)&i__3, (ftnlen)sizeof(integer));
	i__4 = i_nint(&sftbuf_1.ylen);
	do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
	i__5 = -i_nint(&sftbuf_1.xlen);
	do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
	e_wsfi();
	grterm_();
	gresc_(" newpath ", (ftnlen)9);
	gresc_(inline__, (ftnlen)80);
	gresc_(" closepath ", (ftnlen)11);
	s_wsfi(&io___99);
	do_fio(&c__1, "/picstr ", (ftnlen)8);
	do_fio(&c__1, (char *)&sftbuf_1.nxp, (ftnlen)sizeof(integer));
	do_fio(&c__1, " string def", (ftnlen)11);
	e_wsfi();
	gresc_(inline__, (ftnlen)80);
	s_wsfi(&io___100);
	do_fio(&c__1, (char *)&sftbuf_1.nxp, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&sftbuf_1.nyp, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&at, (ftnlen)sizeof(real));
	do_fio(&c__1, (char *)&bt, (ftnlen)sizeof(real));
	do_fio(&c__1, (char *)&ct, (ftnlen)sizeof(real));
	do_fio(&c__1, (char *)&dt, (ftnlen)sizeof(real));
	do_fio(&c__1, (char *)&tx, (ftnlen)sizeof(real));
	do_fio(&c__1, (char *)&ty, (ftnlen)sizeof(real));
	e_wsfi();
	gresc_(inline__, (ftnlen)80);
	gresc_("{ currentfile picstr readhexstring pop}", (ftnlen)39);
	if (sftbuf_1.lcolor) {
	    gresc_("  false 3 colorimage", (ftnlen)20);
	} else {
	    gresc_("  image", (ftnlen)7);
	}
	l = 0;
	i__1 = kend + ntot;
	for (k = kend + 1; k <= i__1; ++k) {
	    ++l;
	    r__1 = sftbuf_1.sbbuff[k - 1] + rndbuf[k % nrnd];
	    ic = i_nint(&r__1);
	    if (sftbuf_1.lcolor) {
		value[l - 1] = sftbuf_1.ir[ic];
		value[l] = sftbuf_1.ig[ic];
		value[l + 1] = sftbuf_1.ib[ic];
		l += 2;
	    } else {
		value[l - 1] = sftbuf_1.ir[ic];
	    }
	    if (l == 33) {
		s_wsfi(&io___105);
		for (i__ = 1; i__ <= 33; ++i__) {
		    do_fio(&c__1, (char *)&value[i__ - 1], (ftnlen)sizeof(
			    integer));
		}
		e_wsfi();
		gresc_(inline__, (ftnlen)66);
		l = 0;
	    }
/* L20: */
	}
	if (l != 0) {
	    s_wsfi(&io___106);
	    i__1 = l;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		do_fio(&c__1, (char *)&value[i__ - 1], (ftnlen)sizeof(integer)
			);
	    }
	    e_wsfi();
	    gresc_(inline__, l << 1);
	}
	gresc_(" newpath ", (ftnlen)9);
	grterm_();
    } else {
	pgbbuf_();
	nxp2 = sftbuf_1.nxp + 2;
	k = kend + 1;
	rnd900 = (float)900.;
	buffer[0] = (real) i_nint(&sftbuf_1.xoff);
	buffer[1] = (real) i_nint(&sftbuf_1.yoff);
	i__1 = sftbuf_1.nyp;
	for (j = 1; j <= i__1; ++j) {
	    l = (integer) (rnd900 * (rndbuf[j] - rndoff)) + 1;
	    sbcls0_(&buffer[2], &sftbuf_1.sbbuff[k - 1], &rndbuf[l], &
		    sftbuf_1.nxp);
	    grexec_(&grcm00_1.grgtyp, &c__26, buffer, &nxp2, chr, &lchr, (
		    ftnlen)16);
	    k += sftbuf_1.nxp;
	    buffer[1] += (float)1.;
/* L40: */
	}
	pgebuf_();
    }
} /* sbfcls_ */


/* Subroutine */ int sbcls0_(a, b, c__, n)
real *a, *b, *c__;
integer *n;
{
    /* System generated locals */
    integer i__1;
    real r__1;

    /* Builtin functions */
    integer i_nint();

    /* Local variables */
    static integer i__;

/*     -------------------------- */


    /* Parameter adjustments */
    --c__;
    --b;
    --a;

    /* Function Body */
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L10: */
	r__1 = b[i__] + c__[i__];
	a[i__] = (real) i_nint(&r__1);
    }
} /* sbcls0_ */


/* Subroutine */ int sbball_(eye, centre, radius, ic1, ic2, light, lshine, x0,
	 y0, r0)
real *eye, *centre, *radius;
integer *ic1, *ic2;
real *light;
logical *lshine;
real *x0, *y0, *r0;
{
    /* System generated locals */
    integer i__1, i__2;
    real r__1, r__2, r__3;
    doublereal d__1, d__2, d__3;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static doublereal alfa, gama, beta;
    static real xdif, ydif, xmin, ymin, xmax, ymax, surf[3], zmax;
    static doublereal a, b, c__;
    static integer k;
    static doublereal q;
    static real corel, small;
    static integer ixmin, ixmax, jymin, jymax;
    static doublereal r1, r2;
    static real ba;
    static integer nc;
    static real dx, dy, yh, xh;
    static integer jy, ix;
    static real alfaxh;
    static doublereal dgamze, dsmall;
    static real betayh, colscl;
    static doublereal cosphi;
    extern /* Subroutine */ int sbglos_();
    static doublereal sinphi;
    static real colour, x0h, y0h, xh2, yh2;
    static doublereal xl0, xl1;
    static real xl2, xn2, xn3;
    static doublereal det, dze, hyp;
    static real xlm;
    static doublereal xmu, dbl1, dbl2;
    static real col0;
    static doublereal dx0h, dy0h, dze2;
    static real xnl2;

/*     ------------------------------------------------------------------ */


/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      This subroutine plots a shiny or matt coloured ball. All */
/*    (x,y,z) values are taken to be given in world coordinates. The */
/*    z-component of the eye-poisition should be positive and that of */
/*    the ball-centre should be negative (< -radius); the viewing-screen */
/*    is fixed at z=0. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    EYE      R*4    I       3      (x,y,z) coordinate of eye-position. */
/*    CENTRE   R*4    I       3      (x,y,z) coordinate of ball-centre. */
/*    RADIUS   R*4    I       -      Radius of ball. */
/*    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be */
/*                                   used for shading. */
/*    LIGHT    R*4    I       3      (x,y,z) direction of flood-light. */
/*    LSHINE   L*1    I       -      Shiny ball if .TRUE., else diffuse. */
/*    X0,Y0    R*4    O       -      Centre of projected ball. */
/*    R0       R*4    O       -      Average radius of projected ball. */

/* Globals */
/*    SFTBUF */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     SBGLOS     Works out colour-shade for surface of ball. */

/* History */
/*   D. S. Sivia       7 Apr 1995  Initial release. */
/* ----------------------------------------------------------------------- */

/* Some initial checks. */

    /* Parameter adjustments */
    --light;
    --centre;
    --eye;

    /* Function Body */
    small = (float)1e-20;
    dsmall = (doublereal) small;
    if (eye[3] <= (float)0.) {
	return 0;
    }
    if (*radius <= (float)0.) {
	return 0;
    }
    if (centre[3] > -(*radius)) {
	return 0;
    }

/* Calculate parameters of projected ellipse. */

    dze = (doublereal) eye[3];
/* Computing 2nd power */
    d__1 = dze;
    dze2 = d__1 * d__1;
    alfa = (doublereal) (eye[1] - centre[1]);
    beta = (doublereal) (eye[2] - centre[2]);
    gama = (doublereal) (eye[3] - centre[3]);
/* Computing 2nd power */
    r__1 = *radius;
/* Computing 2nd power */
    d__1 = alfa;
/* Computing 2nd power */
    d__2 = beta;
/* Computing 2nd power */
    d__3 = gama;
    xmu = (doublereal) (r__1 * r__1) - (d__1 * d__1 + d__2 * d__2 + d__3 * 
	    d__3);
/* Computing 2nd power */
    d__1 = alfa;
    a = xmu * (xmu + d__1 * d__1);
    b = xmu * alfa * beta;
/* Computing 2nd power */
    d__1 = beta;
    c__ = xmu * (xmu + d__1 * d__1);
/* Computing 2nd power */
    d__2 = b;
    det = (d__1 = a * c__ - d__2 * d__2, abs(d__1)) + dsmall;
    dx0h = gama * xmu * dze * (alfa * c__ - beta * b) / det;
    dy0h = gama * xmu * dze * (beta * a - alfa * b) / det;
/* Computing 2nd power */
    d__1 = dx0h;
/* Computing 2nd power */
    d__2 = dy0h;
/* Computing 2nd power */
    d__3 = gama;
    q = a * (d__1 * d__1) + b * (float)2. * dx0h * dy0h + c__ * (d__2 * d__2) 
	    - xmu * (xmu + d__3 * d__3) * dze2;
    x0h = (real) dx0h;
    y0h = (real) dy0h;
    dx = (sftbuf_1.xtrc - sftbuf_1.xblc) / (real) (sftbuf_1.nxp - 1);
    dy = (sftbuf_1.ytrc - sftbuf_1.yblc) / (real) (sftbuf_1.nyp - 1);
    xdif = (real) sqrt((d__1 = c__ * q / det, abs(d__1)) + dsmall);
    xmin = x0h - xdif + eye[1];
    xmax = x0h + xdif + eye[1];
    ixmin = (integer) ((xmin - sftbuf_1.xblc) / dx) + 2;
    ixmax = (integer) ((xmax - sftbuf_1.xblc) / dx) + 1;
    if (ixmin > sftbuf_1.nxp || ixmax < 1) {
	return 0;
    }
    ydif = sqrt((d__1 = a * q / det, abs(d__1)) + dsmall);
    ymin = y0h - ydif + eye[2];
    ymax = y0h + ydif + eye[2];
    jymin = (integer) ((ymin - sftbuf_1.yblc) / dy) + 2;
    jymax = (integer) ((ymax - sftbuf_1.yblc) / dy) + 1;
    if (jymin > sftbuf_1.nyp || jymax < 1) {
	return 0;
    }
    if (jymin < 1) {
	jymin = 1;
    }
    if (jymax > sftbuf_1.nyp) {
	jymax = sftbuf_1.nyp;
    }
    zmax = centre[3] + *radius;
    *x0 = x0h + eye[1];
    *y0 = y0h + eye[2];
    corel = (real) sqrt((d__1 = b * b / (a * c__), abs(d__1)) + dsmall);
    if (corel > (float)1e-4) {
	xl0 = (a + c__) / 2.;
	xl1 = xl0 - sqrt((d__1 = xl0 * xl0 - det, abs(d__1)) + dsmall);
/* Computing 2nd power */
	d__1 = xl1 - a;
/* Computing 2nd power */
	d__2 = b;
	hyp = sqrt(d__1 * d__1 + d__2 * d__2 + dsmall);
	sinphi = (xl1 - a) / hyp;
	cosphi = b / hyp;
    } else {
	sinphi = 0.;
	cosphi = 1.;
    }
    r1 = sqrt(q / (a * cosphi * cosphi + sinphi * (c__ * sinphi + b * (float)
	    2. * cosphi)));
    r2 = sqrt(q / (a * sinphi * sinphi + cosphi * (c__ * cosphi - b * (float)
	    2. * sinphi)));
    *r0 = (real) ((r1 + r2) / 2.);

/* Fill the inside of the projected ellipse with the right colours. */

    nc = *ic2 - *ic1;
    col0 = (real) (*ic1);
    colscl = (real) nc;
/* Computing 2nd power */
    r__1 = light[1];
/* Computing 2nd power */
    r__2 = light[2];
/* Computing 2nd power */
    r__3 = light[3];
    xl2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
/* Computing 2nd power */
    r__1 = *radius;
    xn2 = r__1 * r__1;
    xnl2 = (float)1. / sqrt(xn2 * xl2 + small);
    xn3 = (float)1. / (xn2 + small);
    yh = sftbuf_1.yblc + dy * (real) (jymin - 1) - eye[2];
    dgamze = gama * dze;
    ba = (real) (b / a);
    i__1 = jymax;
    for (jy = jymin; jy <= i__1; ++jy) {
/* Computing 2nd power */
	r__1 = yh;
	yh2 = r__1 * r__1;
	betayh = beta * yh;
	ydif = yh - y0h;
/* Computing 2nd power */
	r__1 = ydif;
	xdif = (real) (sqrt((d__1 = a * q - det * (doublereal) (r__1 * r__1), 
		abs(d__1)) + dsmall) / a);
	xmin = x0h - ba * ydif - xdif + eye[1];
	xmax = x0h - ba * ydif + xdif + eye[1];
	ixmin = (integer) ((xmin - sftbuf_1.xblc) / dx) + 2;
	ixmax = (integer) ((xmax - sftbuf_1.xblc) / dx) + 1;
	if (ixmin <= sftbuf_1.nxp && ixmax >= 1) {
	    if (ixmin < 1) {
		ixmin = 1;
	    }
	    if (ixmax > sftbuf_1.nxp) {
		ixmax = sftbuf_1.nxp;
	    }
	    xh = sftbuf_1.xblc + dx * (real) (ixmin - 1) - eye[1];
	    k = (jy - 1) * sftbuf_1.nxp + ixmin;
	    i__2 = ixmax;
	    for (ix = ixmin; ix <= i__2; ++ix) {
		if (zmax > sftbuf_1.sbbuff[k - 1]) {
/* Computing 2nd power */
		    r__1 = xh;
		    xh2 = r__1 * r__1;
		    alfaxh = alfa * xh;
		    dbl1 = (doublereal) (alfaxh + betayh) - dgamze;
		    dbl2 = (doublereal) (xh2 + yh2) + dze2;
/* Computing 2nd power */
		    d__2 = dbl1;
		    xlm = (real) ((-dbl1 - sqrt((d__1 = d__2 * d__2 + xmu * 
			    dbl2, abs(d__1)) + dsmall)) / dbl2);
		    surf[2] = eye[3] * ((float)1. - xlm);
		    if (surf[2] > sftbuf_1.sbbuff[k - 1]) {
			sftbuf_1.sbbuff[k - 1] = surf[2];
			if (nc == 0) {
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = col0;
			} else {
			    surf[1] = eye[2] + yh * xlm;
			    surf[0] = eye[1] + xh * xlm;
			    sbglos_(&eye[1], &centre[1], &light[1], surf, &
				    xnl2, &xn3, &small, lshine, &colour);
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = col0 + 
				    colour * colscl;
			}
		    }
		}
		++k;
		xh += dx;
/* L10: */
	    }
	}
	yh += dy;
/* L20: */
    }
} /* sbball_ */


/* Subroutine */ int sbglos_(eye, centre, light, surf, xnl2, xn3, small, 
	lshine, colour)
real *eye, *centre, *light, *surf, *xnl2, *xn3, *small;
logical *lshine;
real *colour;
{
    /* System generated locals */
    real r__1, r__2, r__3;

    /* Local variables */
    static real view[3], view2;
    static integer i__;
    static real reflec[3], normal[3], rfnorm, xnl, xrv, ref2;

/*     -------------------------------------------------------------- */

/* Support subroutine for SBBALL, to work out colour-shade. */


    /* Parameter adjustments */
    --surf;
    --light;
    --centre;
    --eye;

    /* Function Body */
    *colour = (float)0.;
    xnl = (float)0.;
    for (i__ = 1; i__ <= 3; ++i__) {
	normal[i__ - 1] = surf[i__] - centre[i__];
	xnl += normal[i__ - 1] * light[i__];
/* L10: */
    }
    if (xnl >= (float)0.) {
	return 0;
    }
    if (*lshine) {
	rfnorm = (xnl + xnl) * *xn3;
	xrv = (float)0.;
	for (i__ = 1; i__ <= 3; ++i__) {
	    view[i__ - 1] = eye[i__] - surf[i__];
	    reflec[i__ - 1] = light[i__] - rfnorm * normal[i__ - 1];
	    xrv += reflec[i__ - 1] * view[i__ - 1];
/* L20: */
	}
	if (xrv < (float)0.) {
	    return 0;
	}
	ref2 = (float)0.;
	view2 = (float)0.;
	for (i__ = 1; i__ <= 3; ++i__) {
/* Computing 2nd power */
	    r__1 = reflec[i__ - 1];
	    ref2 += r__1 * r__1;
/* Computing 2nd power */
	    r__1 = view[i__ - 1];
	    view2 += r__1 * r__1;
/* L30: */
	}
/* Computing MIN */
/* Computing 2nd power */
	r__3 = xrv;
	r__2 = r__3 * r__3 / ((r__1 = ref2 * view2, dabs(r__1)) + *small);
	*colour = dmin(r__2,(float)1.);
    } else {
/* Computing MIN */
	r__1 = -xnl * *xnl2;
	*colour = dmin(r__1,(float)1.);
    }
} /* sbglos_ */


/* Subroutine */ int sbline_(eye, end1, end2, icol, ldash)
real *eye, *end1, *end2;
integer *icol;
logical *ldash;
{
    /* Initialized data */

    static integer ndash1 = 7;
    static integer ndash2 = 3;

    /* System generated locals */
    integer i__1, i__2, i__3;

    /* Builtin functions */
    integer i_nint();

    /* Local variables */
    static real xdif, ydif, dxii, dyjj, xlam, ylam, a, b, c__, d__;
    static integer i__, j, k;
    static real z__, small, x1, x2, y1, y2, x3, y3;
    extern /* Subroutine */ int sblin1_();
    static integer ii, jj;
    static real dx, dy, xi, yj, xx, yy, colour;
    static integer ix1, ix2, jy1, jy2;
    static real xw1, yw1, xw2, yw2, zw1;
    static integer iii, jjj;
    static real dxi, dyj, dxx, dyy;

/*     ------------------------------------------- */


    /* Parameter adjustments */
    --end2;
    --end1;
    --eye;

    /* Function Body */

/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      This subroutine draws a straight line between two points. All */
/*    (x,y,z) values are taken to be given in world coordinates. The */
/*    z-component of the eye-poisition should be positive, while that */
/*    of both the ends should be negative; the viewing-screen is fixed */
/*    at z=0. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    EYE      R*4    I       3      (x,y,z) coordinate of eye-position. */
/*    END1     R*4    I       3      (x,y,z) coordinate of end-1. */
/*    END2     R*4    I       3      (x,y,z) coordinate of end-2. */
/*    ICOL     I*4    I       -      Colour-index for line. */
/*    LDASH    L*1    I       -      Dashed line if .TRUE. (else cont.). */

/* Globals */
/*    SFTBUF */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     SBLIN1     Calculates the projection of (x,y,z) on viewing screen. */

/* History */
/*   D. S. Sivia       4 Apr 1995  Initial release. */
/*   D. S. Sivia      25 Oct 1997  Prevent occasional Z-coordinate bug. */
/* ----------------------------------------------------------------------- */

/* Some initial checks and clipping. */

    small = (float)1e-10;
    if (eye[3] <= (float)0.) {
	return 0;
    }
    if (end1[3] >= (float)0. || end2[3] >= (float)0.) {
	return 0;
    }
    sblin1_(&eye[1], &end1[1], &end1[2], &end1[3], &xw1, &yw1);
    sblin1_(&eye[1], &end2[1], &end2[2], &end2[3], &xw2, &yw2);
    xdif = xw2 - xw1;
    ydif = yw2 - yw1;
    if (dabs(xdif) + dabs(ydif) < small) {
	return 0;
    }
    if (dabs(xdif) < small) {
	xdif = small;
    }
    if (dabs(ydif) < small) {
	ydif = small;
    }
    if (xw1 <= sftbuf_1.xblc) {
	if (xw2 <= sftbuf_1.xblc) {
	    return 0;
	}
	xlam = (sftbuf_1.xblc - xw1) / xdif;
	xw1 += xlam * xdif;
	yw1 += xlam * ydif;
    } else if (xw1 >= sftbuf_1.xtrc) {
	if (xw2 >= sftbuf_1.xtrc) {
	    return 0;
	}
	xlam = (sftbuf_1.xtrc - xw1) / xdif;
	xw1 += xlam * xdif;
	yw1 += xlam * ydif;
    }
    if (yw1 <= sftbuf_1.yblc) {
	if (yw2 <= sftbuf_1.yblc) {
	    return 0;
	}
	ylam = (sftbuf_1.yblc - yw1) / ydif;
	xw1 += ylam * xdif;
	yw1 += ylam * ydif;
    } else if (yw1 >= sftbuf_1.ytrc) {
	if (yw2 >= sftbuf_1.ytrc) {
	    return 0;
	}
	ylam = (sftbuf_1.ytrc - yw1) / ydif;
	xw1 += ylam * xdif;
	yw1 += ylam * ydif;
    }
    if (xw2 <= sftbuf_1.xblc) {
	xlam = (sftbuf_1.xblc - xw1) / xdif;
	xw2 = xw1 + xlam * xdif;
	yw2 = yw1 + xlam * ydif;
    } else if (xw2 >= sftbuf_1.xtrc) {
	xlam = (sftbuf_1.xtrc - xw1) / xdif;
	xw2 = xw1 + xlam * xdif;
	yw2 = yw1 + xlam * ydif;
    }
    if (yw2 <= sftbuf_1.yblc) {
	ylam = (sftbuf_1.yblc - yw1) / ydif;
	xw2 = xw1 + ylam * xdif;
	yw2 = yw1 + ylam * ydif;
    } else if (yw2 >= sftbuf_1.ytrc) {
	ylam = (sftbuf_1.ytrc - yw1) / ydif;
	xw2 = xw1 + ylam * xdif;
	yw2 = yw1 + ylam * ydif;
    }

    colour = (real) (*icol);
    dx = (real) (sftbuf_1.nxp - 1) / (sftbuf_1.xtrc - sftbuf_1.xblc);
    x1 = (xw1 - sftbuf_1.xblc) * dx + (float)1.;
    x2 = (xw2 - sftbuf_1.xblc) * dx + (float)1.;
    xdif = x2 - x1;
    dy = (real) (sftbuf_1.nyp - 1) / (sftbuf_1.ytrc - sftbuf_1.yblc);
    y1 = (yw1 - sftbuf_1.yblc) * dy + (float)1.;
    y2 = (yw2 - sftbuf_1.yblc) * dy + (float)1.;
    ydif = y2 - y1;
    zw1 = end1[3];
    if (dabs(xdif) >= dabs(ydif)) {
	if (dabs(xdif) < small) {
	    return 0;
	}
	if (x1 <= x2) {
	    a = eye[3] - end1[3];
	    b = eye[3] * (eye[1] - end1[1]);
	    c__ = end2[3] - end1[3];
	    d__ = eye[3] * (end2[1] - end1[1]);
	} else {
	    x3 = x1;
	    y3 = y1;
	    x1 = x2;
	    y1 = y2;
	    x2 = x3;
	    y2 = y3;
	    zw1 = end2[3];
	    a = eye[3] - end2[3];
	    b = eye[3] * (eye[1] - end2[1]);
	    c__ = end1[3] - end2[3];
	    d__ = eye[3] * (end1[1] - end2[1]);
	}
	if (dabs(c__) < small) {
	    c__ = small;
	}
	d__ /= c__;
	if (dabs(d__) < small) {
	    d__ = small;
	}
	dyj = ydif / xdif;
	ix1 = i_nint(&x1);
	ix2 = i_nint(&x2);
	yj = y1 + dyj * ((real) ix1 - x1);
	dxx = (float)1. / dx;
	if (*ldash) {
	    dyjj = (ndash1 - ndash2 - 1) * dyj;
	    i__1 = ix2;
	    i__2 = ndash1;
	    for (ii = ix1; i__2 < 0 ? ii >= i__1 : ii <= i__1; ii += i__2) {
/* Computing MIN */
		i__3 = ii + ndash2;
		iii = min(i__3,ix2);
		xx = sftbuf_1.xblc - eye[1] + dxx * (real) (ii - 1);
		i__3 = iii;
		for (i__ = ii; i__ <= i__3; ++i__) {
		    k = sftbuf_1.nxp * (i_nint(&yj) - 1) + i__;
		    z__ = zw1 + (a * xx + b) / (xx + d__);
		    if (z__ > sftbuf_1.sbbuff[k - 1]) {
			sftbuf_1.sbbuff[k - 1] = z__;
			sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = colour;
		    }
		    yj += dyj;
		    xx += dxx;
/* L10: */
		}
		yj += dyjj;
/* L20: */
	    }
	} else {
	    xx = sftbuf_1.xblc - eye[1] + dxx * (real) (ix1 - 1);
	    i__2 = ix2;
	    for (i__ = ix1; i__ <= i__2; ++i__) {
		k = sftbuf_1.nxp * (i_nint(&yj) - 1) + i__;
		z__ = zw1 + (a * xx + b) / (xx + d__);
		if (z__ > sftbuf_1.sbbuff[k - 1]) {
		    sftbuf_1.sbbuff[k - 1] = z__;
		    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = colour;
		}
		yj += dyj;
		xx += dxx;
/* L30: */
	    }
	}
    } else {
	if (dabs(ydif) < small) {
	    return 0;
	}
	if (y1 <= y2) {
	    a = eye[3] - end1[3];
	    b = eye[3] * (eye[2] - end1[2]);
	    c__ = end2[3] - end1[3];
	    d__ = eye[3] * (end2[2] - end1[2]);
	} else {
	    x3 = x1;
	    y3 = y1;
	    x1 = x2;
	    y1 = y2;
	    x2 = x3;
	    y2 = y3;
	    zw1 = end2[3];
	    a = eye[3] - end2[3];
	    b = eye[3] * (eye[2] - end2[2]);
	    c__ = end1[3] - end2[3];
	    d__ = eye[3] * (end1[2] - end2[2]);
	}
	if (dabs(c__) < small) {
	    c__ = small;
	}
	d__ /= c__;
	if (dabs(d__) < small) {
	    d__ = small;
	}
	dxi = xdif / ydif;
	jy1 = i_nint(&y1);
	jy2 = i_nint(&y2);
	xi = x1 + dxi * ((real) jy1 - y1);
	dyy = (float)1. / dy;
	if (*ldash) {
	    dxii = (ndash1 - ndash2 - 1) * dxi;
	    i__2 = jy2;
	    i__1 = ndash1;
	    for (jj = jy1; i__1 < 0 ? jj >= i__2 : jj <= i__2; jj += i__1) {
/* Computing MIN */
		i__3 = jj + ndash2;
		jjj = min(i__3,jy2);
		yy = sftbuf_1.yblc - eye[2] + dyy * (real) (jj - 1);
		i__3 = jjj;
		for (j = jj; j <= i__3; ++j) {
		    k = sftbuf_1.nxp * (j - 1) + i_nint(&xi);
		    z__ = zw1 + (a * yy + b) / (yy + d__);
		    if (z__ > sftbuf_1.sbbuff[k - 1]) {
			sftbuf_1.sbbuff[k - 1] = z__;
			sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = colour;
		    }
		    xi += dxi;
		    yy += dyy;
/* L40: */
		}
		xi += dxii;
/* L50: */
	    }
	} else {
	    yy = sftbuf_1.yblc - eye[2] + dyy * (real) (jy1 - 1);
	    i__1 = jy2;
	    for (j = jy1; j <= i__1; ++j) {
		k = sftbuf_1.nxp * (j - 1) + i_nint(&xi);
		z__ = zw1 + (a * yy + b) / (yy + d__);
		if (z__ > sftbuf_1.sbbuff[k - 1]) {
		    sftbuf_1.sbbuff[k - 1] = z__;
		    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = colour;
		}
		xi += dxi;
		yy += dyy;
/* L60: */
	    }
	}
    }
} /* sbline_ */


/* Subroutine */ int sblin1_(eye, x, y, z__, xw, yw)
real *eye, *x, *y, *z__, *xw, *yw;
{
    static real xlam;

/*     ---------------------------------- */


    /* Parameter adjustments */
    --eye;

    /* Function Body */
    xlam = eye[3] / (eye[3] - *z__);
    *xw = eye[1] + xlam * (*x - eye[1]);
    *yw = eye[2] + xlam * (*y - eye[2]);
} /* sblin1_ */


/* Subroutine */ int sbplan_(eye, nv, vert, ic1, ic2, light)
real *eye;
integer *nv;
real *vert;
integer *ic1, *ic2;
real *light;
{
    /* System generated locals */
    integer i__1, i__2, i__3, i__4;
    real r__1, r__2, r__3;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static real xmin, ymin, xmax, ymax;
    static integer i__, j, k;
    static real gradl, z__, gradr, safer;
    static integer ileft;
    static real xdifl, small, ydifl, xdifr, ydifr;
    static integer istep, ixmin, jymin, ixmax, jymax, ivert, i1, j1, j2, i2, 
	    kstep;
    extern /* Subroutine */ int sblin1_();
    static real small2;
    static integer nc;
    static real ax, ay, az, bx, by, bz, dx, dy, yj, xl, xn, yn, zn, cosdif, 
	    xr, xi, yl, yr, xw[400], yw[400];
    static doublereal zz;
    static integer jbotom;
    static real eyenrm, colour;
    static doublereal xlnorm;
    static real tl2;
    static integer ix1;
    static real tn2;
    static integer ix2, jy1, jy2;
    static real dxi, ten, dyj, tnl;
    static doublereal dzz;
    static integer nvl1, nvl2, nvr1, nvr2;

/*     -------------------------------------------- */



/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      This subroutine plots a diffusively-lit coloured plane; the user */
/*    must ensure that all the verticies lie in a flat plane, and that */
/*    the bounding polygon be convex (so that the angle at any vertex */
/*    <= 180 degs). All (x,y,z) values are taken to be given in world */
/*    coordinates. The z-component of the eye-poisition should be */
/*    positive and that of the vertices should be negative; the viewing- */
/*    screen is fixed at z=0. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    EYE      R*4    I       3      (x,y,z) coordinate of eye-position. */
/*    NV       R*4    I       -      No. of verticies (>=3). */
/*    VERT     R*4    I     3 x NV   (x,y,z) coordinate of verticies. */
/*    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be */
/*                                   used for the shading. */
/*    LIGHT    R*4    I       3      (x,y,z) direction of flood-light. */

/* Globals */
/*    SFTBUF */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     SBLIN1     Calculates the projection of (x,y,z) on viewing screen. */

/* History */
/*   D. S. Sivia       4 Apr 1995  Initial release. */
/*   D. S. Sivia      24 Oct 1997 "Safe-guarded" some rounding errors. */
/* ----------------------------------------------------------------------- */

/* Carry out some initial checks and calculate the coordinates of the */
/* projected polygon. */

    /* Parameter adjustments */
    --light;
    vert -= 4;
    --eye;

    /* Function Body */
    small = (float)1e-10;
/* Computing 2nd power */
    r__1 = small;
    small2 = r__1 * r__1;
    if (eye[3] <= small) {
	return 0;
    }
    if (*nv < 3 || *nv > 400) {
	return 0;
    }
    i__1 = *nv;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L10: */
	if (vert[i__ * 3 + 3] >= (float)0.) {
	    return 0;
	}
    }
    xmin = (float)1e20;
    xmax = (float)-1e20;
    ymin = (float)1e20;
    ymax = (float)-1e20;
    i__1 = *nv;
    for (i__ = 1; i__ <= i__1; ++i__) {
	sblin1_(&eye[1], &vert[i__ * 3 + 1], &vert[i__ * 3 + 2], &vert[i__ * 
		3 + 3], &xw[i__ - 1], &yw[i__ - 1]);
	if (xw[i__ - 1] < xmin) {
	    xmin = xw[i__ - 1];
	    ileft = i__;
	}
	if (yw[i__ - 1] < ymin) {
	    ymin = yw[i__ - 1];
	    jbotom = i__;
	}
/* Computing MAX */
	r__1 = xw[i__ - 1];
	xmax = dmax(r__1,xmax);
/* Computing MAX */
	r__1 = yw[i__ - 1];
	ymax = dmax(r__1,ymax);
/* L20: */
    }
    if (xmin >= sftbuf_1.xtrc || xmax <= sftbuf_1.xblc) {
	return 0;
    }
    if (ymin >= sftbuf_1.ytrc || ymax <= sftbuf_1.yblc) {
	return 0;
    }

/* Find the outward normal seen by the eye, and activate the appropriate */
/* colour. */

    ax = vert[7] - vert[4];
    ay = vert[8] - vert[5];
    az = vert[9] - vert[6];
    bx = vert[4] - vert[*nv * 3 + 1];
    by = vert[5] - vert[*nv * 3 + 2];
    bz = vert[6] - vert[*nv * 3 + 3];
    xn = by * az - ay * bz;
    yn = bz * ax - az * bx;
    zn = bx * ay - ax * by;
    ten = xn * (eye[1] - vert[4]) + yn * (eye[2] - vert[5]) + zn * (eye[3] - 
	    vert[6]);
    colour = (real) (*ic1);
    nc = *ic2 - *ic1;
    if (nc > 0) {
	tnl = xn * light[1] + yn * light[2] + zn * light[3];
	if (ten < (float)0.) {
	    tnl = -tnl;
	}
	cosdif = (float)0.;
	if (tnl < (float)0.) {
/* Computing 2nd power */
	    r__1 = xn;
/* Computing 2nd power */
	    r__2 = yn;
/* Computing 2nd power */
	    r__3 = zn;
	    tn2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
/* Computing 2nd power */
	    r__1 = light[1];
/* Computing 2nd power */
	    r__2 = light[2];
/* Computing 2nd power */
	    r__3 = light[3];
	    tl2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
/* Computing MIN */
	    r__1 = -tnl / sqrt(tn2 * tl2 + small2);
	    cosdif = dmin(r__1,(float)1.);
	}
	colour += cosdif * (real) nc;
    }

/* Plot the projected polygon. */

    xlnorm = (doublereal) eye[3] * (doublereal) ten;
    eyenrm = xn * eye[1] + yn * eye[2] + zn * eye[3];
    dx = (real) (sftbuf_1.nxp - 1) / (sftbuf_1.xtrc - sftbuf_1.xblc);
    dy = (real) (sftbuf_1.nyp - 1) / (sftbuf_1.ytrc - sftbuf_1.yblc);
    dyj = (float)1. / dy;
    dxi = (float)1. / dx;
    safer = (float)1e-4;
    if (xmax - xmin > ymax - ymin) {
	jymin = (integer) ((ymin - sftbuf_1.yblc) * dy) + 2;
/* Computing MIN */
	i__1 = (integer) ((ymax - sftbuf_1.yblc) * dy) + 1;
	jymax = min(i__1,sftbuf_1.nyp);
	if (jymin > jymax) {
	    return 0;
	}
	yj = sftbuf_1.yblc + ((real) (jymin - 1) + safer) * dyj;
	nvl2 = jbotom;
	nvr2 = jbotom;
	j1 = jymin;
	i__1 = *nv;
	for (ivert = 1; ivert <= i__1; ++ivert) {
	    if (yj > yw[nvl2 - 1]) {
L1:
		nvl1 = nvl2;
		nvl2 = nvl1 - 1;
		if (nvl2 < 1) {
		    nvl2 = *nv;
		}
		if (nvl2 == jbotom) {
		    return 0;
		}
		if (yj > yw[nvl2 - 1]) {
		    goto L1;
		}
		ydifl = yw[nvl2 - 1] - yw[nvl1 - 1];
		if (dabs(ydifl) < small) {
		    ydifl = small;
		}
		gradl = (xw[nvl2 - 1] - xw[nvl1 - 1]) / ydifl;
	    }
	    if (yj > yw[nvr2 - 1]) {
L2:
		nvr1 = nvr2;
		nvr2 = nvr1 + 1;
		if (nvr2 > *nv) {
		    nvr2 = 1;
		}
		if (nvr2 == jbotom) {
		    return 0;
		}
		if (yj > yw[nvr2 - 1]) {
		    goto L2;
		}
		ydifr = yw[nvr2 - 1] - yw[nvr1 - 1];
		if (dabs(ydifr) < small) {
		    ydifr = small;
		}
		gradr = (xw[nvr2 - 1] - xw[nvr1 - 1]) / ydifr;
	    }
	    if (yw[nvl2 - 1] < yw[nvr2 - 1]) {
/* Computing MIN */
		i__2 = (integer) ((yw[nvl2 - 1] - sftbuf_1.yblc) * dy) + 1;
		j2 = min(i__2,jymax);
	    } else {
/* Computing MIN */
		i__2 = (integer) ((yw[nvr2 - 1] - sftbuf_1.yblc) * dy) + 1;
		j2 = min(i__2,jymax);
	    }
	    i__2 = j2;
	    for (j = j1; j <= i__2; ++j) {
		if (j >= 1) {
		    xl = xw[nvl1 - 1] + gradl * (yj - yw[nvl1 - 1]);
		    xr = xw[nvr1 - 1] + gradr * (yj - yw[nvr1 - 1]);
		    istep = 1;
/* Computing MAX */
		    i__3 = (integer) ((xl - sftbuf_1.xblc) * dx) + 2;
		    ix1 = max(i__3,1);
/* Computing MIN */
		    i__3 = (integer) ((xr - sftbuf_1.xblc) * dx) + 1;
		    ix2 = min(i__3,sftbuf_1.nxp);
		    if (ix1 > ix2) {
			istep = -1;
/* Computing MIN */
			i__3 = ix1 - 1;
			ix1 = min(i__3,sftbuf_1.nxp);
/* Computing MAX */
			i__3 = ix2 + 1;
			ix2 = max(i__3,1);
		    }
		    dzz = (doublereal) ((real) istep * dxi * xn);
		    zz = (doublereal) (eyenrm - (sftbuf_1.xblc + (real) (ix1 
			    - 1) * dxi) * xn - yj * yn);
		    k = (j - 1) * sftbuf_1.nxp + ix1;
		    i__3 = ix2;
		    i__4 = istep;
		    for (i__ = ix1; i__4 < 0 ? i__ >= i__3 : i__ <= i__3; i__ 
			    += i__4) {
			z__ = eye[3] - (real) (xlnorm / zz);
			if (z__ > sftbuf_1.sbbuff[k - 1]) {
			    sftbuf_1.sbbuff[k - 1] = z__;
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = colour;
			}
			zz -= dzz;
			k += istep;
/* L30: */
		    }
		}
		yj += dyj;
/* L40: */
	    }
	    j1 = j2 + 1;
	    if (j1 > jymax) {
		return 0;
	    }
/* L50: */
	}
    } else {
	ixmin = (integer) ((xmin - sftbuf_1.xblc) * dx) + 2;
/* Computing MIN */
	i__1 = (integer) ((xmax - sftbuf_1.xblc) * dx) + 1;
	ixmax = min(i__1,sftbuf_1.nxp);
	if (ixmin > ixmax) {
	    return 0;
	}
	xi = sftbuf_1.xblc + ((real) (ixmin - 1) + safer) * dxi;
	nvl2 = ileft;
	nvr2 = ileft;
	i1 = ixmin;
	i__1 = *nv;
	for (ivert = 1; ivert <= i__1; ++ivert) {
	    if (xi > xw[nvl2 - 1]) {
L3:
		nvl1 = nvl2;
		nvl2 = nvl1 - 1;
		if (nvl2 < 1) {
		    nvl2 = *nv;
		}
		if (nvl2 == ileft) {
		    return 0;
		}
		if (xi > xw[nvl2 - 1]) {
		    goto L3;
		}
		xdifl = xw[nvl2 - 1] - xw[nvl1 - 1];
		if (dabs(xdifl) < small) {
		    xdifl = small;
		}
		gradl = (yw[nvl2 - 1] - yw[nvl1 - 1]) / xdifl;
	    }
	    if (xi > xw[nvr2 - 1]) {
L4:
		nvr1 = nvr2;
		nvr2 = nvr1 + 1;
		if (nvr2 > *nv) {
		    nvr2 = 1;
		}
		if (nvr2 == ileft) {
		    return 0;
		}
		if (xi > xw[nvr2 - 1]) {
		    goto L4;
		}
		xdifr = xw[nvr2 - 1] - xw[nvr1 - 1];
		if (dabs(xdifr) < small) {
		    xdifr = small;
		}
		gradr = (yw[nvr2 - 1] - yw[nvr1 - 1]) / xdifr;
	    }
	    if (xw[nvl2 - 1] < xw[nvr2 - 1]) {
/* Computing MIN */
		i__2 = (integer) ((xw[nvl2 - 1] - sftbuf_1.xblc) * dx) + 1;
		i2 = min(i__2,ixmax);
	    } else {
/* Computing MIN */
		i__2 = (integer) ((xw[nvr2 - 1] - sftbuf_1.xblc) * dx) + 1;
		i2 = min(i__2,ixmax);
	    }
	    i__2 = i2;
	    for (i__ = i1; i__ <= i__2; ++i__) {
		if (i__ >= 1) {
		    yl = yw[nvl1 - 1] + gradl * (xi - xw[nvl1 - 1]);
		    yr = yw[nvr1 - 1] + gradr * (xi - xw[nvr1 - 1]);
		    istep = 1;
/* Computing MAX */
		    i__4 = (integer) ((yl - sftbuf_1.yblc) * dy) + 2;
		    jy1 = max(i__4,1);
/* Computing MIN */
		    i__4 = (integer) ((yr - sftbuf_1.yblc) * dy) + 1;
		    jy2 = min(i__4,sftbuf_1.nyp);
		    if (jy1 > jy2) {
			istep = -1;
/* Computing MIN */
			i__4 = jy1 - 1;
			jy1 = min(i__4,sftbuf_1.nyp);
/* Computing MAX */
			i__4 = jy2 + 1;
			jy2 = max(i__4,1);
		    }
		    dzz = (doublereal) ((real) istep * dyj * yn);
		    zz = (doublereal) (eyenrm - (sftbuf_1.yblc + (real) (jy1 
			    - 1) * dyj) * yn - xi * xn);
		    k = (jy1 - 1) * sftbuf_1.nxp + i__;
		    kstep = istep * sftbuf_1.nxp;
		    i__4 = jy2;
		    i__3 = istep;
		    for (j = jy1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
			     {
			z__ = eye[3] - (real) (xlnorm / zz);
			if (z__ > sftbuf_1.sbbuff[k - 1]) {
			    sftbuf_1.sbbuff[k - 1] = z__;
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = colour;
			}
			zz -= dzz;
			k += kstep;
/* L60: */
		    }
		}
		xi += dxi;
/* L70: */
	    }
	    i1 = i2 + 1;
	    if (i1 > ixmax) {
		return 0;
	    }
/* L80: */
	}
    }
} /* sbplan_ */


/* Subroutine */ int sbrod_(eye, end1, end2, radius, ic1, ic2, light, nsides, 
	lend)
real *eye, *end1, *end2, *radius;
integer *ic1, *ic2;
real *light;
integer *nsides;
logical *lend;
{
    /* Initialized data */

    static integer nrtmax = 361;
    static real pi = (float)3.141592654;
    static logical lstart = FALSE_;

    /* System generated locals */
    integer i__1;
    real r__1, r__2, r__3;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static real rxy2;
    static integer nrot;
    static logical lend1;
    static integer nrot0, i__, j;
    static real x, y, eyend, small, rleng, x0, y0, z0, rleng2;
    extern /* Subroutine */ int sbrod1_();
    static real xl, yl, zl, xn, yn, zn;
    extern /* Subroutine */ int sbline_(), sbplan_();
    static real cosphi;
    extern /* Subroutine */ int sbrcop_();
    static real sinphi, sclnrm, endvrt[1083]	/* was [3][361] */, costht, 
	    cosrot[361], sidvrt[12]	/* was [3][4] */, sintht, sinrot[361],
	     rxy, enn2;

/*     ---------------------------------------------------------------- */


    /* Parameter adjustments */
    --light;
    --end2;
    --end1;
    --eye;

    /* Function Body */

/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      This subroutine plots a diffusively-shaded coloured rod. All */
/*    (x,y,z) values are taken to be given in world coordinates. The */
/*    z-component of the eye-poisition should be positive and that of */
/*    the rod-ends should be negative (< -radius); the viewing-screen */
/*    is fixed at z=0. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    EYE      R*4    I       3      (x,y,z) coordinate of eye-position. */
/*    END1     R*4    I       3      (x,y,z) coordinate of rod-end 1. */
/*    END2     R*4    I       3      (x,y,z) coordinate of rod-end 2. */
/*    RADIUS   R*4    I       -      Radius of cylinderical rod. */
/*    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be */
/*                                   used for the shading. */
/*    LIGHT    R*4    I       3      (x,y,z) direction of flood-light. */
/*    NSIDES   I*4    I       -      The order of the polygon to be used */
/*                                   for the cross-section of the rod. */
/*    LEND     L*1    I       -      If true, plot the end of the rod. */

/* External Calls */
/*     SBLINE     Draws a straight line between two points. */
/*     SBPLAN     Plots a coloured plane. */
/*     SBROD1     Initialises the array of sines and coses, if necessary. */
/*     SBRCOP     Copies one real array to another. */

/* History */
/*   D. S. Sivia       4 Apr 1995  Initial release. */
/*   D. S. Sivia      22 Oct 1997  Increased NRTMAX from 73 to 361. */
/* ----------------------------------------------------------------------- */

/* Some initial checks. */

    if (*nsides <= 2) {
	sbline_(&eye[1], &end1[1], &end2[1], ic2, &c_false);
	return 0;
    }
    small = (float)1e-20;
    if (eye[3] <= (float)0.) {
	return 0;
    }
    if (*radius <= (float)0.) {
	return 0;
    }
    if (end1[3] > -(*radius) || end2[3] > -(*radius)) {
	return 0;
    }
    xl = end2[1] - end1[1];
    yl = end2[2] - end1[2];
    zl = end2[3] - end1[3];
/* Computing 2nd power */
    r__1 = xl;
/* Computing 2nd power */
    r__2 = yl;
/* Computing 2nd power */
    r__3 = zl;
    rleng2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
    if (rleng2 < small) {
	return 0;
    }

/* Find out which end of the rod, if any, can be seen. */

    lend1 = FALSE_;
    x0 = end1[1];
    y0 = end1[2];
    z0 = end1[3];
    eyend = xl * (eye[1] - x0) + yl * (eye[2] - y0) + zl * (eye[3] - z0);
    if (eyend < (float)0.) {
	lend1 = TRUE_;
    } else {
	x0 = end2[1];
	y0 = end2[2];
	z0 = end2[3];
	xl = -xl;
	yl = -yl;
	zl = -zl;
	eyend = xl * (eye[1] - x0) + yl * (eye[2] - y0) + zl * (eye[3] - z0);
	if (eyend < (float)0.) {
	    lend1 = TRUE_;
	}
    }
    sintht = (float)0.;
    costht = (float)1.;
    sinphi = (float)0.;
    cosphi = (float)1.;
/* Computing 2nd power */
    r__1 = xl;
/* Computing 2nd power */
    r__2 = yl;
    rxy2 = r__1 * r__1 + r__2 * r__2;
    if (rxy2 > small) {
	rleng = sqrt(rleng2);
	rxy = sqrt(rxy2);
	sintht = rxy / rleng;
	costht = -zl / rleng;
	sinphi = -yl / rxy;
	cosphi = -xl / rxy;
    }
    if (! (*lend)) {
	lend1 = FALSE_;
    }

/* Sweep around the rod and plot the shaded surface. */

/* Computing MIN */
    i__1 = *nsides + 1;
    nrot = min(i__1,nrtmax);
    sbrod1_(&lstart, &nrot0, &nrot, sinrot, cosrot, &pi, &sclnrm);
    i__1 = nrot;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x = *radius * cosrot[i__ - 1];
	y = *radius * sinrot[i__ - 1];
	endvrt[i__ * 3 - 3] = x0 + x * costht * cosphi - y * sinphi;
	endvrt[i__ * 3 - 2] = y0 + x * costht * sinphi + y * cosphi;
	endvrt[i__ * 3 - 1] = z0 - x * sintht;
/* L10: */
    }
    i__1 = nrot;
    for (j = 2; j <= i__1; ++j) {
	i__ = j - 1;
	xn = sclnrm * (endvrt[i__ * 3 - 3] + endvrt[j * 3 - 3] - x0 - x0);
	yn = sclnrm * (endvrt[i__ * 3 - 2] + endvrt[j * 3 - 2] - y0 - y0);
	zn = sclnrm * (endvrt[i__ * 3 - 1] + endvrt[j * 3 - 1] - z0 - z0);
	enn2 = (eye[1] - x0 - xn) * xn + (eye[2] - y0 - yn) * yn + (eye[3] - 
		z0 - zn) * zn;
	if (enn2 > (float)0.) {
	    sbrcop_(&endvrt[i__ * 3 - 3], sidvrt, &c__3);
	    sidvrt[3] = endvrt[i__ * 3 - 3] + xl;
	    sidvrt[4] = endvrt[i__ * 3 - 2] + yl;
	    sidvrt[5] = endvrt[i__ * 3 - 1] + zl;
	    sidvrt[6] = endvrt[j * 3 - 3] + xl;
	    sidvrt[7] = endvrt[j * 3 - 2] + yl;
	    sidvrt[8] = endvrt[j * 3 - 1] + zl;
	    sbrcop_(&endvrt[j * 3 - 3], &sidvrt[9], &c__3);
	    sbplan_(&eye[1], &c__4, sidvrt, ic1, ic2, &light[1]);
	}
/* L20: */
    }
    if (lend1) {
	i__1 = nrot - 1;
	sbplan_(&eye[1], &i__1, endvrt, ic1, ic2, &light[1]);
    }
} /* sbrod_ */


/* Subroutine */ int sbrod1_(lstart, nrot0, nrot, sinrot, cosrot, pi, sclnrm)
logical *lstart;
integer *nrot0, *nrot;
real *sinrot, *cosrot, *pi, *sclnrm;
{
    /* System generated locals */
    integer i__1;

    /* Builtin functions */
    double sin(), cos();

    /* Local variables */
    static real drot;
    static integer i__;
    static real rot;

/*     ------------------------------------------------------------ */


    /* Parameter adjustments */
    --cosrot;
    --sinrot;

    /* Function Body */
    if (*lstart && *nrot == *nrot0) {
	return 0;
    }
    rot = (float)0.;
    drot = *pi * (float)2. / (real) (*nrot - 1);
    i__1 = *nrot;
    for (i__ = 1; i__ <= i__1; ++i__) {
	sinrot[i__] = sin(rot);
	cosrot[i__] = cos(rot);
	rot += drot;
/* L10: */
    }
    *sclnrm = (float).5 / cos(drot / (float)2.);
    *lstart = TRUE_;
    *nrot0 = *nrot;
} /* sbrod1_ */


/* Subroutine */ int sbcone_(eye, base, apex, radius, ic1, ic2, light, nsides)
real *eye, *base, *apex, *radius;
integer *ic1, *ic2;
real *light;
integer *nsides;
{
    /* Initialized data */

    static integer nrtmax = 361;
    static real pi = (float)3.141592654;
    static logical lstart = FALSE_;

    /* System generated locals */
    integer i__1;
    real r__1, r__2, r__3;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static real rxy2;
    static integer nrot, nrot0, i__, j;
    static logical lbase;
    static real x, y, eyend, small, rleng, x0, y0, z0, rleng2;
    extern /* Subroutine */ int sbrod1_();
    static real xl, yl, zl;
    extern /* Subroutine */ int sbplan_();
    static real cosphi;
    extern /* Subroutine */ int sbrcop_();
    static real sinphi, sclnrm, basvrt[1083]	/* was [3][361] */, costht, 
	    cosrot[361], sidvrt[9]	/* was [3][3] */, sintht, sinrot[361],
	     rxy;

/*     ------------------------------------------------------------ */


    /* Parameter adjustments */
    --light;
    --apex;
    --base;
    --eye;

    /* Function Body */

/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      This subroutine plots a diffusively-shaded coloured right-angular */
/*    cone. All (x,y,z) values are taken to be given in world coordinates. */
/*    The z-component of the eye-poisition should be positive and that of */
/*    the base and appex of the cone should be negative (< -radius); the */
/*    viewing-screen is fixed at z=0. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    EYE      R*4    I       3      (x,y,z) coordinate of eye-position. */
/*    BASE     R*4    I       3      (x,y,z) coordinate of the centre of */
/*                                   the base of the cone. */
/*    APEX     R*4    I       3      (x,y,z) coordinate of the apex. */
/*    RADIUS   R*4    I       -      Radius of the base of the cone. */
/*    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be */
/*                                   used for the shading. */
/*    LIGHT    R*4    I       3      (x,y,z) direction of flood-light. */
/*    NSIDES   I*4    I       -      The order of the polygon to be used */
/*                                   for the cross-section of the cone. */

/* External Calls */
/*     SBLINE     Draws a straight line between two points. */
/*     SBPLAN     Plots a coloured plane. */
/*     SBROD1     Initialises the array of sines and coses, if necessary. */
/*     SBRCOP     Copies one real array to another. */

/* History */
/*   D. S. Sivia      29 Jun 1995  Initial release. */
/*   D. S. Sivia      22 Oct 1997  Increased NRTMAX from 73 to 361. */
/* ----------------------------------------------------------------------- */

/* Some initial checks. */

    small = (float)1e-20;
    if (*nsides <= 2) {
	return 0;
    }
    if (eye[3] <= (float)0.) {
	return 0;
    }
    if (*radius <= (float)0.) {
	return 0;
    }
    if (base[3] > -(*radius) || apex[3] >= (float)0.) {
	return 0;
    }
    xl = apex[1] - base[1];
    yl = apex[2] - base[2];
    zl = apex[3] - base[3];
/* Computing 2nd power */
    r__1 = xl;
/* Computing 2nd power */
    r__2 = yl;
/* Computing 2nd power */
    r__3 = zl;
    rleng2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
    if (rleng2 < small) {
	return 0;
    }

/* Find out whether the base of the cone can be seen. */

    lbase = FALSE_;
    x0 = base[1];
    y0 = base[2];
    z0 = base[3];
    eyend = xl * (eye[1] - x0) + yl * (eye[2] - y0) + zl * (eye[3] - z0);
    if (eyend < (float)0.) {
	lbase = TRUE_;
    }
    sintht = (float)0.;
    costht = (float)1.;
    sinphi = (float)0.;
    cosphi = (float)1.;
/* Computing 2nd power */
    r__1 = xl;
/* Computing 2nd power */
    r__2 = yl;
    rxy2 = r__1 * r__1 + r__2 * r__2;
    if (rxy2 > small) {
	rleng = sqrt(rleng2);
	rxy = sqrt(rxy2);
	sintht = rxy / rleng;
	costht = -zl / rleng;
	sinphi = -yl / rxy;
	cosphi = -xl / rxy;
    }

/* Sweep around the rod and plot the shaded surface. */

/* Computing MIN */
    i__1 = *nsides + 1;
    nrot = min(i__1,nrtmax);
    sbrod1_(&lstart, &nrot0, &nrot, sinrot, cosrot, &pi, &sclnrm);
    i__1 = nrot;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x = *radius * cosrot[i__ - 1];
	y = *radius * sinrot[i__ - 1];
	basvrt[i__ * 3 - 3] = x0 + x * costht * cosphi - y * sinphi;
	basvrt[i__ * 3 - 2] = y0 + x * costht * sinphi + y * cosphi;
	basvrt[i__ * 3 - 1] = z0 - x * sintht;
/* L10: */
    }
    if (lbase) {
	i__1 = nrot - 1;
	sbplan_(&eye[1], &i__1, basvrt, ic1, ic2, &light[1]);
    }
    sbrcop_(&apex[1], &sidvrt[6], &c__3);
    i__1 = nrot - 1;
    for (j = 1; j <= i__1; ++j) {
	sbrcop_(&basvrt[j * 3 - 3], sidvrt, &c__6);
	sbplan_(&eye[1], &c__3, sidvrt, ic1, ic2, &light[1]);
/* L20: */
    }
} /* sbcone_ */


/* Subroutine */ int sbslic_(eye, latice, dens, n1, n2, n3, dlow, dhigh, ic1, 
	ic2, slnorm, apoint, icedge)
real *eye, *latice, *dens;
integer *n1, *n2, *n3;
real *dlow, *dhigh;
integer *ic1, *ic2;
real *slnorm, *apoint;
integer *icedge;
{
    /* System generated locals */
    integer dens_dim1, dens_dim2, dens_offset, i__1, i__2, i__3, i__4;
    real r__1, r__2, r__3;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static real dcol, cscl, sdxi, sdyj, xmin, ymin, xmax, ymax, vert[36]	
	    /* was [3][12] */, snrm, mtrx[9]	/* was [3][3] */, bas2j;
    static integer i__, j, k, l;
    static real x, gradl, z__, y, gradr, safer;
    static integer ileft;
    static real xdifl, ydifl, small, xdifr, ydifr;
    static integer istep, ixmin, jymin, ixmax, jymax, ivert, i1, j1;
    static logical lvert[12];
    static integer nvert, j2, i2, kstep;
    extern /* Subroutine */ int sbslc1_(), sbslc2_(), sbslc3_();
    static real small2;
    static integer ii;
    static real dx, dy, xi, yj, xl, yl, xn, yn, zn, xr, xlamda, yr, xw[20], 
	    yw[20];
    static doublereal zz;
    static real zdline, detnrm, colnrm;
    static integer jbotom;
    static real eyenrm, cosnrm, colour;
    static doublereal xlnorm;
    static integer ix1, ix2, jy1, jy2;
    static real bas[9]	/* was [3][3] */, det, xae, yae, zae, dxi, dyj;
    static doublereal dzz;
    static real end1[3], end2[3], col0;
    static integer nvl1, nvl2, nvr1, nvr2;

/*     -------------------------------------------------------------- */



/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      This subroutine plots a "grey-scale" slice through a unit-cell */
/*    of density. All (x,y,z) values are taken to be given in world */
/*    coordinates. The z-component of the eye-poisition should be */
/*    positive and that of all the lattice-vertices should be negative; */
/*    the viewing-screen is fixed at z=0. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    EYE      R*4    I       3      (x,y,z) coordinate of eye-position. */
/*    LATICE   R*4    I     3 x 4    (x,y,z) coordinates of the origin */
/*                                   and the a, b & C lattice-vertices. */
/*    DENS     R*4    I     (N1+1)   The density at regular points within */
/*                        x (N2+1)   the unit cell, wrapped around so */
/*                        x (N3+1)   that DENS(0,J,K)=DENS(N1,J,K) etc.. */
/*    N1,N2,N3 I*4    I       -      The dimensions of the unit-cell grid. */
/*    DLOW     R*4    I       -      Density for the lowest colour-index. */
/*    DHIGH    R*4    I       -      Density for the highest colour-index. */
/*    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be */
/*                                   used for the shading. */
/*    SLNORM   R*4    I       3      (x,y,z) direction of the normal to */
/*                                   the slice to be "grey-scaled". */
/*    APONIT   R*4    I       3      (x,y,z) coordinate of a point within */
/*                                   the slice to be "grey-scaled". */
/*    ICEDGE   I*4    I       -      If >=0, it's the colour-index for the */
/*                                   boundary of the "grey-scaled" slice. */

/* Globals */
/*    SFTBUF */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     SBSLC1     Plots a side of the unit cell and sees if it is cut by */
/*                the slice to be "grey-scaled". */
/*     SBSLC2     Calculates the coordinates of the projected polygon. */
/*     SLSLC3     Calculates the appropriate colour for a given pixel. */
/*     SBLIN1     Calculates the projection of (x,y,z) on viewing screen. */

/* History */
/*   D. S. Sivia      30 Apr 1995  Initial release. */
/*   D. S. Sivia       7 Jul 1995  Fixed some bug. */
/*   D. S. Sivia      24 Oct 1997 "Safe-guarded" some rounding errors. */
/* ----------------------------------------------------------------------- */

/* Carry out some initial checks. */

    /* Parameter adjustments */
    --eye;
    latice -= 4;
    dens_dim1 = *n1 - 0 + 1;
    dens_dim2 = *n2 - 0 + 1;
    dens_offset = 0 + dens_dim1 * (0 + dens_dim2 * 0);
    dens -= dens_offset;
    --slnorm;
    --apoint;

    /* Function Body */
    small = (float)1e-10;
/* Computing 2nd power */
    r__1 = small;
    small2 = r__1 * r__1;
    if (eye[3] <= small) {
	return 0;
    }
    if (*n1 < 1 || *n2 < 1 || *n3 < 1) {
	return 0;
    }
/* Computing 2nd power */
    r__1 = slnorm[1];
/* Computing 2nd power */
    r__2 = slnorm[2];
/* Computing 2nd power */
    r__3 = slnorm[3];
    snrm = (float)1. / sqrt(r__1 * r__1 + r__2 * r__2 + r__3 * r__3 + small2);
    xn = slnorm[1] * snrm;
    yn = slnorm[2] * snrm;
    zn = slnorm[3] * snrm;
    xae = eye[1] - apoint[1];
    yae = eye[2] - apoint[2];
    zae = eye[3] - apoint[3];
    xlnorm = (doublereal) (xn * xae) + (doublereal) (yn * yae) + (doublereal) 
	    (zn * zae);
/* Computing 2nd power */
    r__1 = xae;
/* Computing 2nd power */
    r__2 = yae;
/* Computing 2nd power */
    r__3 = zae;
    cosnrm = (real) (xlnorm / sqrt((doublereal) (r__1 * r__1) + (doublereal) (
	    r__2 * r__2) + (doublereal) (r__3 * r__3) + (doublereal) small2));
    if (dabs(cosnrm) < (float).001) {
	return 0;
    }
    for (j = 1; j <= 3; ++j) {
	bas[j * 3 - 3] = latice[(j + 1) * 3 + 1] - latice[4];
	bas[j * 3 - 2] = latice[(j + 1) * 3 + 2] - latice[5];
	bas[j * 3 - 1] = latice[(j + 1) * 3 + 3] - latice[6];
/* Computing 2nd power */
	r__1 = bas[j * 3 - 3];
/* Computing 2nd power */
	r__2 = bas[j * 3 - 2];
/* Computing 2nd power */
	r__3 = bas[j * 3 - 1];
	bas2j = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
	if (bas2j < small2) {
	    return 0;
	}
/* L10: */
    }
    col0 = (real) (*ic1);
    cscl = (real) (*ic2 - *ic1);
    colnrm = *dhigh - *dlow;
    if (dabs(colnrm) < small) {
	return 0;
    }
    dcol = (float)1. / colnrm;

/* Set up matrix for real-space to lattice-index transformation. */

    det = bas[0] * bas[4] * bas[8] + bas[3] * bas[7] * bas[2] + bas[6] * bas[
	    1] * bas[5] - bas[2] * bas[4] * bas[6] - bas[5] * bas[7] * bas[0] 
	    - bas[8] * bas[1] * bas[3];
    if (dabs(det) < small2) {
	return 0;
    }
    detnrm = (float)1. / det;
    mtrx[0] = detnrm * (bas[4] * bas[8] - bas[7] * bas[5]);
    mtrx[3] = detnrm * (bas[7] * bas[2] - bas[1] * bas[8]);
    mtrx[6] = detnrm * (bas[1] * bas[5] - bas[4] * bas[2]);
    mtrx[1] = detnrm * (bas[5] * bas[6] - bas[8] * bas[3]);
    mtrx[4] = detnrm * (bas[8] * bas[0] - bas[2] * bas[6]);
    mtrx[7] = detnrm * (bas[2] * bas[3] - bas[5] * bas[0]);
    mtrx[2] = detnrm * (bas[3] * bas[7] - bas[6] * bas[4]);
    mtrx[5] = detnrm * (bas[6] * bas[1] - bas[0] * bas[7]);
    mtrx[8] = detnrm * (bas[0] * bas[4] - bas[3] * bas[1]);

/* Draw the frame of the unit cell and calculate the coordinates of the */
/* projected polygon. */

    nvert = 0;
    ii = 0;
    for (l = 1; l <= 12; l += 4) {
	i__ = ii + 2;
	j = (ii + 1) % 3 + 2;
	k = (ii + 2) % 3 + 2;
	sbslc1_(&latice[4], &latice[k * 3 + 1], &xn, &yn, &zn, &apoint[1], &
		lvert[l - 1], &vert[l * 3 - 3], &nvert);
	end1[0] = latice[i__ * 3 + 1] + latice[j * 3 + 1] - latice[4];
	end1[1] = latice[i__ * 3 + 2] + latice[j * 3 + 2] - latice[5];
	end1[2] = latice[i__ * 3 + 3] + latice[j * 3 + 3] - latice[6];
	sbslc1_(&latice[i__ * 3 + 1], end1, &xn, &yn, &zn, &apoint[1], &lvert[
		l], &vert[(l + 1) * 3 - 3], &nvert);
	sbslc1_(&latice[j * 3 + 1], end1, &xn, &yn, &zn, &apoint[1], &lvert[l 
		+ 1], &vert[(l + 2) * 3 - 3], &nvert);
	end2[0] = end1[0] + latice[k * 3 + 1] - latice[4];
	end2[1] = end1[1] + latice[k * 3 + 2] - latice[5];
	end2[2] = end1[2] + latice[k * 3 + 3] - latice[6];
	sbslc1_(end1, end2, &xn, &yn, &zn, &apoint[1], &lvert[l + 2], &vert[(
		l + 3) * 3 - 3], &nvert);
	++ii;
/* L20: */
    }
    if (nvert < 3) {
	return 0;
    }
    sbslc2_(&eye[1], lvert, vert, &nvert, &xn, &yn, &zn, xw, yw, icedge, &
	    zdline);

/* Paint the projected polygon slice. */

    xmin = (float)1e20;
    xmax = (float)-1e20;
    ymin = (float)1e20;
    ymax = (float)-1e20;
    i__1 = nvert;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (xw[i__ - 1] < xmin) {
	    xmin = xw[i__ - 1];
	    ileft = i__;
	}
	if (yw[i__ - 1] < ymin) {
	    ymin = yw[i__ - 1];
	    jbotom = i__;
	}
/* Computing MAX */
	r__1 = xw[i__ - 1];
	xmax = dmax(r__1,xmax);
/* Computing MAX */
	r__1 = yw[i__ - 1];
	ymax = dmax(r__1,ymax);
/* L30: */
    }
    if (xmin >= sftbuf_1.xtrc || xmax <= sftbuf_1.xblc) {
	return 0;
    }
    if (ymin >= sftbuf_1.ytrc || ymax <= sftbuf_1.yblc) {
	return 0;
    }

    eyenrm = xn * eye[1] + yn * eye[2] + zn * eye[3];
    dx = (real) (sftbuf_1.nxp - 1) / (sftbuf_1.xtrc - sftbuf_1.xblc);
    dy = (real) (sftbuf_1.nyp - 1) / (sftbuf_1.ytrc - sftbuf_1.yblc);
    dyj = (float)1. / dy;
    dxi = (float)1. / dx;
    safer = (float)1e-4;
    if (xmax - xmin > ymax - ymin) {
	jymin = (integer) ((ymin - sftbuf_1.yblc) * dy) + 2;
/* Computing MIN */
	i__1 = (integer) ((ymax - sftbuf_1.yblc) * dy) + 1;
	jymax = min(i__1,sftbuf_1.nyp);
	if (jymin > jymax) {
	    return 0;
	}
	yj = sftbuf_1.yblc + ((real) (jymin - 1) + safer) * dyj;
	nvl2 = jbotom;
	nvr2 = jbotom;
	j1 = jymin;
	i__1 = nvert;
	for (ivert = 1; ivert <= i__1; ++ivert) {
	    if (yj > yw[nvl2 - 1]) {
L1:
		nvl1 = nvl2;
		nvl2 = nvl1 - 1;
		if (nvl2 < 1) {
		    nvl2 = nvert;
		}
		if (nvl2 == jbotom) {
		    return 0;
		}
		if (yj > yw[nvl2 - 1]) {
		    goto L1;
		}
		ydifl = yw[nvl2 - 1] - yw[nvl1 - 1];
		if (dabs(ydifl) < small) {
		    ydifl = small;
		}
		gradl = (xw[nvl2 - 1] - xw[nvl1 - 1]) / ydifl;
	    }
	    if (yj > yw[nvr2 - 1]) {
L2:
		nvr1 = nvr2;
		nvr2 = nvr1 + 1;
		if (nvr2 > nvert) {
		    nvr2 = 1;
		}
		if (nvr2 == jbotom) {
		    return 0;
		}
		if (yj > yw[nvr2 - 1]) {
		    goto L2;
		}
		ydifr = yw[nvr2 - 1] - yw[nvr1 - 1];
		if (dabs(ydifr) < small) {
		    ydifr = small;
		}
		gradr = (xw[nvr2 - 1] - xw[nvr1 - 1]) / ydifr;
	    }
	    if (yw[nvl2 - 1] < yw[nvr2 - 1]) {
/* Computing MIN */
		i__2 = (integer) ((yw[nvl2 - 1] - sftbuf_1.yblc) * dy) + 1;
		j2 = min(i__2,jymax);
	    } else {
/* Computing MIN */
		i__2 = (integer) ((yw[nvr2 - 1] - sftbuf_1.yblc) * dy) + 1;
		j2 = min(i__2,jymax);
	    }
	    i__2 = j2;
	    for (j = j1; j <= i__2; ++j) {
		if (j >= 1) {
		    xl = xw[nvl1 - 1] + gradl * (yj - yw[nvl1 - 1]);
		    xr = xw[nvr1 - 1] + gradr * (yj - yw[nvr1 - 1]);
		    istep = 1;
/* Computing MAX */
		    i__3 = (integer) ((xl - sftbuf_1.xblc) * dx) + 2;
		    ix1 = max(i__3,1);
/* Computing MIN */
		    i__3 = (integer) ((xr - sftbuf_1.xblc) * dx) + 1;
		    ix2 = min(i__3,sftbuf_1.nxp);
		    if (ix1 > ix2) {
			istep = -1;
/* Computing MIN */
			i__3 = ix1 - 1;
			ix1 = min(i__3,sftbuf_1.nxp);
/* Computing MAX */
			i__3 = ix2 + 1;
			ix2 = max(i__3,1);
		    }
		    xi = sftbuf_1.xblc + (real) (ix1 - 1) * dxi;
		    sdxi = (real) istep * dxi;
		    dzz = (doublereal) (sdxi * xn);
		    zz = (doublereal) (eyenrm - xi * xn - yj * yn);
		    k = (j - 1) * sftbuf_1.nxp + ix1;
		    i__3 = ix2;
		    i__4 = istep;
		    for (i__ = ix1; i__4 < 0 ? i__ >= i__3 : i__ <= i__3; i__ 
			    += i__4) {
			xlamda = (real) (xlnorm / zz);
			z__ = eye[3] * ((float)1. - xlamda);
			if (z__ - sftbuf_1.sbbuff[k - 1] > zdline) {
			    sftbuf_1.sbbuff[k - 1] = z__;
			    x = eye[1] + xlamda * (xi - eye[1]) - latice[4];
			    y = eye[2] + xlamda * (yj - eye[2]) - latice[5];
			    z__ -= latice[6];
			    sbslc3_(&dens[dens_offset], n1, n2, n3, &x, &y, &
				    z__, mtrx, dlow, &dcol, &colour);
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = col0 + 
				    cscl * colour;
			}
			xi += sdxi;
			zz -= dzz;
			k += istep;
/* L40: */
		    }
		}
		yj += dyj;
/* L50: */
	    }
	    j1 = j2 + 1;
	    if (j1 > jymax) {
		return 0;
	    }
/* L60: */
	}
    } else {
	ixmin = (integer) ((xmin - sftbuf_1.xblc) * dx) + 2;
/* Computing MIN */
	i__1 = (integer) ((xmax - sftbuf_1.xblc) * dx) + 1;
	ixmax = min(i__1,sftbuf_1.nxp);
	if (ixmin > ixmax) {
	    return 0;
	}
	xi = sftbuf_1.xblc + ((real) (ixmin - 1) + safer) * dxi;
	nvl2 = ileft;
	nvr2 = ileft;
	i1 = ixmin;
	i__1 = nvert;
	for (ivert = 1; ivert <= i__1; ++ivert) {
	    if (xi > xw[nvl2 - 1]) {
L3:
		nvl1 = nvl2;
		nvl2 = nvl1 - 1;
		if (nvl2 < 1) {
		    nvl2 = nvert;
		}
		if (nvl2 == ileft) {
		    return 0;
		}
		if (xi > xw[nvl2 - 1]) {
		    goto L3;
		}
		xdifl = xw[nvl2 - 1] - xw[nvl1 - 1];
		if (dabs(xdifl) < small) {
		    xdifl = small;
		}
		gradl = (yw[nvl2 - 1] - yw[nvl1 - 1]) / xdifl;
	    }
	    if (xi > xw[nvr2 - 1]) {
L4:
		nvr1 = nvr2;
		nvr2 = nvr1 + 1;
		if (nvr2 > nvert) {
		    nvr2 = 1;
		}
		if (nvr2 == ileft) {
		    return 0;
		}
		if (xi > xw[nvr2 - 1]) {
		    goto L4;
		}
		xdifr = xw[nvr2 - 1] - xw[nvr1 - 1];
		if (dabs(xdifr) < small) {
		    xdifr = small;
		}
		gradr = (yw[nvr2 - 1] - yw[nvr1 - 1]) / xdifr;
	    }
	    if (xw[nvl2 - 1] < xw[nvr2 - 1]) {
/* Computing MIN */
		i__2 = (integer) ((xw[nvl2 - 1] - sftbuf_1.xblc) * dx) + 1;
		i2 = min(i__2,ixmax);
	    } else {
/* Computing MIN */
		i__2 = (integer) ((xw[nvr2 - 1] - sftbuf_1.xblc) * dx) + 1;
		i2 = min(i__2,ixmax);
	    }
	    i__2 = i2;
	    for (i__ = i1; i__ <= i__2; ++i__) {
		if (i__ >= 1) {
		    yl = yw[nvl1 - 1] + gradl * (xi - xw[nvl1 - 1]);
		    yr = yw[nvr1 - 1] + gradr * (xi - xw[nvr1 - 1]);
		    istep = 1;
/* Computing MAX */
		    i__4 = (integer) ((yl - sftbuf_1.yblc) * dy) + 2;
		    jy1 = max(i__4,1);
/* Computing MIN */
		    i__4 = (integer) ((yr - sftbuf_1.yblc) * dy) + 1;
		    jy2 = min(i__4,sftbuf_1.nyp);
		    if (jy1 > jy2) {
			istep = -1;
/* Computing MIN */
			i__4 = jy1 - 1;
			jy1 = min(i__4,sftbuf_1.nyp);
/* Computing MAX */
			i__4 = jy2 + 1;
			jy2 = max(i__4,1);
		    }
		    yj = sftbuf_1.yblc + (real) (jy1 - 1) * dyj;
		    sdyj = (real) istep * dyj;
		    dzz = (doublereal) (sdyj * yn);
		    zz = (doublereal) (eyenrm - yj * yn - xi * xn);
		    k = (jy1 - 1) * sftbuf_1.nxp + i__;
		    kstep = istep * sftbuf_1.nxp;
		    i__4 = jy2;
		    i__3 = istep;
		    for (j = jy1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
			     {
			xlamda = (real) (xlnorm / zz);
			z__ = eye[3] * ((float)1. - xlamda);
			if (z__ - sftbuf_1.sbbuff[k - 1] > zdline) {
			    sftbuf_1.sbbuff[k - 1] = z__;
			    x = eye[1] + xlamda * (xi - eye[1]) - latice[4];
			    y = eye[2] + xlamda * (yj - eye[2]) - latice[5];
			    z__ -= latice[6];
			    sbslc3_(&dens[dens_offset], n1, n2, n3, &x, &y, &
				    z__, mtrx, dlow, &dcol, &colour);
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = col0 + 
				    cscl * colour;
			}
			yj += sdyj;
			zz -= dzz;
			k += kstep;
/* L70: */
		    }
		}
		xi += dxi;
/* L80: */
	    }
	    i1 = i2 + 1;
	    if (i1 > ixmax) {
		return 0;
	    }
/* L90: */
	}
    }
} /* sbslic_ */


/* Subroutine */ int sbslc1_(end1, end2, xn, yn, zn, apoint, lvert, vert, 
	nvert)
real *end1, *end2, *xn, *yn, *zn, *apoint;
logical *lvert;
real *vert;
integer *nvert;
{
    /* System generated locals */
    real r__1, r__2, r__3;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static real xlam, denom, x12, y12, z12, cosnrm;

/*     ------------------------------------------------------------- */


    /* Parameter adjustments */
    --vert;
    --apoint;
    --end2;
    --end1;

    /* Function Body */
    *lvert = FALSE_;
    x12 = end2[1] - end1[1];
    y12 = end2[2] - end1[2];
    z12 = end2[3] - end1[3];
    denom = *xn * x12 + *yn * y12 + *zn * z12;
/* Computing 2nd power */
    r__1 = x12;
/* Computing 2nd power */
    r__2 = y12;
/* Computing 2nd power */
    r__3 = z12;
    cosnrm = denom / sqrt(r__1 * r__1 + r__2 * r__2 + r__3 * r__3 + (float)
	    1e-20);
    if (dabs(cosnrm) < (float).001) {
	return 0;
    }
    xlam = (*xn * (apoint[1] - end1[1]) + *yn * (apoint[2] - end1[2]) + *zn * 
	    (apoint[3] - end1[3])) / denom;
    if (xlam >= (float)0. && xlam <= (float)1.) {
	*lvert = TRUE_;
	++(*nvert);
	vert[1] = end1[1] + xlam * x12;
	vert[2] = end1[2] + xlam * y12;
	vert[3] = end1[3] + xlam * z12;
	if (vert[3] >= (float)0.) {
	    *nvert = -1000;
	}
    }
} /* sbslc1_ */


/* Subroutine */ int sbslc2_(eye, lvert, vert, nvert, xn, yn, zn, xw, yw, 
	icol, zdif)
real *eye;
logical *lvert;
real *vert;
integer *nvert;
real *xn, *yn, *zn, *xw, *yw;
integer *icol;
real *zdif;
{
    /* System generated locals */
    integer i__1;
    real r__1, r__2, r__3;

    /* Builtin functions */
    double sqrt(), atan2();

    /* Local variables */
    static real angj, xbar, ybar, zbar, xref, yref, zref, xvec, yvec, zvec, 
	    zmin, zmax, xnrm, ynrm, znrm;
    static integer i__, j, k;
    static real angle[12], x, y;
    static integer isort[12];
    extern /* Subroutine */ int sblin1_();
    static integer ii;
    extern /* Subroutine */ int sbline_();
    static real refnrm;
    static integer iv1;
    static real xwj, ywj;

/*     ---------------------------------------------------------------- */


    /* Parameter adjustments */
    --yw;
    --xw;
    vert -= 4;
    --lvert;
    --eye;

    /* Function Body */
    iv1 = 0;
    xbar = (float)0.;
    ybar = (float)0.;
    zbar = (float)0.;
    zmin = (float)1e20;
    zmax = (float)-1e20;
    for (k = 1; k <= 12; ++k) {
/* Computing MIN */
	r__1 = zmin, r__2 = vert[k * 3 + 3];
	zmin = dmin(r__1,r__2);
/* Computing MAX */
	r__1 = zmax, r__2 = vert[k * 3 + 3];
	zmax = dmax(r__1,r__2);
	if (lvert[k]) {
	    if (iv1 <= 0) {
		iv1 = k;
	    }
	    xbar += vert[k * 3 + 1];
	    ybar += vert[k * 3 + 2];
	    zbar += vert[k * 3 + 3];
	}
/* L10: */
    }
    *zdif = (zmax - zmin) / (float)5e3;
    xbar /= (real) (*nvert);
    ybar /= (real) (*nvert);
    zbar /= (real) (*nvert);
    xref = vert[iv1 * 3 + 1] - xbar;
    yref = vert[iv1 * 3 + 2] - ybar;
    zref = vert[iv1 * 3 + 3] - zbar;
/* Computing 2nd power */
    r__1 = xref;
/* Computing 2nd power */
    r__2 = yref;
/* Computing 2nd power */
    r__3 = zref;
    refnrm = (float)1. / sqrt(r__1 * r__1 + r__2 * r__2 + r__3 * r__3 + (
	    float)1e-20);
    xref *= refnrm;
    yref *= refnrm;
    zref *= refnrm;
    xnrm = yref * *zn - *yn * zref;
    ynrm = zref * *xn - *zn * xref;
    znrm = xref * *yn - *xn * yref;
    j = 1;
    angle[j - 1] = (float)0.;
    isort[j - 1] = iv1;
    sblin1_(&eye[1], &vert[iv1 * 3 + 1], &vert[iv1 * 3 + 2], &vert[iv1 * 3 + 
	    3], &xw[j], &yw[j]);
    for (k = iv1 + 1; k <= 12; ++k) {
	if (lvert[k]) {
	    ++j;
	    xvec = vert[k * 3 + 1] - xbar;
	    yvec = vert[k * 3 + 2] - ybar;
	    zvec = vert[k * 3 + 3] - zbar;
	    x = xvec * xref + yvec * yref + zvec * zref;
	    y = xvec * xnrm + yvec * ynrm + zvec * znrm;
	    angj = atan2(y, x);
	    sblin1_(&eye[1], &vert[k * 3 + 1], &vert[k * 3 + 2], &vert[k * 3 
		    + 3], &xwj, &ywj);
	    i__1 = j - 1;
	    for (i__ = 1; i__ <= i__1; ++i__) {
/* L20: */
		if (angj < angle[i__ - 1]) {
		    goto L1;
		}
	    }
L1:
	    ii = i__;
	    i__1 = ii + 1;
	    for (i__ = j; i__ >= i__1; --i__) {
		xw[i__] = xw[i__ - 1];
		yw[i__] = yw[i__ - 1];
		angle[i__ - 1] = angle[i__ - 2];
		isort[i__ - 1] = isort[i__ - 2];
/* L30: */
	    }
	    xw[ii] = xwj;
	    yw[ii] = ywj;
	    angle[ii - 1] = angj;
	    isort[ii - 1] = k;
	}
/* L40: */
    }
    if ((real) (*icol) >= (float)0.) {
	i__1 = *nvert - 1;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    j = isort[i__ - 1];
	    k = isort[i__];
	    sbline_(&eye[1], &vert[j * 3 + 1], &vert[k * 3 + 1], icol, &
		    c_false);
/* L50: */
	}
	sbline_(&eye[1], &vert[k * 3 + 1], &vert[isort[0] * 3 + 1], icol, &
		c_false);
    }
} /* sbslc2_ */


/* Subroutine */ int sbslc3_(dens, n1, n2, n3, x, y, z__, bas, dlow, dcol, 
	colour)
real *dens;
integer *n1, *n2, *n3;
real *x, *y, *z__, *bas, *dlow, *dcol, *colour;
{
    /* Initialized data */

    static real rmin = (float)1e-5;
    static real rmax = (float).99999;

    /* System generated locals */
    integer dens_dim1, dens_dim2, dens_offset;
    real r__1, r__2;

    /* Local variables */
    static integer i__, j, k;
    static real d1, d2;
    static integer ii, jj, kk;
    static real dx, dy, dz, xi, yj, zk;

/*     ----------------------------------------------------------- */

    /* Parameter adjustments */
    dens_dim1 = *n1 - 0 + 1;
    dens_dim2 = *n2 - 0 + 1;
    dens_offset = 0 + dens_dim1 * (0 + dens_dim2 * 0);
    dens -= dens_offset;
    bas -= 4;

    /* Function Body */

/* Computing MIN */
/* Computing MAX */
    r__2 = *x * bas[4] + *y * bas[5] + *z__ * bas[6];
    r__1 = dmax(r__2,rmin);
    xi = dmin(r__1,rmax) * (real) (*n1);
/* Computing MIN */
/* Computing MAX */
    r__2 = *x * bas[7] + *y * bas[8] + *z__ * bas[9];
    r__1 = dmax(r__2,rmin);
    yj = dmin(r__1,rmax) * (real) (*n2);
/* Computing MIN */
/* Computing MAX */
    r__2 = *x * bas[10] + *y * bas[11] + *z__ * bas[12];
    r__1 = dmax(r__2,rmin);
    zk = dmin(r__1,rmax) * (real) (*n3);
    i__ = (integer) xi;
    j = (integer) yj;
    k = (integer) zk;
    ii = i__ + 1;
    jj = j + 1;
    kk = k + 1;
    dx = xi - (real) i__;
    dy = yj - (real) j;
    dz = zk - (real) k;
    d1 = ((float)1. - dx) * (dens[i__ + (j + k * dens_dim2) * dens_dim1] + dy 
	    * (dens[i__ + (jj + k * dens_dim2) * dens_dim1] - dens[i__ + (j + 
	    k * dens_dim2) * dens_dim1])) + dx * (dens[ii + (j + k * 
	    dens_dim2) * dens_dim1] + dy * (dens[ii + (jj + k * dens_dim2) * 
	    dens_dim1] - dens[ii + (j + k * dens_dim2) * dens_dim1]));
    d2 = ((float)1. - dx) * (dens[i__ + (j + kk * dens_dim2) * dens_dim1] + 
	    dy * (dens[i__ + (jj + kk * dens_dim2) * dens_dim1] - dens[i__ + (
	    j + kk * dens_dim2) * dens_dim1])) + dx * (dens[ii + (j + kk * 
	    dens_dim2) * dens_dim1] + dy * (dens[ii + (jj + kk * dens_dim2) * 
	    dens_dim1] - dens[ii + (j + kk * dens_dim2) * dens_dim1]));
/* Computing MIN */
/* Computing MAX */
    r__2 = (d1 + dz * (d2 - d1) - *dlow) * *dcol;
    r__1 = dmax(r__2,rmin);
    *colour = dmin(r__1,rmax);
} /* sbslc3_ */


/* Subroutine */ int sbsurf_(eye, latice, dens, n1, n2, n3, dsurf, ic1, ic2, 
	light, lshine)
real *eye, *latice, *dens;
integer *n1, *n2, *n3;
real *dsurf;
integer *ic1, *ic2;
real *light;
logical *lshine;
{
    /* System generated locals */
    integer dens_dim1, dens_dim2, dens_offset, i__1, i__2, i__3;
    real r__1, r__2, r__3;
    doublereal d__1, d__2, d__3;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static real xyz1, xyz2, xyz3, deye, dnrm, zfar, vert[36]	/* was [3][12]
	     */;
    static integer ntot;
    static real dxyz[9]	/* was [3][3] */, bas2j;
    static integer iface, i__, j, k;
    static real small;
    static doublereal pneye[3];
    static integer isumf, ivert[8], j0, j1, i1, i0;
    static real ddxyz[72]	/* was [3][12][2] */;
    static integer k1, k0, isumv;
    static doublereal dsmal2;
    static real small2;
    extern /* Subroutine */ int sbsrf0_(), sbsrf1_(), sbsrf2_(), sbsrf3_(), 
	    sbsrf4_(), sbsrf5_();
    static integer kk, in, jn;
    static real dlocal[8];
    static integer ibside;
    static real xn, yn, zn, grdscl[3], cossee, ddsurf;
    extern /* Subroutine */ int sbrcop_();
    static real detnrm;
    static logical lempty;
    static doublereal xlnorm;
    static real frcxyz[12], xn1, xn2, xn3, bas[9]	/* was [3][3] */, det,
	     x00k, y00k, z00k, xyz[3], x0jk, y0jk, z0jk;

/*     --------------------------------------------------------------- */



/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      This subroutine plots an iso-surface through a unit-cell of */
/*    density. All (x,y,z) values are taken to be given in world */
/*    coordinates. The z-component of the eye-poisition should be */
/*    positive and that of all the lattice-vertices should be negative; */
/*    the viewing-screen is fixed at z=0. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    EYE      R*4    I       3      (x,y,z) coordinate of eye-position. */
/*    LATICE   R*4    I     3 x 4    (x,y,z) coordinates of the origin */
/*                                   and the a, b & C lattice-vertices. */
/*    DENS     R*4    I     (N1+1)   The density at regular points within */
/*                        x (N2+1)   the unit cell, wrapped around so */
/*                        x (N3+1)   that DENS(0,J,K)=DENS(N1,J,K) etc.. */
/*    N1,N2,N3 I*4    I       -      The dimensions of the unit-cell grid. */
/*    DSURF    R*4    I       -      Density for the iso-surface. */
/*    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be */
/*                                   used for the shading. */
/*    LIGHT    R*4    I       3      (x,y,z) direction of flood-light. */
/*    LSHINE   L*1    I       -      Shiny surface if TRUE, else diffuse. */

/* Globals */
/*    SFTBUF */
/*    SRFCOM */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     SBSRF0     A quick check in case there are no iso-surafces. */
/*     SBSRF1     Anlayses a 2-d box in the surface of the unit-cell. */
/*     SBSRF2     Paints a 2-d box in the surface of the unit-cell. */
/*     SBSRF3     Analyses a 3-d box within the unit-cell. */
/*     SBSRF4     Initialises the gradients for a 3-d box. */
/*     SBSRF5     Breaks up the iso-surface in a 3-d box into triangles. */
/*     SBSRF6     Paints a triangular patch of an iso-surface. */

/* History */
/*   D. S. Sivia       3 May 1995  Initial release. */
/*   D. S. Sivia       7 Jul 1995  Fixed bug in determinant calculation. */
/*   D. S. Sivia      20 Oct 1995  Speeded up computations slightly. */
/*   D. S. Sivia      13 Dec 1995  A bit more tinkering for speed. */
/*   D. S. Sivia      14 Jun 1996  Completely new algorithm! */
/*   D. S. Sivia      24 Oct 1997 "Safe-guarded" some rounding errors. */
/* ----------------------------------------------------------------------- */

/* Carry out some initial checks. */

    /* Parameter adjustments */
    --eye;
    latice -= 4;
    dens_dim1 = *n1 - 0 + 1;
    dens_dim2 = *n2 - 0 + 1;
    dens_offset = 0 + dens_dim1 * (0 + dens_dim2 * 0);
    dens -= dens_offset;
    --light;

    /* Function Body */
    small = (float)1e-10;
/* Computing 2nd power */
    r__1 = small;
    small2 = r__1 * r__1;
    dsmal2 = (doublereal) small2;
    if (eye[3] <= small) {
	return 0;
    }
    if (*n1 < 1 || *n2 < 1 || *n3 < 1) {
	return 0;
    }
/* Computing 2nd power */
    r__1 = light[1];
/* Computing 2nd power */
    r__2 = light[2];
/* Computing 2nd power */
    r__3 = light[3];
    srfcom_1.xl2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
    if (srfcom_1.xl2 < small) {
	return 0;
    }
    if (latice[6] >= (float)0.) {
	return 0;
    }
    zfar = latice[9] + latice[12] + latice[15] - latice[6] * (float)2.;
    if (zfar >= (float)0.) {
	return 0;
    }
    for (j = 1; j <= 3; ++j) {
	if (latice[(j + 1) * 3 + 3] >= (float)0.) {
	    return 0;
	}
	bas[j * 3 - 3] = latice[(j + 1) * 3 + 1] - latice[4];
	bas[j * 3 - 2] = latice[(j + 1) * 3 + 2] - latice[5];
	bas[j * 3 - 1] = latice[(j + 1) * 3 + 3] - latice[6];
	if (zfar - bas[j * 3 - 1] >= (float)0.) {
	    return 0;
	}
/* Computing 2nd power */
	r__1 = bas[j * 3 - 3];
/* Computing 2nd power */
	r__2 = bas[j * 3 - 2];
/* Computing 2nd power */
	r__3 = bas[j * 3 - 1];
	bas2j = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
	if (bas2j < small2) {
	    return 0;
	}
/* L10: */
    }
    ntot = (*n1 + 1) * (*n2 + 1) * (*n3 + 1);
    sbsrf0_(&dens[dens_offset], &ntot, dsurf, &lempty);
    if (lempty) {
	return 0;
    }

/* Set up matrix for real-space to lattice-index transformation. */

    xn1 = (real) (*n1) * (float).99999;
    xn2 = (real) (*n2) * (float).99999;
    xn3 = (real) (*n3) * (float).99999;
    det = bas[0] * bas[4] * bas[8] + bas[3] * bas[7] * bas[2] + bas[6] * bas[
	    1] * bas[5] - bas[2] * bas[4] * bas[6] - bas[5] * bas[7] * bas[0] 
	    - bas[8] * bas[1] * bas[3];
    if (dabs(det) < small2) {
	return 0;
    }
    detnrm = (float)1. / det;
    srfcom_1.mtrx[0] = xn1 * detnrm * (bas[4] * bas[8] - bas[7] * bas[5]);
    srfcom_1.mtrx[3] = xn2 * detnrm * (bas[7] * bas[2] - bas[1] * bas[8]);
    srfcom_1.mtrx[6] = xn3 * detnrm * (bas[1] * bas[5] - bas[4] * bas[2]);
    srfcom_1.mtrx[1] = xn1 * detnrm * (bas[5] * bas[6] - bas[8] * bas[3]);
    srfcom_1.mtrx[4] = xn2 * detnrm * (bas[8] * bas[0] - bas[2] * bas[6]);
    srfcom_1.mtrx[7] = xn3 * detnrm * (bas[2] * bas[3] - bas[5] * bas[0]);
    srfcom_1.mtrx[2] = xn1 * detnrm * (bas[3] * bas[7] - bas[6] * bas[4]);
    srfcom_1.mtrx[5] = xn2 * detnrm * (bas[6] * bas[1] - bas[0] * bas[7]);
    srfcom_1.mtrx[8] = xn3 * detnrm * (bas[0] * bas[4] - bas[3] * bas[1]);
    sbrcop_(&latice[4], srfcom_1.orig, &c__3);

/* Some general initialisations. */

/* Computing MAX */
    r__1 = dabs(*dsurf);
    ddsurf = dmax(r__1,small);
    if (*dsurf < (float)0.) {
	ddsurf = -ddsurf;
    }
    grdscl[0] = (float)-.5 / (ddsurf * (real) (*n1));
    grdscl[1] = (float)-.5 / (ddsurf * (real) (*n2));
    grdscl[2] = (float)-.5 / (ddsurf * (real) (*n3));
    srfcom_1.col0 = (real) (*ic1);
    srfcom_1.colscl = (real) (*ic2 - *ic1);
    for (i__ = 1; i__ <= 3; ++i__) {
	dxyz[i__ - 1] = bas[i__ - 1] / (real) (*n1);
	dxyz[i__ + 2] = bas[i__ + 2] / (real) (*n2);
	dxyz[i__ + 5] = bas[i__ + 5] / (real) (*n3);
	ddxyz[i__ - 1] = (float)0.;
	ddxyz[i__ + 35] = dxyz[i__ - 1];
	ddxyz[i__ + 2] = ddxyz[i__ - 1] + ddxyz[i__ + 35];
	ddxyz[i__ + 38] = dxyz[i__ + 2];
	ddxyz[i__ + 5] = ddxyz[i__ + 2] + ddxyz[i__ + 38];
	ddxyz[i__ + 41] = -dxyz[i__ - 1];
	ddxyz[i__ + 8] = ddxyz[i__ + 5] + ddxyz[i__ + 41];
	ddxyz[i__ + 44] = -dxyz[i__ + 2];
	for (j = 1; j <= 4; ++j) {
	    ddxyz[i__ + (j + 16) * 3 - 40] = ddxyz[i__ + (j + 12) * 3 - 40];
	    ddxyz[i__ + (j + 28) * 3 - 40] = dxyz[i__ + 5];
	    ddxyz[i__ + (j + 20) * 3 - 40] = ddxyz[i__ + (j + 12) * 3 - 40] + 
		    dxyz[i__ + 5];
	    ddxyz[i__ + (j + 32) * 3 - 40] = ddxyz[i__ + (j + 24) * 3 - 40];
/* L20: */
	}
/* L30: */
    }

/* First paint the edges of the lattice. */

    for (iface = 1; iface <= 3; ++iface) {
	i__ = iface;
	j = iface % 3 + 1;
	k = j % 3 + 1;
	if (iface == 1) {
	    in = *n1;
	    jn = *n2;
	} else if (iface == 2) {
	    in = *n2;
	    jn = *n3;
	} else {
	    in = *n3;
	    jn = *n1;
	}
	kk = 0;
	xn = bas[j * 3 - 2] * bas[i__ * 3 - 1] - bas[i__ * 3 - 2] * bas[j * 3 
		- 1];
	yn = bas[j * 3 - 1] * bas[i__ * 3 - 3] - bas[i__ * 3 - 1] * bas[j * 3 
		- 3];
	zn = bas[j * 3 - 3] * bas[i__ * 3 - 2] - bas[i__ * 3 - 3] * bas[j * 3 
		- 2];
/* Computing 2nd power */
	r__1 = xn;
/* Computing 2nd power */
	r__2 = yn;
/* Computing 2nd power */
	r__3 = zn;
	dnrm = sqrt(r__1 * r__1 + r__2 * r__2 + r__3 * r__3 + small2);
	pneye[0] = (doublereal) (eye[1] - (latice[(i__ + 1) * 3 + 1] + latice[
		(j + 1) * 3 + 1]) * (float).5);
	pneye[1] = (doublereal) (eye[2] - (latice[(i__ + 1) * 3 + 2] + latice[
		(j + 1) * 3 + 2]) * (float).5);
	pneye[2] = (doublereal) (eye[3] - (latice[(i__ + 1) * 3 + 3] + latice[
		(j + 1) * 3 + 3]) * (float).5);
/* Computing 2nd power */
	d__1 = pneye[0];
/* Computing 2nd power */
	d__2 = pneye[1];
/* Computing 2nd power */
	d__3 = pneye[2];
	deye = (real) sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3 + dsmal2);
	xlnorm = (doublereal) xn * pneye[0] + (doublereal) yn * pneye[1] + (
		doublereal) zn * pneye[2];
	cossee = (real) xlnorm / (deye * dnrm);
	if (cossee < (float).001) {
	    kk = *n3;
	    if (iface == 2) {
		kk = *n1;
	    }
	    if (iface == 3) {
		kk = *n2;
	    }
	    pneye[0] += (doublereal) bas[k * 3 - 3];
	    pneye[1] += (doublereal) bas[k * 3 - 2];
	    pneye[2] += (doublereal) bas[k * 3 - 1];
/* Computing 2nd power */
	    d__1 = pneye[0];
/* Computing 2nd power */
	    d__2 = pneye[1];
/* Computing 2nd power */
	    d__3 = pneye[2];
	    deye = (real) sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3 + 
		    dsmal2);
	    xlnorm = (doublereal) xn * pneye[0] + (doublereal) yn * pneye[1] 
		    + (doublereal) zn * pneye[2];
	    cossee = -((real) xlnorm) / (deye * dnrm);
	}
	if (cossee > (float).001) {
	    xyz1 = (real) kk * dxyz[k * 3 - 3] + latice[4];
	    xyz2 = (real) kk * dxyz[k * 3 - 2] + latice[5];
	    xyz3 = (real) kk * dxyz[k * 3 - 1] + latice[6];
	    i__1 = jn;
	    for (j1 = 1; j1 <= i__1; ++j1) {
		j0 = j1 - 1;
		i__2 = in;
		for (i1 = 1; i1 <= i__2; ++i1) {
		    i0 = i1 - 1;
		    if (iface == 1) {
			dlocal[0] = dens[i0 + (j0 + kk * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[1] = dens[i1 + (j0 + kk * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[2] = dens[i1 + (j1 + kk * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[3] = dens[i0 + (j1 + kk * dens_dim2) * 
				dens_dim1] - *dsurf;
		    } else if (iface == 2) {
			dlocal[0] = dens[kk + (i0 + j0 * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[1] = dens[kk + (i1 + j0 * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[2] = dens[kk + (i1 + j1 * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[3] = dens[kk + (i0 + j1 * dens_dim2) * 
				dens_dim1] - *dsurf;
		    } else {
			dlocal[0] = dens[j0 + (kk + i0 * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[1] = dens[j0 + (kk + i1 * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[2] = dens[j1 + (kk + i1 * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[3] = dens[j1 + (kk + i0 * dens_dim2) * 
				dens_dim1] - *dsurf;
		    }
		    sbsrf1_(dlocal, &ibside, frcxyz);
		    if (ibside != 0) {
			xyz[0] = xyz1 + dxyz[i__ * 3 - 3] * (real) i0;
			xyz[1] = xyz2 + dxyz[i__ * 3 - 2] * (real) i0;
			xyz[2] = xyz3 + dxyz[i__ * 3 - 1] * (real) i0;
			sbsrf2_(xyz, &dxyz[i__ * 3 - 3], &dxyz[j * 3 - 3], &
				ibside, frcxyz, vert, &eye[1], &light[1], 
				lshine);
		    }
/* L40: */
		}
		xyz1 += dxyz[j * 3 - 3];
		xyz2 += dxyz[j * 3 - 2];
		xyz3 += dxyz[j * 3 - 1];
/* L50: */
	    }
	}
/* L60: */
    }

/* Step through each "cube" in the lattice, and paint any isosurfaces */
/* found therein. */

    x00k = latice[4];
    y00k = latice[5];
    z00k = latice[6];
    i__1 = *n3;
    for (k1 = 1; k1 <= i__1; ++k1) {
	k0 = k1 - 1;
	i__2 = *n2;
	for (j1 = 1; j1 <= i__2; ++j1) {
	    j0 = j1 - 1;
	    x0jk = x00k + dxyz[3] * (real) j0;
	    y0jk = y00k + dxyz[4] * (real) j0;
	    z0jk = z00k + dxyz[5] * (real) j0;
	    i__3 = *n1;
	    for (i1 = 1; i1 <= i__3; ++i1) {
		i0 = i1 - 1;
		dlocal[0] = dens[i0 + (j0 + k0 * dens_dim2) * dens_dim1] - *
			dsurf;
		dlocal[1] = dens[i1 + (j0 + k0 * dens_dim2) * dens_dim1] - *
			dsurf;
		dlocal[2] = dens[i1 + (j1 + k0 * dens_dim2) * dens_dim1] - *
			dsurf;
		dlocal[3] = dens[i0 + (j1 + k0 * dens_dim2) * dens_dim1] - *
			dsurf;
		dlocal[4] = dens[i0 + (j0 + k1 * dens_dim2) * dens_dim1] - *
			dsurf;
		dlocal[5] = dens[i1 + (j0 + k1 * dens_dim2) * dens_dim1] - *
			dsurf;
		dlocal[6] = dens[i1 + (j1 + k1 * dens_dim2) * dens_dim1] - *
			dsurf;
		dlocal[7] = dens[i0 + (j1 + k1 * dens_dim2) * dens_dim1] - *
			dsurf;
		sbsrf3_(dlocal, ivert, frcxyz, &isumv, &isumf);
		if (isumv != 0) {
		    xyz[0] = x0jk + dxyz[0] * (real) i0;
		    xyz[1] = y0jk + dxyz[1] * (real) i0;
		    xyz[2] = z0jk + dxyz[2] * (real) i0;
		    sbsrf4_(&dens[dens_offset], n1, n2, n3, &i0, &j0, &k0, 
			    grdscl, bas, srfcom_1.grdcub);
		    sbsrf5_(xyz, ddxyz, &isumv, &isumf, ivert, frcxyz, vert, &
			    eye[1], &light[1], lshine);
		}
/* L70: */
	    }
/* L80: */
	}
	x00k += dxyz[6];
	y00k += dxyz[7];
	z00k += dxyz[8];
/* L90: */
    }
} /* sbsurf_ */


/* Subroutine */ int sbsrf0_(dens, ntot, dsurf, lempty)
real *dens;
integer *ntot;
real *dsurf;
logical *lempty;
{
    /* System generated locals */
    integer i__1;

    /* Local variables */
    static integer i__;

/*     ----------------------------------------- */


    /* Parameter adjustments */
    --dens;

    /* Function Body */
    *lempty = TRUE_;
    i__1 = *ntot;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (dens[i__] > *dsurf) {
	    *lempty = FALSE_;
	    return 0;
	}
/* L10: */
    }
} /* sbsrf0_ */


/* Subroutine */ int sbsrf1_(d__, ib, df)
real *d__;
integer *ib;
real *df;
{
    /* Initialized data */

    static real small = (float)1e-20;

    /* System generated locals */
    real r__1;

    /* Local variables */
    static integer i__, j;
    static real di;

/*     -------------------------- */

    /* Parameter adjustments */
    --df;
    --d__;

    /* Function Body */

    *ib = 0;
    if (d__[1] >= (float)0.) {
	*ib = 1;
    }
    if (d__[2] >= (float)0.) {
	*ib += 2;
    }
    if (d__[3] >= (float)0.) {
	*ib += 4;
    }
    if (d__[4] >= (float)0.) {
	*ib += 8;
    }
    if (*ib == 0 || *ib == 15) {
	return 0;
    }
    for (i__ = 1; i__ <= 4; ++i__) {
	j = i__ % 4 + 1;
	if (d__[i__] * d__[j] < -small) {
	    di = (r__1 = d__[i__], dabs(r__1));
	    df[i__] = di / (di + (r__1 = d__[j], dabs(r__1)));
	}
/* L10: */
    }
} /* sbsrf1_ */


/* Subroutine */ int sbsrf2_(xyz, d1, d2, ib, frc, vert, eye, light, lshine)
real *xyz, *d1, *d2;
integer *ib;
real *frc, *vert, *eye, *light;
logical *lshine;
{
    static integer i__;
    extern /* Subroutine */ int sbsrf6_();

/*     --------------------------------------------------------- */


    /* Parameter adjustments */
    --light;
    --eye;
    vert -= 4;
    --frc;
    --d2;
    --d1;
    --xyz;

    /* Function Body */
    if (*ib == 15) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__];
	    vert[i__ + 6] = xyz[i__] + d1[i__];
	    vert[i__ + 9] = vert[i__ + 6] + d2[i__];
	    vert[i__ + 12] = xyz[i__] + d2[i__];
/* L10: */
	}
	sbsrf6_(&eye[1], &c__4, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 1) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__];
	    vert[i__ + 6] = vert[i__ + 3] + frc[1] * d1[i__];
	    vert[i__ + 9] = xyz[i__] + ((float)1. - frc[4]) * d2[i__];
/* L20: */
	}
	sbsrf6_(&eye[1], &c__3, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 2) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d1[i__];
	    vert[i__ + 6] = vert[i__ + 3] + frc[2] * d2[i__];
	    vert[i__ + 9] = xyz[i__] + frc[1] * d1[i__];
/* L30: */
	}
	sbsrf6_(&eye[1], &c__3, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 4) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d1[i__] + d2[i__];
	    vert[i__ + 6] = vert[i__ + 3] - frc[3] * d1[i__];
	    vert[i__ + 9] = vert[i__ + 3] - ((float)1. - frc[2]) * d2[i__];
/* L40: */
	}
	sbsrf6_(&eye[1], &c__3, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 8) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d2[i__];
	    vert[i__ + 6] = vert[i__ + 3] - frc[4] * d2[i__];
	    vert[i__ + 9] = vert[i__ + 3] + ((float)1. - frc[3]) * d1[i__];
/* L50: */
	}
	sbsrf6_(&eye[1], &c__3, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 7) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__];
	    vert[i__ + 6] = vert[i__ + 3] + d1[i__];
	    vert[i__ + 9] = vert[i__ + 6] + d2[i__];
	    vert[i__ + 12] = vert[i__ + 9] - frc[3] * d1[i__];
	    vert[i__ + 15] = xyz[i__] + ((float)1. - frc[4]) * d2[i__];
/* L60: */
	}
	sbsrf6_(&eye[1], &c__5, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 14) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d1[i__];
	    vert[i__ + 6] = vert[i__ + 3] + d2[i__];
	    vert[i__ + 9] = xyz[i__] + d2[i__];
	    vert[i__ + 12] = xyz[i__] + ((float)1. - frc[4]) * d2[i__];
	    vert[i__ + 15] = xyz[i__] + frc[1] * d1[i__];
/* L70: */
	}
	sbsrf6_(&eye[1], &c__5, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 13) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d1[i__] + d2[i__];
	    vert[i__ + 6] = xyz[i__] + d2[i__];
	    vert[i__ + 9] = xyz[i__];
	    vert[i__ + 12] = xyz[i__] + frc[1] * d1[i__];
	    vert[i__ + 15] = xyz[i__] + d1[i__] + frc[2] * d2[i__];
/* L80: */
	}
	sbsrf6_(&eye[1], &c__5, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 11) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d2[i__];
	    vert[i__ + 6] = xyz[i__];
	    vert[i__ + 9] = xyz[i__] + d1[i__];
	    vert[i__ + 12] = vert[i__ + 9] + frc[2] * d2[i__];
	    vert[i__ + 15] = vert[i__ + 3] + ((float)1. - frc[3]) * d1[i__];
/* L90: */
	}
	sbsrf6_(&eye[1], &c__5, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 3) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__];
	    vert[i__ + 6] = xyz[i__] + d1[i__];
	    vert[i__ + 9] = vert[i__ + 6] + frc[2] * d2[i__];
	    vert[i__ + 12] = xyz[i__] + ((float)1. - frc[4]) * d2[i__];
/* L100: */
	}
	sbsrf6_(&eye[1], &c__4, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 6) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d1[i__];
	    vert[i__ + 6] = vert[i__ + 3] + d2[i__];
	    vert[i__ + 9] = vert[i__ + 6] - frc[3] * d1[i__];
	    vert[i__ + 12] = xyz[i__] + frc[1] * d1[i__];
/* L110: */
	}
	sbsrf6_(&eye[1], &c__4, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 12) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d1[i__] + d2[i__];
	    vert[i__ + 6] = xyz[i__] + d2[i__];
	    vert[i__ + 9] = vert[i__ + 6] - frc[4] * d2[i__];
	    vert[i__ + 12] = xyz[i__] + d1[i__] + frc[2] * d2[i__];
/* L120: */
	}
	sbsrf6_(&eye[1], &c__4, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 9) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d2[i__];
	    vert[i__ + 6] = xyz[i__];
	    vert[i__ + 9] = xyz[i__] + frc[1] * d1[i__];
	    vert[i__ + 12] = vert[i__ + 3] + ((float)1. - frc[3]) * d1[i__];
/* L130: */
	}
	sbsrf6_(&eye[1], &c__4, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 5) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__];
	    vert[i__ + 6] = vert[i__ + 3] + frc[1] * d1[i__];
	    vert[i__ + 9] = xyz[i__] + ((float)1. - frc[4]) * d2[i__];
	    vert[i__ + 12] = xyz[i__] + d1[i__] + d2[i__];
	    vert[i__ + 15] = vert[i__ + 12] - frc[3] * d1[i__];
	    vert[i__ + 18] = vert[i__ + 12] - ((float)1. - frc[2]) * d2[i__];
/* L140: */
	}
	sbsrf6_(&eye[1], &c__3, &vert[4], lshine, &light[1], &c__0);
	sbsrf6_(&eye[1], &c__3, &vert[13], lshine, &light[1], &c__0);
    } else if (*ib == 10) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d1[i__];
	    vert[i__ + 6] = vert[i__ + 3] + frc[2] * d2[i__];
	    vert[i__ + 9] = xyz[i__] + frc[1] * d1[i__];
	    vert[i__ + 12] = xyz[i__] + d2[i__];
	    vert[i__ + 15] = vert[i__ + 12] - frc[4] * d2[i__];
	    vert[i__ + 18] = vert[i__ + 12] + ((float)1. - frc[3]) * d1[i__];
/* L150: */
	}
	sbsrf6_(&eye[1], &c__3, &vert[4], lshine, &light[1], &c__0);
	sbsrf6_(&eye[1], &c__3, &vert[13], lshine, &light[1], &c__0);
    }
} /* sbsrf2_ */


/* Subroutine */ int sbsrf3_(d__, ivert, df, isumv, isumf)
real *d__;
integer *ivert;
real *df;
integer *isumv, *isumf;
{
    /* Initialized data */

    static real small = (float)1e-20;

    /* System generated locals */
    real r__1;

    /* Local variables */
    static integer i__, j, k, l, ic[8];
    static real di, dk;

/*     ----------------------------------------- */

    /* Parameter adjustments */
    --df;
    --ivert;
    --d__;

    /* Function Body */

    *isumv = 0;
    for (i__ = 1; i__ <= 8; ++i__) {
	if (d__[i__] < (float)0.) {
	    ic[i__ - 1] = 0;
	} else {
	    ic[i__ - 1] = 1;
	    ++(*isumv);
	}
/* L10: */
    }
    if (*isumv == 0 || *isumv == 8) {
	*isumv = 0;
	return 0;
    }
    if (*isumv > 4) {
	*isumv = 8 - *isumv;
	for (i__ = 1; i__ <= 8; ++i__) {
/* L20: */
	    ic[i__ - 1] = (ic[i__ - 1] + 1) % 2;
	}
    }
    j = 0;
    for (i__ = 1; i__ <= 8; ++i__) {
	if (ic[i__ - 1] == 1) {
	    ++j;
	    ivert[j] = i__;
	}
/* L30: */
    }
    *isumf = 0;
    for (i__ = 1; i__ <= 4; ++i__) {
	j = i__ % 4 + 1;
	if (d__[i__] * d__[j] < -small) {
	    di = (r__1 = d__[i__], dabs(r__1));
	    df[i__] = di / (di + (r__1 = d__[j], dabs(r__1)));
	    ++(*isumf);
	}
	k = i__ + 4;
	if (d__[i__] * d__[k] < -small) {
	    di = (r__1 = d__[i__], dabs(r__1));
	    df[k] = di / (di + (r__1 = d__[k], dabs(r__1)));
	    ++(*isumf);
	}
	l = j + 4;
	if (d__[k] * d__[l] < -small) {
	    dk = (r__1 = d__[k], dabs(r__1));
	    df[i__ + 8] = dk / (dk + (r__1 = d__[l], dabs(r__1)));
	    ++(*isumf);
	}
/* L40: */
    }
} /* sbsrf3_ */


/* Subroutine */ int sbsrf4_(dens, n1, n2, n3, i0, j0, k0, grdscl, bas, grd)
real *dens;
integer *n1, *n2, *n3, *i0, *j0, *k0;
real *grdscl, *bas, *grd;
{
    /* System generated locals */
    integer dens_dim1, dens_dim2, dens_offset;

    /* Local variables */
    static real g[24]	/* was [3][8] */;
    static integer i__, j, i1, j1, k1, im, jm, km, ip, jp, kp;

/*     -------------------------------------------------------- */


    /* Parameter adjustments */
    dens_dim1 = *n1 - 0 + 1;
    dens_dim2 = *n2 - 0 + 1;
    dens_offset = 0 + dens_dim1 * (0 + dens_dim2 * 0);
    dens -= dens_offset;
    --grdscl;
    bas -= 4;
    grd -= 4;

    /* Function Body */
    im = *i0 - 1;
    if (im < 0) {
	im = *n1;
    }
    jm = *j0 - 1;
    if (jm < 0) {
	jm = *n2;
    }
    km = *k0 - 1;
    if (km < 0) {
	km = *n3;
    }
    i1 = *i0 + 1;
    j1 = *j0 + 1;
    k1 = *k0 + 1;
    ip = i1 + 1;
    if (ip > *n1) {
	ip = 0;
    }
    jp = j1 + 1;
    if (jp > *n2) {
	jp = 0;
    }
    kp = k1 + 1;
    if (kp > *n3) {
	kp = 0;
    }
    g[0] = grdscl[1] * (dens[i1 + (*j0 + *k0 * dens_dim2) * dens_dim1] - dens[
	    im + (*j0 + *k0 * dens_dim2) * dens_dim1]);
    g[1] = grdscl[2] * (dens[*i0 + (j1 + *k0 * dens_dim2) * dens_dim1] - dens[
	    *i0 + (jm + *k0 * dens_dim2) * dens_dim1]);
    g[2] = grdscl[3] * (dens[*i0 + (*j0 + k1 * dens_dim2) * dens_dim1] - dens[
	    *i0 + (*j0 + km * dens_dim2) * dens_dim1]);
    g[3] = grdscl[1] * (dens[ip + (*j0 + *k0 * dens_dim2) * dens_dim1] - dens[
	    *i0 + (*j0 + *k0 * dens_dim2) * dens_dim1]);
    g[4] = grdscl[2] * (dens[i1 + (j1 + *k0 * dens_dim2) * dens_dim1] - dens[
	    i1 + (jm + *k0 * dens_dim2) * dens_dim1]);
    g[5] = grdscl[3] * (dens[i1 + (*j0 + k1 * dens_dim2) * dens_dim1] - dens[
	    i1 + (*j0 + km * dens_dim2) * dens_dim1]);
    g[6] = grdscl[1] * (dens[ip + (j1 + *k0 * dens_dim2) * dens_dim1] - dens[*
	    i0 + (j1 + *k0 * dens_dim2) * dens_dim1]);
    g[7] = grdscl[2] * (dens[i1 + (jp + *k0 * dens_dim2) * dens_dim1] - dens[
	    i1 + (*j0 + *k0 * dens_dim2) * dens_dim1]);
    g[8] = grdscl[3] * (dens[i1 + (j1 + k1 * dens_dim2) * dens_dim1] - dens[
	    i1 + (j1 + km * dens_dim2) * dens_dim1]);
    g[9] = grdscl[1] * (dens[i1 + (j1 + *k0 * dens_dim2) * dens_dim1] - dens[
	    im + (j1 + *k0 * dens_dim2) * dens_dim1]);
    g[10] = grdscl[2] * (dens[*i0 + (jp + *k0 * dens_dim2) * dens_dim1] - 
	    dens[*i0 + (*j0 + *k0 * dens_dim2) * dens_dim1]);
    g[11] = grdscl[3] * (dens[*i0 + (j1 + k1 * dens_dim2) * dens_dim1] - dens[
	    *i0 + (j1 + km * dens_dim2) * dens_dim1]);
    g[12] = grdscl[1] * (dens[i1 + (*j0 + k1 * dens_dim2) * dens_dim1] - dens[
	    im + (*j0 + k1 * dens_dim2) * dens_dim1]);
    g[13] = grdscl[2] * (dens[*i0 + (j1 + k1 * dens_dim2) * dens_dim1] - dens[
	    *i0 + (jm + k1 * dens_dim2) * dens_dim1]);
    g[14] = grdscl[3] * (dens[*i0 + (*j0 + kp * dens_dim2) * dens_dim1] - 
	    dens[*i0 + (*j0 + *k0 * dens_dim2) * dens_dim1]);
    g[15] = grdscl[1] * (dens[ip + (*j0 + k1 * dens_dim2) * dens_dim1] - dens[
	    *i0 + (*j0 + k1 * dens_dim2) * dens_dim1]);
    g[16] = grdscl[2] * (dens[i1 + (j1 + k1 * dens_dim2) * dens_dim1] - dens[
	    i1 + (jm + k1 * dens_dim2) * dens_dim1]);
    g[17] = grdscl[3] * (dens[i1 + (*j0 + kp * dens_dim2) * dens_dim1] - dens[
	    i1 + (*j0 + *k0 * dens_dim2) * dens_dim1]);
    g[18] = grdscl[1] * (dens[ip + (j1 + k1 * dens_dim2) * dens_dim1] - dens[*
	    i0 + (j1 + k1 * dens_dim2) * dens_dim1]);
    g[19] = grdscl[2] * (dens[i1 + (jp + k1 * dens_dim2) * dens_dim1] - dens[
	    i1 + (*j0 + k1 * dens_dim2) * dens_dim1]);
    g[20] = grdscl[3] * (dens[i1 + (j1 + kp * dens_dim2) * dens_dim1] - dens[
	    i1 + (j1 + *k0 * dens_dim2) * dens_dim1]);
    g[21] = grdscl[1] * (dens[i1 + (j1 + k1 * dens_dim2) * dens_dim1] - dens[
	    im + (j1 + k1 * dens_dim2) * dens_dim1]);
    g[22] = grdscl[2] * (dens[*i0 + (jp + k1 * dens_dim2) * dens_dim1] - dens[
	    *i0 + (*j0 + k1 * dens_dim2) * dens_dim1]);
    g[23] = grdscl[3] * (dens[*i0 + (j1 + kp * dens_dim2) * dens_dim1] - dens[
	    *i0 + (j1 + *k0 * dens_dim2) * dens_dim1]);
    for (j = 1; j <= 8; ++j) {
	for (i__ = 1; i__ <= 3; ++i__) {
/* L10: */
	    grd[i__ + j * 3] = g[j * 3 - 3] * bas[i__ + 3] + g[j * 3 - 2] * 
		    bas[i__ + 6] + g[j * 3 - 1] * bas[i__ + 9];
	}
/* L20: */
    }
} /* sbsrf4_ */


/* Subroutine */ int sbsrf5_(xyz, dxyz, isv, isf, iv, frc, vert, eye, light, 
	lshine)
real *xyz, *dxyz;
integer *isv, *isf, *iv;
real *frc, *vert, *eye, *light;
logical *lshine;
{
    /* Initialized data */

    static integer iv4map[12] = { 12,8,4,3,11,7,6,2,10,9,5,1 };

    static integer i__, j, ijdif, i1, i2, k2, k3, k4;
    extern /* Subroutine */ int sbsf5a_(), sbsf5b_(), sbsf5c_(), sbsf5d_();
    static integer k4a, k4b;

/*     ---------------------------------------------------------------- */

    /* Parameter adjustments */
    --light;
    --eye;
    vert -= 4;
    --frc;
    --iv;
    dxyz -= 40;
    --xyz;

    /* Function Body */

    if (*isv == 1) {
	sbsf5a_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &iv[1], &eye[1], 
		lshine, &light[1]);
    } else if (*isv == 2) {
	if (*isf == 6) {
	    sbsf5a_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &iv[1], &eye[1], 
		    lshine, &light[1]);
	    sbsf5a_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &iv[2], &eye[1], 
		    lshine, &light[1]);
	} else {
	    ijdif = iv[2] - iv[1];
	    if (iv[1] <= 4) {
		if (iv[2] <= 4) {
		    k2 = iv[1];
		    if (ijdif == 3) {
			k2 = iv[2];
		    }
		} else {
		    k2 = iv[2];
		}
	    } else {
		k2 = iv[1] + 4;
		if (ijdif == 3) {
		    k2 = iv[2] + 4;
		}
	    }
	    sbsf5b_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &k2, &eye[1], 
		    lshine, &light[1], &c__1);
	}
    } else if (*isv == 3) {
	if (*isf == 9) {
	    for (i__ = 1; i__ <= 3; ++i__) {
/* L10: */
		sbsf5a_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &iv[i__], &eye[
			1], lshine, &light[1]);
	    }
	} else if (*isf == 6) {
	    for (i1 = 1; i1 <= 3; ++i1) {
		i2 = i1 % 3 + 1;
		i__ = min(i1,i2);
		j = max(i1,i2);
		k2 = 0;
		ijdif = iv[j] - iv[i__];
		if (iv[i__] <= 4) {
		    if (iv[j] <= 4) {
			if (ijdif == 1) {
			    k2 = iv[i__];
			} else if (ijdif == 3) {
			    k2 = iv[j];
			}
		    } else {
			if (ijdif == 4) {
			    k2 = iv[j];
			}
		    }
		} else {
		    if (ijdif == 1) {
			k2 = iv[i__] + 4;
		    } else if (ijdif == 3) {
			k2 = iv[j] + 4;
		    }
		}
		if (k2 > 0) {
		    goto L1;
		}
/* L20: */
	    }
L1:
	    sbsf5b_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &k2, &eye[1], 
		    lshine, &light[1], &c__1);
	} else {
	    k3 = iv[1] + iv[2] + iv[3] - 5 + (iv[1] / 5 + (iv[2] / 5 << 1) + 
		    iv[3] / 5 << 1);
	    sbsf5c_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &k3, &eye[1], 
		    lshine, &light[1]);
	}
    } else {
	if (*isf == 12) {
	    for (i__ = 1; i__ <= 4; ++i__) {
/* L30: */
		sbsf5a_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &iv[i__], &eye[
			1], lshine, &light[1]);
	    }
	} else if (*isf == 4) {
	    k4 = (iv[1] + iv[2] + iv[3] + iv[4] - 6) / 4;
	    if (iv[2] - iv[1] == 3) {
		k4 = 6;
	    }
	    sbsf5b_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &k4, &eye[1], 
		    lshine, &light[1], &c__2);
	} else if (*isf == 6) {
	    if (iv[3] <= 4) {
		k3 = iv[1] + iv[2] + iv[3] - 6;
		k4 = (iv[4] + k3) % 4 + k3 * 3;
	    } else {
		if (iv[2] >= 5) {
		    k3 = iv[2] + iv[3] + iv[4] - 18;
		    k4 = iv4map[(iv[1] + k3) % 4 + k3 * 3 - 1];
		} else {
		    k4 = iv[3] + 12 - iv[2];
		    if (iv[1] + iv[2] + iv[3] + iv[4] == 22) {
			k4 = 29 - k4;
		    }
		}
	    }
	    sbsf5d_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &k4, &eye[1], 
		    lshine, &light[1]);
	} else {
	    k4 = iv[1] + iv[2] + iv[3] + iv[4];
	    if (k4 == 16 || k4 == 20) {
		sbsf5b_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &iv[3], &eye[1]
			, lshine, &light[1], &c__1);
		sbsf5b_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &iv[4], &eye[1]
			, lshine, &light[1], &c__1);
	    } else if (k4 == 18) {
		k4a = iv[1];
		if (iv[2] - k4a == 3) {
		    k4a = 4;
		}
		k4b = (k4a + 1) % 4 + 9;
		sbsf5b_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &k4a, &eye[1], 
			lshine, &light[1], &c__1);
		sbsf5b_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &k4b, &eye[1], 
			lshine, &light[1], &c__1);
	    } else {
		if (k4 == 14) {
		    k4a = iv[4];
		    k3 = iv[1] + iv[2] + iv[3] - 5 + (iv[1] / 5 + (iv[2] / 5 
			    << 1) + iv[3] / 5 << 1);
		} else if (k4 == 22) {
		    k4a = iv[1];
		    k3 = iv[2] + iv[3] + iv[4] - 5 + (iv[2] / 5 + (iv[3] / 5 
			    << 1) + iv[4] / 5 << 1);
		} else {
		    if ((iv[1] + iv[2]) % 2 == 0) {
			if (iv[4] == 6 || iv[3] - iv[2] == 2) {
			    k4a = iv[2];
			    k3 = iv[1] + iv[3] + iv[4] - 5 + (iv[1] / 5 + (iv[
				    3] / 5 << 1) + iv[4] / 5 << 1);
			} else {
			    k4a = iv[1];
			    k3 = iv[2] + iv[3] + iv[4] - 5 + (iv[2] / 5 + (iv[
				    3] / 5 << 1) + iv[4] / 5 << 1);
			}
		    } else {
			if (iv[1] == 3 || iv[3] - iv[2] == 2) {
			    k4a = iv[3];
			    k3 = iv[1] + iv[2] + iv[4] - 5 + (iv[1] / 5 + (iv[
				    2] / 5 << 1) + iv[4] / 5 << 1);
			} else {
			    k4a = iv[4];
			    k3 = iv[1] + iv[2] + iv[3] - 5 + (iv[1] / 5 + (iv[
				    2] / 5 << 1) + iv[3] / 5 << 1);
			}
		    }
		}
		sbsf5a_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &k4a, &eye[1], 
			lshine, &light[1]);
		sbsf5c_(&xyz[1], &dxyz[40], &frc[1], &vert[4], &k3, &eye[1], 
			lshine, &light[1]);
	    }
	}
    }
} /* sbsrf5_ */


/* Subroutine */ int sbsf5a_(xyz, dxyz, frc, vert, iv, eye, lshine, light)
real *xyz, *dxyz, *frc, *vert;
integer *iv;
real *eye;
logical *lshine;
real *light;
{
    static integer i__, j, k, l;
    extern /* Subroutine */ int sbsrf6_();

/*     --------------------------------------------------------- */


    /* Parameter adjustments */
    --light;
    --eye;
    vert -= 4;
    --frc;
    dxyz -= 40;
    --xyz;

    /* Function Body */
    if (*iv <= 4) {
	j = *iv;
	k = (*iv + 2) % 4 + 1;
	l = *iv + 4;
    } else {
	j = *iv + 4;
	k = (*iv - 2) % 4 + 9;
	l = *iv;
    }
    for (i__ = 1; i__ <= 3; ++i__) {
	vert[i__ + 3] = xyz[i__] + dxyz[i__ + (j + 12) * 3] + frc[j] * dxyz[
		i__ + (j + 24) * 3];
	vert[i__ + 6] = xyz[i__] + dxyz[i__ + (k + 12) * 3] + frc[k] * dxyz[
		i__ + (k + 24) * 3];
	vert[i__ + 9] = xyz[i__] + dxyz[i__ + (l + 12) * 3] + frc[l] * dxyz[
		i__ + (l + 24) * 3];
/* L10: */
    }
    sbsrf6_(&eye[1], &c__3, &vert[4], lshine, &light[1], &c__1);
} /* sbsf5a_ */


/* Subroutine */ int sbsf5b_(xyz, dxyz, frc, vert, kk, eye, lshine, light, ll)
real *xyz, *dxyz, *frc, *vert;
integer *kk;
real *eye;
logical *lshine;
real *light;
integer *ll;
{
    /* Initialized data */

    static integer ivl[96]	/* was [4][12][2] */ = { 5,6,2,4,6,7,3,1,7,8,
	    4,2,8,5,1,3,9,1,4,12,10,2,1,9,11,3,2,10,12,4,3,11,12,5,6,10,9,6,7,
	    11,10,7,8,12,11,8,5,9,5,6,7,8,4,2,10,12,1,3,11,9,4,2,10,12,5,6,7,
	    8,1,3,11,9,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 };

    static integer i__, j, k, l, m;
    extern /* Subroutine */ int sbsrf6_(), sbrcop_();

/*     ------------------------------------------------------------ */

    /* Parameter adjustments */
    --light;
    --eye;
    vert -= 4;
    --frc;
    dxyz -= 40;
    --xyz;

    /* Function Body */

    j = ivl[(0 + (0 + (1 + (*kk + *ll * 12 << 2) - 53 << 2))) / 4];
    k = ivl[(*kk + *ll * 12 << 2) - 51];
    l = ivl[(*kk + *ll * 12 << 2) - 50];
    m = ivl[(*kk + *ll * 12 << 2) - 49];
    for (i__ = 1; i__ <= 3; ++i__) {
	vert[i__ + 3] = xyz[i__] + dxyz[i__ + (j + 12) * 3] + frc[j] * dxyz[
		i__ + (j + 24) * 3];
	vert[i__ + 6] = xyz[i__] + dxyz[i__ + (k + 12) * 3] + frc[k] * dxyz[
		i__ + (k + 24) * 3];
	vert[i__ + 9] = xyz[i__] + dxyz[i__ + (l + 12) * 3] + frc[l] * dxyz[
		i__ + (l + 24) * 3];
	vert[i__ + 12] = xyz[i__] + dxyz[i__ + (m + 12) * 3] + frc[m] * dxyz[
		i__ + (m + 24) * 3];
	vert[i__ + 15] = vert[i__ + 3];
	vert[i__ + 18] = (vert[i__ + 3] + vert[i__ + 6] + vert[i__ + 9] + 
		vert[i__ + 12]) * (float).25;
/* L10: */
    }
    for (i__ = 1; i__ <= 4; ++i__) {
	sbrcop_(&vert[i__ * 3 + 1], &vert[22], &c__6);
	sbsrf6_(&eye[1], &c__3, &vert[19], lshine, &light[1], &c__1);
/* L20: */
    }
} /* sbsf5b_ */


/* Subroutine */ int sbsf5c_(xyz, dxyz, frc, vert, k3, eye, lshine, light)
real *xyz, *dxyz, *frc, *vert;
integer *k3;
real *eye;
logical *lshine;
real *light;
{
    /* Initialized data */

    static integer iv3[120]	/* was [5][24] */ = { 5,6,7,3,4,8,5,6,2,3,7,8,
	    5,1,2,6,7,8,4,1,12,4,2,6,9,4,2,10,9,5,9,1,3,8,12,9,1,3,7,10,1,3,
	    11,10,6,1,3,11,12,5,4,2,10,11,8,2,4,12,11,7,10,12,4,1,6,12,10,2,1,
	    5,11,9,1,4,8,1,9,11,7,2,3,11,9,6,2,3,11,9,5,4,2,10,12,8,3,4,12,10,
	    7,3,5,6,7,11,12,8,5,6,10,11,7,8,5,9,10,6,7,8,12,9 };

    static integer i__, j, k, l, m, n;
    extern /* Subroutine */ int sbsrf6_(), sbrcop_();

/*     --------------------------------------------------------- */

    /* Parameter adjustments */
    --light;
    --eye;
    vert -= 4;
    --frc;
    dxyz -= 40;
    --xyz;

    /* Function Body */

    j = iv3[(0 + (0 + (1 + *k3 * 5 - 6 << 2))) / 4];
    k = iv3[*k3 * 5 - 4];
    l = iv3[*k3 * 5 - 3];
    m = iv3[*k3 * 5 - 2];
    n = iv3[*k3 * 5 - 1];
    for (i__ = 1; i__ <= 3; ++i__) {
	vert[i__ + 3] = xyz[i__] + dxyz[i__ + (j + 12) * 3] + frc[j] * dxyz[
		i__ + (j + 24) * 3];
	vert[i__ + 6] = xyz[i__] + dxyz[i__ + (k + 12) * 3] + frc[k] * dxyz[
		i__ + (k + 24) * 3];
	vert[i__ + 9] = xyz[i__] + dxyz[i__ + (l + 12) * 3] + frc[l] * dxyz[
		i__ + (l + 24) * 3];
	vert[i__ + 12] = xyz[i__] + dxyz[i__ + (m + 12) * 3] + frc[m] * dxyz[
		i__ + (m + 24) * 3];
	vert[i__ + 15] = xyz[i__] + dxyz[i__ + (n + 12) * 3] + frc[n] * dxyz[
		i__ + (n + 24) * 3];
	vert[i__ + 18] = vert[i__ + 3];
	vert[i__ + 21] = (vert[i__ + 3] + vert[i__ + 6] + vert[i__ + 9] + 
		vert[i__ + 12] + vert[i__ + 15]) * (float).2;
/* L10: */
    }
    for (i__ = 1; i__ <= 5; ++i__) {
	sbrcop_(&vert[i__ * 3 + 1], &vert[25], &c__6);
	sbsrf6_(&eye[1], &c__3, &vert[22], lshine, &light[1], &c__1);
/* L20: */
    }
} /* sbsf5c_ */


/* Subroutine */ int sbsf5d_(xyz, dxyz, frc, vert, k4, eye, lshine, light)
real *xyz, *dxyz, *frc, *vert;
integer *k4;
real *eye;
logical *lshine;
real *light;
{
    /* Initialized data */

    static integer iv4[96]	/* was [6][16] */ = { 12,9,6,7,3,4,10,9,5,4,3,
	    7,11,10,6,5,4,3,11,12,5,6,2,3,9,12,8,3,2,6,10,9,5,8,3,2,10,11,8,5,
	    1,2,12,11,7,2,1,5,9,12,8,7,2,1,9,10,7,8,4,1,11,10,6,1,4,8,12,11,7,
	    6,1,4,12,10,6,1,3,8,12,10,7,3,1,5,11,9,6,2,4,8,11,9,5,4,2,7 };
    static real vnorm = (float).1666666667;

    static integer i__, j, k;
    extern /* Subroutine */ int sbsrf6_(), sbrfil_(), sbrcop_();

/*     --------------------------------------------------------- */

    /* Parameter adjustments */
    --light;
    --eye;
    vert -= 4;
    --frc;
    dxyz -= 40;
    --xyz;

    /* Function Body */

    sbrfil_(&vert[25], &c_b14, &c__3);
    for (j = 1; j <= 6; ++j) {
	k = iv4[j + *k4 * 6 - 7];
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + j * 3] = xyz[i__] + dxyz[i__ + (k + 12) * 3] + frc[k] *
		     dxyz[i__ + (k + 24) * 3];
	    vert[i__ + 24] += vert[i__ + j * 3];
/* L10: */
	}
/* L20: */
    }
    sbrcop_(&vert[4], &vert[22], &c__3);
    for (i__ = 1; i__ <= 3; ++i__) {
/* L30: */
	vert[i__ + 24] *= vnorm;
    }
    for (i__ = 1; i__ <= 6; ++i__) {
	sbrcop_(&vert[i__ * 3 + 1], &vert[28], &c__6);
	sbsrf6_(&eye[1], &c__3, &vert[25], lshine, &light[1], &c__1);
/* L40: */
    }
} /* sbsf5d_ */


/* Subroutine */ int sbsrf6_(eye, nv, vert, lshine, light, inside)
real *eye;
integer *nv;
real *vert;
logical *lshine;
real *light;
integer *inside;
{
    /* System generated locals */
    integer i__1, i__2, i__3, i__4;
    real r__1;

    /* Local variables */
    static real sdxi, sdyj, xmin, ymin, xmax, ymax;
    static integer i__, j, k;
    static real x, gradl, z__, y, gradr, safer;
    static integer ileft;
    static real xdifl, small, ydifl, xdifr, ydifr;
    static integer istep, ixmin, jymin, ixmax, jymax, ivert, i1, j1, j2, i2, 
	    kstep;
    extern /* Subroutine */ int sbsf6a_(), sbsf6b_(), sblin1_();
    static real ax, ay, az, bx, by, bz, dx, dy, yj, xl, xn, yn, zn, xr, xi, 
	    xlamda, xw[20], yw[20];
    static doublereal zz;
    static real gx, gy, gz, yl;
    static integer jbotom;
    static real yr, eyenrm;
    static doublereal xlnorm;
    static integer ix1, ix2, jy1, jy2;
    static real clr, dxi, ten, dyj;
    static doublereal dzz;
    static integer nvl1, nvl2, nvr1, nvr2;

/*     -------------------------------------------------- */



/* Carry out some initial checks and calculate the coordinates of the */
/* projected triangle. */

    /* Parameter adjustments */
    --light;
    vert -= 4;
    --eye;

    /* Function Body */
    if (*nv < 3 || *nv > 10) {
	return 0;
    }
    small = (float)1e-10;
    xmin = (float)1e20;
    xmax = (float)-1e20;
    ymin = (float)1e20;
    ymax = (float)-1e20;
    i__1 = *nv;
    for (i__ = 1; i__ <= i__1; ++i__) {
	sblin1_(&eye[1], &vert[i__ * 3 + 1], &vert[i__ * 3 + 2], &vert[i__ * 
		3 + 3], &xw[i__ - 1], &yw[i__ - 1]);
	if (xw[i__ - 1] < xmin) {
	    xmin = xw[i__ - 1];
	    ileft = i__;
	}
	if (yw[i__ - 1] < ymin) {
	    ymin = yw[i__ - 1];
	    jbotom = i__;
	}
/* Computing MAX */
	r__1 = xw[i__ - 1];
	xmax = dmax(r__1,xmax);
/* Computing MAX */
	r__1 = yw[i__ - 1];
	ymax = dmax(r__1,ymax);
/* L10: */
    }
    if (xmin >= sftbuf_1.xtrc || xmax <= sftbuf_1.xblc) {
	return 0;
    }
    if (ymin >= sftbuf_1.ytrc || ymax <= sftbuf_1.yblc) {
	return 0;
    }

/* Find the outward normal seen by the eye. */

    ax = vert[7] - vert[4];
    ay = vert[8] - vert[5];
    az = vert[9] - vert[6];
    bx = vert[4] - vert[*nv * 3 + 1];
    by = vert[5] - vert[*nv * 3 + 2];
    bz = vert[6] - vert[*nv * 3 + 3];
    xn = by * az - ay * bz;
    yn = bz * ax - az * bx;
    zn = bx * ay - ax * by;
    ten = xn * (eye[1] - vert[4]) + yn * (eye[2] - vert[5]) + zn * (eye[3] - 
	    vert[6]);
    if (ten < (float)0.) {
	xn = -xn;
	yn = -yn;
	zn = -zn;
	ten = -ten;
    }

/* Plot the projected triangle. */

    xlnorm = (doublereal) ten;
    eyenrm = xn * eye[1] + yn * eye[2] + zn * eye[3];
    dx = (real) (sftbuf_1.nxp - 1) / (sftbuf_1.xtrc - sftbuf_1.xblc);
    dy = (real) (sftbuf_1.nyp - 1) / (sftbuf_1.ytrc - sftbuf_1.yblc);
    dyj = (float)1. / dy;
    dxi = (float)1. / dx;
    safer = (float)1e-4;
    if (xmax - xmin > ymax - ymin) {
	jymin = (integer) ((ymin - sftbuf_1.yblc) * dy) + 2;
/* Computing MIN */
	i__1 = (integer) ((ymax - sftbuf_1.yblc) * dy) + 1;
	jymax = min(i__1,sftbuf_1.nyp);
	if (jymin > jymax) {
	    return 0;
	}
	yj = sftbuf_1.yblc + ((real) (jymin - 1) + safer) * dyj;
	nvl2 = jbotom;
	nvr2 = jbotom;
	j1 = jymin;
	i__1 = *nv;
	for (ivert = 1; ivert <= i__1; ++ivert) {
	    if (yj > yw[nvl2 - 1]) {
L1:
		nvl1 = nvl2;
		nvl2 = nvl1 - 1;
		if (nvl2 < 1) {
		    nvl2 = *nv;
		}
		if (nvl2 == jbotom) {
		    return 0;
		}
		if (yj > yw[nvl2 - 1]) {
		    goto L1;
		}
		ydifl = yw[nvl2 - 1] - yw[nvl1 - 1];
		if (dabs(ydifl) < small) {
		    ydifl = small;
		}
		gradl = (xw[nvl2 - 1] - xw[nvl1 - 1]) / ydifl;
	    }
	    if (yj > yw[nvr2 - 1]) {
L2:
		nvr1 = nvr2;
		nvr2 = nvr1 + 1;
		if (nvr2 > *nv) {
		    nvr2 = 1;
		}
		if (nvr2 == jbotom) {
		    return 0;
		}
		if (yj > yw[nvr2 - 1]) {
		    goto L2;
		}
		ydifr = yw[nvr2 - 1] - yw[nvr1 - 1];
		if (dabs(ydifr) < small) {
		    ydifr = small;
		}
		gradr = (xw[nvr2 - 1] - xw[nvr1 - 1]) / ydifr;
	    }
	    if (yw[nvl2 - 1] < yw[nvr2 - 1]) {
/* Computing MIN */
		i__2 = (integer) ((yw[nvl2 - 1] - sftbuf_1.yblc) * dy) + 1;
		j2 = min(i__2,jymax);
	    } else {
/* Computing MIN */
		i__2 = (integer) ((yw[nvr2 - 1] - sftbuf_1.yblc) * dy) + 1;
		j2 = min(i__2,jymax);
	    }
	    i__2 = j2;
	    for (j = j1; j <= i__2; ++j) {
		if (j >= 1) {
		    xl = xw[nvl1 - 1] + gradl * (yj - yw[nvl1 - 1]);
		    xr = xw[nvr1 - 1] + gradr * (yj - yw[nvr1 - 1]);
		    istep = 1;
/* Computing MAX */
		    i__3 = (integer) ((xl - sftbuf_1.xblc) * dx) + 2;
		    ix1 = max(i__3,1);
/* Computing MIN */
		    i__3 = (integer) ((xr - sftbuf_1.xblc) * dx) + 1;
		    ix2 = min(i__3,sftbuf_1.nxp);
		    if (ix1 > ix2) {
			istep = -1;
/* Computing MIN */
			i__3 = ix1 - 1;
			ix1 = min(i__3,sftbuf_1.nxp);
/* Computing MAX */
			i__3 = ix2 + 1;
			ix2 = max(i__3,1);
		    }
		    xi = sftbuf_1.xblc + (real) (ix1 - 1) * dxi;
		    sdxi = (real) istep * dxi;
		    dzz = (doublereal) (sdxi * xn);
		    zz = (doublereal) (eyenrm - xi * xn - yj * yn);
		    k = (j - 1) * sftbuf_1.nxp + ix1;
		    i__3 = ix2;
		    i__4 = istep;
		    for (i__ = ix1; i__4 < 0 ? i__ >= i__3 : i__ <= i__3; i__ 
			    += i__4) {
			xlamda = (real) (xlnorm / zz);
			z__ = eye[3] * ((float)1. - xlamda);
			if (z__ > sftbuf_1.sbbuff[k - 1]) {
			    sftbuf_1.sbbuff[k - 1] = z__;
			    x = eye[1] + xlamda * (xi - eye[1]);
			    y = eye[2] + xlamda * (yj - eye[2]);
			    if (*inside == 0) {
				gx = xn;
				gy = yn;
				gz = zn;
			    } else {
				sbsf6a_(&x, &y, &z__, srfcom_1.orig, 
					srfcom_1.mtrx, srfcom_1.grdcub, &gx, &
					gy, &gz);
			    }
			    sbsf6b_(&eye[1], &x, &y, &z__, &gx, &gy, &gz, &
				    light[1], &srfcom_1.xl2, lshine, &clr);
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = 
				    srfcom_1.col0 + srfcom_1.colscl * clr;
			}
			xi += sdxi;
			zz -= dzz;
			k += istep;
/* L20: */
		    }
		}
		yj += dyj;
/* L30: */
	    }
	    j1 = j2 + 1;
	    if (j1 > jymax) {
		return 0;
	    }
/* L40: */
	}
    } else {
	ixmin = (integer) ((xmin - sftbuf_1.xblc) * dx) + 2;
/* Computing MIN */
	i__1 = (integer) ((xmax - sftbuf_1.xblc) * dx) + 1;
	ixmax = min(i__1,sftbuf_1.nxp);
	if (ixmin > ixmax) {
	    return 0;
	}
	xi = sftbuf_1.xblc + ((real) (ixmin - 1) + safer) * dxi;
	nvl2 = ileft;
	nvr2 = ileft;
	i1 = ixmin;
	i__1 = *nv;
	for (ivert = 1; ivert <= i__1; ++ivert) {
	    if (xi > xw[nvl2 - 1]) {
L3:
		nvl1 = nvl2;
		nvl2 = nvl1 - 1;
		if (nvl2 < 1) {
		    nvl2 = *nv;
		}
		if (nvl2 == ileft) {
		    return 0;
		}
		if (xi > xw[nvl2 - 1]) {
		    goto L3;
		}
		xdifl = xw[nvl2 - 1] - xw[nvl1 - 1];
		if (dabs(xdifl) < small) {
		    xdifl = small;
		}
		gradl = (yw[nvl2 - 1] - yw[nvl1 - 1]) / xdifl;
	    }
	    if (xi > xw[nvr2 - 1]) {
L4:
		nvr1 = nvr2;
		nvr2 = nvr1 + 1;
		if (nvr2 > *nv) {
		    nvr2 = 1;
		}
		if (nvr2 == ileft) {
		    return 0;
		}
		if (xi > xw[nvr2 - 1]) {
		    goto L4;
		}
		xdifr = xw[nvr2 - 1] - xw[nvr1 - 1];
		if (dabs(xdifr) < small) {
		    xdifr = small;
		}
		gradr = (yw[nvr2 - 1] - yw[nvr1 - 1]) / xdifr;
	    }
	    if (xw[nvl2 - 1] < xw[nvr2 - 1]) {
/* Computing MIN */
		i__2 = (integer) ((xw[nvl2 - 1] - sftbuf_1.xblc) * dx) + 1;
		i2 = min(i__2,ixmax);
	    } else {
/* Computing MIN */
		i__2 = (integer) ((xw[nvr2 - 1] - sftbuf_1.xblc) * dx) + 1;
		i2 = min(i__2,ixmax);
	    }
	    i__2 = i2;
	    for (i__ = i1; i__ <= i__2; ++i__) {
		if (i__ >= 1) {
		    yl = yw[nvl1 - 1] + gradl * (xi - xw[nvl1 - 1]);
		    yr = yw[nvr1 - 1] + gradr * (xi - xw[nvr1 - 1]);
		    istep = 1;
/* Computing MAX */
		    i__4 = (integer) ((yl - sftbuf_1.yblc) * dy) + 2;
		    jy1 = max(i__4,1);
/* Computing MIN */
		    i__4 = (integer) ((yr - sftbuf_1.yblc) * dy) + 1;
		    jy2 = min(i__4,sftbuf_1.nyp);
		    if (jy1 > jy2) {
			istep = -1;
/* Computing MIN */
			i__4 = jy1 - 1;
			jy1 = min(i__4,sftbuf_1.nyp);
/* Computing MAX */
			i__4 = jy2 + 1;
			jy2 = max(i__4,1);
		    }
		    yj = sftbuf_1.yblc + (real) (jy1 - 1) * dyj;
		    sdyj = (real) istep * dyj;
		    dzz = (doublereal) (sdyj * yn);
		    zz = (doublereal) (eyenrm - yj * yn - xi * xn);
		    k = (jy1 - 1) * sftbuf_1.nxp + i__;
		    kstep = istep * sftbuf_1.nxp;
		    i__4 = jy2;
		    i__3 = istep;
		    for (j = jy1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
			     {
			xlamda = (real) (xlnorm / zz);
			z__ = eye[3] * ((float)1. - xlamda);
			if (z__ > sftbuf_1.sbbuff[k - 1]) {
			    sftbuf_1.sbbuff[k - 1] = z__;
			    x = eye[1] + xlamda * (xi - eye[1]);
			    y = eye[2] + xlamda * (yj - eye[2]);
			    if (*inside == 0) {
				gx = xn;
				gy = yn;
				gz = zn;
			    } else {
				sbsf6a_(&x, &y, &z__, srfcom_1.orig, 
					srfcom_1.mtrx, srfcom_1.grdcub, &gx, &
					gy, &gz);
			    }
			    sbsf6b_(&eye[1], &x, &y, &z__, &gx, &gy, &gz, &
				    light[1], &srfcom_1.xl2, lshine, &clr);
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = 
				    srfcom_1.col0 + srfcom_1.colscl * clr;
			}
			yj += sdyj;
			zz -= dzz;
			k += kstep;
/* L50: */
		    }
		}
		xi += dxi;
/* L60: */
	    }
	    i1 = i2 + 1;
	    if (i1 > ixmax) {
		return 0;
	    }
/* L70: */
	}
    }
} /* sbsrf6_ */


/* Subroutine */ int sbsf6a_(x, y, z__, orig, mtrx, grd, xn, yn, zn)
real *x, *y, *z__, *orig, *mtrx, *grd, *xn, *yn, *zn;
{
    /* Initialized data */

    static real zero = (float)1e-5;
    static real one = (float).99999;

    /* System generated locals */
    real r__1, r__2, r__3, r__4;

    /* Local variables */
    static real x0, y0, z0, dx, dy, dz, xi, yj, zk, xn1, xn2, yn1, yn2, zn1, 
	    zn2;

/*     ----------------------------------------------- */

    /* Parameter adjustments */
    grd -= 4;
    mtrx -= 4;
    --orig;

    /* Function Body */

    x0 = *x - orig[1];
    y0 = *y - orig[2];
    z0 = *z__ - orig[3];
    xi = x0 * mtrx[4] + y0 * mtrx[5] + z0 * mtrx[6];
    yj = x0 * mtrx[7] + y0 * mtrx[8] + z0 * mtrx[9];
    zk = x0 * mtrx[10] + y0 * mtrx[11] + z0 * mtrx[12];
/* Computing MIN */
/* Computing MAX */
    r__3 = zero, r__4 = xi - (real) ((integer) xi);
    r__1 = one, r__2 = dmax(r__3,r__4);
    dx = dmin(r__1,r__2);
/* Computing MIN */
/* Computing MAX */
    r__3 = zero, r__4 = yj - (real) ((integer) yj);
    r__1 = one, r__2 = dmax(r__3,r__4);
    dy = dmin(r__1,r__2);
/* Computing MIN */
/* Computing MAX */
    r__3 = zero, r__4 = zk - (real) ((integer) zk);
    r__1 = one, r__2 = dmax(r__3,r__4);
    dz = dmin(r__1,r__2);
    xn1 = ((float)1. - dx) * (grd[4] + dy * (grd[13] - grd[4])) + dx * (grd[7]
	     + dy * (grd[10] - grd[7]));
    xn2 = ((float)1. - dx) * (grd[16] + dy * (grd[25] - grd[16])) + dx * (grd[
	    19] + dy * (grd[22] - grd[19]));
    *xn = xn1 + dz * (xn2 - xn1);
    yn1 = ((float)1. - dx) * (grd[5] + dy * (grd[14] - grd[5])) + dx * (grd[8]
	     + dy * (grd[11] - grd[8]));
    yn2 = ((float)1. - dx) * (grd[17] + dy * (grd[26] - grd[17])) + dx * (grd[
	    20] + dy * (grd[23] - grd[20]));
    *yn = yn1 + dz * (yn2 - yn1);
    zn1 = ((float)1. - dx) * (grd[6] + dy * (grd[15] - grd[6])) + dx * (grd[9]
	     + dy * (grd[12] - grd[9]));
    zn2 = ((float)1. - dx) * (grd[18] + dy * (grd[27] - grd[18])) + dx * (grd[
	    21] + dy * (grd[24] - grd[21]));
    *zn = zn1 + dz * (zn2 - zn1);
} /* sbsf6a_ */


/* Subroutine */ int sbsf6b_(eye, x, y, z__, xn, yn, zn, light, xl2, lshine, 
	colour)
real *eye, *x, *y, *z__, *xn, *yn, *zn, *light, *xl2;
logical *lshine;
real *colour;
{
    /* Initialized data */

    static real small2 = (float)1e-20;

    /* System generated locals */
    real r__1, r__2, r__3;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static real v2, rx, ry, rz, vx, vy, vz, rfnorm, xn2, xnl, xrv;

/*     ------------------------------------------------------------- */

    /* Parameter adjustments */
    --light;
    --eye;

    /* Function Body */

    *colour = (float)0.;
    xnl = *xn * light[1] + *yn * light[2] + *zn * light[3];
    if (xnl >= (float)0.) {
	return 0;
    }
/* Computing 2nd power */
    r__1 = *xn;
/* Computing 2nd power */
    r__2 = *yn;
/* Computing 2nd power */
    r__3 = *zn;
    xn2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3 + small2;
    if (*lshine) {
	rfnorm = xnl * (float)2. / xn2;
	rx = light[1] - *xn * rfnorm;
	ry = light[2] - *yn * rfnorm;
	rz = light[3] - *zn * rfnorm;
	vx = eye[1] - *x;
	vy = eye[2] - *y;
	vz = eye[3] - *z__;
	xrv = rx * vx + ry * vy + rz * vz;
	if (xrv < (float)0.) {
	    return 0;
	}
/* Computing 2nd power */
	r__1 = vx;
/* Computing 2nd power */
	r__2 = vy;
/* Computing 2nd power */
	r__3 = vz;
	v2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
/* Computing MIN */
/* Computing 2nd power */
	r__3 = xrv;
	r__2 = r__3 * r__3 / ((r__1 = *xl2 * v2, dabs(r__1)) + small2);
	*colour = dmin(r__2,(float)1.);
    } else {
/* Computing MIN */
	r__2 = -xnl / sqrt((r__1 = *xl2 * xn2, dabs(r__1)) + small2);
	*colour = dmin(r__2,(float)1.);
    }
} /* sbsf6b_ */


/* Subroutine */ int sb2srf_(eye, latice, dens, n1, n2, dlow, dhigh, dvert, 
	ic1, ic2, ncband, light, lshine)
real *eye, *latice, *dens;
integer *n1, *n2;
real *dlow, *dhigh, *dvert;
integer *ic1, *ic2, *ncband;
real *light;
logical *lshine;
{
    /* System generated locals */
    integer dens_dim1, dens_offset, i__1, i__2, i__3, i__4, i__5;
    real r__1, r__2, r__3, r__4;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static real safe, cscl, dmin__, dmax__;
    static integer jlat, ilat;
    static real zfar, xmin, ymin, xmax, ymax, vert[24]	/* was [3][8] */;
    static integer ntot;
    static real mtrx[9]	/* was [3][3] */, bas2j;
    static integer i__, j, k;
    static real gradl, z__, gradr, dkscl, safer;
    static integer ileft;
    static real xdifl, small, ydifl;
    extern /* Subroutine */ int sb2sr1_();
    static real ydifr;
    extern /* Subroutine */ int sb2sr3_(), sb2sr4_();
    static real xdifr;
    static integer istep, jymin, ixmin, jymax, ivert, ixmax, j1, j2, i1, i2, 
	    jstep, kstep;
    static real latic2[12]	/* was [3][4] */;
    static doublereal dsmal2;
    extern /* Subroutine */ int sblin1_();
    static real small2, eylat1, eylat2, di, dj, dk;
    static integer ii;
    static real ax, ay, cx, cy, cz, dx, drange, dy;
    static integer iv;
    static real az, bx, by, bz, xn, yn, zn, yj, grdscl[3], xw[20], yw[20];
    static doublereal zz;
    static integer nshads;
    static real colscl, xl;
    extern /* Subroutine */ int sbrcop_();
    static real orgscl, detnrm;
    static integer jbotom;
    static real eyenrm, xr, xi, xlamda, gx, gy, gz, colour, yl, dxistp, yr, 
	    dyjstp;
    static doublereal xlnorm;
    static integer ix1, ix2, jy1, jy2;
    static real xl2, xn1, xn2, xn3, big, bas[9]	/* was [3][3] */, det, dxi, 
	    dyj, ten, xdi, ydj, zdk;
    static doublereal dzz;
    static real col0;
    static integer nvl1, nvl2, nvr1, nvr2;

/*     ----------------------------------------------------------------- */



/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      This subroutine plots a 3-d surface given a 2-d unit-cell */
/*    of density. All (x,y,z) values are taken to be given in world */
/*    coordinates. The z-component of the eye-poisition should be */
/*    positive and that of all the lattice-vertices should be negative; */
/*    the viewing-screen is fixed at z=0. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    EYE      R*4    I       3      (x,y,z) coordinate of eye-position. */
/*    LATICE   R*4    I     3 x 3    (x,y,z) coordinates of the origin */
/*                                   and the a and b lattice-vertices. */
/*    DENS     R*4    I     (N1+1)   The density at regular points within */
/*                        x (N2+1)   the unit cell, wrapped around so */
/*                                   that DENS(0,J)=DENS(N1,J) etc.. */
/*    N1,N2    I*4    I       -      The dimensions of the unit-cell grid. */
/*    DLOW     R*4    I       -      Lowest density to be plotted. */
/*    DHIGH    R*4    I       -      Highest density to be plotted. */
/*    DVERT    R*4    I       -      "Vertical" world-coordinate length */
/*                                   corresponding to density-range. */
/*    IC1,IC2  I*4    I       -      Lowest and highest colour-index to */
/*                                   be used for the rendering. */
/*    NCBAND   I*4    I       -      Number of colour-bands for the */
/*                                   height, so that the number of shades */
/*                                   per band = (IC2-IC1+1)/NCBAND. */
/*    LIGHT    R*4    I       3      (x,y,z) direction of flood-light. */
/*    LSHINE   L*1    I       -      Shiny surface if TRUE, else diffuse. */

/* Globals */
/*    SFTBUF */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     SBLIN1     Calculates the projection of (x,y,z) on viewing screen. */
/*     SB2SR1     Calculates vertecies of triangular breakdown of grid. */
/*     SB2SR3     Calculates the normal of the surface. */
/*     SB2SR4     Calculates the appropriate colour for a given pixel. */

/* History */
/*   D. S. Sivia        1 Jun 1995  Initial release. */
/*   D. S. Sivia        7 Jul 1995  Fixed bug in determinant calculation. */
/*   D. S. Sivia       20 Oct 1995  Speeded up computations slightly. */
/*   D. S. Sivia       26 Oct 1995  Completely new algorithm! */
/*   D. S. Sivia       24 Oct 1997 "Safe-guarded" some rounding errors. */
/* ----------------------------------------------------------------------- */

/* Carry out some initial checks. */

    /* Parameter adjustments */
    --eye;
    latice -= 4;
    dens_dim1 = *n1 - 0 + 1;
    dens_offset = 0 + dens_dim1 * 0;
    dens -= dens_offset;
    --light;

    /* Function Body */
    big = (float)1e20;
    small = (float)1e-10;
/* Computing 2nd power */
    r__1 = small;
    small2 = r__1 * r__1;
    dsmal2 = (doublereal) small2;
    if (eye[3] <= small) {
	return 0;
    }
    if (*n1 < 1 || *n2 < 1) {
	return 0;
    }
    drange = *dhigh - *dlow;
    if (drange <= small) {
	return 0;
    }
/* Computing 2nd power */
    r__1 = light[1];
/* Computing 2nd power */
    r__2 = light[2];
/* Computing 2nd power */
    r__3 = light[3];
    xl2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
    if (xl2 < small) {
	return 0;
    }
    for (i__ = 1; i__ <= 3; ++i__) {
	bas[i__ - 1] = latice[i__ + 6] - latice[i__ + 3];
	bas[i__ + 2] = latice[i__ + 9] - latice[i__ + 3];
/* L10: */
    }
    cx = bas[1] * bas[5] - bas[4] * bas[2];
    cy = bas[2] * bas[3] - bas[5] * bas[0];
    cz = bas[0] * bas[4] - bas[3] * bas[1];
/* Computing 2nd power */
    r__1 = cx;
/* Computing 2nd power */
    r__2 = cy;
/* Computing 2nd power */
    r__3 = cz;
/* Computing 2nd power */
    r__4 = small;
    cscl = *dvert / sqrt(r__1 * r__1 + r__2 * r__2 + r__3 * r__3 + r__4 * 
	    r__4);
    bas[6] = cx * cscl;
    bas[7] = cy * cscl;
    bas[8] = cz * cscl;
    dmin__ = dmin(*dlow,(float)0.);
    dmax__ = dmax(*dhigh,(float)0.);
    orgscl = dmin__ / (dmax__ - dmin__ + small);
    for (i__ = 1; i__ <= 3; ++i__) {
	latic2[i__ - 1] = latice[i__ + 3] + orgscl * bas[i__ + 5];
	latic2[i__ + 2] = latic2[i__ - 1] + bas[i__ - 1];
	latic2[i__ + 5] = latic2[i__ - 1] + bas[i__ + 2];
	latic2[i__ + 8] = latic2[i__ - 1] + bas[i__ + 5];
/* L11: */
    }
    if (latic2[2] >= (float)0.) {
	return 0;
    }
    zfar = latic2[5] + latic2[8] + latic2[11] - latic2[2] * (float)2.;
    if (zfar >= (float)0.) {
	return 0;
    }
    for (j = 1; j <= 3; ++j) {
	if (latic2[(j + 1) * 3 - 1] >= (float)0.) {
	    return 0;
	}
	if (zfar - bas[j * 3 - 1] >= (float)0.) {
	    return 0;
	}
/* Computing 2nd power */
	r__1 = bas[j * 3 - 3];
/* Computing 2nd power */
	r__2 = bas[j * 3 - 2];
/* Computing 2nd power */
	r__3 = bas[j * 3 - 1];
	bas2j = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
	if (bas2j < small2) {
	    return 0;
	}
/* L12: */
    }
    eylat1 = eye[1] - latic2[0];
    eylat2 = eye[2] - latic2[1];
    ntot = (*n1 + 1) * (*n2 + 1);

/* Set up matrix for real-space to lattice-index transformation. */

    safe = (float)1e-4;
    xn1 = (real) (*n1) * (float).99999;
    xn2 = (real) (*n2) * (float).99999;
    xn3 = (float).99999;
    det = bas[0] * bas[4] * bas[8] + bas[3] * bas[7] * bas[2] + bas[6] * bas[
	    1] * bas[5] - bas[2] * bas[4] * bas[6] - bas[5] * bas[7] * bas[0] 
	    - bas[8] * bas[1] * bas[3];
    if (dabs(det) < small2) {
	return 0;
    }
    detnrm = (float)1. / det;
    mtrx[0] = xn1 * detnrm * (bas[4] * bas[8] - bas[7] * bas[5]);
    mtrx[3] = xn2 * detnrm * (bas[7] * bas[2] - bas[1] * bas[8]);
    mtrx[6] = xn3 * detnrm * (bas[1] * bas[5] - bas[4] * bas[2]);
    mtrx[1] = xn1 * detnrm * (bas[5] * bas[6] - bas[8] * bas[3]);
    mtrx[4] = xn2 * detnrm * (bas[8] * bas[0] - bas[2] * bas[6]);
    mtrx[7] = xn3 * detnrm * (bas[2] * bas[3] - bas[5] * bas[0]);
    mtrx[2] = xn1 * detnrm * (bas[3] * bas[7] - bas[6] * bas[4]);
    mtrx[5] = xn2 * detnrm * (bas[6] * bas[1] - bas[0] * bas[7]);
    mtrx[8] = xn3 * detnrm * (bas[0] * bas[4] - bas[3] * bas[1]);

/* Some general initialisations. */

    grdscl[0] = -((real) (*n1));
    grdscl[1] = -((real) (*n2));
    grdscl[2] = (float)1. / drange;
    if (*ic2 < *ic1) {
	return 0;
    }
/* Computing MAX */
    i__1 = (*ic2 - *ic1 + 1) / max(*ncband,1);
    nshads = max(i__1,1);
    colscl = (real) (nshads - 1);
    col0 = (real) (*ic1);
    dkscl = (real) ((*ic2 - *ic1 + 1) / nshads) * (float).9999;
    dx = (real) (sftbuf_1.nxp - 1) / (sftbuf_1.xtrc - sftbuf_1.xblc);
    dy = (real) (sftbuf_1.nyp - 1) / (sftbuf_1.ytrc - sftbuf_1.yblc);
    dyj = (float)1. / dy;
    dxi = (float)1. / dx;

/* New algorithm here: divide each box of 4 grid-points into four */
/* triangles and paint them. */

    i__1 = *n2;
    for (jlat = 1; jlat <= i__1; ++jlat) {
	i__2 = *n1;
	for (ilat = 1; ilat <= i__2; ++ilat) {
	    sb2sr1_(&ilat, &jlat, &dens[dens_offset], n1, n2, dlow, &drange, 
		    bas, latic2, vert);
	    for (iv = 1; iv <= 4; ++iv) {
		sbrcop_(&vert[iv * 3 - 3], &vert[15], &c__6);
		xmin = big;
		xmax = -big;
		ymin = big;
		ymax = -big;
		for (i__ = 1; i__ <= 3; ++i__) {
		    ii = i__ + 5;
		    sblin1_(&eye[1], &vert[ii * 3 - 3], &vert[ii * 3 - 2], &
			    vert[ii * 3 - 1], &xw[i__ - 1], &yw[i__ - 1]);
		    if (xw[i__ - 1] < xmin) {
			xmin = xw[i__ - 1];
			ileft = i__;
		    }
		    if (yw[i__ - 1] < ymin) {
			ymin = yw[i__ - 1];
			jbotom = i__;
		    }
/* Computing MAX */
		    r__1 = xw[i__ - 1];
		    xmax = dmax(r__1,xmax);
/* Computing MAX */
		    r__1 = yw[i__ - 1];
		    ymax = dmax(r__1,ymax);
/* L20: */
		}
		if (xmin >= sftbuf_1.xtrc || xmax <= sftbuf_1.xblc) {
		    goto L50;
		}
		if (ymin >= sftbuf_1.ytrc || ymax <= sftbuf_1.yblc) {
		    goto L50;
		}
		ax = vert[18] - vert[15];
		ay = vert[19] - vert[16];
		az = vert[20] - vert[17];
		bx = vert[15] - vert[21];
		by = vert[16] - vert[22];
		bz = vert[17] - vert[23];
		xn = by * az - ay * bz;
		yn = bz * ax - az * bx;
		zn = bx * ay - ax * by;
		ten = xn * (eye[1] - vert[15]) + yn * (eye[2] - vert[16]) + 
			zn * (eye[3] - vert[17]);
		xlnorm = (doublereal) ten;
		eyenrm = xn * eye[1] + yn * eye[2] + zn * eye[3];
		safer = (float)1e-4;
		if (xmax - xmin > ymax - ymin) {
		    jymin = (integer) ((ymin - sftbuf_1.yblc) * dy) + 2;
/* Computing MIN */
		    i__3 = (integer) ((ymax - sftbuf_1.yblc) * dy) + 1;
		    jymax = min(i__3,sftbuf_1.nyp);
		    if (jymin > jymax) {
			goto L50;
		    }
		    yj = sftbuf_1.yblc + ((real) (jymin - 1) + safer) * dyj;
		    nvl2 = jbotom;
		    nvr2 = jbotom;
		    j1 = jymin;
		    for (ivert = 1; ivert <= 3; ++ivert) {
			if (yj > yw[nvl2 - 1]) {
L1:
			    nvl1 = nvl2;
			    nvl2 = nvl1 - 1;
			    if (nvl2 < 1) {
				nvl2 = 3;
			    }
			    if (nvl2 == jbotom) {
				goto L50;
			    }
			    if (yj > yw[nvl2 - 1]) {
				goto L1;
			    }
			    ydifl = yw[nvl2 - 1] - yw[nvl1 - 1];
			    if (dabs(ydifl) < small) {
				ydifl = small;
			    }
			    gradl = (xw[nvl2 - 1] - xw[nvl1 - 1]) / ydifl;
			}
			if (yj > yw[nvr2 - 1]) {
L2:
			    nvr1 = nvr2;
			    nvr2 = nvr1 + 1;
			    if (nvr2 > 3) {
				nvr2 = 1;
			    }
			    if (nvr2 == jbotom) {
				goto L50;
			    }
			    if (yj > yw[nvr2 - 1]) {
				goto L2;
			    }
			    ydifr = yw[nvr2 - 1] - yw[nvr1 - 1];
			    if (dabs(ydifr) < small) {
				ydifr = small;
			    }
			    gradr = (xw[nvr2 - 1] - xw[nvr1 - 1]) / ydifr;
			}
			if (yw[nvl2 - 1] < yw[nvr2 - 1]) {
/* Computing MIN */
			    i__3 = (integer) ((yw[nvl2 - 1] - sftbuf_1.yblc) *
				     dy) + 1;
			    j2 = min(i__3,jymax);
			} else {
/* Computing MIN */
			    i__3 = (integer) ((yw[nvr2 - 1] - sftbuf_1.yblc) *
				     dy) + 1;
			    j2 = min(i__3,jymax);
			}
			i__3 = j2;
			for (j = j1; j <= i__3; ++j) {
			    if (j >= 1) {
				xl = xw[nvl1 - 1] + gradl * (yj - yw[nvl1 - 1]
					);
				xr = xw[nvr1 - 1] + gradr * (yj - yw[nvr1 - 1]
					);
				istep = 1;
/* Computing MAX */
				i__4 = (integer) ((xl - sftbuf_1.xblc) * dx) 
					+ 2;
				ix1 = max(i__4,1);
/* Computing MIN */
				i__4 = (integer) ((xr - sftbuf_1.xblc) * dx) 
					+ 1;
				ix2 = min(i__4,sftbuf_1.nxp);
				if (ix1 > ix2) {
				    istep = -1;
/* Computing MIN */
				    i__4 = ix1 - 1;
				    ix1 = min(i__4,sftbuf_1.nxp);
/* Computing MAX */
				    i__4 = ix2 + 1;
				    ix2 = max(i__4,1);
				}
				xi = sftbuf_1.xblc + (real) (ix1 - 1) * dxi;
				dxistp = (real) istep * dxi;
				dzz = (doublereal) (dxistp * xn);
				zz = (doublereal) (eyenrm - xi * xn - yj * yn)
					;
				k = (j - 1) * sftbuf_1.nxp + ix1;
				i__4 = ix2;
				i__5 = istep;
				for (i__ = ix1; i__5 < 0 ? i__ >= i__4 : i__ 
					<= i__4; i__ += i__5) {
				    xlamda = (real) (xlnorm / zz);
				    z__ = eye[3] * ((float)1. - xlamda);
				    if (z__ > sftbuf_1.sbbuff[k - 1]) {
					sftbuf_1.sbbuff[k - 1] = z__;
					if (*ic1 == *ic2) {
					    sftbuf_1.sbbuff[k + 
						    sftbuf_1.kstart - 1] = 
						    col0;
					} else {
					    xdi = eylat1 + xlamda * (xi - eye[
						    1]);
					    ydj = eylat2 + xlamda * (yj - eye[
						    2]);
					    zdk = z__ - latic2[2];
					    if (*ncband > 1) {
/* Computing MAX */
/* Computing MIN */
			  r__2 = xdi * mtrx[6] + ydj * mtrx[7] + zdk * mtrx[8]
				  ;
			  r__1 = dmin(r__2,xn3);
			  dk = dmax(r__1,safe);
			  col0 = (real) (*ic1 + nshads * (integer) (dk * 
				  dkscl));
					    }
/* Computing MAX */
/* Computing MIN */
					    r__2 = xdi * mtrx[0] + ydj * mtrx[
						    1] + zdk * mtrx[2];
					    r__1 = dmin(r__2,xn1);
					    di = dmax(r__1,safe);
/* Computing MAX */
/* Computing MIN */
					    r__2 = xdi * mtrx[3] + ydj * mtrx[
						    4] + zdk * mtrx[5];
					    r__1 = dmin(r__2,xn2);
					    dj = dmax(r__1,safe);
					    sb2sr3_(&dens[dens_offset], n1, 
						    n2, &di, &dj, bas, &gx, &
						    gy, &gz, grdscl);
					    sb2sr4_(&eye[1], &xi, &yj, &c_b14,
						     &gx, &gy, &gz, &light[1],
						     &xl2, &small2, lshine, &
						    colour);
					    sftbuf_1.sbbuff[k + 
						    sftbuf_1.kstart - 1] = 
						    col0 + colour * colscl;
					}
				    }
				    xi += dxistp;
				    zz -= dzz;
				    k += istep;
/* L28: */
				}
			    }
			    yj += dyj;
/* L29: */
			}
			j1 = j2 + 1;
			if (j1 > jymax) {
			    goto L50;
			}
/* L30: */
		    }
		} else {
		    ixmin = (integer) ((xmin - sftbuf_1.xblc) * dx) + 2;
/* Computing MIN */
		    i__3 = (integer) ((xmax - sftbuf_1.xblc) * dx) + 1;
		    ixmax = min(i__3,sftbuf_1.nxp);
		    if (ixmin > ixmax) {
			goto L50;
		    }
		    xi = sftbuf_1.xblc + ((real) (ixmin - 1) + safer) * dxi;
		    nvl2 = ileft;
		    nvr2 = ileft;
		    i1 = ixmin;
		    for (ivert = 1; ivert <= 3; ++ivert) {
			if (xi > xw[nvl2 - 1]) {
L3:
			    nvl1 = nvl2;
			    nvl2 = nvl1 - 1;
			    if (nvl2 < 1) {
				nvl2 = 3;
			    }
			    if (nvl2 == ileft) {
				goto L50;
			    }
			    if (xi > xw[nvl2 - 1]) {
				goto L3;
			    }
			    xdifl = xw[nvl2 - 1] - xw[nvl1 - 1];
			    if (dabs(xdifl) < small) {
				xdifl = small;
			    }
			    gradl = (yw[nvl2 - 1] - yw[nvl1 - 1]) / xdifl;
			}
			if (xi > xw[nvr2 - 1]) {
L4:
			    nvr1 = nvr2;
			    nvr2 = nvr1 + 1;
			    if (nvr2 > 3) {
				nvr2 = 1;
			    }
			    if (nvr2 == ileft) {
				goto L50;
			    }
			    if (xi > xw[nvr2 - 1]) {
				goto L4;
			    }
			    xdifr = xw[nvr2 - 1] - xw[nvr1 - 1];
			    if (dabs(xdifr) < small) {
				xdifr = small;
			    }
			    gradr = (yw[nvr2 - 1] - yw[nvr1 - 1]) / xdifr;
			}
			if (xw[nvl2 - 1] < xw[nvr2 - 1]) {
/* Computing MIN */
			    i__3 = (integer) ((xw[nvl2 - 1] - sftbuf_1.xblc) *
				     dx) + 1;
			    i2 = min(i__3,ixmax);
			} else {
/* Computing MIN */
			    i__3 = (integer) ((xw[nvr2 - 1] - sftbuf_1.xblc) *
				     dx) + 1;
			    i2 = min(i__3,ixmax);
			}
			i__3 = i2;
			for (i__ = i1; i__ <= i__3; ++i__) {
			    if (i__ >= 1) {
				yl = yw[nvl1 - 1] + gradl * (xi - xw[nvl1 - 1]
					);
				yr = yw[nvr1 - 1] + gradr * (xi - xw[nvr1 - 1]
					);
				jstep = 1;
/* Computing MAX */
				i__5 = (integer) ((yl - sftbuf_1.yblc) * dy) 
					+ 2;
				jy1 = max(i__5,1);
/* Computing MIN */
				i__5 = (integer) ((yr - sftbuf_1.yblc) * dy) 
					+ 1;
				jy2 = min(i__5,sftbuf_1.nyp);
				if (jy1 > jy2) {
				    jstep = -1;
/* Computing MIN */
				    i__5 = jy1 - 1;
				    jy1 = min(i__5,sftbuf_1.nyp);
/* Computing MAX */
				    i__5 = jy2 + 1;
				    jy2 = max(i__5,1);
				}
				yj = sftbuf_1.yblc + (real) (jy1 - 1) * dyj;
				dyjstp = (real) jstep * dyj;
				dzz = (doublereal) (dyjstp * yn);
				zz = (doublereal) (eyenrm - yj * yn - xi * xn)
					;
				k = (jy1 - 1) * sftbuf_1.nxp + i__;
				kstep = jstep * sftbuf_1.nxp;
				i__5 = jy2;
				i__4 = jstep;
				for (j = jy1; i__4 < 0 ? j >= i__5 : j <= 
					i__5; j += i__4) {
				    xlamda = (real) (xlnorm / zz);
				    z__ = eye[3] * ((float)1. - xlamda);
				    if (z__ > sftbuf_1.sbbuff[k - 1]) {
					sftbuf_1.sbbuff[k - 1] = z__;
					if (*ic1 == *ic2) {
					    sftbuf_1.sbbuff[k + 
						    sftbuf_1.kstart - 1] = 
						    col0;
					} else {
					    xdi = eylat1 + xlamda * (xi - eye[
						    1]);
					    ydj = eylat2 + xlamda * (yj - eye[
						    2]);
					    zdk = z__ - latic2[2];
					    if (*ncband > 1) {
/* Computing MAX */
/* Computing MIN */
			  r__2 = xdi * mtrx[6] + ydj * mtrx[7] + zdk * mtrx[8]
				  ;
			  r__1 = dmin(r__2,xn3);
			  dk = dmax(r__1,safe);
			  col0 = (real) (*ic1 + nshads * (integer) (dk * 
				  dkscl));
					    }
/* Computing MAX */
/* Computing MIN */
					    r__2 = xdi * mtrx[0] + ydj * mtrx[
						    1] + zdk * mtrx[2];
					    r__1 = dmin(r__2,xn1);
					    di = dmax(r__1,safe);
/* Computing MAX */
/* Computing MIN */
					    r__2 = xdi * mtrx[3] + ydj * mtrx[
						    4] + zdk * mtrx[5];
					    r__1 = dmin(r__2,xn2);
					    dj = dmax(r__1,safe);
					    sb2sr3_(&dens[dens_offset], n1, 
						    n2, &di, &dj, bas, &gx, &
						    gy, &gz, grdscl);
					    sb2sr4_(&eye[1], &xi, &yj, &c_b14,
						     &gx, &gy, &gz, &light[1],
						     &xl2, &small2, lshine, &
						    colour);
					    sftbuf_1.sbbuff[k + 
						    sftbuf_1.kstart - 1] = 
						    col0 + colour * colscl;
					}
				    }
				    yj += dyjstp;
				    zz -= dzz;
				    k += kstep;
/* L38: */
				}
			    }
			    xi += dxi;
/* L39: */
			}
			i1 = i2 + 1;
			if (i1 > ixmax) {
			    goto L50;
			}
/* L40: */
		    }
		}
L50:
		;
	    }
/* L60: */
	}
/* L70: */
    }
} /* sb2srf_ */


/* Subroutine */ int sb2sr1_(i1, j1, dens, n1, n2, dlow, drange, bas, latice, 
	vert)
integer *i1, *j1;
real *dens;
integer *n1, *n2;
real *dlow, *drange, *bas, *latice, *vert;
{
    /* System generated locals */
    integer dens_dim1, dens_offset;
    real r__1, r__2;

    /* Local variables */
    static integer i0, j0;
    static real xnorm, ynorm, znorm, x0, x1, y0, y1, d00, d10, d11, d01, dm, 
	    xm, ym;

/*     --------------------------------------------------------------- */


    /* Parameter adjustments */
    dens_dim1 = *n1 - 0 + 1;
    dens_offset = 0 + dens_dim1 * 0;
    dens -= dens_offset;
    bas -= 4;
    --latice;
    vert -= 4;

    /* Function Body */
    i0 = *i1 - 1;
    j0 = *j1 - 1;
    xnorm = (float)1. / (real) (*n1);
    ynorm = (float)1. / (real) (*n2);
    znorm = (float)1. / *drange;
/* Computing MAX */
/* Computing MIN */
    r__2 = (dens[i0 + j0 * dens_dim1] - *dlow) * znorm;
    r__1 = dmin(r__2,(float)1.);
    d00 = dmax(r__1,(float)0.);
/* Computing MAX */
/* Computing MIN */
    r__2 = (dens[*i1 + j0 * dens_dim1] - *dlow) * znorm;
    r__1 = dmin(r__2,(float)1.);
    d10 = dmax(r__1,(float)0.);
/* Computing MAX */
/* Computing MIN */
    r__2 = (dens[*i1 + *j1 * dens_dim1] - *dlow) * znorm;
    r__1 = dmin(r__2,(float)1.);
    d11 = dmax(r__1,(float)0.);
/* Computing MAX */
/* Computing MIN */
    r__2 = (dens[i0 + *j1 * dens_dim1] - *dlow) * znorm;
    r__1 = dmin(r__2,(float)1.);
    d01 = dmax(r__1,(float)0.);
    x0 = (real) i0 * xnorm;
    x1 = (real) (*i1) * xnorm;
    y0 = (real) j0 * ynorm;
    y1 = (real) (*j1) * ynorm;
    vert[4] = x0 * bas[4] + y0 * bas[7] + d00 * bas[10] + latice[1];
    vert[5] = x0 * bas[5] + y0 * bas[8] + d00 * bas[11] + latice[2];
    vert[6] = x0 * bas[6] + y0 * bas[9] + d00 * bas[12] + latice[3];
    vert[7] = x1 * bas[4] + y0 * bas[7] + d10 * bas[10] + latice[1];
    vert[8] = x1 * bas[5] + y0 * bas[8] + d10 * bas[11] + latice[2];
    vert[9] = x1 * bas[6] + y0 * bas[9] + d10 * bas[12] + latice[3];
    vert[10] = x1 * bas[4] + y1 * bas[7] + d11 * bas[10] + latice[1];
    vert[11] = x1 * bas[5] + y1 * bas[8] + d11 * bas[11] + latice[2];
    vert[12] = x1 * bas[6] + y1 * bas[9] + d11 * bas[12] + latice[3];
    vert[13] = x0 * bas[4] + y1 * bas[7] + d01 * bas[10] + latice[1];
    vert[14] = x0 * bas[5] + y1 * bas[8] + d01 * bas[11] + latice[2];
    vert[15] = x0 * bas[6] + y1 * bas[9] + d01 * bas[12] + latice[3];
    vert[16] = vert[4];
    vert[17] = vert[5];
    vert[18] = vert[6];
    xm = (real) (i0 + *i1) * (float).5 * xnorm;
    ym = (real) (j0 + *j1) * (float).5 * ynorm;
    dm = (dens[i0 + j0 * dens_dim1] + dens[*i1 + j0 * dens_dim1] + dens[*i1 + 
	    *j1 * dens_dim1] + dens[i0 + *j1 * dens_dim1]) * (float).25;
/* Computing MAX */
/* Computing MIN */
    r__2 = (dm - *dlow) * znorm;
    r__1 = dmin(r__2,(float)1.);
    dm = dmax(r__1,(float)0.);
    vert[25] = xm * bas[4] + ym * bas[7] + dm * bas[10] + latice[1];
    vert[26] = xm * bas[5] + ym * bas[8] + dm * bas[11] + latice[2];
    vert[27] = xm * bas[6] + ym * bas[9] + dm * bas[12] + latice[3];
} /* sb2sr1_ */


/* Subroutine */ int sb2sr3_(dens, n1, n2, xi, yj, bas, xn, yn, zn, grdscl)
real *dens;
integer *n1, *n2;
real *xi, *yj, *bas, *xn, *yn, *zn, *grdscl;
{
    /* System generated locals */
    integer dens_dim1, dens_offset;

    /* Local variables */
    static integer i__, j;
    extern /* Subroutine */ int s2sr3a_();
    static integer i0, j0;
    static real x0, y0;
    static integer ii, jj, im, jm, ip, jp;
    static real dx, dy, gx, gy, gz, xm, xp, ym, yp, ddx, ddy;

/*     ------------------------------------------------------- */


    /* Parameter adjustments */
    dens_dim1 = *n1 - 0 + 1;
    dens_offset = 0 + dens_dim1 * 0;
    dens -= dens_offset;
    bas -= 4;
    --grdscl;

    /* Function Body */
    i__ = (integer) (*xi);
    j = (integer) (*yj);
    ii = i__ + 1;
    jj = j + 1;
    dx = *xi - (real) i__;
    dy = *yj - (real) j;
    s2sr3a_(&i__, &dx, n1, &im, &i0, &ip, &ddx);
    xm = dens[im + j * dens_dim1] + dy * (dens[im + jj * dens_dim1] - dens[im 
	    + j * dens_dim1]);
    x0 = dens[i0 + j * dens_dim1] + dy * (dens[i0 + jj * dens_dim1] - dens[i0 
	    + j * dens_dim1]);
    xp = dens[ip + j * dens_dim1] + dy * (dens[ip + jj * dens_dim1] - dens[ip 
	    + j * dens_dim1]);
    gx = grdscl[1] * grdscl[3] * (((float)1. - ddx) * (x0 - xm) + ddx * (xp - 
	    x0));
    s2sr3a_(&j, &dy, n2, &jm, &j0, &jp, &ddy);
    ym = dens[i__ + jm * dens_dim1] + dx * (dens[ii + jm * dens_dim1] - dens[
	    i__ + jm * dens_dim1]);
    y0 = dens[i__ + j0 * dens_dim1] + dx * (dens[ii + j0 * dens_dim1] - dens[
	    i__ + j0 * dens_dim1]);
    yp = dens[i__ + jp * dens_dim1] + dx * (dens[ii + jp * dens_dim1] - dens[
	    i__ + jp * dens_dim1]);
    gy = grdscl[2] * grdscl[3] * (((float)1. - ddy) * (y0 - ym) + ddy * (yp - 
	    y0));
    gz = (float)1.;
    *xn = gx * bas[4] + gy * bas[7] + gz * bas[10];
    *yn = gx * bas[5] + gy * bas[8] + gz * bas[11];
    *zn = gx * bas[6] + gy * bas[9] + gz * bas[12];
} /* sb2sr3_ */


/* Subroutine */ int s2sr3a_(i__, dx, nx, im, i0, ip, ddx)
integer *i__;
real *dx;
integer *nx, *im, *i0, *ip;
real *ddx;
{
/*     --------------------------------------- */

    if (*dx < (float).5) {
	*ddx = *dx + (float).5;
	*i0 = *i__;
	*im = *i0 - 1;
	*ip = *i0 + 1;
	if (*im < 0) {
	    *im = *nx;
	}
    } else {
	*ddx = *dx - (float).5;
	*i0 = *i__ + 1;
	*im = *i0 - 1;
	*ip = *i0 + 1;
	if (*ip > *nx) {
	    *ip = 0;
	}
    }
} /* s2sr3a_ */


/* Subroutine */ int sb2sr4_(eye, x, y, z__, xn, yn, zn, light, xl2, small2, 
	lshine, colour)
real *eye, *x, *y, *z__, *xn, *yn, *zn, *light, *xl2, *small2;
logical *lshine;
real *colour;
{
    /* System generated locals */
    real r__1, r__2, r__3;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static real v2, rx, ry, rz, vx, vy, vz, rfnorm, xn2, xnl, xrv;

/*     ------------------------------------------------------------- */


    /* Parameter adjustments */
    --light;
    --eye;

    /* Function Body */
    *colour = (float)0.;
    xnl = *xn * light[1] + *yn * light[2] + *zn * light[3];
    if (xnl >= (float)0.) {
	return 0;
    }
/* Computing 2nd power */
    r__1 = *xn;
/* Computing 2nd power */
    r__2 = *yn;
/* Computing 2nd power */
    r__3 = *zn;
    xn2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3 + *small2;
    if (*lshine) {
	rfnorm = xnl * (float)2. / xn2;
	rx = light[1] - *xn * rfnorm;
	ry = light[2] - *yn * rfnorm;
	rz = light[3] - *zn * rfnorm;
	vx = eye[1] - *x;
	vy = eye[2] - *y;
	vz = eye[3] - *z__;
	xrv = rx * vx + ry * vy + rz * vz;
	if (xrv < (float)0.) {
	    return 0;
	}
/* Computing 2nd power */
	r__1 = vx;
/* Computing 2nd power */
	r__2 = vy;
/* Computing 2nd power */
	r__3 = vz;
	v2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
/* Computing MIN */
/* Computing 2nd power */
	r__3 = xrv;
	r__2 = r__3 * r__3 / ((r__1 = *xl2 * v2, dabs(r__1)) + *small2);
	*colour = dmin(r__2,(float)1.);
    } else {
/* Computing MIN */
	r__2 = -xnl / sqrt((r__1 = *xl2 * xn2, dabs(r__1)) + *small2);
	*colour = dmin(r__2,(float)1.);
    }
} /* sb2sr4_ */


/* Subroutine */ int sbplnt_(eye, nv, vert, ic1, ic2, light, itrans)
real *eye;
integer *nv;
real *vert;
integer *ic1, *ic2;
real *light;
integer *itrans;
{
    /* System generated locals */
    integer i__1, i__2, i__3, i__4;
    real r__1, r__2, r__3;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static real xmin, ymin, xmax, ymax;
    static integer i__, j, k;
    static real gradl, z__, gradr, safer;
    static integer ileft;
    static real xdifl, small, ydifl, xdifr, ydifr;
    static integer istep, ixmin, jymin, ixmax, jymax, ivert, jtest, j1, j2, 
	    itest, i1, i2, kstep;
    extern /* Subroutine */ int sblin1_();
    static real small2;
    static integer nc;
    static real ax, ay, az, bx, by, bz, dx, dy, yj, xl, xn, yn, zn, cosdif, 
	    xr, xi, yl, yr, xw[400], yw[400];
    static doublereal zz;
    static integer jbotom, itlevl;
    static real eyenrm, colour;
    static doublereal xlnorm;
    static real tl2;
    static integer ix1;
    static real tn2;
    static integer ix2, jy1, jy2;
    static real dxi, ten, dyj, tnl;
    static doublereal dzz;
    static integer nvl1, nvl2, nvr1, nvr2;

/*     --------------------------------------------------- */



/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      This subroutine plots a diffusively-lit, semi-transparent, */
/*    coloured plane; the use must ensure that all the verticies lie in a */
/*    flat plane, and that the bounding polygon be convex (so that the */
/*    angle at any vertex <= 180 degs). All (x,y,z) values are taken to */
/*    be given in world coordinates. The z-component of the eye-poisition */
/*    should be positive and that of the vertices should be negative; the */
/*    viewing-screen is fixed at z=0. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    EYE      R*4    I       3      (x,y,z) coordinate of eye-position. */
/*    NV       R*4    I       -      No. of verticies (>=3). */
/*    VERT     R*4    I     3 x NV   (x,y,z) coordinate of verticies. */
/*    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be */
/*                                   used for the shading. */
/*    LIGHT    R*4    I       3      (x,y,z) direction of flood-light. */
/*    ITRANS   I*4    I       -      Level of transparency: */
/*                                        1 = 25%; 2 = 50%; 3 = 75%. */

/* Globals */
/*    SFTBUF */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     SBLIN1     Calculates the projection of (x,y,z) on viewing screen. */

/* History */
/*   D. S. Sivia      21 Aug 1995  Initial release. */
/*   D. S. Sivia      24 Oct 1997 "Safe-guarded" some rounding errors. */
/* ----------------------------------------------------------------------- */

/* Carry out some initial checks and calculate the coordinates of the */
/* projected polygon. */

    /* Parameter adjustments */
    --light;
    vert -= 4;
    --eye;

    /* Function Body */
    small = (float)1e-10;
/* Computing 2nd power */
    r__1 = small;
    small2 = r__1 * r__1;
    if (eye[3] <= small) {
	return 0;
    }
    if (*nv < 3 || *nv > 400) {
	return 0;
    }
    i__1 = *nv;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L10: */
	if (vert[i__ * 3 + 3] >= (float)0.) {
	    return 0;
	}
    }
    xmin = (float)1e20;
    xmax = (float)-1e20;
    ymin = (float)1e20;
    ymax = (float)-1e20;
    i__1 = *nv;
    for (i__ = 1; i__ <= i__1; ++i__) {
	sblin1_(&eye[1], &vert[i__ * 3 + 1], &vert[i__ * 3 + 2], &vert[i__ * 
		3 + 3], &xw[i__ - 1], &yw[i__ - 1]);
	if (xw[i__ - 1] < xmin) {
	    xmin = xw[i__ - 1];
	    ileft = i__;
	}
	if (yw[i__ - 1] < ymin) {
	    ymin = yw[i__ - 1];
	    jbotom = i__;
	}
/* Computing MAX */
	r__1 = xw[i__ - 1];
	xmax = dmax(r__1,xmax);
/* Computing MAX */
	r__1 = yw[i__ - 1];
	ymax = dmax(r__1,ymax);
/* L20: */
    }
    if (xmin >= sftbuf_1.xtrc || xmax <= sftbuf_1.xblc) {
	return 0;
    }
    if (ymin >= sftbuf_1.ytrc || ymax <= sftbuf_1.yblc) {
	return 0;
    }

/* Find the outward normal seen by the eye, and activate the appropriate */
/* colour. */

    ax = vert[7] - vert[4];
    ay = vert[8] - vert[5];
    az = vert[9] - vert[6];
    bx = vert[4] - vert[*nv * 3 + 1];
    by = vert[5] - vert[*nv * 3 + 2];
    bz = vert[6] - vert[*nv * 3 + 3];
    xn = by * az - ay * bz;
    yn = bz * ax - az * bx;
    zn = bx * ay - ax * by;
    ten = xn * (eye[1] - vert[4]) + yn * (eye[2] - vert[5]) + zn * (eye[3] - 
	    vert[6]);
    colour = (real) (*ic1);
    nc = *ic2 - *ic1;
    if (nc > 0) {
	tnl = xn * light[1] + yn * light[2] + zn * light[3];
	if (ten < (float)0.) {
	    tnl = -tnl;
	}
	cosdif = (float)0.;
	if (tnl < (float)0.) {
/* Computing 2nd power */
	    r__1 = xn;
/* Computing 2nd power */
	    r__2 = yn;
/* Computing 2nd power */
	    r__3 = zn;
	    tn2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
/* Computing 2nd power */
	    r__1 = light[1];
/* Computing 2nd power */
	    r__2 = light[2];
/* Computing 2nd power */
	    r__3 = light[3];
	    tl2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
/* Computing MIN */
	    r__1 = -tnl / sqrt(tn2 * tl2 + small2);
	    cosdif = dmin(r__1,(float)1.);
	}
	colour += cosdif * (real) nc;
    }

/* Plot the projected polygon. */

/* Computing MAX */
    i__1 = min(*itrans,3);
    itlevl = max(i__1,1);
    xlnorm = (doublereal) eye[3] * (doublereal) ten;
    eyenrm = xn * eye[1] + yn * eye[2] + zn * eye[3];
    dx = (real) (sftbuf_1.nxp - 1) / (sftbuf_1.xtrc - sftbuf_1.xblc);
    dy = (real) (sftbuf_1.nyp - 1) / (sftbuf_1.ytrc - sftbuf_1.yblc);
    dyj = (float)1. / dy;
    dxi = (float)1. / dx;
    safer = (float)1e-4;
    if (xmax - xmin > ymax - ymin) {
	jymin = (integer) ((ymin - sftbuf_1.yblc) * dy) + 2;
/* Computing MIN */
	i__1 = (integer) ((ymax - sftbuf_1.yblc) * dy) + 1;
	jymax = min(i__1,sftbuf_1.nyp);
	if (jymin > jymax) {
	    return 0;
	}
	yj = sftbuf_1.yblc + ((real) (jymin - 1) + safer) * dyj;
	nvl2 = jbotom;
	nvr2 = jbotom;
	j1 = jymin;
	i__1 = *nv;
	for (ivert = 1; ivert <= i__1; ++ivert) {
	    if (yj > yw[nvl2 - 1]) {
L1:
		nvl1 = nvl2;
		nvl2 = nvl1 - 1;
		if (nvl2 < 1) {
		    nvl2 = *nv;
		}
		if (nvl2 == jbotom) {
		    return 0;
		}
		if (yj > yw[nvl2 - 1]) {
		    goto L1;
		}
		ydifl = yw[nvl2 - 1] - yw[nvl1 - 1];
		if (dabs(ydifl) < small) {
		    ydifl = small;
		}
		gradl = (xw[nvl2 - 1] - xw[nvl1 - 1]) / ydifl;
	    }
	    if (yj > yw[nvr2 - 1]) {
L2:
		nvr1 = nvr2;
		nvr2 = nvr1 + 1;
		if (nvr2 > *nv) {
		    nvr2 = 1;
		}
		if (nvr2 == jbotom) {
		    return 0;
		}
		if (yj > yw[nvr2 - 1]) {
		    goto L2;
		}
		ydifr = yw[nvr2 - 1] - yw[nvr1 - 1];
		if (dabs(ydifr) < small) {
		    ydifr = small;
		}
		gradr = (xw[nvr2 - 1] - xw[nvr1 - 1]) / ydifr;
	    }
	    if (yw[nvl2 - 1] < yw[nvr2 - 1]) {
/* Computing MIN */
		i__2 = (integer) ((yw[nvl2 - 1] - sftbuf_1.yblc) * dy) + 1;
		j2 = min(i__2,jymax);
	    } else {
/* Computing MIN */
		i__2 = (integer) ((yw[nvr2 - 1] - sftbuf_1.yblc) * dy) + 1;
		j2 = min(i__2,jymax);
	    }
	    i__2 = j2;
	    for (j = j1; j <= i__2; ++j) {
		if (j >= 1) {
		    jtest = j % 2;
		    if (itlevl == 3 && jtest == 1) {
			goto L39;
		    }
		    xl = xw[nvl1 - 1] + gradl * (yj - yw[nvl1 - 1]);
		    xr = xw[nvr1 - 1] + gradr * (yj - yw[nvr1 - 1]);
		    istep = 1;
/* Computing MAX */
		    i__3 = (integer) ((xl - sftbuf_1.xblc) * dx) + 2;
		    ix1 = max(i__3,1);
/* Computing MIN */
		    i__3 = (integer) ((xr - sftbuf_1.xblc) * dx) + 1;
		    ix2 = min(i__3,sftbuf_1.nxp);
		    if (ix1 > ix2) {
			istep = -1;
/* Computing MIN */
			i__3 = ix1 - 1;
			ix1 = min(i__3,sftbuf_1.nxp);
/* Computing MAX */
			i__3 = ix2 + 1;
			ix2 = max(i__3,1);
		    }
		    dzz = (doublereal) ((real) istep * dxi * xn);
		    zz = (doublereal) (eyenrm - (sftbuf_1.xblc + (real) (ix1 
			    - 1) * dxi) * xn - yj * yn);
		    k = (j - 1) * sftbuf_1.nxp + ix1;
		    i__3 = ix2;
		    i__4 = istep;
		    for (i__ = ix1; i__4 < 0 ? i__ >= i__3 : i__ <= i__3; i__ 
			    += i__4) {
			itest = i__ % 2;
			if (itlevl == 1) {
			    if (itest + jtest == 0) {
				goto L29;
			    }
			} else if (itlevl == 2) {
			    if (itest + jtest == 1) {
				goto L29;
			    }
			} else {
			    if (itest == 1) {
				goto L29;
			    }
			}
			z__ = eye[3] - (real) (xlnorm / zz);
			if (z__ > sftbuf_1.sbbuff[k - 1]) {
			    sftbuf_1.sbbuff[k - 1] = z__;
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = colour;
			}
L29:
			zz -= dzz;
			k += istep;
/* L30: */
		    }
		}
L39:
		yj += dyj;
/* L40: */
	    }
	    j1 = j2 + 1;
	    if (j1 > jymax) {
		return 0;
	    }
/* L50: */
	}
    } else {
	ixmin = (integer) ((xmin - sftbuf_1.xblc) * dx) + 2;
/* Computing MIN */
	i__1 = (integer) ((xmax - sftbuf_1.xblc) * dx) + 1;
	ixmax = min(i__1,sftbuf_1.nxp);
	if (ixmin > ixmax) {
	    return 0;
	}
	xi = sftbuf_1.xblc + ((real) (ixmin - 1) + safer) * dxi;
	nvl2 = ileft;
	nvr2 = ileft;
	i1 = ixmin;
	i__1 = *nv;
	for (ivert = 1; ivert <= i__1; ++ivert) {
	    if (xi > xw[nvl2 - 1]) {
L3:
		nvl1 = nvl2;
		nvl2 = nvl1 - 1;
		if (nvl2 < 1) {
		    nvl2 = *nv;
		}
		if (nvl2 == ileft) {
		    return 0;
		}
		if (xi > xw[nvl2 - 1]) {
		    goto L3;
		}
		xdifl = xw[nvl2 - 1] - xw[nvl1 - 1];
		if (dabs(xdifl) < small) {
		    xdifl = small;
		}
		gradl = (yw[nvl2 - 1] - yw[nvl1 - 1]) / xdifl;
	    }
	    if (xi > xw[nvr2 - 1]) {
L4:
		nvr1 = nvr2;
		nvr2 = nvr1 + 1;
		if (nvr2 > *nv) {
		    nvr2 = 1;
		}
		if (nvr2 == ileft) {
		    return 0;
		}
		if (xi > xw[nvr2 - 1]) {
		    goto L4;
		}
		xdifr = xw[nvr2 - 1] - xw[nvr1 - 1];
		if (dabs(xdifr) < small) {
		    xdifr = small;
		}
		gradr = (yw[nvr2 - 1] - yw[nvr1 - 1]) / xdifr;
	    }
	    if (xw[nvl2 - 1] < xw[nvr2 - 1]) {
/* Computing MIN */
		i__2 = (integer) ((xw[nvl2 - 1] - sftbuf_1.xblc) * dx) + 1;
		i2 = min(i__2,ixmax);
	    } else {
/* Computing MIN */
		i__2 = (integer) ((xw[nvr2 - 1] - sftbuf_1.xblc) * dx) + 1;
		i2 = min(i__2,ixmax);
	    }
	    i__2 = i2;
	    for (i__ = i1; i__ <= i__2; ++i__) {
		if (i__ >= 1) {
		    itest = i__ % 2;
		    if (itlevl == 3 && itest == 1) {
			goto L69;
		    }
		    yl = yw[nvl1 - 1] + gradl * (xi - xw[nvl1 - 1]);
		    yr = yw[nvr1 - 1] + gradr * (xi - xw[nvr1 - 1]);
		    istep = 1;
/* Computing MAX */
		    i__4 = (integer) ((yl - sftbuf_1.yblc) * dy) + 2;
		    jy1 = max(i__4,1);
/* Computing MIN */
		    i__4 = (integer) ((yr - sftbuf_1.yblc) * dy) + 1;
		    jy2 = min(i__4,sftbuf_1.nyp);
		    if (jy1 > jy2) {
			istep = -1;
/* Computing MIN */
			i__4 = jy1 - 1;
			jy1 = min(i__4,sftbuf_1.nyp);
/* Computing MAX */
			i__4 = jy2 + 1;
			jy2 = max(i__4,1);
		    }
		    dzz = (doublereal) ((real) istep * dyj * yn);
		    zz = (doublereal) (eyenrm - (sftbuf_1.yblc + (real) (jy1 
			    - 1) * dyj) * yn - xi * xn);
		    k = (jy1 - 1) * sftbuf_1.nxp + i__;
		    kstep = istep * sftbuf_1.nxp;
		    i__4 = jy2;
		    i__3 = istep;
		    for (j = jy1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
			     {
			jtest = j % 2;
			if (itlevl == 1) {
			    if (itest + jtest == 0) {
				goto L59;
			    }
			} else if (itlevl == 2) {
			    if (itest + jtest == 1) {
				goto L59;
			    }
			} else {
			    if (jtest == 1) {
				goto L59;
			    }
			}
			z__ = eye[3] - (real) (xlnorm / zz);
			if (z__ > sftbuf_1.sbbuff[k - 1]) {
			    sftbuf_1.sbbuff[k - 1] = z__;
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = colour;
			}
L59:
			zz -= dzz;
			k += kstep;
/* L60: */
		    }
		}
L69:
		xi += dxi;
/* L70: */
	    }
	    i1 = i2 + 1;
	    if (i1 > ixmax) {
		return 0;
	    }
/* L80: */
	}
    }
} /* sbplnt_ */


/* Subroutine */ int sbelip_(eye, centre, paxes, ic1, ic2, light, lshine, 
	icline, anglin, x0, y0, r0)
real *eye, *centre, *paxes;
integer *ic1, *ic2;
real *light;
logical *lshine;
integer *icline;
real *anglin, *x0, *y0, *r0;
{
    /* System generated locals */
    integer i__1, i__2;
    real r__1, r__2, r__3;
    doublereal d__1, d__2, d__3;

    /* Builtin functions */
    double sqrt(), sin();

    /* Local variables */
    static doublereal alfa, gama, beta;
    static real evec[9]	/* was [3][3] */, xdif, ydif, enrm[3];
    static doublereal duxh, dwze, dvyh;
    static real xmin, ymin, xmax, ymax, surf[3], zmax, eval1, eval2, eval3;
    static doublereal a, b, c__;
    static integer i__, j, k;
    static doublereal q, u, v, w;
    static real corel, small;
    static integer ixmin, ixmax, jymin, jymax;
    static doublereal r1, r2;
    static real ba;
    static integer nc;
    static real dx, dy, yh, xh;
    static integer jy, ix;
    static real coline;
    static doublereal dsmall;
    static real colscl;
    extern /* Subroutine */ int sbegls_();
    static doublereal cosphi;
    static real cosmin;
    static doublereal sinphi;
    static real colour, dotsum, x0h, y0h;
    static doublereal xl0, xl1;
    static real xl2;
    static doublereal det, dxe, dye, dze, dxh, dyh, hyp;
    static real xlm;
    static doublereal xmu, qxx, qxy, qyy, qyz, qzz, qzx, dbl0, dbl1, dbl2;
    static real col0;
    static doublereal dx0h, dze2, dy0h;

/*     --------------------------------------------------------------- */



/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      This subroutine plots a shiny or matt coloured elliptical ball. */
/*    All (x,y,z) values are taken to be given in world coordinates. The */
/*    z-component of the eye-poisition should be positive and that of */
/*    the ball-centre should be negative (< -radius); the viewing-screen */
/*    is fixed at z=0. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    EYE      R*4    I       3      (x,y,z) coordinate of eye-position. */
/*    CENTRE   R*4    I       3      (x,y,z) coordinate of ball-centre. */
/*    PAXES    R*4    I     3 x 3    Principal axes of the elliposid. */
/*    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be */
/*                                   used for shading. */
/*    LIGHT    R*4    I       3      (x,y,z) direction of flood-light. */
/*    LSHINE   L*1    I       -      Shiny ball if .TRUE., else diffuse. */
/*    ICLINE   I*4    I       -      If >=0, colour index for lines on */
/*                                   surface of ellipsoid. */
/*    ANGLIN   R*4    I       -      Width of lines: +/- degs. */
/*    X0,Y0    R*4    O       -      Centre of projected ball. */
/*    R0       R*4    O       -      Average radius of projected ball. */

/* Globals */
/*    SFTBUF */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     SBEGLS     Works out colour-shade for surface of ellipsoid. */

/* History */
/*   D. S. Sivia       8 Sep 1995  Initial release. */
/*   D. S. Sivia      29 Sep 1995  Pass down angular-width of lines. */
/* ----------------------------------------------------------------------- */

/* Set up standard ellipsoid and carry out some initial checks. */

    /* Parameter adjustments */
    --light;
    paxes -= 4;
    --centre;
    --eye;

    /* Function Body */
    small = (float)1e-20;
    dsmall = (doublereal) small;
    if (eye[3] <= (float)0.) {
	return 0;
    }
/* Computing 2nd power */
    r__1 = paxes[4];
/* Computing 2nd power */
    r__2 = paxes[5];
/* Computing 2nd power */
    r__3 = paxes[6];
    eval1 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
/* Computing 2nd power */
    r__1 = paxes[7];
/* Computing 2nd power */
    r__2 = paxes[8];
/* Computing 2nd power */
    r__3 = paxes[9];
    eval2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
/* Computing 2nd power */
    r__1 = paxes[10];
/* Computing 2nd power */
    r__2 = paxes[11];
/* Computing 2nd power */
    r__3 = paxes[12];
    eval3 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
    if (eval1 < small || eval2 < small || eval3 < small) {
	return 0;
    }
    eval1 = (float)1. / eval1;
    eval2 = (float)1. / eval2;
    eval3 = (float)1. / eval3;
    enrm[0] = sqrt(eval1);
    enrm[1] = sqrt(eval2);
    enrm[2] = sqrt(eval3);
    for (j = 1; j <= 3; ++j) {
	for (i__ = 1; i__ <= 3; ++i__) {
/* L10: */
	    evec[i__ + j * 3 - 4] = paxes[i__ + j * 3] * enrm[j - 1];
	}
/* L20: */
    }
    dotsum = evec[0] * evec[3] + evec[1] * evec[4] + evec[2] * evec[5] + evec[
	    3] * evec[6] + evec[4] * evec[7] + evec[5] * evec[8] + evec[6] * 
	    evec[0] + evec[7] * evec[1] + evec[8] * evec[2];
    if (dotsum > (float).001) {
	return 0;
    }
/* Computing 2nd power */
    r__1 = evec[0];
/* Computing 2nd power */
    r__2 = evec[3];
/* Computing 2nd power */
    r__3 = evec[6];
    qxx = (doublereal) (eval1 * (r__1 * r__1) + eval2 * (r__2 * r__2) + eval3 
	    * (r__3 * r__3));
/* Computing 2nd power */
    r__1 = evec[1];
/* Computing 2nd power */
    r__2 = evec[4];
/* Computing 2nd power */
    r__3 = evec[7];
    qyy = (doublereal) (eval1 * (r__1 * r__1) + eval2 * (r__2 * r__2) + eval3 
	    * (r__3 * r__3));
/* Computing 2nd power */
    r__1 = evec[2];
/* Computing 2nd power */
    r__2 = evec[5];
/* Computing 2nd power */
    r__3 = evec[8];
    qzz = (doublereal) (eval1 * (r__1 * r__1) + eval2 * (r__2 * r__2) + eval3 
	    * (r__3 * r__3));
    qxy = (doublereal) (eval1 * evec[0] * evec[1] + eval2 * evec[3] * evec[4] 
	    + eval3 * evec[6] * evec[7]);
    qyz = (doublereal) (eval1 * evec[1] * evec[2] + eval2 * evec[4] * evec[5] 
	    + eval3 * evec[7] * evec[8]);
    qzx = (doublereal) (eval1 * evec[2] * evec[0] + eval2 * evec[5] * evec[3] 
	    + eval3 * evec[8] * evec[6]);
/* Computing 2nd power */
    d__1 = qxy;
    dbl1 = (qyz * qxx - qxy * qzx) / (d__1 * d__1 - qxx * qyy);
/* Computing 2nd power */
    d__1 = qxy;
    dbl2 = (qyz * qxy - qyy * qzx) / (qxx * qyy - d__1 * d__1);
/* Computing 2nd power */
    d__1 = dbl2;
/* Computing 2nd power */
    d__2 = dbl1;
    a = qxx * (d__1 * d__1) + qyy * (d__2 * d__2) + qzz;
    b = qxy * dbl1 * dbl2 + qyz * dbl1 + qzx * dbl2;
/* Computing 2nd power */
    d__1 = b;
    zmax = centre[3] + (real) ((sqrt(d__1 * d__1 + a) - b) / a);
    if (zmax > -small) {
	return 0;
    }

/* Calculate some useful parameters. */

    dxe = (doublereal) eye[1];
    dye = (doublereal) eye[2];
    dze = (doublereal) eye[3];
/* Computing 2nd power */
    d__1 = dze;
    dze2 = d__1 * d__1;
    alfa = (doublereal) (eye[1] - centre[1]);
    beta = (doublereal) (eye[2] - centre[2]);
    gama = (doublereal) (eye[3] - centre[3]);
    u = alfa * qxx + beta * qxy + gama * qzx;
    v = alfa * qxy + beta * qyy + gama * qyz;
    w = alfa * qzx + beta * qyz + gama * qzz;
/* Computing 2nd power */
    d__1 = alfa;
/* Computing 2nd power */
    d__2 = beta;
/* Computing 2nd power */
    d__3 = gama;
    xmu = qxx * (d__1 * d__1) + qyy * (d__2 * d__2) + qzz * (d__3 * d__3) + (
	    alfa * beta * qxy + beta * gama * qyz + gama * alfa * qzx) * 2. - 
	    1.;
/* Computing 2nd power */
    d__1 = u;
    a = xmu * qxx - d__1 * d__1;
    b = xmu * qxy - u * v;
/* Computing 2nd power */
    d__1 = v;
    c__ = xmu * qyy - d__1 * d__1;
/* Computing 2nd power */
    d__2 = b;
    det = (d__1 = a * c__ - d__2 * d__2, abs(d__1)) + dsmall;
    dbl1 = dze * (xmu * qzx - u * w);
    dbl2 = dze * (xmu * qyz - v * w);
    dx0h = (dbl1 * c__ - dbl2 * b) / det;
    dy0h = (dbl2 * a - dbl1 * b) / det;
/* Computing 2nd power */
    d__1 = w;
/* Computing 2nd power */
    d__2 = dx0h;
/* Computing 2nd power */
    d__3 = dy0h;
    q = dze2 * (d__1 * d__1 - xmu * qzz) + a * (d__2 * d__2) + b * 2. * dx0h *
	     dy0h + c__ * (d__3 * d__3);
    x0h = (real) dx0h;
    y0h = (real) dy0h;
    dx = (sftbuf_1.xtrc - sftbuf_1.xblc) / (real) (sftbuf_1.nxp - 1);
    dy = (sftbuf_1.ytrc - sftbuf_1.yblc) / (real) (sftbuf_1.nyp - 1);
    xdif = (real) sqrt((d__1 = c__ * q / det, abs(d__1)) + dsmall);
    xmin = x0h - xdif + eye[1];
    xmax = x0h + xdif + eye[1];
    ixmin = (integer) ((xmin - sftbuf_1.xblc) / dx) + 2;
    ixmax = (integer) ((xmax - sftbuf_1.xblc) / dx) + 1;
    if (ixmin > sftbuf_1.nxp || ixmax < 1) {
	return 0;
    }
    ydif = sqrt((d__1 = a * q / det, abs(d__1)) + dsmall);
    ymin = y0h - ydif + eye[2];
    ymax = y0h + ydif + eye[2];
    jymin = (integer) ((ymin - sftbuf_1.yblc) / dy) + 2;
    jymax = (integer) ((ymax - sftbuf_1.yblc) / dy) + 1;
    if (jymin > sftbuf_1.nyp || jymax < 1) {
	return 0;
    }
    if (jymin < 1) {
	jymin = 1;
    }
    if (jymax > sftbuf_1.nyp) {
	jymax = sftbuf_1.nyp;
    }
    *x0 = x0h + eye[1];
    *y0 = y0h + eye[2];
    corel = (real) sqrt((d__1 = b * b / (a * c__), abs(d__1)) + dsmall);
    if (corel > (float)1e-4) {
	xl0 = (a + c__) / 2.;
	xl1 = xl0 - sqrt((d__1 = xl0 * xl0 - det, abs(d__1)) + dsmall);
/* Computing 2nd power */
	d__1 = xl1 - a;
/* Computing 2nd power */
	d__2 = b;
	hyp = sqrt(d__1 * d__1 + d__2 * d__2 + dsmall);
	sinphi = (xl1 - a) / hyp;
	cosphi = b / hyp;
    } else {
	sinphi = 0.;
	cosphi = 1.;
    }
    r1 = sqrt(q / (a * cosphi * cosphi + sinphi * (c__ * sinphi + b * (float)
	    2. * cosphi)));
    r2 = sqrt(q / (a * sinphi * sinphi + cosphi * (c__ * cosphi - b * (float)
	    2. * sinphi)));
    *r0 = (real) ((r1 + r2) / 2.);

/* Fill the inside of the projected ellipse with the right colours. */

/* Computing MAX */
    r__2 = sin((r__1 = *anglin / (float)57.29578, dabs(r__1)));
    cosmin = dmax(r__2,(float)1e-4);
    nc = *ic2 - *ic1;
    col0 = (real) (*ic1);
    colscl = (real) nc;
    coline = (real) (*icline);
/* Computing 2nd power */
    r__1 = light[1];
/* Computing 2nd power */
    r__2 = light[2];
/* Computing 2nd power */
    r__3 = light[3];
    xl2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
    yh = sftbuf_1.yblc + dy * (real) (jymin - 1) - eye[2];
    dwze = w * dze;
    ba = (real) (b / a);
    i__1 = jymax;
    for (jy = jymin; jy <= i__1; ++jy) {
	dyh = (doublereal) yh;
	dvyh = v * dyh;
	dbl0 = qzz * dze2 + dyh * (qyy * dyh - qyz * 2. * dze);
	ydif = yh - y0h;
/* Computing 2nd power */
	r__1 = ydif;
	xdif = (real) (sqrt((d__1 = a * q - det * (doublereal) (r__1 * r__1), 
		abs(d__1)) + dsmall) / a);
	xmin = x0h - ba * ydif - xdif + eye[1];
	xmax = x0h - ba * ydif + xdif + eye[1];
	ixmin = (integer) ((xmin - sftbuf_1.xblc) / dx) + 2;
	ixmax = (integer) ((xmax - sftbuf_1.xblc) / dx) + 1;
	if (ixmin <= sftbuf_1.nxp && ixmax >= 1) {
	    if (ixmin < 1) {
		ixmin = 1;
	    }
	    if (ixmax > sftbuf_1.nxp) {
		ixmax = sftbuf_1.nxp;
	    }
	    xh = sftbuf_1.xblc + dx * (real) (ixmin - 1) - eye[1];
	    k = (jy - 1) * sftbuf_1.nxp + ixmin;
	    i__2 = ixmax;
	    for (ix = ixmin; ix <= i__2; ++ix) {
		if (zmax > sftbuf_1.sbbuff[k - 1]) {
		    dxh = (doublereal) xh;
		    duxh = u * dxh;
		    dbl1 = duxh + dvyh - dwze;
		    dbl2 = dbl0 + dxh * (qxx * dxh + (qxy * dyh - qzx * dze) *
			     2.);
/* Computing 2nd power */
		    d__2 = dbl1;
		    xlm = (real) ((-dbl1 - sqrt((d__1 = d__2 * d__2 - xmu * 
			    dbl2, abs(d__1)) + dsmall)) / dbl2);
		    surf[2] = eye[3] * ((float)1. - xlm);
		    if (surf[2] > sftbuf_1.sbbuff[k - 1]) {
			sftbuf_1.sbbuff[k - 1] = surf[2];
			if (nc == 0) {
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = col0;
			} else {
			    surf[1] = eye[2] + yh * xlm;
			    surf[0] = eye[1] + xh * xlm;
			    sbegls_(&eye[1], &centre[1], &light[1], surf, &
				    xl2, &qxx, &qyy, &qzz, &qxy, &qyz, &qzx, &
				    small, lshine, &colour, evec, icline, &
				    cosmin);
			    if (colour > (float)2.) {
				sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = 
					coline;
			    } else {
				sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = 
					col0 + colour * colscl;
			    }
			}
		    }
		}
		++k;
		xh += dx;
/* L30: */
	    }
	}
	yh += dy;
/* L40: */
    }
} /* sbelip_ */


/* Subroutine */ int sbegls_(eye, centre, light, surf, xl2, qxx, qyy, qzz, 
	qxy, qyz, qzx, small, lshine, colour, evec, icline, cosang)
real *eye, *centre, *light, *surf, *xl2;
doublereal *qxx, *qyy, *qzz, *qxy, *qyz, *qzx;
real *small;
logical *lshine;
real *colour, *evec;
integer *icline;
real *cosang;
{
    /* System generated locals */
    real r__1, r__2, r__3;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static real view[3], view2;
    static integer i__;
    static real snorm, dx, dy, dz, reflec[3], normal[3], cosmin, rfnorm, xn2;
    static doublereal ddx, ddy, ddz;
    static real xnl, xrv, ref2, cos1, cos2, cos3;

/*     ---------------------------------------------------------------- */

/* Support subroutine for SBELIP, to work out colour-shade. */


    /* Parameter adjustments */
    evec -= 4;
    --surf;
    --light;
    --centre;
    --eye;

    /* Function Body */
    *colour = (float)0.;
    dx = surf[1] - centre[1];
    dy = surf[2] - centre[2];
    dz = surf[3] - centre[3];
    if (*icline >= 0) {
/* Computing 2nd power */
	r__1 = dx;
/* Computing 2nd power */
	r__2 = dy;
/* Computing 2nd power */
	r__3 = dz;
	snorm = (float)1. / sqrt(r__1 * r__1 + r__2 * r__2 + r__3 * r__3);
	cos1 = (r__1 = snorm * (dx * evec[4] + dy * evec[5] + dz * evec[6]), 
		dabs(r__1));
	cos2 = (r__1 = snorm * (dx * evec[7] + dy * evec[8] + dz * evec[9]), 
		dabs(r__1));
	cos3 = (r__1 = snorm * (dx * evec[10] + dy * evec[11] + dz * evec[12])
		, dabs(r__1));
/* Computing MIN */
	r__1 = min(cos1,cos2);
	cosmin = dmin(r__1,cos3);
	if (cosmin < *cosang) {
	    *colour = (float)10.;
	    return 0;
	}
    }
    ddx = (doublereal) dx;
    ddy = (doublereal) dy;
    ddz = (doublereal) dz;
    normal[0] = (real) (*qxx * ddx + *qxy * ddy + *qzx * ddz);
    normal[1] = (real) (*qxy * ddx + *qyy * ddy + *qyz * ddz);
    normal[2] = (real) (*qzx * ddx + *qyz * ddy + *qzz * ddz);
    xn2 = (float)0.;
    xnl = (float)0.;
    for (i__ = 1; i__ <= 3; ++i__) {
	xnl += normal[i__ - 1] * light[i__];
/* Computing 2nd power */
	r__1 = normal[i__ - 1];
	xn2 += r__1 * r__1;
/* L10: */
    }
    if (xnl >= (float)0.) {
	return 0;
    }
    if (*lshine) {
	rfnorm = (xnl + xnl) / (xn2 + *small);
	xrv = (float)0.;
	for (i__ = 1; i__ <= 3; ++i__) {
	    view[i__ - 1] = eye[i__] - surf[i__];
	    reflec[i__ - 1] = light[i__] - rfnorm * normal[i__ - 1];
	    xrv += reflec[i__ - 1] * view[i__ - 1];
/* L20: */
	}
	if (xrv < (float)0.) {
	    return 0;
	}
	ref2 = (float)0.;
	view2 = (float)0.;
	for (i__ = 1; i__ <= 3; ++i__) {
/* Computing 2nd power */
	    r__1 = reflec[i__ - 1];
	    ref2 += r__1 * r__1;
/* Computing 2nd power */
	    r__1 = view[i__ - 1];
	    view2 += r__1 * r__1;
/* L30: */
	}
/* Computing MIN */
/* Computing 2nd power */
	r__3 = xrv;
	r__2 = r__3 * r__3 / ((r__1 = ref2 * view2, dabs(r__1)) + *small);
	*colour = dmin(r__2,(float)1.);
    } else {
/* Computing MIN */
	r__1 = -xnl / sqrt(xn2 * *xl2 + *small);
	*colour = dmin(r__1,(float)1.);
    }
} /* sbegls_ */


/* Subroutine */ int sbtext_(eye, text, icol, pivot, fjust, orient, size, 
	text_len)
real *eye;
char *text;
integer *icol;
real *pivot, *fjust, *orient, *size;
ftnlen text_len;
{
    /* Initialized data */

    static logical lstart = FALSE_;
    static real small = (float)1e-10;
    static integer ijflag = -64;

    /* System generated locals */
    integer i__1, i__2;
    real r__1, r__2, r__3;

    /* Builtin functions */
    double sqrt();
    integer i_len();
    double pow_ri();

    /* Local variables */
    static real tscl, xlen, ylen, d__;
    static integer i__, j, k, nchar;
    extern /* Subroutine */ int grlen_(), grsy00_();
    static integer ksymb;
    static real xnorm, ynorm, x0, y0, z0, z1;
    static integer jj;
    static real dx, dy, dz, fntfac;
    static integer ix, jy;
    static real xl, cosang;
    static integer nchmax, nchmin;
    static real xx, xy;
    static integer isymba, xybase;
    static real xz, yx;
    static integer symbol[256], xygrid[300], xyleft;
    static logical unused;
    extern /* Subroutine */ int grsyds_();
    static integer nsymbs;
    extern /* Subroutine */ int grsyxd_();
    static real yy, yz, fntbas;
    static integer ifntlv;
    extern /* Subroutine */ int sbline_(), sbrcop_();
    static real rlx, rly, end1[3], end2[3];

/*     -------------------------------------------------------- */


/* ----------------------------------------------------------------------- */
/*            Include file for GRPCKG */
/* Modifications: */
/*   29-Jan-1985 - add HP2648 (KS/TJP). */
/*   16-Sep-1985 - remove tabs (TJP). */
/*   30-Dec-1985 - add PS, VPS (TJP). */
/*   27-May-1987 - remove ARGS, NULL, PS, VPS, QMS, VQMS, HIDMP, */
/*                 HP7221, GRINL (TJP). */
/*    6-Jun-1987 - remove PRTX, TRILOG, VERS, VV (TJP). */
/*   11-Jun-1987 - remove remaining built-in devices (TJP). */
/*    5-Jul-1987 - replace GRINIT, GRPLTD by GRSTAT. */
/*   16-Aug-1987 - remove obsolete variables. */
/*    9-Sep-1989 - add SAVE statement. */
/*   26-Nov-1990 - remove GRCTYP. */
/*    5-Jan-1993 - add GRADJU. */
/*    1-Sep-1994 - add GRGCAP. */
/*   21-Dec-1995 - increase GRIMAX to 8. */
/*   30-Apr-1997 - remove GRC{XY}SP */
/* ----------------------------------------------------------------------- */

/* Parameters: */
/*   GRIMAX : maximum number of concurrent devices */
/*   GRFNMX : maximum length of file names */
/*   GRCXSZ : default width of chars (pixels) */
/*   GRCYSZ : default height of chars (pixels) */


/* Common blocks: */
/*   GRCIDE : identifier of current plot */
/*   GRGTYP : device type of current plot */
/* The following are qualified by a plot id: */
/*   GRSTAT : 0 => workstation closed */
/*            1 => workstation open */
/*            2 => picture open */
/*   GRPLTD : */
/*   GRDASH : software dashing in effect? */
/*   GRUNIT : unit associated with id */
/*   GRFNLN : length of filename */
/*   GRTYPE : device type */
/*   GRXMXA : x size of plotting surface */
/*   GRYMXA : y size of plotting surface */
/*   GRXMIN : blc of plotting window */
/*   GRYMIN : ditto */
/*   GRXMAX : trc of plotting window */
/*   GRYMAX : ditto */
/*   GRSTYL : line style (integer code) */
/*   GRWIDT : line width (integer code) */
/*   GRCCOL : current color index (integer code) */
/*   GRMNCI : minimum color index on this device */
/*   GRMXCI : maximum color index on this device */
/*   GRCMRK : marker number */
/*   GRXPRE : previous (current) pen position (x) */
/*   GRYPRE : ditto (y) */
/*   GRXORG : transformation variables (GRTRAN) */
/*   GRYORG : ditto */
/*   GRXSCL : ditto */
/*   GRYSCL : ditto */
/*   GRCSCL : character scaling factor */
/*   GRCFAC : */
/*   GRCFNT : character font */
/*   GRFILE : file name (character) */
/*   GRGCAP : device capabilities (character) */
/*   GRPXPI : pixels per inch in x */
/*   GRPYPI : pixels per inch in y */
/*   GRADJU : TRUE if GRSETS (PGPAP) has been called */


/* ----------------------------------------------------------------------- */
    /* Parameter adjustments */
    orient -= 4;
    --pivot;
    --eye;

    /* Function Body */

/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      Write a text string in 3-d perspective. All (x,y,z) values are */
/*    taken to be given in world coordinates. The z-component of the */
/*    eye-poisition should be positive and that of the text string should */
/*    be negative; the viewing-screen is fixed at z=0. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    EYE      R*4    I       3      (x,y,z) coordinate of eye-position. */
/*    TEXT     C*1    I       *      The text string to be written. */
/*    ICOL     I*4    I       -      Colour index for text. */
/*    PIVOT    R*4    I       3      (x,y,z) coordinate of pivot point. */
/*    FJUST    R*4    I       -      Position of pivot along the text: */
/*                                   0.0=left, 0.5=centre, 1.0=right. */
/*    ORIENT   R*4    I     3 x 2    (x,y,z) for X-length and Y-height */
/*                                   directions of the text. */
/*    SIZE     R*4    I       -      Height of the reference symbol "A". */

/* Globals */
/*    GRPCKG1.INC */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     GRSY00     Initialises font description. */
/*     GRSYDS     Decodes string into a list of Hershey symbol numbers. */
/*     GRSYXD     Obtains the polyline representation of a given symbol. */
/*     GRLEN      Calculates the length of the string. */
/*     SBLINE     Draws a 3-d line in perspective. */

/* History */
/*   D. S. Sivia      14 Sep 1995  Initial release. */
/*   D. S. Sivia      11 Oct 1995  Modified a J DO LOOP for a Pentium! */
/* ----------------------------------------------------------------------- */

/* Carry out some initial checks. */

    if (eye[3] <= small) {
	return 0;
    }
    if (*fjust < (float)0. || *fjust > (float)1.) {
	return 0;
    }
    if (*size < small) {
	return 0;
    }
/* Computing 2nd power */
    r__1 = orient[4];
/* Computing 2nd power */
    r__2 = orient[5];
/* Computing 2nd power */
    r__3 = orient[6];
    xlen = sqrt(r__1 * r__1 + r__2 * r__2 + r__3 * r__3);
/* Computing 2nd power */
    r__1 = orient[7];
/* Computing 2nd power */
    r__2 = orient[8];
/* Computing 2nd power */
    r__3 = orient[9];
    ylen = sqrt(r__1 * r__1 + r__2 * r__2 + r__3 * r__3);
    if (xlen < small || ylen < small) {
	return 0;
    }
    cosang = (orient[4] * orient[7] + orient[5] * orient[8] + orient[6] * 
	    orient[9]) / (xlen * ylen);
    if (dabs(cosang) > (float).001) {
	return 0;
    }
    if (! lstart) {
	grsy00_();
	lstart = TRUE_;
    }
/* Computing MIN */
    i__1 = i_len(text, text_len);
    nchar = min(i__1,256);
    for (i__ = nchar; i__ >= 1; --i__) {
/* L10: */
	if (*(unsigned char *)&text[i__ - 1] != ' ') {
	    goto L1;
	}
    }
L1:
    nchmax = i__;
    if (nchmax < 1) {
	return 0;
    }
    i__1 = nchmax;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L20: */
	if (*(unsigned char *)&text[i__ - 1] != ' ') {
	    goto L2;
	}
    }
L2:
    nchmin = i__;

/* Calculate the parameters for the Hershey --> world coordinates */
/* transformation. */

    grlen_(text + (nchmin - 1), &d__, nchmax - (nchmin - 1));
    d__ = d__ * (float)2.5 / grcm00_1.grcfac[grcm00_1.grcide - 1];
    grsyds_(&isymba, &nsymbs, "A", &c__1, (ftnlen)1);
    grsyxd_(&isymba, xygrid, &unused);
    tscl = *size / (real) (xygrid[2] - xygrid[1]);
    xnorm = tscl / xlen;
    ynorm = tscl / ylen;
    xx = orient[4] * xnorm;
    xy = orient[5] * xnorm;
    xz = orient[6] * xnorm;
    yx = orient[7] * ynorm;
    yy = orient[8] * ynorm;
    yz = orient[9] * ynorm;
    x0 = pivot[1] - *fjust * d__ * xx;
    y0 = pivot[2] - *fjust * d__ * xy;
    z0 = pivot[3] - *fjust * d__ * xz;
    z1 = pivot[3] + ((float)1. - *fjust) * d__ * xz;
    if (z0 > -small || z1 > -small) {
	return 0;
    }

/* Write out the text string, character by character. */

    dx = (float)0.;
    dy = (float)0.;
    dz = (float)0.;
    fntbas = (float)0.;
    fntfac = (float)1.;
    ifntlv = 0;
    grsyds_(symbol, &nsymbs, text + (nchmin - 1), &c__1, nchmax - (nchmin - 1)
	    );
    i__1 = nsymbs;
    for (k = 1; k <= i__1; ++k) {
	ksymb = symbol[k - 1];
	if (ksymb < 0) {
	    if (ksymb == -1) {
		++ifntlv;
		fntbas += fntfac * (float)16.;
		i__2 = abs(ifntlv);
		fntfac = pow_ri(&c_b334, &i__2);
	    } else if (ksymb == -2) {
		--ifntlv;
		i__2 = abs(ifntlv);
		fntfac = pow_ri(&c_b334, &i__2);
		fntbas -= fntfac * (float)16.;
	    } else if (ksymb == -3) {
		x0 -= dx;
		y0 -= dy;
		z0 -= dz;
	    }
	    goto L40;
	}
	grsyxd_(&ksymb, xygrid, &unused);
	if (! unused) {
	    xybase = xygrid[1];
	    xyleft = xygrid[3];
	    rlx = (real) (xygrid[5] - xyleft) * fntfac;
	    rly = (real) (xygrid[6] - xybase) * fntfac + fntbas;
	    end1[0] = x0 + rlx * xx + rly * yx;
	    end1[1] = y0 + rlx * xy + rly * yy;
	    end1[2] = z0 + rlx * xz + rly * yz;
	    j = 8;
	    for (jj = 8; jj <= 298; jj += 2) {
		ix = xygrid[j - 1];
		jy = xygrid[j];
		if (jy == ijflag) {
		    goto L3;
		}
		if (ix == ijflag) {
		    j += 2;
		    rlx = (real) (xygrid[j - 1] - xyleft) * fntfac;
		    rly = (real) (xygrid[j] - xybase) * fntfac + fntbas;
		    end1[0] = x0 + rlx * xx + rly * yx;
		    end1[1] = y0 + rlx * xy + rly * yy;
		    end1[2] = z0 + rlx * xz + rly * yz;
		} else {
		    rlx = (real) (ix - xyleft) * fntfac;
		    rly = (real) (jy - xybase) * fntfac + fntbas;
		    end2[0] = x0 + rlx * xx + rly * yx;
		    end2[1] = y0 + rlx * xy + rly * yy;
		    end2[2] = z0 + rlx * xz + rly * yz;
		    sbline_(&eye[1], end1, end2, icol, &c_false);
		    sbrcop_(end2, end1, &c__3);
		}
		j += 2;
/* L30: */
	    }
	}
L3:
	xl = fntfac * (real) (xygrid[4] - xyleft);
	dx = xl * xx;
	dy = xl * xy;
	dz = xl * xz;
	x0 += dx;
	y0 += dy;
	z0 += dz;
L40:
	;
    }
} /* sbtext_ */


/* Subroutine */ int sbcpln_(eye, latice, ic1, ic2, light, slnorm, apoint, 
	icedge, itrans)
real *eye, *latice;
integer *ic1, *ic2;
real *light, *slnorm, *apoint;
integer *icedge, *itrans;
{
    /* System generated locals */
    integer i__1;
    real r__1, r__2, r__3;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static real snrm, vert1[36]	/* was [3][12] */, vert2[36]	/* was [3][12]
	     */;
    static integer i__, j, k, l;
    static real small, d2;
    static logical lvert[12];
    static integer nvert;
    extern /* Subroutine */ int sbcpl1_(), sbslc1_();
    static real small2;
    static integer ii;
    static real dx, dy, dz, xn, yn, zn;
    extern /* Subroutine */ int sbplan_();
    static real zdline;
    static integer itlevl;
    static real cosnrm;
    extern /* Subroutine */ int sbplnt_();
    static real xlnorm, xae, yae, zae, end1[3], end2[3];

/*     ---------------------------------------------------------------- */



/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      This subroutine plots a diffusively-lit, semi-transparent, */
/*    coloured plane through a unit cell. All (x,y,z) values are taken to */
/*    be given in world coordinates. The z-component of the eye-poisition */
/*    should be positive and that of all the lattice-vertices should be */
/*    negative; the viewing-screen is fixed at z=0. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    EYE      R*4    I       3      (x,y,z) coordinate of eye-position. */
/*    LATICE   R*4    I     3 x 4    (x,y,z) coordinates of the origin */
/*                                   and the a, b & C lattice-vertices. */
/*    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be */
/*                                   used for the shading. */
/*    LIGHT    R*4    I       3      (x,y,z) direction of flood-light. */
/*    SLNORM   R*4    I       3      (x,y,z) direction of normal to plane. */
/*    APONIT   R*4    I       3      (x,y,z) coordinate of a point within */
/*                                   the plane. */
/*    ICEDGE   I*4    I       -      If >=0, it's the colour-index for */
/*                                   the boundary of the plane. */
/*    ITRANS   I*4    I       -      Level of transparency: */
/*                                     0 = 0%; 1 = 25%; 2 = 50%; 3 = 75%. */

/* Globals */
/*    None */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     SBSLC1     Checks whether a side of the unit cell is cut by the */
/*                plane & calculates the coordinates of the intersection. */
/*     SBCPL1     Order the verticies of the polygon-of-intersection. */
/*     SBLIN1     Calculates the projection of (x,y,z) on viewing screen. */
/*     SBPLAN     Plots a coloured plane. */
/*     SBPLNT     Plots a semi-transparent coloured plane. */

/* History */
/*   D. S. Sivia      26 Sep 1995  Initial release. */
/* ----------------------------------------------------------------------- */

/* Carry out some initial checks. */

    /* Parameter adjustments */
    --apoint;
    --slnorm;
    --light;
    latice -= 4;
    --eye;

    /* Function Body */
    small = (float)1e-10;
/* Computing 2nd power */
    r__1 = small;
    small2 = r__1 * r__1;
    if (eye[3] <= small) {
	return 0;
    }
/* Computing 2nd power */
    r__1 = slnorm[1];
/* Computing 2nd power */
    r__2 = slnorm[2];
/* Computing 2nd power */
    r__3 = slnorm[3];
    snrm = (float)1. / sqrt(r__1 * r__1 + r__2 * r__2 + r__3 * r__3 + small2);
    xn = slnorm[1] * snrm;
    yn = slnorm[2] * snrm;
    zn = slnorm[3] * snrm;
    xae = eye[1] - apoint[1];
    yae = eye[2] - apoint[2];
    zae = eye[3] - apoint[3];
    xlnorm = (doublereal) (xn * xae) + (doublereal) (yn * yae) + (doublereal) 
	    (zn * zae);
/* Computing 2nd power */
    r__1 = xae;
/* Computing 2nd power */
    r__2 = yae;
/* Computing 2nd power */
    r__3 = zae;
    cosnrm = (real) (xlnorm / sqrt((doublereal) (r__1 * r__1) + (doublereal) (
	    r__2 * r__2) + (doublereal) (r__3 * r__3) + (doublereal) small2));
    if (dabs(cosnrm) < (float).001) {
	return 0;
    }
    for (j = 1; j <= 3; ++j) {
	dx = latice[(j + 1) * 3 + 1] - latice[4];
	dy = latice[(j + 1) * 3 + 2] - latice[5];
	dz = latice[(j + 1) * 3 + 3] - latice[6];
/* Computing 2nd power */
	r__1 = dx;
/* Computing 2nd power */
	r__2 = dy;
/* Computing 2nd power */
	r__3 = dz;
	d2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
	if (d2 < small2) {
	    return 0;
	}
/* L10: */
    }

/* Calculate the coordinates of the polygon-of-intersection between the */
/* the plane and the edges of the unit cell. */

    nvert = 0;
    ii = 0;
    for (l = 1; l <= 12; l += 4) {
	i__ = ii + 2;
	j = (ii + 1) % 3 + 2;
	k = (ii + 2) % 3 + 2;
	sbslc1_(&latice[4], &latice[k * 3 + 1], &xn, &yn, &zn, &apoint[1], &
		lvert[l - 1], &vert1[l * 3 - 3], &nvert);
	end1[0] = latice[i__ * 3 + 1] + latice[j * 3 + 1] - latice[4];
	end1[1] = latice[i__ * 3 + 2] + latice[j * 3 + 2] - latice[5];
	end1[2] = latice[i__ * 3 + 3] + latice[j * 3 + 3] - latice[6];
	sbslc1_(&latice[i__ * 3 + 1], end1, &xn, &yn, &zn, &apoint[1], &lvert[
		l], &vert1[(l + 1) * 3 - 3], &nvert);
	sbslc1_(&latice[j * 3 + 1], end1, &xn, &yn, &zn, &apoint[1], &lvert[l 
		+ 1], &vert1[(l + 2) * 3 - 3], &nvert);
	end2[0] = end1[0] + latice[k * 3 + 1] - latice[4];
	end2[1] = end1[1] + latice[k * 3 + 2] - latice[5];
	end2[2] = end1[2] + latice[k * 3 + 3] - latice[6];
	sbslc1_(end1, end2, &xn, &yn, &zn, &apoint[1], &lvert[l + 2], &vert1[(
		l + 3) * 3 - 3], &nvert);
	++ii;
/* L20: */
    }
    if (nvert < 3) {
	return 0;
    }
    sbcpl1_(&eye[1], lvert, vert1, vert2, &nvert, &xn, &yn, &zn, icedge, &
	    zdline);

/* Plot the plane. */

/* Computing MAX */
    i__1 = min(*itrans,3);
    itlevl = max(i__1,0);
    if (itlevl == 0) {
	sbplan_(&eye[1], &nvert, vert2, ic1, ic2, &light[1]);
    } else {
	sbplnt_(&eye[1], &nvert, vert2, ic1, ic2, &light[1], &itlevl);
    }
} /* sbcpln_ */


/* Subroutine */ int sbcpl1_(eye, lvert, vert1, vert2, nvert, xn, yn, zn, 
	icol, zdif)
real *eye;
logical *lvert;
real *vert1, *vert2;
integer *nvert;
real *xn, *yn, *zn;
integer *icol;
real *zdif;
{
    /* System generated locals */
    integer i__1;
    real r__1, r__2, r__3;

    /* Builtin functions */
    double sqrt(), atan2();

    /* Local variables */
    static real angj, xbar, ybar, zbar, xref, yref, zref, xvec, yvec, zvec, 
	    zmin, zmax, xnrm, ynrm, znrm, vert3[3];
    static integer i__, j, k;
    static real angle[12], x, y;
    static integer isort[12], ii;
    extern /* Subroutine */ int sbline_(), sbrcop_();
    static real refnrm;
    static integer iv1;

/*     ----------------------------------------------------------------- */


    /* Parameter adjustments */
    vert2 -= 4;
    vert1 -= 4;
    --lvert;
    --eye;

    /* Function Body */
    iv1 = 0;
    xbar = (float)0.;
    ybar = (float)0.;
    zbar = (float)0.;
    zmin = (float)1e20;
    zmax = (float)-1e20;
    for (k = 1; k <= 12; ++k) {
/* Computing MIN */
	r__1 = zmin, r__2 = vert1[k * 3 + 3];
	zmin = dmin(r__1,r__2);
/* Computing MAX */
	r__1 = zmax, r__2 = vert1[k * 3 + 3];
	zmax = dmax(r__1,r__2);
	if (lvert[k]) {
	    if (iv1 <= 0) {
		iv1 = k;
	    }
	    xbar += vert1[k * 3 + 1];
	    ybar += vert1[k * 3 + 2];
	    zbar += vert1[k * 3 + 3];
	}
/* L10: */
    }
    *zdif = (zmax - zmin) / (float)5e3;
    xbar /= (real) (*nvert);
    ybar /= (real) (*nvert);
    zbar /= (real) (*nvert);
    xref = vert1[iv1 * 3 + 1] - xbar;
    yref = vert1[iv1 * 3 + 2] - ybar;
    zref = vert1[iv1 * 3 + 3] - zbar;
/* Computing 2nd power */
    r__1 = xref;
/* Computing 2nd power */
    r__2 = yref;
/* Computing 2nd power */
    r__3 = zref;
    refnrm = (float)1. / sqrt(r__1 * r__1 + r__2 * r__2 + r__3 * r__3 + (
	    float)1e-20);
    xref *= refnrm;
    yref *= refnrm;
    zref *= refnrm;
    xnrm = yref * *zn - *yn * zref;
    ynrm = zref * *xn - *zn * xref;
    znrm = xref * *yn - *xn * yref;
    j = 1;
    angle[j - 1] = (float)0.;
    isort[j - 1] = iv1;
    sbrcop_(&vert1[iv1 * 3 + 1], &vert2[j * 3 + 1], &c__3);
    for (k = iv1 + 1; k <= 12; ++k) {
	if (lvert[k]) {
	    ++j;
	    xvec = vert1[k * 3 + 1] - xbar;
	    yvec = vert1[k * 3 + 2] - ybar;
	    zvec = vert1[k * 3 + 3] - zbar;
	    x = xvec * xref + yvec * yref + zvec * zref;
	    y = xvec * xnrm + yvec * ynrm + zvec * znrm;
	    angj = atan2(y, x);
	    sbrcop_(&vert1[k * 3 + 1], vert3, &c__3);
	    i__1 = j - 1;
	    for (i__ = 1; i__ <= i__1; ++i__) {
/* L20: */
		if (angj < angle[i__ - 1]) {
		    goto L1;
		}
	    }
L1:
	    ii = i__;
	    i__1 = ii + 1;
	    for (i__ = j; i__ >= i__1; --i__) {
		sbrcop_(&vert2[(i__ - 1) * 3 + 1], &vert2[i__ * 3 + 1], &c__3)
			;
		angle[i__ - 1] = angle[i__ - 2];
		isort[i__ - 1] = isort[i__ - 2];
/* L30: */
	    }
	    sbrcop_(vert3, &vert2[ii * 3 + 1], &c__3);
	    angle[ii - 1] = angj;
	    isort[ii - 1] = k;
	}
/* L40: */
    }
    if ((real) (*icol) >= (float)0.) {
	i__1 = *nvert - 1;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    j = isort[i__ - 1];
	    k = isort[i__];
	    sbline_(&eye[1], &vert1[j * 3 + 1], &vert1[k * 3 + 1], icol, &
		    c_false);
/* L50: */
	}
	sbline_(&eye[1], &vert1[k * 3 + 1], &vert1[isort[0] * 3 + 1], icol, &
		c_false);
    }
} /* sbcpl1_ */


/* Subroutine */ int sbtbal_(eye, centre, radius, ic1, ic2, light, lshine, x0,
	 y0, r0, itrans)
real *eye, *centre, *radius;
integer *ic1, *ic2;
real *light;
logical *lshine;
real *x0, *y0, *r0;
integer *itrans;
{
    /* System generated locals */
    integer i__1, i__2;
    real r__1, r__2, r__3;
    doublereal d__1, d__2, d__3;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static doublereal alfa, gama, beta;
    static real xdif, ydif, xmin, ymin, xmax, ymax, surf[3], zmax;
    static doublereal a, b, c__;
    static integer k;
    static doublereal q;
    static real corel, small;
    static integer ixmin, ixmax, jymin, jymax, jtest, itest;
    static doublereal r1, r2;
    static real ba;
    static integer nc;
    static real dx, dy, yh, xh;
    static integer jy, ix;
    static real alfaxh;
    static doublereal dgamze, dsmall;
    static real betayh, colscl;
    static doublereal cosphi;
    extern /* Subroutine */ int sbglos_();
    static doublereal sinphi;
    static integer itlevl;
    static real colour, x0h, y0h, xh2, yh2;
    static doublereal xl0, xl1;
    static real xl2, xn2, xn3;
    static doublereal det, dze, hyp;
    static real xlm;
    static doublereal xmu, dbl1, dbl2;
    static real col0;
    static doublereal dx0h, dy0h, dze2;
    static real xnl2;

/*     ------------------------------------------------------------------ */


/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      This subroutine plots a semi-transparent shiny or matt coloured */
/*    ball. All (x,y,z) values are taken to be given in world coordinates. */
/*    The z-component of the eye-poisition should be positive and that of */
/*    the ball-centre should be negative (< -radius); the viewing-screen */
/*    is fixed at z=0. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    EYE      R*4    I       3      (x,y,z) coordinate of eye-position. */
/*    CENTRE   R*4    I       3      (x,y,z) coordinate of ball-centre. */
/*    RADIUS   R*4    I       -      Radius of ball. */
/*    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be */
/*                                   used for shading. */
/*    LIGHT    R*4    I       3      (x,y,z) direction of flood-light. */
/*    LSHINE   L*1    I       -      Shiny ball if .TRUE., else diffuse. */
/*    X0,Y0    R*4    O       -      Centre of projected ball. */
/*    R0       R*4    O       -      Average radius of projected ball. */
/*    ITRANS   I*4    I       -      Level of transparency: */
/*                                        1 = 25%; 2 = 50%; 3 = 75%. */

/* Globals */
/*    SFTBUF */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     SBGLOS     Works out colour-shade for surface of ball. */

/* History */
/*   D. S. Sivia       8 Jul 1996  Initial release. */
/* ----------------------------------------------------------------------- */

/* Some initial checks. */

    /* Parameter adjustments */
    --light;
    --centre;
    --eye;

    /* Function Body */
    small = (float)1e-20;
    dsmall = (doublereal) small;
    if (eye[3] <= (float)0.) {
	return 0;
    }
    if (*radius <= (float)0.) {
	return 0;
    }
    if (centre[3] > -(*radius)) {
	return 0;
    }

/* Calculate parameters of projected ellipse. */

    dze = (doublereal) eye[3];
/* Computing 2nd power */
    d__1 = dze;
    dze2 = d__1 * d__1;
    alfa = (doublereal) (eye[1] - centre[1]);
    beta = (doublereal) (eye[2] - centre[2]);
    gama = (doublereal) (eye[3] - centre[3]);
/* Computing 2nd power */
    r__1 = *radius;
/* Computing 2nd power */
    d__1 = alfa;
/* Computing 2nd power */
    d__2 = beta;
/* Computing 2nd power */
    d__3 = gama;
    xmu = (doublereal) (r__1 * r__1) - (d__1 * d__1 + d__2 * d__2 + d__3 * 
	    d__3);
/* Computing 2nd power */
    d__1 = alfa;
    a = xmu * (xmu + d__1 * d__1);
    b = xmu * alfa * beta;
/* Computing 2nd power */
    d__1 = beta;
    c__ = xmu * (xmu + d__1 * d__1);
/* Computing 2nd power */
    d__2 = b;
    det = (d__1 = a * c__ - d__2 * d__2, abs(d__1)) + dsmall;
    dx0h = gama * xmu * dze * (alfa * c__ - beta * b) / det;
    dy0h = gama * xmu * dze * (beta * a - alfa * b) / det;
/* Computing 2nd power */
    d__1 = dx0h;
/* Computing 2nd power */
    d__2 = dy0h;
/* Computing 2nd power */
    d__3 = gama;
    q = a * (d__1 * d__1) + b * (float)2. * dx0h * dy0h + c__ * (d__2 * d__2) 
	    - xmu * (xmu + d__3 * d__3) * dze2;
    x0h = (real) dx0h;
    y0h = (real) dy0h;
    dx = (sftbuf_1.xtrc - sftbuf_1.xblc) / (real) (sftbuf_1.nxp - 1);
    dy = (sftbuf_1.ytrc - sftbuf_1.yblc) / (real) (sftbuf_1.nyp - 1);
    xdif = (real) sqrt((d__1 = c__ * q / det, abs(d__1)) + dsmall);
    xmin = x0h - xdif + eye[1];
    xmax = x0h + xdif + eye[1];
    ixmin = (integer) ((xmin - sftbuf_1.xblc) / dx) + 2;
    ixmax = (integer) ((xmax - sftbuf_1.xblc) / dx) + 1;
    if (ixmin > sftbuf_1.nxp || ixmax < 1) {
	return 0;
    }
    ydif = sqrt((d__1 = a * q / det, abs(d__1)) + dsmall);
    ymin = y0h - ydif + eye[2];
    ymax = y0h + ydif + eye[2];
    jymin = (integer) ((ymin - sftbuf_1.yblc) / dy) + 2;
    jymax = (integer) ((ymax - sftbuf_1.yblc) / dy) + 1;
    if (jymin > sftbuf_1.nyp || jymax < 1) {
	return 0;
    }
    if (jymin < 1) {
	jymin = 1;
    }
    if (jymax > sftbuf_1.nyp) {
	jymax = sftbuf_1.nyp;
    }
    zmax = centre[3] + *radius;
    *x0 = x0h + eye[1];
    *y0 = y0h + eye[2];
    corel = (real) sqrt((d__1 = b * b / (a * c__), abs(d__1)) + dsmall);
    if (corel > (float)1e-4) {
	xl0 = (a + c__) / 2.;
	xl1 = xl0 - sqrt((d__1 = xl0 * xl0 - det, abs(d__1)) + dsmall);
/* Computing 2nd power */
	d__1 = xl1 - a;
/* Computing 2nd power */
	d__2 = b;
	hyp = sqrt(d__1 * d__1 + d__2 * d__2 + dsmall);
	sinphi = (xl1 - a) / hyp;
	cosphi = b / hyp;
    } else {
	sinphi = 0.;
	cosphi = 1.;
    }
    r1 = sqrt(q / (a * cosphi * cosphi + sinphi * (c__ * sinphi + b * (float)
	    2. * cosphi)));
    r2 = sqrt(q / (a * sinphi * sinphi + cosphi * (c__ * cosphi - b * (float)
	    2. * sinphi)));
    *r0 = (real) ((r1 + r2) / 2.);

/* Fill the inside of the projected ellipse with the right colours. */

/* Computing MAX */
    i__1 = min(*itrans,3);
    itlevl = max(i__1,1);
    nc = *ic2 - *ic1;
    col0 = (real) (*ic1);
    colscl = (real) nc;
/* Computing 2nd power */
    r__1 = light[1];
/* Computing 2nd power */
    r__2 = light[2];
/* Computing 2nd power */
    r__3 = light[3];
    xl2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
/* Computing 2nd power */
    r__1 = *radius;
    xn2 = r__1 * r__1;
    xnl2 = (float)1. / sqrt(xn2 * xl2 + small);
    xn3 = (float)1. / (xn2 + small);
    yh = sftbuf_1.yblc + dy * (real) (jymin - 1) - eye[2];
    dgamze = gama * dze;
    ba = (real) (b / a);
    i__1 = jymax;
    for (jy = jymin; jy <= i__1; ++jy) {
	jtest = jy % 2;
	if (itlevl == 3 && jtest == 1) {
	    goto L19;
	}
/* Computing 2nd power */
	r__1 = yh;
	yh2 = r__1 * r__1;
	betayh = beta * yh;
	ydif = yh - y0h;
/* Computing 2nd power */
	r__1 = ydif;
	xdif = (real) (sqrt((d__1 = a * q - det * (doublereal) (r__1 * r__1), 
		abs(d__1)) + dsmall) / a);
	xmin = x0h - ba * ydif - xdif + eye[1];
	xmax = x0h - ba * ydif + xdif + eye[1];
	ixmin = (integer) ((xmin - sftbuf_1.xblc) / dx) + 2;
	ixmax = (integer) ((xmax - sftbuf_1.xblc) / dx) + 1;
	if (ixmin <= sftbuf_1.nxp && ixmax >= 1) {
	    if (ixmin < 1) {
		ixmin = 1;
	    }
	    if (ixmax > sftbuf_1.nxp) {
		ixmax = sftbuf_1.nxp;
	    }
	    xh = sftbuf_1.xblc + dx * (real) (ixmin - 1) - eye[1];
	    k = (jy - 1) * sftbuf_1.nxp + ixmin;
	    i__2 = ixmax;
	    for (ix = ixmin; ix <= i__2; ++ix) {
		itest = ix % 2;
		if (itlevl == 1) {
		    if (itest + jtest == 0) {
			goto L9;
		    }
		} else if (itlevl == 2) {
		    if (itest + jtest == 1) {
			goto L9;
		    }
		} else {
		    if (itest == 1) {
			goto L9;
		    }
		}
		if (zmax > sftbuf_1.sbbuff[k - 1]) {
/* Computing 2nd power */
		    r__1 = xh;
		    xh2 = r__1 * r__1;
		    alfaxh = alfa * xh;
		    dbl1 = (doublereal) (alfaxh + betayh) - dgamze;
		    dbl2 = (doublereal) (xh2 + yh2) + dze2;
/* Computing 2nd power */
		    d__2 = dbl1;
		    xlm = (real) ((-dbl1 - sqrt((d__1 = d__2 * d__2 + xmu * 
			    dbl2, abs(d__1)) + dsmall)) / dbl2);
		    surf[2] = eye[3] * ((float)1. - xlm);
		    if (surf[2] > sftbuf_1.sbbuff[k - 1]) {
			sftbuf_1.sbbuff[k - 1] = surf[2];
			if (nc == 0) {
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = col0;
			} else {
			    surf[1] = eye[2] + yh * xlm;
			    surf[0] = eye[1] + xh * xlm;
			    sbglos_(&eye[1], &centre[1], &light[1], surf, &
				    xnl2, &xn3, &small, lshine, &colour);
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = col0 + 
				    colour * colscl;
			}
		    }
		}
L9:
		++k;
		xh += dx;
/* L10: */
	    }
	}
L19:
	yh += dy;
/* L20: */
    }
} /* sbtbal_ */


/* Subroutine */ int sbtsur_(eye, latice, dens, n1, n2, n3, dsurf, ic1, ic2, 
	light, lshine, itrans)
real *eye, *latice, *dens;
integer *n1, *n2, *n3;
real *dsurf;
integer *ic1, *ic2;
real *light;
logical *lshine;
integer *itrans;
{
    /* System generated locals */
    integer dens_dim1, dens_dim2, dens_offset, i__1, i__2, i__3;
    real r__1, r__2, r__3;
    doublereal d__1, d__2, d__3;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static real xyz1, xyz2, xyz3, deye, dnrm, zfar, vert[36]	/* was [3][12]
	     */;
    static integer ntot;
    static real dxyz[9]	/* was [3][3] */, bas2j;
    static integer iface, i__, j, k;
    static real small;
    static doublereal pneye[3];
    static integer isumf, ivert[8], j0, j1, i1, i0;
    static real ddxyz[72]	/* was [3][12][2] */;
    static integer k1, k0, isumv;
    static doublereal dsmal2;
    static real small2;
    extern /* Subroutine */ int sbsrf0_(), sbsrf1_(), sbsrf3_(), sbtsf2_(), 
	    sbsrf4_(), sbtsf5_();
    static integer kk, in, jn;
    static real dlocal[8];
    static integer ibside;
    static real xn, yn, zn, grdscl[3], cossee, ddsurf;
    extern /* Subroutine */ int sbrcop_();
    static real detnrm;
    static logical lempty;
    static doublereal xlnorm;
    static real frcxyz[12], xn1, xn2, xn3, bas[9]	/* was [3][3] */, det,
	     x00k, y00k, z00k, xyz[3], x0jk, y0jk, z0jk;

/*     --------------------------------------------------------------- */



/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      This subroutine plots a semi-transparent iso-surface through a */
/*    unit-cell of density. All (x,y,z) values are taken to be given in */
/*    world coordinates. The z-component of the eye-poisition should be */
/*    positive and that of all the lattice-vertices should be negative; */
/*    the viewing-screen is fixed at z=0. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    EYE      R*4    I       3      (x,y,z) coordinate of eye-position. */
/*    LATICE   R*4    I     3 x 4    (x,y,z) coordinates of the origin */
/*                                   and the a, b & C lattice-vertices. */
/*    DENS     R*4    I     (N1+1)   The density at regular points within */
/*                        x (N2+1)   the unit cell, wrapped around so */
/*                        x (N3+1)   that DENS(0,J,K)=DENS(N1,J,K) etc.. */
/*    N1,N2,N3 I*4    I       -      The dimensions of the unit-cell grid. */
/*    DSURF    R*4    I       -      Density for the iso-surface. */
/*    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be */
/*                                   used for the shading. */
/*    LIGHT    R*4    I       3      (x,y,z) direction of flood-light. */
/*    LSHINE   L*1    I       -      Shiny surface if TRUE, else diffuse. */
/*    ITRANS   I*4    I       -      Level of transparency: */
/*                                        1 = 25%; 2 = 50%; 3 = 75%. */

/* Globals */
/*    SFTBUF */
/*    SRFCOM */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     SBSRF0     A quick check in case there are no iso-surafces. */
/*     SBSRF1     Anlayses a 2-d box in the surface of the unit-cell. */
/*     SBTSF2     Paints a 2-d box in the surface of the unit-cell. */
/*     SBSRF3     Analyses a 3-d box within the unit-cell. */
/*     SBSRF4     Initialises the gradients for a 3-d box. */
/*     SBTSF5     Breaks up the iso-surface in a 3-d box into triangles. */
/*     SBTSF6     Paints a triangular patch of a semi-transp iso-surface. */

/* History */
/*   D. S. Sivia       9 Jul 1996  Initial release. */
/*   D. S. Sivia      24 Oct 1997 "Safe-guarded" some rounding errors. */
/* ----------------------------------------------------------------------- */

/* Carry out some initial checks. */

    /* Parameter adjustments */
    --eye;
    latice -= 4;
    dens_dim1 = *n1 - 0 + 1;
    dens_dim2 = *n2 - 0 + 1;
    dens_offset = 0 + dens_dim1 * (0 + dens_dim2 * 0);
    dens -= dens_offset;
    --light;

    /* Function Body */
    small = (float)1e-10;
/* Computing 2nd power */
    r__1 = small;
    small2 = r__1 * r__1;
    dsmal2 = (doublereal) small2;
    if (eye[3] <= small) {
	return 0;
    }
    if (*n1 < 1 || *n2 < 1 || *n3 < 1) {
	return 0;
    }
/* Computing 2nd power */
    r__1 = light[1];
/* Computing 2nd power */
    r__2 = light[2];
/* Computing 2nd power */
    r__3 = light[3];
    srfcom_1.xl2 = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
    if (srfcom_1.xl2 < small) {
	return 0;
    }
    if (latice[6] >= (float)0.) {
	return 0;
    }
    zfar = latice[9] + latice[12] + latice[15] - latice[6] * (float)2.;
    if (zfar >= (float)0.) {
	return 0;
    }
    for (j = 1; j <= 3; ++j) {
	if (latice[(j + 1) * 3 + 3] >= (float)0.) {
	    return 0;
	}
	bas[j * 3 - 3] = latice[(j + 1) * 3 + 1] - latice[4];
	bas[j * 3 - 2] = latice[(j + 1) * 3 + 2] - latice[5];
	bas[j * 3 - 1] = latice[(j + 1) * 3 + 3] - latice[6];
	if (zfar - bas[j * 3 - 1] >= (float)0.) {
	    return 0;
	}
/* Computing 2nd power */
	r__1 = bas[j * 3 - 3];
/* Computing 2nd power */
	r__2 = bas[j * 3 - 2];
/* Computing 2nd power */
	r__3 = bas[j * 3 - 1];
	bas2j = r__1 * r__1 + r__2 * r__2 + r__3 * r__3;
	if (bas2j < small2) {
	    return 0;
	}
/* L10: */
    }
    ntot = (*n1 + 1) * (*n2 + 1) * (*n3 + 1);
    sbsrf0_(&dens[dens_offset], &ntot, dsurf, &lempty);
    if (lempty) {
	return 0;
    }

/* Set up matrix for real-space to lattice-index transformation. */

    xn1 = (real) (*n1) * (float).99999;
    xn2 = (real) (*n2) * (float).99999;
    xn3 = (real) (*n3) * (float).99999;
    det = bas[0] * bas[4] * bas[8] + bas[3] * bas[7] * bas[2] + bas[6] * bas[
	    1] * bas[5] - bas[2] * bas[4] * bas[6] - bas[5] * bas[7] * bas[0] 
	    - bas[8] * bas[1] * bas[3];
    if (dabs(det) < small2) {
	return 0;
    }
    detnrm = (float)1. / det;
    srfcom_1.mtrx[0] = xn1 * detnrm * (bas[4] * bas[8] - bas[7] * bas[5]);
    srfcom_1.mtrx[3] = xn2 * detnrm * (bas[7] * bas[2] - bas[1] * bas[8]);
    srfcom_1.mtrx[6] = xn3 * detnrm * (bas[1] * bas[5] - bas[4] * bas[2]);
    srfcom_1.mtrx[1] = xn1 * detnrm * (bas[5] * bas[6] - bas[8] * bas[3]);
    srfcom_1.mtrx[4] = xn2 * detnrm * (bas[8] * bas[0] - bas[2] * bas[6]);
    srfcom_1.mtrx[7] = xn3 * detnrm * (bas[2] * bas[3] - bas[5] * bas[0]);
    srfcom_1.mtrx[2] = xn1 * detnrm * (bas[3] * bas[7] - bas[6] * bas[4]);
    srfcom_1.mtrx[5] = xn2 * detnrm * (bas[6] * bas[1] - bas[0] * bas[7]);
    srfcom_1.mtrx[8] = xn3 * detnrm * (bas[0] * bas[4] - bas[3] * bas[1]);
    sbrcop_(&latice[4], srfcom_1.orig, &c__3);

/* Some general initialisations. */

/* Computing MAX */
    r__1 = dabs(*dsurf);
    ddsurf = dmax(r__1,small);
    if (*dsurf < (float)0.) {
	ddsurf = -ddsurf;
    }
    grdscl[0] = (float)-.5 / (ddsurf * (real) (*n1));
    grdscl[1] = (float)-.5 / (ddsurf * (real) (*n2));
    grdscl[2] = (float)-.5 / (ddsurf * (real) (*n3));
    srfcom_1.col0 = (real) (*ic1);
    srfcom_1.colscl = (real) (*ic2 - *ic1);
    for (i__ = 1; i__ <= 3; ++i__) {
	dxyz[i__ - 1] = bas[i__ - 1] / (real) (*n1);
	dxyz[i__ + 2] = bas[i__ + 2] / (real) (*n2);
	dxyz[i__ + 5] = bas[i__ + 5] / (real) (*n3);
	ddxyz[i__ - 1] = (float)0.;
	ddxyz[i__ + 35] = dxyz[i__ - 1];
	ddxyz[i__ + 2] = ddxyz[i__ - 1] + ddxyz[i__ + 35];
	ddxyz[i__ + 38] = dxyz[i__ + 2];
	ddxyz[i__ + 5] = ddxyz[i__ + 2] + ddxyz[i__ + 38];
	ddxyz[i__ + 41] = -dxyz[i__ - 1];
	ddxyz[i__ + 8] = ddxyz[i__ + 5] + ddxyz[i__ + 41];
	ddxyz[i__ + 44] = -dxyz[i__ + 2];
	for (j = 1; j <= 4; ++j) {
	    ddxyz[i__ + (j + 16) * 3 - 40] = ddxyz[i__ + (j + 12) * 3 - 40];
	    ddxyz[i__ + (j + 28) * 3 - 40] = dxyz[i__ + 5];
	    ddxyz[i__ + (j + 20) * 3 - 40] = ddxyz[i__ + (j + 12) * 3 - 40] + 
		    dxyz[i__ + 5];
	    ddxyz[i__ + (j + 32) * 3 - 40] = ddxyz[i__ + (j + 24) * 3 - 40];
/* L20: */
	}
/* L30: */
    }

/* First paint the edges of the lattice. */

    for (iface = 1; iface <= 3; ++iface) {
	i__ = iface;
	j = iface % 3 + 1;
	k = j % 3 + 1;
	if (iface == 1) {
	    in = *n1;
	    jn = *n2;
	} else if (iface == 2) {
	    in = *n2;
	    jn = *n3;
	} else {
	    in = *n3;
	    jn = *n1;
	}
	kk = 0;
	xn = bas[j * 3 - 2] * bas[i__ * 3 - 1] - bas[i__ * 3 - 2] * bas[j * 3 
		- 1];
	yn = bas[j * 3 - 1] * bas[i__ * 3 - 3] - bas[i__ * 3 - 1] * bas[j * 3 
		- 3];
	zn = bas[j * 3 - 3] * bas[i__ * 3 - 2] - bas[i__ * 3 - 3] * bas[j * 3 
		- 2];
/* Computing 2nd power */
	r__1 = xn;
/* Computing 2nd power */
	r__2 = yn;
/* Computing 2nd power */
	r__3 = zn;
	dnrm = sqrt(r__1 * r__1 + r__2 * r__2 + r__3 * r__3 + small2);
	pneye[0] = (doublereal) (eye[1] - (latice[(i__ + 1) * 3 + 1] + latice[
		(j + 1) * 3 + 1]) * (float).5);
	pneye[1] = (doublereal) (eye[2] - (latice[(i__ + 1) * 3 + 2] + latice[
		(j + 1) * 3 + 2]) * (float).5);
	pneye[2] = (doublereal) (eye[3] - (latice[(i__ + 1) * 3 + 3] + latice[
		(j + 1) * 3 + 3]) * (float).5);
/* Computing 2nd power */
	d__1 = pneye[0];
/* Computing 2nd power */
	d__2 = pneye[1];
/* Computing 2nd power */
	d__3 = pneye[2];
	deye = (real) sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3 + dsmal2);
	xlnorm = (doublereal) xn * pneye[0] + (doublereal) yn * pneye[1] + (
		doublereal) zn * pneye[2];
	cossee = (real) xlnorm / (deye * dnrm);
	if (cossee < (float).001) {
	    kk = *n3;
	    if (iface == 2) {
		kk = *n1;
	    }
	    if (iface == 3) {
		kk = *n2;
	    }
	    pneye[0] += (doublereal) bas[k * 3 - 3];
	    pneye[1] += (doublereal) bas[k * 3 - 2];
	    pneye[2] += (doublereal) bas[k * 3 - 1];
/* Computing 2nd power */
	    d__1 = pneye[0];
/* Computing 2nd power */
	    d__2 = pneye[1];
/* Computing 2nd power */
	    d__3 = pneye[2];
	    deye = (real) sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3 + 
		    dsmal2);
	    xlnorm = (doublereal) xn * pneye[0] + (doublereal) yn * pneye[1] 
		    + (doublereal) zn * pneye[2];
	    cossee = -((real) xlnorm) / (deye * dnrm);
	}
	if (cossee > (float).001) {
	    xyz1 = (real) kk * dxyz[k * 3 - 3] + latice[4];
	    xyz2 = (real) kk * dxyz[k * 3 - 2] + latice[5];
	    xyz3 = (real) kk * dxyz[k * 3 - 1] + latice[6];
	    i__1 = jn;
	    for (j1 = 1; j1 <= i__1; ++j1) {
		j0 = j1 - 1;
		i__2 = in;
		for (i1 = 1; i1 <= i__2; ++i1) {
		    i0 = i1 - 1;
		    if (iface == 1) {
			dlocal[0] = dens[i0 + (j0 + kk * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[1] = dens[i1 + (j0 + kk * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[2] = dens[i1 + (j1 + kk * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[3] = dens[i0 + (j1 + kk * dens_dim2) * 
				dens_dim1] - *dsurf;
		    } else if (iface == 2) {
			dlocal[0] = dens[kk + (i0 + j0 * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[1] = dens[kk + (i1 + j0 * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[2] = dens[kk + (i1 + j1 * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[3] = dens[kk + (i0 + j1 * dens_dim2) * 
				dens_dim1] - *dsurf;
		    } else {
			dlocal[0] = dens[j0 + (kk + i0 * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[1] = dens[j0 + (kk + i1 * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[2] = dens[j1 + (kk + i1 * dens_dim2) * 
				dens_dim1] - *dsurf;
			dlocal[3] = dens[j1 + (kk + i0 * dens_dim2) * 
				dens_dim1] - *dsurf;
		    }
		    sbsrf1_(dlocal, &ibside, frcxyz);
		    if (ibside != 0) {
			xyz[0] = xyz1 + dxyz[i__ * 3 - 3] * (real) i0;
			xyz[1] = xyz2 + dxyz[i__ * 3 - 2] * (real) i0;
			xyz[2] = xyz3 + dxyz[i__ * 3 - 1] * (real) i0;
			sbtsf2_(xyz, &dxyz[i__ * 3 - 3], &dxyz[j * 3 - 3], &
				ibside, frcxyz, vert, &eye[1], &light[1], 
				lshine, itrans);
		    }
/* L40: */
		}
		xyz1 += dxyz[j * 3 - 3];
		xyz2 += dxyz[j * 3 - 2];
		xyz3 += dxyz[j * 3 - 1];
/* L50: */
	    }
	}
/* L60: */
    }

/* Step through each "cube" in the lattice, and paint any isosurfaces */
/* found therein. */

    x00k = latice[4];
    y00k = latice[5];
    z00k = latice[6];
    i__1 = *n3;
    for (k1 = 1; k1 <= i__1; ++k1) {
	k0 = k1 - 1;
	i__2 = *n2;
	for (j1 = 1; j1 <= i__2; ++j1) {
	    j0 = j1 - 1;
	    x0jk = x00k + dxyz[3] * (real) j0;
	    y0jk = y00k + dxyz[4] * (real) j0;
	    z0jk = z00k + dxyz[5] * (real) j0;
	    i__3 = *n1;
	    for (i1 = 1; i1 <= i__3; ++i1) {
		i0 = i1 - 1;
		dlocal[0] = dens[i0 + (j0 + k0 * dens_dim2) * dens_dim1] - *
			dsurf;
		dlocal[1] = dens[i1 + (j0 + k0 * dens_dim2) * dens_dim1] - *
			dsurf;
		dlocal[2] = dens[i1 + (j1 + k0 * dens_dim2) * dens_dim1] - *
			dsurf;
		dlocal[3] = dens[i0 + (j1 + k0 * dens_dim2) * dens_dim1] - *
			dsurf;
		dlocal[4] = dens[i0 + (j0 + k1 * dens_dim2) * dens_dim1] - *
			dsurf;
		dlocal[5] = dens[i1 + (j0 + k1 * dens_dim2) * dens_dim1] - *
			dsurf;
		dlocal[6] = dens[i1 + (j1 + k1 * dens_dim2) * dens_dim1] - *
			dsurf;
		dlocal[7] = dens[i0 + (j1 + k1 * dens_dim2) * dens_dim1] - *
			dsurf;
		sbsrf3_(dlocal, ivert, frcxyz, &isumv, &isumf);
		if (isumv != 0) {
		    xyz[0] = x0jk + dxyz[0] * (real) i0;
		    xyz[1] = y0jk + dxyz[1] * (real) i0;
		    xyz[2] = z0jk + dxyz[2] * (real) i0;
		    sbsrf4_(&dens[dens_offset], n1, n2, n3, &i0, &j0, &k0, 
			    grdscl, bas, srfcom_1.grdcub);
		    sbtsf5_(xyz, ddxyz, &isumv, &isumf, ivert, frcxyz, vert, &
			    eye[1], &light[1], lshine, itrans);
		}
/* L70: */
	    }
/* L80: */
	}
	x00k += dxyz[6];
	y00k += dxyz[7];
	z00k += dxyz[8];
/* L90: */
    }
} /* sbtsur_ */


/* Subroutine */ int sbtsf2_(xyz, d1, d2, ib, frc, vert, eye, light, lshine, 
	itrans)
real *xyz, *d1, *d2;
integer *ib;
real *frc, *vert, *eye, *light;
logical *lshine;
integer *itrans;
{
    static integer i__;
    extern /* Subroutine */ int sbtsf6_();

/*     ---------------------------------------------------------------- */


    /* Parameter adjustments */
    --light;
    --eye;
    vert -= 4;
    --frc;
    --d2;
    --d1;
    --xyz;

    /* Function Body */
    if (*ib == 15) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__];
	    vert[i__ + 6] = xyz[i__] + d1[i__];
	    vert[i__ + 9] = vert[i__ + 6] + d2[i__];
	    vert[i__ + 12] = xyz[i__] + d2[i__];
/* L10: */
	}
	sbtsf6_(itrans, &eye[1], &c__4, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 1) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__];
	    vert[i__ + 6] = vert[i__ + 3] + frc[1] * d1[i__];
	    vert[i__ + 9] = xyz[i__] + ((float)1. - frc[4]) * d2[i__];
/* L20: */
	}
	sbtsf6_(itrans, &eye[1], &c__3, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 2) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d1[i__];
	    vert[i__ + 6] = vert[i__ + 3] + frc[2] * d2[i__];
	    vert[i__ + 9] = xyz[i__] + frc[1] * d1[i__];
/* L30: */
	}
	sbtsf6_(itrans, &eye[1], &c__3, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 4) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d1[i__] + d2[i__];
	    vert[i__ + 6] = vert[i__ + 3] - frc[3] * d1[i__];
	    vert[i__ + 9] = vert[i__ + 3] - ((float)1. - frc[2]) * d2[i__];
/* L40: */
	}
	sbtsf6_(itrans, &eye[1], &c__3, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 8) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d2[i__];
	    vert[i__ + 6] = vert[i__ + 3] - frc[4] * d2[i__];
	    vert[i__ + 9] = vert[i__ + 3] + ((float)1. - frc[3]) * d1[i__];
/* L50: */
	}
	sbtsf6_(itrans, &eye[1], &c__3, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 7) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__];
	    vert[i__ + 6] = vert[i__ + 3] + d1[i__];
	    vert[i__ + 9] = vert[i__ + 6] + d2[i__];
	    vert[i__ + 12] = vert[i__ + 9] - frc[3] * d1[i__];
	    vert[i__ + 15] = xyz[i__] + ((float)1. - frc[4]) * d2[i__];
/* L60: */
	}
	sbtsf6_(itrans, &eye[1], &c__5, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 14) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d1[i__];
	    vert[i__ + 6] = vert[i__ + 3] + d2[i__];
	    vert[i__ + 9] = xyz[i__] + d2[i__];
	    vert[i__ + 12] = xyz[i__] + ((float)1. - frc[4]) * d2[i__];
	    vert[i__ + 15] = xyz[i__] + frc[1] * d1[i__];
/* L70: */
	}
	sbtsf6_(itrans, &eye[1], &c__5, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 13) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d1[i__] + d2[i__];
	    vert[i__ + 6] = xyz[i__] + d2[i__];
	    vert[i__ + 9] = xyz[i__];
	    vert[i__ + 12] = xyz[i__] + frc[1] * d1[i__];
	    vert[i__ + 15] = xyz[i__] + d1[i__] + frc[2] * d2[i__];
/* L80: */
	}
	sbtsf6_(itrans, &eye[1], &c__5, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 11) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d2[i__];
	    vert[i__ + 6] = xyz[i__];
	    vert[i__ + 9] = xyz[i__] + d1[i__];
	    vert[i__ + 12] = vert[i__ + 9] + frc[2] * d2[i__];
	    vert[i__ + 15] = vert[i__ + 3] + ((float)1. - frc[3]) * d1[i__];
/* L90: */
	}
	sbtsf6_(itrans, &eye[1], &c__5, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 3) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__];
	    vert[i__ + 6] = xyz[i__] + d1[i__];
	    vert[i__ + 9] = vert[i__ + 6] + frc[2] * d2[i__];
	    vert[i__ + 12] = xyz[i__] + ((float)1. - frc[4]) * d2[i__];
/* L100: */
	}
	sbtsf6_(itrans, &eye[1], &c__4, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 6) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d1[i__];
	    vert[i__ + 6] = vert[i__ + 3] + d2[i__];
	    vert[i__ + 9] = vert[i__ + 6] - frc[3] * d1[i__];
	    vert[i__ + 12] = xyz[i__] + frc[1] * d1[i__];
/* L110: */
	}
	sbtsf6_(itrans, &eye[1], &c__4, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 12) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d1[i__] + d2[i__];
	    vert[i__ + 6] = xyz[i__] + d2[i__];
	    vert[i__ + 9] = vert[i__ + 6] - frc[4] * d2[i__];
	    vert[i__ + 12] = xyz[i__] + d1[i__] + frc[2] * d2[i__];
/* L120: */
	}
	sbtsf6_(itrans, &eye[1], &c__4, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 9) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d2[i__];
	    vert[i__ + 6] = xyz[i__];
	    vert[i__ + 9] = xyz[i__] + frc[1] * d1[i__];
	    vert[i__ + 12] = vert[i__ + 3] + ((float)1. - frc[3]) * d1[i__];
/* L130: */
	}
	sbtsf6_(itrans, &eye[1], &c__4, &vert[4], lshine, &light[1], &c__0);
    } else if (*ib == 5) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__];
	    vert[i__ + 6] = vert[i__ + 3] + frc[1] * d1[i__];
	    vert[i__ + 9] = xyz[i__] + ((float)1. - frc[4]) * d2[i__];
	    vert[i__ + 12] = xyz[i__] + d1[i__] + d2[i__];
	    vert[i__ + 15] = vert[i__ + 12] - frc[3] * d1[i__];
	    vert[i__ + 18] = vert[i__ + 12] - ((float)1. - frc[2]) * d2[i__];
/* L140: */
	}
	sbtsf6_(itrans, &eye[1], &c__3, &vert[4], lshine, &light[1], &c__0);
	sbtsf6_(itrans, &eye[1], &c__3, &vert[13], lshine, &light[1], &c__0);
    } else if (*ib == 10) {
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + 3] = xyz[i__] + d1[i__];
	    vert[i__ + 6] = vert[i__ + 3] + frc[2] * d2[i__];
	    vert[i__ + 9] = xyz[i__] + frc[1] * d1[i__];
	    vert[i__ + 12] = xyz[i__] + d2[i__];
	    vert[i__ + 15] = vert[i__ + 12] - frc[4] * d2[i__];
	    vert[i__ + 18] = vert[i__ + 12] + ((float)1. - frc[3]) * d1[i__];
/* L150: */
	}
	sbtsf6_(itrans, &eye[1], &c__3, &vert[4], lshine, &light[1], &c__0);
	sbtsf6_(itrans, &eye[1], &c__3, &vert[13], lshine, &light[1], &c__0);
    }
} /* sbtsf2_ */


/* Subroutine */ int sbtsf5_(xyz, dxyz, isv, isf, iv, frc, vert, eye, light, 
	lshine, itrans)
real *xyz, *dxyz;
integer *isv, *isf, *iv;
real *frc, *vert, *eye, *light;
logical *lshine;
integer *itrans;
{
    /* Initialized data */

    static integer iv4map[12] = { 12,8,4,3,11,7,6,2,10,9,5,1 };

    static integer i__, j, ijdif, i1, i2, k2, k3, k4;
    extern /* Subroutine */ int stsf5a_(), stsf5b_(), stsf5c_(), stsf5d_();
    static integer k4a, k4b;

/*     ---------------------------------------------------------------- */

    /* Parameter adjustments */
    --light;
    --eye;
    vert -= 4;
    --frc;
    --iv;
    dxyz -= 40;
    --xyz;

    /* Function Body */

    if (*isv == 1) {
	stsf5a_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &iv[1], &eye[1]
		, lshine, &light[1]);
    } else if (*isv == 2) {
	if (*isf == 6) {
	    stsf5a_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &iv[1], &
		    eye[1], lshine, &light[1]);
	    stsf5a_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &iv[2], &
		    eye[1], lshine, &light[1]);
	} else {
	    ijdif = iv[2] - iv[1];
	    if (iv[1] <= 4) {
		if (iv[2] <= 4) {
		    k2 = iv[1];
		    if (ijdif == 3) {
			k2 = iv[2];
		    }
		} else {
		    k2 = iv[2];
		}
	    } else {
		k2 = iv[1] + 4;
		if (ijdif == 3) {
		    k2 = iv[2] + 4;
		}
	    }
	    stsf5b_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &k2, &eye[
		    1], lshine, &light[1], &c__1);
	}
    } else if (*isv == 3) {
	if (*isf == 9) {
	    for (i__ = 1; i__ <= 3; ++i__) {
/* L10: */
		stsf5a_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &iv[
			i__], &eye[1], lshine, &light[1]);
	    }
	} else if (*isf == 6) {
	    for (i1 = 1; i1 <= 3; ++i1) {
		i2 = i1 % 3 + 1;
		i__ = min(i1,i2);
		j = max(i1,i2);
		k2 = 0;
		ijdif = iv[j] - iv[i__];
		if (iv[i__] <= 4) {
		    if (iv[j] <= 4) {
			if (ijdif == 1) {
			    k2 = iv[i__];
			} else if (ijdif == 3) {
			    k2 = iv[j];
			}
		    } else {
			if (ijdif == 4) {
			    k2 = iv[j];
			}
		    }
		} else {
		    if (ijdif == 1) {
			k2 = iv[i__] + 4;
		    } else if (ijdif == 3) {
			k2 = iv[j] + 4;
		    }
		}
		if (k2 > 0) {
		    goto L1;
		}
/* L20: */
	    }
L1:
	    stsf5b_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &k2, &eye[
		    1], lshine, &light[1], &c__1);
	} else {
	    k3 = iv[1] + iv[2] + iv[3] - 5 + (iv[1] / 5 + (iv[2] / 5 << 1) + 
		    iv[3] / 5 << 1);
	    stsf5c_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &k3, &eye[
		    1], lshine, &light[1]);
	}
    } else {
	if (*isf == 12) {
	    for (i__ = 1; i__ <= 4; ++i__) {
/* L30: */
		stsf5a_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &iv[
			i__], &eye[1], lshine, &light[1]);
	    }
	} else if (*isf == 4) {
	    k4 = (iv[1] + iv[2] + iv[3] + iv[4] - 6) / 4;
	    if (iv[2] - iv[1] == 3) {
		k4 = 6;
	    }
	    stsf5b_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &k4, &eye[
		    1], lshine, &light[1], &c__2);
	} else if (*isf == 6) {
	    if (iv[3] <= 4) {
		k3 = iv[1] + iv[2] + iv[3] - 6;
		k4 = (iv[4] + k3) % 4 + k3 * 3;
	    } else {
		if (iv[2] >= 5) {
		    k3 = iv[2] + iv[3] + iv[4] - 18;
		    k4 = iv4map[(iv[1] + k3) % 4 + k3 * 3 - 1];
		} else {
		    k4 = iv[3] + 12 - iv[2];
		    if (iv[1] + iv[2] + iv[3] + iv[4] == 22) {
			k4 = 29 - k4;
		    }
		}
	    }
	    stsf5d_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &k4, &eye[
		    1], lshine, &light[1]);
	} else {
	    k4 = iv[1] + iv[2] + iv[3] + iv[4];
	    if (k4 == 16 || k4 == 20) {
		stsf5b_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &iv[3],
			 &eye[1], lshine, &light[1], &c__1);
		stsf5b_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &iv[4],
			 &eye[1], lshine, &light[1], &c__1);
	    } else if (k4 == 18) {
		k4a = iv[1];
		if (iv[2] - k4a == 3) {
		    k4a = 4;
		}
		k4b = (k4a + 1) % 4 + 9;
		stsf5b_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &k4a, &
			eye[1], lshine, &light[1], &c__1);
		stsf5b_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &k4b, &
			eye[1], lshine, &light[1], &c__1);
	    } else {
		if (k4 == 14) {
		    k4a = iv[4];
		    k3 = iv[1] + iv[2] + iv[3] - 5 + (iv[1] / 5 + (iv[2] / 5 
			    << 1) + iv[3] / 5 << 1);
		} else if (k4 == 22) {
		    k4a = iv[1];
		    k3 = iv[2] + iv[3] + iv[4] - 5 + (iv[2] / 5 + (iv[3] / 5 
			    << 1) + iv[4] / 5 << 1);
		} else {
		    if ((iv[1] + iv[2]) % 2 == 0) {
			if (iv[4] == 6 || iv[3] - iv[2] == 2) {
			    k4a = iv[2];
			    k3 = iv[1] + iv[3] + iv[4] - 5 + (iv[1] / 5 + (iv[
				    3] / 5 << 1) + iv[4] / 5 << 1);
			} else {
			    k4a = iv[1];
			    k3 = iv[2] + iv[3] + iv[4] - 5 + (iv[2] / 5 + (iv[
				    3] / 5 << 1) + iv[4] / 5 << 1);
			}
		    } else {
			if (iv[1] == 3 || iv[3] - iv[2] == 2) {
			    k4a = iv[3];
			    k3 = iv[1] + iv[2] + iv[4] - 5 + (iv[1] / 5 + (iv[
				    2] / 5 << 1) + iv[4] / 5 << 1);
			} else {
			    k4a = iv[4];
			    k3 = iv[1] + iv[2] + iv[3] - 5 + (iv[1] / 5 + (iv[
				    2] / 5 << 1) + iv[3] / 5 << 1);
			}
		    }
		}
		stsf5a_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &k4a, &
			eye[1], lshine, &light[1]);
		stsf5c_(itrans, &xyz[1], &dxyz[40], &frc[1], &vert[4], &k3, &
			eye[1], lshine, &light[1]);
	    }
	}
    }
} /* sbtsf5_ */


/* Subroutine */ int stsf5a_(itrans, xyz, dxyz, frc, vert, iv, eye, lshine, 
	light)
integer *itrans;
real *xyz, *dxyz, *frc, *vert;
integer *iv;
real *eye;
logical *lshine;
real *light;
{
    static integer i__, j, k, l;
    extern /* Subroutine */ int sbtsf6_();

/*     --------------------------------------------------------------- */


    /* Parameter adjustments */
    --light;
    --eye;
    vert -= 4;
    --frc;
    dxyz -= 40;
    --xyz;

    /* Function Body */
    if (*iv <= 4) {
	j = *iv;
	k = (*iv + 2) % 4 + 1;
	l = *iv + 4;
    } else {
	j = *iv + 4;
	k = (*iv - 2) % 4 + 9;
	l = *iv;
    }
    for (i__ = 1; i__ <= 3; ++i__) {
	vert[i__ + 3] = xyz[i__] + dxyz[i__ + (j + 12) * 3] + frc[j] * dxyz[
		i__ + (j + 24) * 3];
	vert[i__ + 6] = xyz[i__] + dxyz[i__ + (k + 12) * 3] + frc[k] * dxyz[
		i__ + (k + 24) * 3];
	vert[i__ + 9] = xyz[i__] + dxyz[i__ + (l + 12) * 3] + frc[l] * dxyz[
		i__ + (l + 24) * 3];
/* L10: */
    }
    sbtsf6_(itrans, &eye[1], &c__3, &vert[4], lshine, &light[1], &c__1);
} /* stsf5a_ */


/* Subroutine */ int stsf5b_(itrans, xyz, dxyz, frc, vert, kk, eye, lshine, 
	light, ll)
integer *itrans;
real *xyz, *dxyz, *frc, *vert;
integer *kk;
real *eye;
logical *lshine;
real *light;
integer *ll;
{
    /* Initialized data */

    static integer ivl[96]	/* was [4][12][2] */ = { 5,6,2,4,6,7,3,1,7,8,
	    4,2,8,5,1,3,9,1,4,12,10,2,1,9,11,3,2,10,12,4,3,11,12,5,6,10,9,6,7,
	    11,10,7,8,12,11,8,5,9,5,6,7,8,4,2,10,12,1,3,11,9,4,2,10,12,5,6,7,
	    8,1,3,11,9,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 };

    static integer i__, j, k, l, m;
    extern /* Subroutine */ int sbtsf6_(), sbrcop_();

/*     ------------------------------------------------------------------ */

    /* Parameter adjustments */
    --light;
    --eye;
    vert -= 4;
    --frc;
    dxyz -= 40;
    --xyz;

    /* Function Body */

    j = ivl[(0 + (0 + (1 + (*kk + *ll * 12 << 2) - 53 << 2))) / 4];
    k = ivl[(*kk + *ll * 12 << 2) - 51];
    l = ivl[(*kk + *ll * 12 << 2) - 50];
    m = ivl[(*kk + *ll * 12 << 2) - 49];
    for (i__ = 1; i__ <= 3; ++i__) {
	vert[i__ + 3] = xyz[i__] + dxyz[i__ + (j + 12) * 3] + frc[j] * dxyz[
		i__ + (j + 24) * 3];
	vert[i__ + 6] = xyz[i__] + dxyz[i__ + (k + 12) * 3] + frc[k] * dxyz[
		i__ + (k + 24) * 3];
	vert[i__ + 9] = xyz[i__] + dxyz[i__ + (l + 12) * 3] + frc[l] * dxyz[
		i__ + (l + 24) * 3];
	vert[i__ + 12] = xyz[i__] + dxyz[i__ + (m + 12) * 3] + frc[m] * dxyz[
		i__ + (m + 24) * 3];
	vert[i__ + 15] = vert[i__ + 3];
	vert[i__ + 18] = (vert[i__ + 3] + vert[i__ + 6] + vert[i__ + 9] + 
		vert[i__ + 12]) * (float).25;
/* L10: */
    }
    for (i__ = 1; i__ <= 4; ++i__) {
	sbrcop_(&vert[i__ * 3 + 1], &vert[22], &c__6);
	sbtsf6_(itrans, &eye[1], &c__3, &vert[19], lshine, &light[1], &c__1);
/* L20: */
    }
} /* stsf5b_ */


/* Subroutine */ int stsf5c_(itrans, xyz, dxyz, frc, vert, k3, eye, lshine, 
	light)
integer *itrans;
real *xyz, *dxyz, *frc, *vert;
integer *k3;
real *eye;
logical *lshine;
real *light;
{
    /* Initialized data */

    static integer iv3[120]	/* was [5][24] */ = { 5,6,7,3,4,8,5,6,2,3,7,8,
	    5,1,2,6,7,8,4,1,12,4,2,6,9,4,2,10,9,5,9,1,3,8,12,9,1,3,7,10,1,3,
	    11,10,6,1,3,11,12,5,4,2,10,11,8,2,4,12,11,7,10,12,4,1,6,12,10,2,1,
	    5,11,9,1,4,8,1,9,11,7,2,3,11,9,6,2,3,11,9,5,4,2,10,12,8,3,4,12,10,
	    7,3,5,6,7,11,12,8,5,6,10,11,7,8,5,9,10,6,7,8,12,9 };

    static integer i__, j, k, l, m, n;
    extern /* Subroutine */ int sbtsf6_(), sbrcop_();

/*     --------------------------------------------------------------- */

    /* Parameter adjustments */
    --light;
    --eye;
    vert -= 4;
    --frc;
    dxyz -= 40;
    --xyz;

    /* Function Body */

    j = iv3[(0 + (0 + (1 + *k3 * 5 - 6 << 2))) / 4];
    k = iv3[*k3 * 5 - 4];
    l = iv3[*k3 * 5 - 3];
    m = iv3[*k3 * 5 - 2];
    n = iv3[*k3 * 5 - 1];
    for (i__ = 1; i__ <= 3; ++i__) {
	vert[i__ + 3] = xyz[i__] + dxyz[i__ + (j + 12) * 3] + frc[j] * dxyz[
		i__ + (j + 24) * 3];
	vert[i__ + 6] = xyz[i__] + dxyz[i__ + (k + 12) * 3] + frc[k] * dxyz[
		i__ + (k + 24) * 3];
	vert[i__ + 9] = xyz[i__] + dxyz[i__ + (l + 12) * 3] + frc[l] * dxyz[
		i__ + (l + 24) * 3];
	vert[i__ + 12] = xyz[i__] + dxyz[i__ + (m + 12) * 3] + frc[m] * dxyz[
		i__ + (m + 24) * 3];
	vert[i__ + 15] = xyz[i__] + dxyz[i__ + (n + 12) * 3] + frc[n] * dxyz[
		i__ + (n + 24) * 3];
	vert[i__ + 18] = vert[i__ + 3];
	vert[i__ + 21] = (vert[i__ + 3] + vert[i__ + 6] + vert[i__ + 9] + 
		vert[i__ + 12] + vert[i__ + 15]) * (float).2;
/* L10: */
    }
    for (i__ = 1; i__ <= 5; ++i__) {
	sbrcop_(&vert[i__ * 3 + 1], &vert[25], &c__6);
	sbtsf6_(itrans, &eye[1], &c__3, &vert[22], lshine, &light[1], &c__1);
/* L20: */
    }
} /* stsf5c_ */


/* Subroutine */ int stsf5d_(itrans, xyz, dxyz, frc, vert, k4, eye, lshine, 
	light)
integer *itrans;
real *xyz, *dxyz, *frc, *vert;
integer *k4;
real *eye;
logical *lshine;
real *light;
{
    /* Initialized data */

    static integer iv4[96]	/* was [6][16] */ = { 12,9,6,7,3,4,10,9,5,4,3,
	    7,11,10,6,5,4,3,11,12,5,6,2,3,9,12,8,3,2,6,10,9,5,8,3,2,10,11,8,5,
	    1,2,12,11,7,2,1,5,9,12,8,7,2,1,9,10,7,8,4,1,11,10,6,1,4,8,12,11,7,
	    6,1,4,12,10,6,1,3,8,12,10,7,3,1,5,11,9,6,2,4,8,11,9,5,4,2,7 };
    static real vnorm = (float).1666666667;

    static integer i__, j, k;
    extern /* Subroutine */ int sbtsf6_(), sbrfil_(), sbrcop_();

/*     --------------------------------------------------------------- */

    /* Parameter adjustments */
    --light;
    --eye;
    vert -= 4;
    --frc;
    dxyz -= 40;
    --xyz;

    /* Function Body */

    sbrfil_(&vert[25], &c_b14, &c__3);
    for (j = 1; j <= 6; ++j) {
	k = iv4[j + *k4 * 6 - 7];
	for (i__ = 1; i__ <= 3; ++i__) {
	    vert[i__ + j * 3] = xyz[i__] + dxyz[i__ + (k + 12) * 3] + frc[k] *
		     dxyz[i__ + (k + 24) * 3];
	    vert[i__ + 24] += vert[i__ + j * 3];
/* L10: */
	}
/* L20: */
    }
    sbrcop_(&vert[4], &vert[22], &c__3);
    for (i__ = 1; i__ <= 3; ++i__) {
/* L30: */
	vert[i__ + 24] *= vnorm;
    }
    for (i__ = 1; i__ <= 6; ++i__) {
	sbrcop_(&vert[i__ * 3 + 1], &vert[28], &c__6);
	sbtsf6_(itrans, &eye[1], &c__3, &vert[25], lshine, &light[1], &c__1);
/* L40: */
    }
} /* stsf5d_ */


/* Subroutine */ int sbtsf6_(itrans, eye, nv, vert, lshine, light, inside)
integer *itrans;
real *eye;
integer *nv;
real *vert;
logical *lshine;
real *light;
integer *inside;
{
    /* System generated locals */
    integer i__1, i__2, i__3, i__4;
    real r__1;

    /* Local variables */
    static real sdxi, sdyj, xmin, ymin, xmax, ymax;
    static integer i__, j, k;
    static real x, gradl, z__, y, gradr, safer;
    static integer ileft;
    static real xdifl, small, ydifl, xdifr, ydifr;
    static integer istep, ixmin, jymin, ixmax, jymax, ivert, jtest, j1, j2, 
	    itest, i1, i2, kstep;
    extern /* Subroutine */ int sbsf6a_(), sbsf6b_(), sblin1_();
    static real ax, ay, az, bx, by, bz, dx, dy, yj, xl, xn, yn, zn, xr, xi, 
	    xlamda, xw[20], yw[20];
    static doublereal zz;
    static real gx, gy, gz, yl;
    static integer jbotom;
    static real yr;
    static integer itlevl;
    static real eyenrm;
    static doublereal xlnorm;
    static integer ix1, ix2, jy1, jy2;
    static real clr, dxi, ten, dyj;
    static doublereal dzz;
    static integer nvl1, nvl2, nvr1, nvr2;

/*     --------------------------------------------------------- */



/* Carry out some initial checks and calculate the coordinates of the */
/* projected triangle. */

    /* Parameter adjustments */
    --light;
    vert -= 4;
    --eye;

    /* Function Body */
    if (*nv < 3 || *nv > 10) {
	return 0;
    }
    small = (float)1e-10;
    xmin = (float)1e20;
    xmax = (float)-1e20;
    ymin = (float)1e20;
    ymax = (float)-1e20;
    i__1 = *nv;
    for (i__ = 1; i__ <= i__1; ++i__) {
	sblin1_(&eye[1], &vert[i__ * 3 + 1], &vert[i__ * 3 + 2], &vert[i__ * 
		3 + 3], &xw[i__ - 1], &yw[i__ - 1]);
	if (xw[i__ - 1] < xmin) {
	    xmin = xw[i__ - 1];
	    ileft = i__;
	}
	if (yw[i__ - 1] < ymin) {
	    ymin = yw[i__ - 1];
	    jbotom = i__;
	}
/* Computing MAX */
	r__1 = xw[i__ - 1];
	xmax = dmax(r__1,xmax);
/* Computing MAX */
	r__1 = yw[i__ - 1];
	ymax = dmax(r__1,ymax);
/* L10: */
    }
    if (xmin >= sftbuf_1.xtrc || xmax <= sftbuf_1.xblc) {
	return 0;
    }
    if (ymin >= sftbuf_1.ytrc || ymax <= sftbuf_1.yblc) {
	return 0;
    }

/* Find the outward normal seen by the eye. */

    ax = vert[7] - vert[4];
    ay = vert[8] - vert[5];
    az = vert[9] - vert[6];
    bx = vert[4] - vert[*nv * 3 + 1];
    by = vert[5] - vert[*nv * 3 + 2];
    bz = vert[6] - vert[*nv * 3 + 3];
    xn = by * az - ay * bz;
    yn = bz * ax - az * bx;
    zn = bx * ay - ax * by;
    ten = xn * (eye[1] - vert[4]) + yn * (eye[2] - vert[5]) + zn * (eye[3] - 
	    vert[6]);
    if (ten < (float)0.) {
	xn = -xn;
	yn = -yn;
	zn = -zn;
	ten = -ten;
    }

/* Plot the projected triangle. */

/* Computing MAX */
    i__1 = min(*itrans,3);
    itlevl = max(i__1,1);
    xlnorm = (doublereal) ten;
    eyenrm = xn * eye[1] + yn * eye[2] + zn * eye[3];
    dx = (real) (sftbuf_1.nxp - 1) / (sftbuf_1.xtrc - sftbuf_1.xblc);
    dy = (real) (sftbuf_1.nyp - 1) / (sftbuf_1.ytrc - sftbuf_1.yblc);
    dyj = (float)1. / dy;
    dxi = (float)1. / dx;
    safer = (float)1e-4;
    if (xmax - xmin > ymax - ymin) {
	jymin = (integer) ((ymin - sftbuf_1.yblc) * dy) + 2;
/* Computing MIN */
	i__1 = (integer) ((ymax - sftbuf_1.yblc) * dy) + 1;
	jymax = min(i__1,sftbuf_1.nyp);
	if (jymin > jymax) {
	    return 0;
	}
	yj = sftbuf_1.yblc + ((real) (jymin - 1) + safer) * dyj;
	nvl2 = jbotom;
	nvr2 = jbotom;
	j1 = jymin;
	i__1 = *nv;
	for (ivert = 1; ivert <= i__1; ++ivert) {
	    if (yj > yw[nvl2 - 1]) {
L1:
		nvl1 = nvl2;
		nvl2 = nvl1 - 1;
		if (nvl2 < 1) {
		    nvl2 = *nv;
		}
		if (nvl2 == jbotom) {
		    return 0;
		}
		if (yj > yw[nvl2 - 1]) {
		    goto L1;
		}
		ydifl = yw[nvl2 - 1] - yw[nvl1 - 1];
		if (dabs(ydifl) < small) {
		    ydifl = small;
		}
		gradl = (xw[nvl2 - 1] - xw[nvl1 - 1]) / ydifl;
	    }
	    if (yj > yw[nvr2 - 1]) {
L2:
		nvr1 = nvr2;
		nvr2 = nvr1 + 1;
		if (nvr2 > *nv) {
		    nvr2 = 1;
		}
		if (nvr2 == jbotom) {
		    return 0;
		}
		if (yj > yw[nvr2 - 1]) {
		    goto L2;
		}
		ydifr = yw[nvr2 - 1] - yw[nvr1 - 1];
		if (dabs(ydifr) < small) {
		    ydifr = small;
		}
		gradr = (xw[nvr2 - 1] - xw[nvr1 - 1]) / ydifr;
	    }
	    if (yw[nvl2 - 1] < yw[nvr2 - 1]) {
/* Computing MIN */
		i__2 = (integer) ((yw[nvl2 - 1] - sftbuf_1.yblc) * dy) + 1;
		j2 = min(i__2,jymax);
	    } else {
/* Computing MIN */
		i__2 = (integer) ((yw[nvr2 - 1] - sftbuf_1.yblc) * dy) + 1;
		j2 = min(i__2,jymax);
	    }
	    i__2 = j2;
	    for (j = j1; j <= i__2; ++j) {
		if (j >= 1) {
		    jtest = j % 2;
		    if (itlevl == 3 && jtest == 1) {
			goto L29;
		    }
		    xl = xw[nvl1 - 1] + gradl * (yj - yw[nvl1 - 1]);
		    xr = xw[nvr1 - 1] + gradr * (yj - yw[nvr1 - 1]);
		    istep = 1;
/* Computing MAX */
		    i__3 = (integer) ((xl - sftbuf_1.xblc) * dx) + 2;
		    ix1 = max(i__3,1);
/* Computing MIN */
		    i__3 = (integer) ((xr - sftbuf_1.xblc) * dx) + 1;
		    ix2 = min(i__3,sftbuf_1.nxp);
		    if (ix1 > ix2) {
			istep = -1;
/* Computing MIN */
			i__3 = ix1 - 1;
			ix1 = min(i__3,sftbuf_1.nxp);
/* Computing MAX */
			i__3 = ix2 + 1;
			ix2 = max(i__3,1);
		    }
		    xi = sftbuf_1.xblc + (real) (ix1 - 1) * dxi;
		    sdxi = (real) istep * dxi;
		    dzz = (doublereal) (sdxi * xn);
		    zz = (doublereal) (eyenrm - xi * xn - yj * yn);
		    k = (j - 1) * sftbuf_1.nxp + ix1;
		    i__3 = ix2;
		    i__4 = istep;
		    for (i__ = ix1; i__4 < 0 ? i__ >= i__3 : i__ <= i__3; i__ 
			    += i__4) {
			itest = i__ % 2;
			if (itlevl == 1) {
			    if (itest + jtest == 0) {
				goto L19;
			    }
			} else if (itlevl == 2) {
			    if (itest + jtest == 1) {
				goto L19;
			    }
			} else {
			    if (itest == 1) {
				goto L19;
			    }
			}
			xlamda = (real) (xlnorm / zz);
			z__ = eye[3] * ((float)1. - xlamda);
			if (z__ > sftbuf_1.sbbuff[k - 1]) {
			    sftbuf_1.sbbuff[k - 1] = z__;
			    x = eye[1] + xlamda * (xi - eye[1]);
			    y = eye[2] + xlamda * (yj - eye[2]);
			    if (*inside == 0) {
				gx = xn;
				gy = yn;
				gz = zn;
			    } else {
				sbsf6a_(&x, &y, &z__, srfcom_1.orig, 
					srfcom_1.mtrx, srfcom_1.grdcub, &gx, &
					gy, &gz);
			    }
			    sbsf6b_(&eye[1], &x, &y, &z__, &gx, &gy, &gz, &
				    light[1], &srfcom_1.xl2, lshine, &clr);
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = 
				    srfcom_1.col0 + srfcom_1.colscl * clr;
			}
L19:
			xi += sdxi;
			zz -= dzz;
			k += istep;
/* L20: */
		    }
		}
L29:
		yj += dyj;
/* L30: */
	    }
	    j1 = j2 + 1;
	    if (j1 > jymax) {
		return 0;
	    }
/* L40: */
	}
    } else {
	ixmin = (integer) ((xmin - sftbuf_1.xblc) * dx) + 2;
/* Computing MIN */
	i__1 = (integer) ((xmax - sftbuf_1.xblc) * dx) + 1;
	ixmax = min(i__1,sftbuf_1.nxp);
	if (ixmin > ixmax) {
	    return 0;
	}
	xi = sftbuf_1.xblc + ((real) (ixmin - 1) + safer) * dxi;
	nvl2 = ileft;
	nvr2 = ileft;
	i1 = ixmin;
	i__1 = *nv;
	for (ivert = 1; ivert <= i__1; ++ivert) {
	    if (xi > xw[nvl2 - 1]) {
L3:
		nvl1 = nvl2;
		nvl2 = nvl1 - 1;
		if (nvl2 < 1) {
		    nvl2 = *nv;
		}
		if (nvl2 == ileft) {
		    return 0;
		}
		if (xi > xw[nvl2 - 1]) {
		    goto L3;
		}
		xdifl = xw[nvl2 - 1] - xw[nvl1 - 1];
		if (dabs(xdifl) < small) {
		    xdifl = small;
		}
		gradl = (yw[nvl2 - 1] - yw[nvl1 - 1]) / xdifl;
	    }
	    if (xi > xw[nvr2 - 1]) {
L4:
		nvr1 = nvr2;
		nvr2 = nvr1 + 1;
		if (nvr2 > *nv) {
		    nvr2 = 1;
		}
		if (nvr2 == ileft) {
		    return 0;
		}
		if (xi > xw[nvr2 - 1]) {
		    goto L4;
		}
		xdifr = xw[nvr2 - 1] - xw[nvr1 - 1];
		if (dabs(xdifr) < small) {
		    xdifr = small;
		}
		gradr = (yw[nvr2 - 1] - yw[nvr1 - 1]) / xdifr;
	    }
	    if (xw[nvl2 - 1] < xw[nvr2 - 1]) {
/* Computing MIN */
		i__2 = (integer) ((xw[nvl2 - 1] - sftbuf_1.xblc) * dx) + 1;
		i2 = min(i__2,ixmax);
	    } else {
/* Computing MIN */
		i__2 = (integer) ((xw[nvr2 - 1] - sftbuf_1.xblc) * dx) + 1;
		i2 = min(i__2,ixmax);
	    }
	    i__2 = i2;
	    for (i__ = i1; i__ <= i__2; ++i__) {
		if (i__ >= 1) {
		    itest = i__ % 2;
		    if (itlevl == 3 && itest == 1) {
			goto L59;
		    }
		    yl = yw[nvl1 - 1] + gradl * (xi - xw[nvl1 - 1]);
		    yr = yw[nvr1 - 1] + gradr * (xi - xw[nvr1 - 1]);
		    istep = 1;
/* Computing MAX */
		    i__4 = (integer) ((yl - sftbuf_1.yblc) * dy) + 2;
		    jy1 = max(i__4,1);
/* Computing MIN */
		    i__4 = (integer) ((yr - sftbuf_1.yblc) * dy) + 1;
		    jy2 = min(i__4,sftbuf_1.nyp);
		    if (jy1 > jy2) {
			istep = -1;
/* Computing MIN */
			i__4 = jy1 - 1;
			jy1 = min(i__4,sftbuf_1.nyp);
/* Computing MAX */
			i__4 = jy2 + 1;
			jy2 = max(i__4,1);
		    }
		    yj = sftbuf_1.yblc + (real) (jy1 - 1) * dyj;
		    sdyj = (real) istep * dyj;
		    dzz = (doublereal) (sdyj * yn);
		    zz = (doublereal) (eyenrm - yj * yn - xi * xn);
		    k = (jy1 - 1) * sftbuf_1.nxp + i__;
		    kstep = istep * sftbuf_1.nxp;
		    i__4 = jy2;
		    i__3 = istep;
		    for (j = jy1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
			     {
			jtest = j % 2;
			if (itlevl == 1) {
			    if (itest + jtest == 0) {
				goto L49;
			    }
			} else if (itlevl == 2) {
			    if (itest + jtest == 1) {
				goto L49;
			    }
			} else {
			    if (jtest == 1) {
				goto L49;
			    }
			}
			xlamda = (real) (xlnorm / zz);
			z__ = eye[3] * ((float)1. - xlamda);
			if (z__ > sftbuf_1.sbbuff[k - 1]) {
			    sftbuf_1.sbbuff[k - 1] = z__;
			    x = eye[1] + xlamda * (xi - eye[1]);
			    y = eye[2] + xlamda * (yj - eye[2]);
			    if (*inside == 0) {
				gx = xn;
				gy = yn;
				gz = zn;
			    } else {
				sbsf6a_(&x, &y, &z__, srfcom_1.orig, 
					srfcom_1.mtrx, srfcom_1.grdcub, &gx, &
					gy, &gz);
			    }
			    sbsf6b_(&eye[1], &x, &y, &z__, &gx, &gy, &gz, &
				    light[1], &srfcom_1.xl2, lshine, &clr);
			    sftbuf_1.sbbuff[sftbuf_1.kstart + k - 1] = 
				    srfcom_1.col0 + srfcom_1.colscl * clr;
			}
L49:
			yj += sdyj;
			zz -= dzz;
			k += kstep;
/* L50: */
		    }
		}
L59:
		xi += dxi;
/* L60: */
	    }
	    i1 = i2 + 1;
	    if (i1 > ixmax) {
		return 0;
	    }
/* L70: */
	}
    }
} /* sbtsf6_ */


/* Subroutine */ int sbfbkg_(ic1, ic2, ishade)
integer *ic1, *ic2, *ishade;
{
    /* System generated locals */
    integer i__1, i__2, i__3;
    real r__1, r__2;

    /* Local variables */
    static real dcol;
    static integer ntot, i__, j, k, l, nc;
    static real xn, yn;
    extern /* Subroutine */ int sbrfil_();
    static real col, xni, ynj, col0;
    static integer nxp1, nyp1, nyp2, nxp2;

/*     --------------------------------- */


/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      Sets the shading for the background. This routine should be */
/*    called after SBFINT, and COLINT or COLTAB, but before any objects */
/*    are plotted. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be */
/*                                   used for the shading. */
/*    ISHADE   I*4    I       -      Order of shading (IC1-->IC2 - IC1): */
/*                                      1 - Bottom to top. */
/*                                      2 - Left to right. */
/*                                      3 - Bottom-left to top-right. */
/*                                      4 - Top-left to bottom-right. */
/*                                      5 - Bottom, middle and top. */
/*                                      6 - Left, middle and right. */
/*                                      7 - Rectangular zoom to centre. */
/*                                      8 - Elliptical zoom to centre. */
/* Globals */
/*    SFTBUF */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     SBRFIL     Fills a real aray with a constant. */

/* History */
/*   D. S. Sivia      12 Oct 1995  Initial release. */
/* ----------------------------------------------------------------------- */

    if (sftbuf_1.ibfmod == 2) {
	return 0;
    }
    nc = *ic2 - *ic1;
    ntot = sftbuf_1.nxp * sftbuf_1.nyp;
    if (nc == 0) {
	r__1 = (real) (*ic1);
	sbrfil_(&sftbuf_1.sbbuff[sftbuf_1.kstart], &r__1, &ntot);
	return 0;
    }
    if (*ishade == 1) {
	col = (real) (*ic1);
	dcol = (real) nc * (float).9999 / (real) (sftbuf_1.nyp - 1);
	k = sftbuf_1.kstart + 1;
	i__1 = sftbuf_1.nyp;
	for (j = 1; j <= i__1; ++j) {
	    sbrfil_(&sftbuf_1.sbbuff[k - 1], &col, &sftbuf_1.nxp);
	    k += sftbuf_1.nxp;
	    col += dcol;
/* L1: */
	}
    } else if (*ishade == 2) {
	col = (real) (*ic1);
	dcol = (real) nc * (float).9999 / (real) (sftbuf_1.nxp - 1);
	i__1 = sftbuf_1.nxp;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    i__2 = sftbuf_1.kstart + ntot;
	    i__3 = sftbuf_1.nxp;
	    for (k = sftbuf_1.kstart + i__; i__3 < 0 ? k >= i__2 : k <= i__2; 
		    k += i__3) {
/* L10: */
		sftbuf_1.sbbuff[k - 1] = col;
	    }
	    col += dcol;
/* L11: */
	}
    } else if (*ishade == 3) {
	xn = (real) (sftbuf_1.nxp - 1);
	yn = (real) (sftbuf_1.nyp - 1);
	col0 = (real) (*ic1) + (real) nc * (float)1e-4;
/* Computing 2nd power */
	r__1 = xn;
/* Computing 2nd power */
	r__2 = yn;
	dcol = (real) nc * (float).9998 / (r__1 * r__1 + r__2 * r__2);
	k = sftbuf_1.kstart + 1;
	i__1 = sftbuf_1.nyp - 1;
	for (j = 0; j <= i__1; ++j) {
	    ynj = yn * (real) j;
	    i__3 = sftbuf_1.nxp - 1;
	    for (i__ = 0; i__ <= i__3; ++i__) {
		sftbuf_1.sbbuff[k - 1] = col0 + dcol * (xn * (real) i__ + ynj)
			;
		++k;
/* L20: */
	    }
/* L21: */
	}
    } else if (*ishade == 4) {
	xn = (real) (sftbuf_1.nxp - 1);
	yn = (real) (1 - sftbuf_1.nyp);
	col0 = (real) (*ic1) + (real) nc * (float)1e-4;
/* Computing 2nd power */
	r__1 = xn;
/* Computing 2nd power */
	r__2 = yn;
	dcol = (real) nc * (float).9998 / (r__1 * r__1 + r__2 * r__2);
	k = sftbuf_1.kstart + 1;
	i__1 = sftbuf_1.nyp;
	for (j = 1; j <= i__1; ++j) {
	    ynj = yn * (real) (j - sftbuf_1.nyp);
	    i__3 = sftbuf_1.nxp - 1;
	    for (i__ = 0; i__ <= i__3; ++i__) {
		sftbuf_1.sbbuff[k - 1] = col0 + dcol * (xn * (real) i__ + ynj)
			;
		++k;
/* L30: */
	    }
/* L31: */
	}
    } else if (*ishade == 5) {
	nyp1 = 1;
	nyp2 = sftbuf_1.nyp / 2;
	col = (real) (*ic1);
	dcol = (real) nc * (float).9999 / (real) (nyp2 - nyp1);
	k = sftbuf_1.kstart + 1;
	for (l = 1; l <= 2; ++l) {
	    if (l == 2) {
		nyp1 = nyp2 + 1;
		nyp2 = sftbuf_1.nyp;
		col = (real) (*ic2);
		dcol = (real) nc * (float)-.9999 / (real) (nyp2 - nyp1);
	    }
	    i__1 = nyp2;
	    for (j = nyp1; j <= i__1; ++j) {
		sbrfil_(&sftbuf_1.sbbuff[k - 1], &col, &sftbuf_1.nxp);
		k += sftbuf_1.nxp;
		col += dcol;
/* L40: */
	    }
/* L41: */
	}
    } else if (*ishade == 6) {
	nxp1 = 1;
	nxp2 = sftbuf_1.nxp / 2;
	col = (real) (*ic1);
	dcol = (real) nc * (float).9999 / (real) (nxp2 - nxp1);
	for (l = 1; l <= 2; ++l) {
	    if (l == 2) {
		nxp1 = nxp2 + 1;
		nxp2 = sftbuf_1.nxp;
		col = (real) (*ic2);
		dcol = (real) nc * (float)-.9999 / (real) (nxp2 - nxp1);
	    }
	    i__1 = nxp2;
	    for (i__ = nxp1; i__ <= i__1; ++i__) {
		i__3 = sftbuf_1.kstart + ntot;
		i__2 = sftbuf_1.nxp;
		for (k = sftbuf_1.kstart + i__; i__2 < 0 ? k >= i__3 : k <= 
			i__3; k += i__2) {
/* L50: */
		    sftbuf_1.sbbuff[k - 1] = col;
		}
		col += dcol;
/* L51: */
	    }
/* L52: */
	}
    } else if (*ishade == 7) {
	nxp2 = sftbuf_1.nxp / 2 + 1;
	nyp2 = sftbuf_1.nyp / 2 + 1;
	xn = (float)1. / (real) (nxp2 - 1);
	yn = (float)1. / (real) (nyp2 - 1);
	col0 = (real) (*ic2);
	dcol = (real) nc * (float)-.9999;
	k = sftbuf_1.kstart + 1;
	i__1 = sftbuf_1.nyp;
	for (j = 1; j <= i__1; ++j) {
	    ynj = (r__1 = yn * (real) (j - nyp2), dabs(r__1));
	    i__2 = sftbuf_1.nxp;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		xni = (r__1 = xn * (real) (i__ - nxp2), dabs(r__1));
		sftbuf_1.sbbuff[k - 1] = col0 + dcol * dmax(xni,ynj);
		++k;
/* L60: */
	    }
/* L61: */
	}
    } else if (*ishade == 8) {
	nxp2 = sftbuf_1.nxp / 2 + 1;
	nyp2 = sftbuf_1.nyp / 2 + 1;
	xn = (float)1. / (real) (nxp2 - 1);
	yn = (float)1. / (real) (nyp2 - 1);
	col0 = (real) (*ic2);
	dcol = (real) nc * (float)-.9999;
	k = sftbuf_1.kstart + 1;
	i__1 = sftbuf_1.nyp;
	for (j = 1; j <= i__1; ++j) {
/* Computing 2nd power */
	    r__1 = yn * (real) (j - nyp2);
	    ynj = r__1 * r__1;
	    i__2 = sftbuf_1.nxp;
	    for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing 2nd power */
		r__1 = xn * (real) (i__ - nxp2);
		xni = r__1 * r__1;
/* Computing MIN */
		r__1 = xni + ynj;
		sftbuf_1.sbbuff[k - 1] = col0 + dcol * dmin(r__1,(float)1.);
		++k;
/* L70: */
	    }
/* L71: */
	}
    }
} /* sbfbkg_ */


/* Subroutine */ int sbqinf_(xleft, xright, ybot, ytop, zbmin, zbmax)
real *xleft, *xright, *ybot, *ytop, *zbmin, *zbmax;
{
    /* System generated locals */
    integer i__1;
    real r__1;

    /* Local variables */
    static integer ntot, i__;

/*     ----------------------------------------------------- */


/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      Passes back some useful information about the software buffer */
/*    and canvas to be plotted. All (x,y,z) values are taken to be given */
/*    in world coordinates. */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    XLEFT    R*4    O       -      X-coord of left-hand of window. */
/*    XRIGHT   R*4    O       -      X-coord of right-hand of window. */
/*    YBOT     R*4    O       -      Y-coord of bottom of window. */
/*    YTOP     R*4    O       -      Y-coord of top of window. */
/*    ZBMIN    R*4    O       -      Minimum Z for distance buffer. */
/*    ZBMAX    R*4    O       -      Maximum Z for distance buffer. */

/* Globals */
/*    SFTBUF */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     None. */

/* History */
/*   D. S. Sivia       6 Jul 1995  Initial release. */
/* ----------------------------------------------------------------------- */

    *xleft = sftbuf_1.xblc;
    *xright = sftbuf_1.xtrc;
    *ybot = sftbuf_1.yblc;
    *ytop = sftbuf_1.ytrc;

    ntot = sftbuf_1.nxp * sftbuf_1.nyp;
    *zbmin = (float)0.;
    *zbmax = (float)-1e20;
    i__1 = ntot;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MIN */
	r__1 = sftbuf_1.sbbuff[i__ - 1];
	*zbmin = dmin(r__1,*zbmin);
/* Computing MAX */
	r__1 = sftbuf_1.sbbuff[i__ - 1];
	*zbmax = dmax(r__1,*zbmax);
/* L10: */
    }
} /* sbqinf_ */


/* ***<vector utility routines>******************************************* */

/* Subroutine */ int sbrfil_(x, a, n)
real *x, *a;
integer *n;
{
    /* System generated locals */
    integer i__1;

    /* Local variables */
    static integer i__;

/*     ------------------------ */


    /* Parameter adjustments */
    --x;

    /* Function Body */
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L10: */
	x[i__] = *a;
    }
} /* sbrfil_ */


/* Subroutine */ int sbrcop_(x, y, n)
real *x, *y;
integer *n;
{
    /* System generated locals */
    integer i__1;

    /* Local variables */
    static integer i__;

/*     ------------------------ */


    /* Parameter adjustments */
    --y;
    --x;

    /* Function Body */
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L10: */
	y[i__] = x[i__];
    }
} /* sbrcop_ */

