render.src

        Copyright (c) Kapteyn Laboratorium Groningen 2009
        All Rights Reserved.

Name:         render.src
Creator:      vogelaar
Host:         albirumi
Date:         Apr 14, 2009
Contents:     render.make render.dc1 gui.h plotdevices.h animator.h
              orientation.h render.c gui.c orientation.c srfplot.f
              isoplot.f pgxtal.f plotdevices.c animator.c

#>            render.make
#----------------------------------------------------------------------
# Makefile for RENDER, Dec 18, 1998
#
#
# Pack sources into render.src with:     > make -f render.make pack
# Clean executable and objects           > make -f render.make clean
# Unpack source files with:              > $gip_exe/xfile render.src
# Install source file with:              > p -reserve render.src
#                                        > p -install render.src
#
# Local compilation for testing:         > p render.make
#
# The CC_OPTS etc. are set by 'compile'
#----------------------------------------------------------------------

SHELL = /bin/sh

OPTS  = $(CC_OPTS)
COMP  = $(CC_COMP)
LIBS  = $(CC_LIBS)

.SUFFIXES: .c .o

DOCUMENTS = render.dc1

INCLUDES  = gui.h plotdevices.h animator.h orientation.h

SOURCES   = render.c gui.c orientation.c srfplot.f isoplot.f pgxtal.f \
            plotdevices.c animator.c

OBJECTS   = render.o gui.o orientation.o srfplot.o srfplot_ctof.o \
            isoplot.o isoplot_ctof.o pgxtal.o plotdevices.o animator.o


default:: render

pack::
	$${gip_sys}/pack.csh render.src render.make \
        $(DOCUMENTS) $(INCLUDES) $(SOURCES)

clean::
	rm -f render $(OBJECTS) srfplot.h isoplot.h

pgxtal.o: pgxtal.f grpckg1.inc

render.o: $(INCLUDES) srfplot.o isoplot.o pgxtal.o

gui.o: gui.h
   
orientation.o: orientation.h
     
grpckg1.inc :
	${gip_exe}/xfile ${gip_sub}/pgplot.src -ngrpckg1.inc

pgxtal.o:
	$(FC_COMP) -c $(FC_OPTS)  pgxtal.f

.c.o:  
	@echo "$(CC_COMP) -c $(CC_OPTS) $(X11_OPTS) $< ";\
	$(CC_COMP) -c $(CC_OPTS) $(X11_OPTS) $<

.f.o:
	$$gip_exe/f2cvv $< > f2cvv.out
	$$gip_exe/xfile $< > xfile.out
	$(CC_COMP) -c $(CC_OPTS) `basename $< .f`_ctof.c
	rm -f f2cvv.out xfile.out
	@echo "$(FC_COMP) -c $(FC_OPTS) $< ";\
	$(FC_COMP) -c $(FC_OPTS)  $<

render: $(OBJECTS)
	@echo "$(CC_COMP) -o render $(OBJECTS) $(X11_LIBS) $(CC_LIBS) $(XT_LIBS)";\
	$(CC_COMP) -o render $(OBJECTS) $(X11_LIBS) $(CC_LIBS) $(XT_LIBS)
#<

#>            render.dc1

Program:       RENDER

Purpose:       Render 2d- and 3d GIPSY data and display 2d-slices at any
               angle.

Category:      PLOTTING

File:          render.c

Author:        M.G.R. Vogelaar
               (GUI: J.P. Terlouw)

Warning:       1) For volume-rendering, the entire data cube is read from
               disk and stored in memory. To avoid slow performance or
               even hang-ups, use a machine with a lot of memory.

               2) When building the frames of a movie loop, make sure 
               that no other window covers part of your plot, otherwise
               the plot could be obscured by the overlay (this depends
               on the X-server in use).

               3) Blanks in your data are replaced by the minimum data value
               in your (sub)set. If you want to replace blanks with another
               value, use COPY to copy your original data and CBLANK to
               replace blanks.

               4) Reading data from a big set can take a while. If you 
               are planning to use a smaller box than the default 
               (entire (sub)set ) start RENDER in Hermes with a 
               pre-specified box e.g. 
               RENDER INSET=AURORA BOX=-150 -150 150 150


Keywords:      Program RENDER is an easy to use data inspection tool to:

               1) surface render a 2-dim. set
               2) volume render a 3-dim. set
               3) display slices at any angle through 3-dim. data
               4) record a series of plots and play them in a movie

               The listing below is an overview of buttons and input fields
               of the Graphical User Interface for this program. Each button
               or input field has an associated GIPSY keyword. This
               enables you to start the program with pre-specified keywords.
               Also the keyword macro's will work.


   PLOTSIZE=   Hidden keyword

               Set the size of the plot window in pixels. This keyword
               accepts one and two values. If one value is entered a 
               square plot window is made. Whatever the size of the plot window
               is, the render output is always square. The default is:
               PLOTSIZE=532 532


   QUIT=       Menu <FILE>, option Exit

               Abort program by selecting exit from menu. Open PGPLOT
               devices will be closed. From within Hermes type QUIT=Y


   PSFILE=     Menu <FILE>, option PostScript file

               Select a name for the PostScript file to which the output
               is redirected. The default name is rederplot.ps


   PLOTTER=    Menu "PLOTTER"

               Before you make a hardcopy of the current plot, select
               a plot device first from this menu. However if you want to
               (pre) specify the keyword in Hermes, you have to enter a number.
               The number of the first device is 0 etc.
               Create the plot with the <PLOT> button.


   PLOT=       Button <PLOT>

               A hardcopy is made on the selected device (See PLOTTER=).
               The corresponding PostScript file name is set by PSFILE=
               (File menu).


   ANNOT=      Button <ANNOT>

               Open a window to set plot annotations. See also keywords
               XTITLE=, YTITLE=, ZTITLE=, PLOTTITLE= and CHARSIZE=


   HELP=       Button <HELP>

               Show the 'dc1' document for this program. This is the
               document that you are reading now. String search can be 
               started with <ctrl> C


   INSET=      Input field "Set"

               Maximum number of subsets is 1.
               For this GIPSY data a surface plot is created. The data can
               be 2 dimensional for a surface plot where the height represents
               the data value, (e.g. INSET=aurora freq 0 if aurora is a
               RA-DEC-FREQ cube) or 3 dimensional for an iso-surface plot
               (e.g. INSET=aurora). In the 3-dim. case the ISOVAL= keyword
               becomes active.
               Note that reading a big cube into memory can disable the 
               gui for a while.


   BOX=        Input field "Box"

               Data within this box will be used for plotting.
               This field if reset by a default every time a new set is
               entered. The default box is the entire set/subset.
               You get the default by pressing Enter in an empty input field. 


   ZMINMAX=    Input field "Min, max"

               These are the minimum and maximum data values in your 2- or
               3-dim. set/subset. Real data min. and max. values are displayed
               in the gui every time new data is read. The values are used to 
               clip values in the surface rendering and are used to scale the
               colours or gray scales in a slice. Note that for 3D-data
               the default values for the minimum and maximum are the real
               minimum and maximum in the data cube. If you want to compare
               a colour slice with a subset viewed in GIDS then note that GIDS 
               reads values for the min. and max. from the header of the 
               displayed SUBset. These are usually not the same values as 
               displayed in the gui of RENDER.


   ISOVAL=     Input field "Isoval"

               For three dimensional sets the program renders an iso
               surface. The surface is a volume plot of data boundaries with
               the same value (in units of the data). The default is
               a value half between the minimum and maximum data values.
               The input field is not erased if a new set or box is
               entered.


   APOINT=     Input field "Slice point"

               Enter x, y and z values of a point on the slice that you want 
               to plot. The values for x, y and z are in coordinates of your
               box. The normal of the slice is set by PHI= and THETA=.
               

   THETA=      Input field "Slice normal: Theta"

               Enter a value in degrees. This is an angle of the normal
               of your slice in the xz (horizontal) plane. Zero degrees
               points in the z-direction. Note that the angles are defined
               in a unit cell (all sides have length 1), i.e. the angles 
               are not with respect to the pixel coordinate system.


   PHI=        Input field "Slice normal: Phi"

               Enter a value in degrees. This is an angle of the normal
               of your slice in the xy (vertical) plane. Zero degrees
               points in the x-direction.


   XTITLE=     Input field "X-title"

               The default title is copied from header item corresponding
               to the axis name of the first axis in your set.


   YTITLE=     Input field "Y-title"

               The default title is copied from header item corresponding
               to the axis name of the first axis in your set.


   ZTITLE=     Input field "Z-title"

               Only for a 3-dim. set/subset a z-axis is plotted.
               The default title is copied from header item corresponding
               to the axis name of the first axis in your set.


   PLOTTITLE=  Input field "Plot title"

               Enter text to label the plot.
               The position of the title is always top-middle.


   PSFILE=     Input field "PS file"

               Enter the name of the PostScript file on disk where to
               hardcopy output is directed.


   CHARSIZE=   Input field "Char.size"

               This value applies to all characters on the plot. The default
               is set to 1.1.


   COLOPTION=  Button <COLOR>

               Set the color mode for plotting. Default is monochrome in
               the colour set by MONORGB= (input field Mono color in gui).
               The other option is a colour scheme set by GIDS, which is
               automatically started. RENDER borrows the colours from
               GIDS in the condition as it is at the moment of pressing
               the <GO> button. Note that in order to get colours you need
               to set a value for NCBAND= (i.e. # Bands input field in gui)
               greater than 1. If you are interested in colours only, 
               set the diffuse value to 0. This is the default if you
               select colours from GIDS.


   NCBAND=     Input field "# Bands"

               In colour mode you can plot different bands of colour.
               Problems can arise if RENDER cannot allocate as much colours
               as the number of colour bands. The default value is 1 for
               monochrome and n > 1 for colours from GIDS.


   LI_HOR=     Dial "Light-H"

               Dial for setting the rotation of the light source.
               Value in degrees. Default is 0.  (See also LIGHT=)
               The direction of the arrow is along the imaginary line that 
               connects the light source and the fixed object in the middle 
               of the circle.


   LI_VER=     Dial "Light-V"

               Dial for setting the tilt of the light source.
               Value in degrees. Default is 0.  (See also LIGHT=)


   MONORGB=    Input field "Mono color"

               This colour is the main surface colour of the plot when
               plotting in monochrome mode. The default values for red,
               green and blue are 0, 1 and  0.


   BACKRGB=    Input field "Back color"

               Red, green and blue values between 0 and 1 for the
               background colour The default values are
               BACKRGB=0.2 0.4 0.7 which is some kind of blue.


   EYE=        Input field "Eye"

               This a distance in arbitrary units. The default is 8.
               You will see perspective effects only with values smaller
               than 1.0.


   DIFFUSE=    Input field "Diffuse"

               Number between 0 and 1 and the default is set to 0.8.
               The higher this number, the more dynamic range you will get.
               If you switch to colours from GIDS, the diffuse number is set 
               to 0.0 so that plot colours correspond to colours set by GIDS.


   POLISH=     Input field "Polish"

               If you want a shiny object, SHINE= must be greater than 0.
               For these objects POLISH= sets the size of the shiny
               reflections. The default value is 1.


   SHINE=      Input field "Shine"

               SHINE determines the whiteness of the shiny reflections
               (or grayness if < 1). The range is from 0 to 1 and
               the default is set to 0.


   TRANS=      Input field "Transp."
   
               Set the level of transparency for iso surface (=3-dim.)
               data rendering. There are four numbers for four levels:
               0 = not transparent, 1 = 25%, 2 = 50% and 3 = 75% transpa-
               rency.
                             

   ROTATION=   Dial "Rotation"

               Dial (or circular valuator) to rotate the object.
               Object is rotated in a horizontal plane. Default value is
               40 deg. A value can also be entered manually in the 
               corresponding input field. You can also adjust values by
               dragging the cube in the small plot window using the left
               mouse button.


   TILT=       Dial "Tilt"

               Dial (or circular valuator) to rotate the object
               Object is rotated in a vertical plane. Default value is
               20 deg. See also ROTATION=


   GO=         Button "GO"

               Use the current values set by the user to create a (new)
               plot on screen. If you want a plot on a hardcopy device,
               select a device first with the PLOTTER= and PLOT= keywords
               or the <PLOTTER> and <PLOT> buttons


   LWIDTH=     Hidden keyword

               Keyword which sets the line width (between 1 and 20)
               of the plot title. Default value is 2. Other line widths
               must be set in Hermes with LWIDTH=n where n is a number
               between 1 and 21. It does NOT apply to the line widths
               of the coordinate system.


   LIGHT=      Hidden Keyword

               Keyword for setting the direction (x,y,z) of the light.
               Default is 0 0 -1. The values are set by two circular valuators
               that transform their values into a vector which represents the
               direction of the light. Imagine the (rotated and tilted) object
               in the middle of the circular valuators. The left valuator
               sets the direction an a horizontal plane and the right
               valuator sets the direction an a vertical plane.
               See also 'Description: Coordinate system'.


               ANIMATOR WINDOW (movies)
               ------------------------

   ANIMATOR=   Button <ANIMATOR>

               Pressing this button will pop up a new window with the all the
               movie controls for your current input. The input fields
               correspond to the fields in the main gui, but here you 
               enter a start value in the left column and an end value in 
               the right column for the values that you want to animate.
               The number of frames (input field '#frames') sets the step
               size for each pair of start and end value. If you enter 
               more frames than the system can handle, it will change 
               automatically to the maximum value that is allowed. Value
               for the start and end column can be imported from the main 
               gui with the <Start> and <End> buttons next to 'load:'.
               You can also export start and end values to the main gui
               with <Start> and <End> next to 'Store:'.
               
               Before a movie can be played, you have to build the frames 
               by pressing the <BUILD> button. After displaying the 
               frames one by one, you can start the movie by pressing one
               of the buttons: << <-> or >> which stands for: play backwards,
               play forth and back and play the frames in increasing order.
               

   FRAME=      Input field and slider "Frame"
   
               Select your frame number by hand or with the slider.
               
              
   SPEED=      Input field and slider "Speed"

               Approximately the number of frames per second. Note that 
               the higher the speed, the more difficult it becomes to 
               interact with the system.

  
   BUILD=      Button <BUILD>
   
               Before playing a movie, you need to build it. This command
               sets the loop rotations and tilts etc. and calls repeatedly
               the plot routines. 


   ANIMATOR=   Button <CLOSE>

               Close current animator window.
                  


Description:   Program RENDER creates a surface plot of 2-dim. GIPSY datasets 
               f(x,y) or it creates an iso surface of 3-dim. data f(x,y,z).
               This selection depends on the dimensionality of the
               input set (Set field in gui or INSET= keyword).


               Coordinate system
               -----------------

               Your screen is taken at z=0 in an right handed system 
               xyz so that the +z axis comes out of the screen.
               Data is scaled onto a unit cell. The viewpoint of the 
               eye remains the same after the rotation. Only the
               lattice vectors are rotated.


Example:       Next keywords display volume rendered GIPSY data
               with a slice in RA-DEC through pixel coordinate 0,0,0.
               The colours originate from GIDS (See COLOR menu).

               APOINT= 0 0 0
               BACKRGB= 0.2 0.4 0.7
               BOX= -100 -100 -32 100 100 38
               CHARSIZE= 1.1
               COLOPTION= 1
               DIFFUSE= 0
               EYE= 8
               GO=
               INSET= n2403-13
               ISOVAL= 2
               LIGHT= 0 0 -1
               LWIDTH= 2
               MONORGB= 0 1 0
               NCBAND= 60
               PHI= 0
               PLOTTER= 0
               PLOTTITLE= W.U. '
               POLISH= 1
               PSFILE= renderplot.ps
               ROTATION= 40.00
               SHINE= 0
               THETA= 0
               TILT= 20.00
               TRANS= 0
               XTITLE= RA---NCP
               YTITLE= DEC--NCP
               ZMINMAX= 0 3
               ZTITLE= FREQ-RHEL



Copyright:     Program RENDER is based on the Fortran subroutine library
               PGXTALL made by D.S. Sivia of the Rutherford Appleton
               Laboratory, Chilton, Oxon OX11 0QX, U.K.
               (http://www.isis.rl.ac.uk/dataanalysis/dsplot/pgxtal.htm)
Notes:         

Updates:       Nov 23, 1998: VOG, Document created.
               May 29, 2000: JPT, Eliminated PostScript-specific code.
               Apr 14, 2009: VOG, Cleaned up a bit. Removed NINT macro
#<

#>            gui.h
#if !defined(_gui_h_)
#define _gui_h_
void gui(int xsize, int ysize);              /* activate GUI */
void gui_status(char *message, int lineno); /* display status message */
void gui_error(char *message);              /* display error message */
#endif
#<

#>            plotdevices.h
#if !defined(_plotdevices_h_)
#define _plotdevices_h_
extern char **plotdevices(void);
#endif

#<

#>            animator.h
#if !defined(_animator_h_)
#define _animator_h_
void Animator(char *key);
#endif
#<

#>            orientation.h
#if !defined(_orientation_h_)
#define _orientation_h_
void Orientation(char *device);
#endif
#<

#>            render.c
/* render.c -XT
                            COPYRIGHT (c) 1999
                      Kapteyn Astronomical Institute
                University of Groningen, The Netherlands
                           All Rights Reserved.

*/

/*  render.c: include files     */

#include    "stdio.h"        /* Defines ANSI C input and output utilities */
#include    "stdlib.h"       /* Defines the ANSI C functions for number */
                             /* conversion, storage allocation, and similar tasks.*/
#include    "string.h"       /* Declares the ANSI C string functions*/
                             /* like:strcpy, strcat etc.*/
#include    "math.h"         /* Declares the mathematical functions and macros.*/
#include    "cmain.h"        /* Defines the main body of a C program with */
                             /* MAIN_PROGRAM_ENTRY and IDENTIFICATION */
#include    "gipsyc.h"       /* Defines the ANSI-F77 types for Fortran to C intface */
                             /* including def. of char2str,str2char,tofchar,zadd */
                             /* and macros tobool and toflog */
#include    "float.h"        /* Definition of FLT_MAX etc.*/
#include    "ctype.h"        /* Declares ANSI C functions for testing characters */
                             /* like: isalpha, isdigit etc. also tolower, toupper.*/


/* Common includes */

#include    "init.h"         /* Declare task running to HERMES and initialize.*/
#include    "finis.h"        /* Informs HERMES that servant quits and cleans up the mess.*/
#include    "anyout.h"       /* General character output routine for GIPSY programs.*/
#include    "setfblank.h"    /* Subroutine to set a data value to the universal BLANK.*/
#include    "error.h"        /* User error handling routine. */
#include    "myname.h"       /* Obtain the name under which a GIPSY task is being run.*/
#include    "nelc.h"         /* Characters in F-string discarding trailing blanks.*/
#include    "minmax2.h"

/* User input routines */

#include    "userfio.h"      /* Easy-C companions for user interface routines.*/
#include    "userint.h"      /* User input interface routines.*/
#include    "userlog.h"
#include    "userreal.h"
#include    "userdble.h"
#include    "usertext.h"
#include    "userchar.h"
#include    "usercharu.h"
#include    "userfio.h"      /* Easy-C companions of userxxx_c */
#include    "reject.h"       /* Reject user input.*/
#include    "cancel.h"       /* Remove user input from table maintained by HERMES.*/
#include    "keyevents.h"    /* Definitions for event-driven operation */
#include    "events.h"
#include    "wkey.h"
#include    "subst.h"
#include    "status.h"

/* Input of sets */

#include    "gdsinp.h"       /* Input of set, subsets, return # subsets.*/
#include    "gdspos.h"       /* Define a position in a subset.*/
#include    "gdsbox.h"       /* Define a box inside/around a subset.*/
#include    "gdsc_range.h"   /* Return lower left and upper right corner of a subset.*/
#include    "gdsc_ndims.h"   /* Return the dimensionality of a coordinate word.*/
#include    "gdsc_grid.h"    /* Extract grid value.*/
#include    "gdsc_fill.h"    /* return coordinate word filled with a grid */
                             /* value for each axis.*/
#include    "gdsi_read.h"    /* Reads data from (part of) a set.*/
#include    "gdsc_name.h"
#include    "gdsd_rchar.h"

/* PGPLOT includes */

#include    "pgplot.h"       /* All PGPLOT includes. */

#include    "gui.h"
#include    "ggi.h"
#include    "gdi_open.h"
#include    "gdi_close.h"
#include    "gdi_cinfo.h"

#include "plotdevices.h"

/* DEFINITIONS: */

/* Initialize Fortran compatible string with macro 'fmake' */

#define fmake(fchr,size) { \
                           static char buff[size+1]; \
                           int i; \
                           for (i = 0; i < size; buff[i++] = ' '); \
                           buff[i] = 0; \
                           fchr.a = buff; \
                           fchr.l = size; \
                         }

/* Malloc version of 'fmake. Strings allocated with'  */
/* finit, must be freed with free( fc.a ) */
#define finit( fc , len ) { fc.a = malloc( ( len + 1 ) * sizeof( char ) ) ;  \
                            fc.a[ len ] = '\0' ; \
                            fc.l = len ; }

#define MYMAX(a,b)     ( (a) > (b) ? (a) : (b) )
#define MYMIN(a,b)     ( (a) > (b) ? (b) : (a) )
#define ABS(a)         ( (a) < 0 ? (-(a)) : (a) )
#define PI             3.141592653589793
#define RAD(a)         ( (a) * 0.017453292519943295769237 )
#define DEG(a)         ( (a) * 57.295779513082320876798155 )

#define RELEASE        "1.0"      /* Version number */
#define MAXAXES        10         /* Max. axes in a set */
#define MAXSUBSETS     1          /* Max. allowed subsets */
#define MAXBUF         4096       /* Buffer size for I/O */
#define STRLEN         256        /* Max length of strings */
#define FILENAMELEN    256        /* Max length of file names */
#define FITSLEN        20         /* Max length of header items etc.*/
#define NONE           0          /* Default levels in userxxx routines */
#define REQUEST        1
#define HIDDEN         2
#define EXACT          4
#define YES            1          /* C versions of .TRUE. and .FALSE. */
#define NO             0
#define FIRSTLINE      0
#define SECONDLINE     1
#define DEBUG          16


/* Defaults */
#define CHARSIZE       1.1
#define LWIDTH         2
#define ROTATION       40.0
#define TILT           20.0
#define NCBANDS        1            /* Number of colour bands */
#define POLISH         1.0        
#define DIFFUSE        0.8
#define SHINE          0.0
#define D_EYE          5.0          /* Distance eye in arbitrary units */
#define INTERVAL       50           /* Interval in ms between two frames in movie */
#define ZOOM           0.75


/* Miscellaneous */

static fint     setlevel = 0;       /* To get header items at set level. */
static float    blank;              /* Global value for BLANK. */
static int      odev;               /* Device to which output is directed */
static char     **plotters;

static char     *taskname = "render";



#define KEY_BOX        tofchar("BOX=")


typedef struct
{
   float    *image;                        /* 1-dim matrix with floats */
   int      setexist;
   int      boxexist;
   fchar    Setin;                         /* Name of 2-or 3 dim. input set */
   char     setbuf[STRLEN];
   fint     subin[MAXSUBSETS];             /* Subset coordinate words */
   fint     axnum[MAXAXES];
   fint     subdim;                        /* Dimensionality of the subsets */
                                           /* Highest box dimension is 3. */
   fint     blo[3];                        /* Low  edge of box in grids */
   fint     bhi[3];                        /* High edge of box in grids */
   fint     flo[3];                        /* Low  edge of frame in grids */
   fint     fhi[3];                        /* High edge of frame in grids */   
   char     xtitle[STRLEN];
   char     ytitle[STRLEN];
   char     ztitle[STRLEN];
   char     ptitle[STRLEN];
   float    datamin;
   float    datamax;
   fint     nsubs;                         /* Number of input subsets */
   fint     imagesize;
   fint     nx, ny, nz;                    /* Axis lengths of input image */
   float    charsize;                      /* PGPLOT Character size */
   fint     lwidth;                        /* PGPLOT Line width */
   fint     gids_id;
   float    rotation;                      /* Viewing angles */
   float    tilt;
   float    monorgb[3];
   float    backrgb[3];
   fint     ncbands;                       /* Render characteristics */
   float    shine;
   float    diffuse;
   float    polish;
   fint     transparencylevel;   
   float    light[3];
   float    eye;                           /* Distance of eye */
   float    dataoffset;
   float    isoval;                        /* Iso surface value for 3d sets */
   int      coloption;                     /* 0=gray, 1=colours from GIDS */
   char     devnam[20];
   char     psfile[STRLEN];
   bool     plotslice;                     /* If wanted, plot slice */
   float    theta;                         /* Angle of slice normal in xz plane */
   float    phi;                           /* Angle of s-n in xy plane */
   float    apoint[3];                     /* A point on the slice */
   float    movie_rot[128];
   float    movie_tilt[128];
   ident    plotid;   
   int      interval;
   ident    timer;
   float    zoom;
} globaltype;

#include "isoplot.h"
#include "srfplot.h"



static void hermesstatus( char *txt )
/*------------------------------------------------------------*/
/* PURPOSE: Update status in hermes status                    */
/*------------------------------------------------------------*/
{
   status_c( tofchar(txt) );
}



static void error_status( char *errstr,
                          char *statstr1,
                          char *statstr2 )
/*------------------------------------------------------------*/
/* PURPOSE: Update status and error messages in gui.          */
/*------------------------------------------------------------*/
{
   gui_error( errstr );
   gui_status( statstr1, FIRSTLINE );
   hermesstatus( statstr1 );
   gui_status( statstr2, SECONDLINE );
}



static void clearstatus( void )
/*------------------------------------------------------------*/
/* PURPOSE: Clear status and error messages in gui.           */
/*------------------------------------------------------------*/
{
   gui_error( "" );
   gui_status( "", FIRSTLINE );
   gui_status( "", SECONDLINE );
   hermesstatus("");
}



static bool UserLog(char *key)
/*------------------------------------------------------------*/
/* Purpose: Special version of userlog with default.          */
/*------------------------------------------------------------*/
{
   bool result=toflog(FALSE);
   fint fint1=1, fint2=2;

   (void)userlog_c(&result, &fint1, &fint2, tofchar(key), tofchar(" "));
   return tobool(result);
}




static void clearstr( fchar Fstr )
/*------------------------------------------------------------*/
/* Purpose: Blank a Fortran string up to 'len' characters     */
/*------------------------------------------------------------*/
{
   int    i;
   fint   len = Fstr.l;


   for (i = 0; i < (int) len; i++)
   {
      Fstr.a[i] = '\0';
   }
}




static void getreal( ident id,
                     char  *key,
                     int   code,
                     void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: Keyword handler for floats.                       */
/*------------------------------------------------------------*/
{
    float     *userval = (float *) arg;
    fint       nitems = 1;
    fint       dfault = HIDDEN;

    (void) userreal_c( userval,
                       &nitems,
                       &dfault,
                       tofchar(key),
                       tofchar(" ") );
}




static void getint( ident id,
                    char  *key,
                    int   code,
                    void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: Keyword handler for (f)ints.                      */
/*------------------------------------------------------------*/
{
    fint       *userval = (fint  *) arg;
    fint       nitems  = 1;
    fint       dfault  = HIDDEN;

    (void) userint_c( userval,
                      &nitems,
                      &dfault,
                      tofchar(key),
                      tofchar(" ") );
}



#ifdef FUTUREUSE
static void getbool( ident id,
                     char  *key,
                     int   code,
                     void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: Keyword handler for logicals.                     */
/*------------------------------------------------------------*/
{
   bool       *userval = (fint  *) arg;
   fint       dfault  = HIDDEN;
   fint       nitems = 1;

   (void) userlog_c( userval,
                     &nitems,
                     &dfault,
                     tofchar(key),
                     tofchar(" ") );

   *userval = tobool( *userval );
}
#endif



static void gettxt( ident id,
                    char  *key,
                    int   code,
                    void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: Keyword handler for text.                         */
/*------------------------------------------------------------*/
{
    char      *userval = (char  *) arg;
    fint       dfault  = HIDDEN;
    fchar      Text;
    char       buf[STRLEN];

    Text.a = buf;
    Text.l = STRLEN-1;
    (void) usertext_c( Text,
                       &dfault,
                       tofchar(key),
                       tofchar(" ") );
    Text.a[nelc_c(Text)] = '\0';
    strcpy( userval, Text.a )                       ;
}




static void getchr(  ident id,
                     char  *key,
                     int   code,
                     void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: Keyword handler for a string.                     */
/*------------------------------------------------------------*/
{
    char       *userval = (char *) arg;
    fint       nitems  = 1;
    fint       dfault  = HIDDEN;
    fchar      Text;
    char       buf[STRLEN];

    Text.a = buf;
    Text.l = STRLEN-1;

    (void) userchar_c( Text,
                       &nitems,
                       &dfault,
                       tofchar(key),
                       tofchar(" ") );
    Text.a[nelc_c(Text)] = '\0';
    strcpy( userval, Text.a );
}





static void getrgb( ident id,
                    char  *key,
                    int   code,
                    void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: MONORGB= and BACKRGB= keyword handler.            */
/*------------------------------------------------------------*/
{
   float     *rgb = (float *) arg;
   fint       nitems = 3;
   fint       dfault = HIDDEN;
   int        i;

   (void) userreal_c( rgb,
                      &nitems,
                      &dfault,
                      tofchar(key),
                      tofchar(" ") );

   for (i = 0; i < 3; i++)
   {
      rgb[i] = MYMIN( 1.0, rgb[i] );
      rgb[i] = MYMAX( 0.0, rgb[i] );
   }
}




static void getxyz( ident id,
                    char  *key,
                    int   code,
                    void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: APOINT= keyword handler.                          */
/*------------------------------------------------------------*/
{
   float     *xyz = (float *) arg;
   fint       nitems = 3;
   fint       dfault = HIDDEN;

   (void) userreal_c( xyz,
                      &nitems,
                      &dfault,
                      tofchar(key),
                      tofchar(" ") );
}




static void getlight( ident id,
                      char  *key,
                      int   code,
                      void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: LIGHT=keyword handler.                            */
/*------------------------------------------------------------*/
{
   float     *light = (float *) arg;
   fint       nitems = 3;
   fint       dfault = HIDDEN;

   (void) userreal_c( light,
                      &nitems,
                      &dfault,
                      tofchar(key),
                      tofchar(" ") );
}



static void colopt( ident id,
                    char  *key,
                    int   code,
                    void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: COLOPTION= keyword handler.                       */
/* Get an id from GIDS.                                       */
/*------------------------------------------------------------*/
{
   globaltype *g = (globaltype *) arg;
   fint       userval;
   fint       dfault  = HIDDEN;
   fint       nitems = 1;


   userval = 0;
   (void) userint_c( &userval, &nitems, &dfault, tofchar(key), tofchar(" ") );
   g->coloption = userval;
   if (g->coloption)
   {
      /* User wants coloured surface, connnect to GIDS */
      gui_status( "GIDS started to adjust colour table", FIRSTLINE );
      if (g->gids_id > 0)
      {
         gdi_close_c( &(g->gids_id) );
      }
      g->gids_id = gdi_open_c( tofchar(" ") );
      if (g->gids_id < 0)
         gui_error( "Could not connect to GIDS. Reason unknown." );
      else
      {
         fint   mincol, maxcol, numcol, iblank;
         gdi_cinfo_c( &(g->gids_id), &mincol, &maxcol, &numcol, &iblank );
         wkeyf( "NCBAND=%d", numcol );
         wkeyf( "DIFFUSE=0" );
      }
   }
   else
   {
      wkeyf( "NCBAND=1" );
      wkeyf( "DIFFUSE=%f", DIFFUSE );
      gui_status( "# colour bands and diffusiveness reset", FIRSTLINE );
   }
}



static void setminmax( ident id,
                       char  *key,
                       int   code,
                       void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: ZMINMAX= keyword handler.                         */
/* Set min, max of data to be displayed.                      */
/*------------------------------------------------------------*/
{
   globaltype *g = (globaltype *) arg;
   float       userval[2];
   fint        nitems  = 2;
   fint        dfault  = HIDDEN;
   fint        r;
   int         i;
   float       zoffset;


   r = userreal_c( userval,
                   &nitems,
                   &dfault,
                   tofchar(key),
                   tofchar(" ") );

   g->datamin = MYMIN( userval[0], userval[1] );
   g->datamax = MYMAX( userval[0], userval[1] );

   /* Restore Z data */
   for (i = 0; i < g->imagesize; i++)
   {
      g->image[i] -= g->dataoffset;
   }
   zoffset = MYMAX(-1.0*g->datamin, 0.0);
   if (zoffset > 0.0)
   {
      g->dataoffset = zoffset;
      for (i = 0; i < g->imagesize; i++)
      {
         g->image[i] += g->dataoffset;
      }
   }
   else
      g->dataoffset = 0.0;
}




static void getdata( globaltype *g )
/*------------------------------------------------------------*/
/* PURPOSE:  Read all values in between blo and bhi in'image' */
/*           Note that one subset is entered.                 */
/*------------------------------------------------------------*/
{
   fint  pixelsread;
   fint  cwlo, cwhi;
   fint  tid = 0;
   fint  subset = g->subin[0];
   int   i;


   gui_status( "Reading data from disk", FIRSTLINE );
   g->dataoffset = 0.0;
   g->imagesize = 1;
   for (i = 0; i < g->subdim; i++)
   {
      g->imagesize *= g->bhi[i] - g->blo[i] + 1;
   }
   cwlo   = gdsc_fill_c( g->Setin, &subset, g->blo );
   cwhi   = gdsc_fill_c( g->Setin, &subset, g->bhi );
   gdsi_read_c( g->Setin,
                &cwlo, &cwhi,
                g->image,
                &(g->imagesize),
                &pixelsread,
                &tid );

   if (tid != 0 || pixelsread != g->imagesize)
   {
      /* PROBLEMS!!! PROBLEMS!!! PROBLEMS!!! PROBLEMS!!! */
      gui_error( "Problems reading data from disk" );
      g->imagesize = 0;
      return;
   }
   else
   {
      fint   nblanks;
      minmax2_c( g->image, &(g->imagesize), &(g->datamin), &(g->datamax),
                 &nblanks );
      if (nblanks != 0)
      {
         int   i;
         error_status( "", "This box contains blanks.",
                       "Busy to replace blanks by the minimum data value!" );
         for (i = 0; i < g->imagesize; i++)
         {
            if (g->image[i] == blank)
               g->image[i] = g->datamin;
         }
      }
      clearstatus();
      anyoutf( DEBUG, "Data min=%f, max=%f", g->datamin, g->datamax );
   }
}




static void getbox( ident id,
                    char  *key,
                    int   code,
                    void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: BOX= Process user input for a box.                */
/*------------------------------------------------------------*/
{
   fint        boxopt = 0;
   fint        dfault = HIDDEN;
   fint        showdev = (fint) odev;
   fint        r;
   int         nx, ny, nz;
   char        dummytxt[STRLEN+1];
   fchar       Dummytxt;
   globaltype *g=(globaltype*)arg;
   static int  first = YES;


   if (!g->setexist)
   {
      reject_c( KEY_BOX, tofchar("You cannot define a box without a set!") );
      g->imagesize = 0;
      g->boxexist = NO;
      return;                     /* Nothing changed so return old image data */
   }
   /* Check on empty strings */
   Dummytxt.l = STRLEN;
   Dummytxt.a = dummytxt;
   r = usertext_c( Dummytxt, &dfault, tofchar(key), tofchar(" ") );
   if (!r)
   {
      if (g->subdim == 2)
         wkeyf( "BOX=%d %d %d %d", g->flo[0], g->flo[1], g->fhi[0], g->fhi[1] );
      else
         wkeyf( "BOX=%d %d %d %d %d %d",
                g->flo[0], g->flo[1], g->flo[2],
                g->fhi[0], g->fhi[1], g->fhi[2] );
         /* getbox( NULL, "BOX=", KEYCHANGE, g );*/     /* pseudo event */
      return;
   }

   dfault = REQUEST;
   boxopt = 16;
   gdsbox_c( g->blo, g->bhi,
             g->Setin, g->subin,
             &dfault,
             tofchar(key),
             tofchar(" "),
             &showdev,
             &boxopt );

   if (boxopt == -1)
   {
      /* 'gdsbox' detected an error */
      fchar   Errtxt;
      char    errtxt[STRLEN];
      fint    l;
      fint    dfault = -1;

      Errtxt.a = errtxt; Errtxt.l = STRLEN-1; clearstr(Errtxt);
      cancel_c(tofchar("UCAMESSAGE="));
      l = usertext_c( Errtxt, &dfault, tofchar("UCAMESSAGE="), tofchar("") );
      Errtxt.a[l] = '\0';

      error_status( Errtxt.a, "Enter another box.", "" );

      g->imagesize = 0;
      g->boxexist = NO;
      return;
   }
   /*--------------------------------------------------*/
   /* Allocate memory for an array, big enough to      */
   /* store (sub)set data between blo and bhi.         */
   /*--------------------------------------------------*/
   {
      int len = (g->bhi[0]-g->blo[0]+1) * (g->bhi[1]-g->blo[1]+1);
      anyoutf( DEBUG, "Try to allocate %d bytes? (box=%d %d %d %d)", len,
              g->blo[0], g->blo[1], g->bhi[0], g->bhi[1] );
   }

   if (g->image != NULL) free( g->image );

   nx = g->bhi[0] - g->blo[0] + 1;
   ny = g->bhi[1] - g->blo[1] + 1;
   if (g->subdim == 3)
      nz = g->bhi[2] - g->blo[2] + 1;
   else
      nz = 1;
   g->nz = nz;

   g->image = (float *) calloc( nx*ny*nz, sizeof(float) );
   if (g->image == NULL)
   {
      error_status( "Cannot allocate memory for box!",
                    "Try a smaller box or restart program.", "" );
      reject_c( tofchar(key), tofchar("Cannot allocate memory for box!") );
      g->imagesize = 0;
      g->boxexist = NO;
      return;
   }
   g->nx = nx;
   g->ny = ny;
   g->imagesize = nx * ny;

   getdata( g );

   /*---------------------------------------------------*/
   /* The minimum and maximum values of the data are    */
   /* known at this moment. So we have to update the    */
   /* min, max field, but not if there are values given */
   /* at the start.                                     */
   /*---------------------------------------------------*/
   {
      fchar  Minmaxtxt;
      char   buf[128];
      Minmaxtxt.a = buf;
      Minmaxtxt.l = 127;
      dfault = HIDDEN;
      r = usertext_c( Minmaxtxt, &dfault, tofchar("ZMINMAX="), tofchar("") );
      if (r == 0 || !first)
      {
         /* No data min, max specified before */
         wkeyf( "ZMINMAX=%f %f", g->datamin, g->datamax );
         setminmax( NULL, "ZMINMAX=", KEYCHANGE, g );   /* Pseudo event */
      }
      if (first && r != 0)
         setminmax( NULL, "ZMINMAX=", KEYCHANGE, g );
   }
   /* Set for 3d data also the value of the iso surface */
   if (g->subdim == 3)
   {
      fchar  Minmaxtxt;
      char   buf[128];
      Minmaxtxt.a = buf;
      Minmaxtxt.l = 127;
      dfault = HIDDEN;
      r = usertext_c( Minmaxtxt, &dfault, tofchar("ISOVAL="), tofchar("") );
      if (r == 0 || !first)
      {
         /* No value for iso surface specified before */
         wkeyf( "ISOVAL=%f", (g->datamin+g->datamax)/2.0 );
         getreal( NULL, "ISOVAL=", KEYCHANGE, &(g->isoval) ); /* Pseudo event */
      }
      if (first && r != 0)
         getreal( NULL, "ISOVAL=", KEYCHANGE, &(g->isoval) );
   }
   first = NO;

   /*--------------------------------------------------*/
   /* Are we here, then we have a set, we have a box,  */
   /* and a 2-dim buffer filled with data from the box.*/
   /*--------------------------------------------------*/
   g->boxexist = YES;
   return;
}




static void getset( ident  id,
                    char  *key,
                    int    code,
                    void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: INSET= keyword handler.                           */
/*------------------------------------------------------------*/
{
   fint     axcount[MAXAXES];
   fint     maxsubs = MAXSUBSETS;
   fint     maxaxes = MAXAXES;          /* Max num. of axes the program can deal with.*/
   fint     class   = 1;                /* Class 1 is for applications which repeat */
   fint     showdev = (fint) odev;
   fint     r;
   fint     dfault;
   char     dummytxt[STRLEN+1];
   fchar    Dummytxt;

   static int   first = YES;
   globaltype   *g=(globaltype*)arg;


   gui_error("");                        /* Empty error field */
   dfault = HIDDEN+100;                  /* Return immediately when error occurs */
   g->subdim = 0;                        /* Allow only 2 and 3-dim structures */
   clearstr( g->Setin );

   g->nsubs = gdsinp_c( g->Setin,
                        g->subin,
                        &maxsubs,
                        &dfault,
                        tofchar( key ),
                        tofchar(" "),
                        &showdev,        /* Device number (as in ANYOUT). */
                        g->axnum,
                        axcount,         /* Number of grids on axes in 'axnum' */
                        &maxaxes,
                        &class,          /* Class 1 is for applications which repeat */
                        &(g->subdim) );  /* Dimensionality of the subsets for class 1 */

   if (g->nsubs <= 0)
   {
      fchar   Errtxt;
      char    errtxt[STRLEN];
      fint    dfault = -1;              /* Special default to get UCA message */
      fint    l;

      Errtxt.a = errtxt; Errtxt.l = STRLEN-1; clearstr(Errtxt);
      g->setexist = NO;
      g->imagesize = 0;
      l = usertext_c( Errtxt, &dfault, tofchar("UCAMESSAGE="), tofchar("") );
      Errtxt.a[l] = '\0';
      error_status( Errtxt.a, "Check existence of set and check (sub)set dimension", "" );
      return;
   }

   if (g->subdim < 2 || g->subdim > 3)
   {
      g->setexist = NO;
      g->imagesize = 0;
      reject_c( tofchar(key), tofchar("Dimension must be 2 or 3!") );
      return;
   }
   g->setexist = YES;

   /* Get the default labels */
   {
      fchar    Xtitle, Ytitle, Ztitle, Ptitle;
      fint     r1;

      Xtitle.a = g->xtitle;
      Xtitle.l = STRLEN-1;
      Ytitle.a = g->ytitle;
      Ytitle.l = STRLEN-1;
      Ztitle.a = g->ztitle;
      Ztitle.l = STRLEN-1;

      Ptitle.a = g->ptitle;
      Ptitle.l = STRLEN-1;

      r1 = 0; gdsc_name_c( Xtitle, g->Setin, &(g->axnum[0]), &r1 );
      if (r1 < 0)
         strcpy( g->xtitle, "X" );
      else
         Xtitle.a[nelc_c(Xtitle)] = '\0';

      r1 = 0; gdsc_name_c( Ytitle, g->Setin, &(g->axnum[1]), &r1 );
      if (r1 < 0)
         strcpy( g->ytitle, "Y" );
      else
         Ytitle.a[nelc_c(Ytitle)] = '\0';

      strcpy( g->ztitle, "" );
      if (g->subdim == 3)
      {
         r1 = 0; gdsc_name_c( Ztitle, g->Setin, &(g->axnum[2]), &r1 );
         if (r1 < 0)
            strcpy( g->ztitle, "Y" );
         else
            Ztitle.a[nelc_c(Ztitle)] = '\0';
      }

      r1 = 0; gdsd_rchar_c( g->Setin, tofchar("BUNIT"), &setlevel, Ptitle, &r1 );
      if (r1 < 0)
      {
         if (g->subdim == 2)
           strcpy( g->ptitle, "Surface height in pixels" );
         else
           strcpy( g->ptitle, "Iso surface in pixels" );
      }
      else
         Ptitle.a[nelc_c(Ptitle)] = '\0';
      wkeyf( "XTITLE=%s", g->xtitle );
      wkeyf( "YTITLE=%s", g->ytitle );
      wkeyf( "ZTITLE=%s", g->ztitle );
      wkeyf( "PLOTTITLE=%s", g->ptitle );

   }
   anyoutf( DEBUG, "Header: %s %s %s", g->xtitle, g->ytitle, g->ptitle );


   /*-------------------------------*/
   /* Determine edges of this frame */
   /*-------------------------------*/
   {
      fint cwlo, cwhi;                          /* Local coordinate words */
      int  m;
      fint r2, r1 = 0;
      gdsc_range_c( g->Setin, &setlevel, &cwlo, &cwhi, &r1 );
      r1 = r2 = 0;
      for (m = 0; m < g->subdim; m++)
      {
         g->flo[m] = gdsc_grid_c( g->Setin, &(g->axnum[m]), &cwlo, &r1 );
         g->fhi[m] = gdsc_grid_c( g->Setin, &(g->axnum[m]), &cwhi, &r2 );
      }
   }


   dfault     = HIDDEN;
   Dummytxt.l = STRLEN;
   Dummytxt.a = dummytxt;
   r = usertext_c( Dummytxt, &dfault, tofchar("BOX="), tofchar(" ") );
   
   if (r && first)
   /*--------------------------------------------------*/
   /* A box is specified before a set. Now the set is  */
   /* known and we can get the box + data.             */
   /*--------------------------------------------------*/
   {
      getbox( NULL, "BOX=", KEYCHANGE, g );     /* pseudo event */
      first = NO;
   }
   else
   {
      /* No box yet */
      first = NO;
   }
}




static void initplot( char *dev )
/*------------------------------------------------------------*/
/* PURPOSE: Initialize PGPLOT                                 */
/* We have more plot windows to process. Therefore pgbeg is   */
/* replaced by pgopen.                                        */
/* r = pgbeg_c( &unit, tofchar( dev ),&nxysub[0],&nxysub[1] );*/
/* In this stage a plot window is already opened by gui.c     */
/*------------------------------------------------------------*/
{
   fint      unit, r, nxysub[2];

   nxysub[0] = nxysub[1] = 1;
   unit = 0;
   
   r = pgopen_c( tofchar(dev) );
}




static void dozoom( ident id,
                    char  *key,
                    int   code,
                    void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: ZOOM= keyword handler.                            */
/*------------------------------------------------------------*/
{
   globaltype *g = (globaltype *) arg;
   float      userval;
   fint       nitems = 1;
   fint       dfault = HIDDEN;


   (void) userreal_c( &userval,
                      &nitems,
                      &dfault,
                      tofchar(key),
                      tofchar(" ") );
                      
   g->zoom = userval;
   if (g->imagesize != 0)
      wkeyf("GO=YES");
}




static void makeplot( ident id,
                      char  *key,
                      int   code,
                      void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: GO= keyword handler.                              */
/*                                                            */
/* Make the actual plot with srfplot or isoplot.              */
/*------------------------------------------------------------*/
{
   globaltype *g = (globaltype *) arg;
   bool       value;
   bool       boxexist;
   
  
   value = UserLog( key );
   if (value)
   {
      char   dummytxt[256];
      fchar  Dum;
      fint   dfault = HIDDEN;
        
      Dum.a = dummytxt;
      Dum.l = 255;      
      if (!g->setexist)
      {
          wkeyf( key );                                    /* Reset GO button */
          gui_error("At least a set (or subset) is needed!" );
          return;
      }
      boxexist = usertext_c( Dum, &dfault, tofchar("BOX="), tofchar("") );
      if (!boxexist)
      {

         if (!usertext_c( Dum, &dfault, tofchar("BOX="), tofchar("") ))
         {
            if (g->subdim == 2)
               wkeyf( "BOX=%d %d %d %d", g->flo[0], g->flo[1], g->fhi[0], g->fhi[1] );
            else
               wkeyf( "BOX=%d %d %d %d %d %d",
                       g->flo[0], g->flo[1], g->flo[2],
                       g->fhi[0], g->fhi[1], g->fhi[2] );
            getbox( NULL, "BOX=", KEYCHANGE, g );     /* pseudo event */
         }
      }


      {
         bool   Coloured;
         float  datmin = g->datamin + g->dataoffset;
         float  datmax = g->datamax + g->dataoffset;
         float  lastrot, lasttilt;
         float  window[4];

         window[0] = window[1] =  -1.0/(g->zoom);   /* xlo, ylo */
         window[2] = window[3] =  +1.0/g->zoom;     /* xhi, yhi */

         hermesstatus( "Building the plot..." );

         g->eye = ABS( g->eye );             /* Distance must be  > 0 to view */

         if (g->coloption == 1)
            Coloured = toflog( YES );
         else
            Coloured = toflog( NO );

         /*--------------------------------------------------*/
         /* Some parameters are stored in a keyword so that  */
         /* a change in value generates an event. These plot */
         /* routines need to know the current values of the  */
         /* rotation and tilt. Therefore we have to read the */
         /* keywords ROTATION= and TILT=                     */
         /*--------------------------------------------------*/
         {
            fint   dfault, nitems;
            fint   r;
                           
            dfault = HIDDEN;
            nitems = 1;
            r = userreal_c( &lastrot, &nitems, &dfault, 
                            tofchar("ROTATION="), tofchar("") );
            r = userreal_c( &lasttilt, &nitems, &dfault, 
                            tofchar("TILT="), tofchar("") );
         }
                                        
         if (g->subdim == 2)
         {
            float   Xmin = g->blo[0], Xmax = g->bhi[0];
            float   Ymin = g->blo[1], Ymax = g->bhi[1];
            srfplot_c( &Xmin, &Xmax, &Ymin, &Ymax,
                       g->image,&(g->nx), &(g->ny),
                       &(g->charsize), &(g->lwidth),
                       tofchar(g->xtitle),
                       tofchar(g->ytitle),
                       tofchar(g->ptitle),
                       &Coloured,
                       &(g->gids_id),
                       &datmin,
                       &datmax,
                       &lastrot,
                       &lasttilt,
                       g->monorgb,
                       g->backrgb,
                       g->light,
                       &(g->eye),
                       &(g->ncbands),
                       &(g->shine),
                       &(g->polish),
                       &(g->diffuse),
                       window );
         }
         else
         {
            float   iso = g->isoval + g->dataoffset;
            float   Xmin = g->blo[0], Xmax = g->bhi[0];
            float   Ymin = g->blo[1], Ymax = g->bhi[1];
            float   Zmin = g->blo[2], Zmax = g->bhi[2];
            fint    translev = g->transparencylevel;
            fint    nitems = 3;
            fint    dfault = HIDDEN;
            fint    r1, r2, r3;
            float   dummy[3];

            if (translev < 0) translev = 0;
            if (translev > 3) translev = 3;

            /* Are there enough keyword values to plot a slice? */
            r1 = userreal_c( dummy, &nitems, &dfault, tofchar("APOINT="), tofchar("") );
            nitems = 1;
            r2 = userreal_c( &dummy[0], &nitems, &dfault, tofchar("THETA="), tofchar("") );
            r3 = userreal_c( &dummy[0], &nitems, &dfault, tofchar("PHI="), tofchar("") );
            g->plotslice = (r1 == 3 && r2 == 1 && r3 == 1);
            g->plotslice = toflog( g->plotslice );
                                      
            isoplot_c( &Xmin, &Xmax, &Ymin, &Ymax, &Zmin, &Zmax,
                       g->image,&(g->nx), &(g->ny), &(g->nz),
                       &(g->charsize), &(g->lwidth),
                       tofchar(g->xtitle),
                       tofchar(g->ytitle),
                       tofchar(g->ztitle),
                       tofchar(g->ptitle),
                       &Coloured,
                       &(g->gids_id),
                       &datmin,
                       &datmax,
                       &lastrot,
                       &lasttilt,
                       g->monorgb,
                       g->backrgb,
                       g->light,
                       &(g->eye),
                       &(g->ncbands),
                       &(g->shine),
                       &(g->polish),
                       &(g->diffuse),
                       &iso,
                       &translev,
                       &(g->plotslice),
                       g->apoint,
                       &(g->theta),
                       &(g->phi),
                       window );                       
         }
      }
      clearstatus();
      wkeyf( key );
   }
}




static void showhelp( ident id,
                      char  *key,
                      int   code,
                      void  *arg )
/*------------------------------------------------------------*/
/* PURPOSE: HELP= keyword handler.                            */
/* Try to display the dc1 document with document viewer.      */
/*------------------------------------------------------------*/
{

   bool help = UserLog(key);
   if (help)
   {
      char       path[FILENAME_MAX];
      char       filename[FILENAME_MAX];
      FILE       *fp;

      strcpy( path, getenv("gip_tsk") );

      (void) sprintf( filename, "%s/%s.dc1", path, taskname );
      fp = fopen( filename, "r" );
      if (fp == NULL)
      {
         (void) sprintf( filename, "./%s.dc1", taskname );
         fp = fopen( filename, "r" );
         if (fp == NULL)
         {
            error_status( "Cannot open dc1 document for help", "", "" );
            return;
         }
      }
      GgiShowDoc( filename );
      return;
   }
   else
   {
      GgiShowDoc( NULL );
      wkeyf( key );
   }
}




static void setplotter( ident id,
                        char  *key,
                        int   code,
                        void  *arg)
/*------------------------------------------------------------*/
/* PURPOSE: PLOTTER= keyword handler.                         */
/* After starting the program a list with available devices   */
/* is stored in an array. The PLOTTER= keyword sets in a menu */
/* in gui.c the array index of this list. When a number is    */
/* set (this is automatically an available device), we copy   */
/* the name in the global stucture member 'devnam'.           */
/*------------------------------------------------------------*/
{
   char        *g = (char*) arg;
   fint         n;
   fint         nitems = 1;
   fint         dfault = HIDDEN;


   (void) userint_c( &n, &nitems, &dfault, tofchar(key), tofchar(" ") );
   strcpy( g, plotters[n] );
}




static void toplotter( ident id,
                       char  *key,
                       int   code,
                       void  *arg)
/*------------------------------------------------------------*/
/* PURPOSE: PLOT= keyword handler.                            */
/*------------------------------------------------------------*/
{
   globaltype  *g = (globaltype*) arg;
   bool        value;


   value = UserLog( key );
   if (value)
   {
      char    dev[STRLEN+20];
      sprintf( dev, "%s/%s", g->devnam, g->psfile );
      anyoutf( DEBUG, "Selected device: %s", dev );
      pgend_c();
      initplot( dev );             /* The current plot device set by PLOTTER= */
      wkeyf("GO=Y");
      makeplot( NULL, "GO=", KEYCHANGE, g );                  /* pseudo event */
      pgiden_c();
      pgend_c();
      initplot( "3DPLOT" );
      sprintf( dev, "Plot ready, device: %s", g->devnam );
      gui_status( dev, FIRSTLINE );
      sprintf( dev, "PS file on disk: %s", g->psfile );
      gui_status( dev, SECONDLINE );
      wkeyf( key );
   }
}




static void quit( ident id,
                  char  *key,
                  int   code,
                  void  *arg)
/*------------------------------------------------------------*/
/* PURPOSE: QUIT= keyword handler.                            */
/*------------------------------------------------------------*/
{
   globaltype  *g = (globaltype*) arg;


/*   bool quit = UserLog(key);*/
   if (1)
   {
      if (g->image != NULL) free( g->image );
      cancel_c( tofchar(key) );                       /* remove QUIT= keyword */
      cancel_c( tofchar("PLAY=") );
      cancel_c( tofchar("FRAME=") );
      cancel_c( tofchar("GO=") );
      pgend_c();
      finis_c();                                            /* terminate task */
   }
   wkeyf( key );
}




static void initializestruct( globaltype *g )
/*------------------------------------------------------------*/
/* PURPOSE: Initialize values for current status.             */
/*------------------------------------------------------------*/
{
   odev = 16;                    /* Output log. destination */

   g->image = NULL;              /* 1-dim matrix with floats */

   g->Setin.a = g->setbuf;
   g->Setin.l = STRLEN - 1;
   g->setexist = NO;
   g->boxexist = NO;
   g->blo[0] = g->blo[1] = 0;    /* Low  edge of box in grids */
   g->bhi[0] = g->bhi[1] = 0;    /* High edge of box in grids */
   g->nsubs = 0;                 /* Number of input subsets */
   g->imagesize = 0;
   g->charsize = CHARSIZE;       /* PGPLOT character height */
   g->lwidth   = LWIDTH;         /* PGPLOT line width */
   g->gids_id  = -1;             /* Identification for connection with GIDS */
   g->rotation = ROTATION;
   g->tilt = TILT;
   g->monorgb[0] = 0.0;
   g->monorgb[1] = 1.0;
   g->monorgb[2] = 0.0;
   g->backrgb[0] = 0.2;
   g->backrgb[1] = 0.4;
   g->backrgb[2] = 0.7;
   g->ncbands = NCBANDS;
   g->shine   = SHINE;
   g->diffuse = DIFFUSE;
   g->polish  = POLISH;
   g->dataoffset = 0.0;
   g->isoval = 0.0;
   g->coloption = 0;              /* 0 monochrome, 1 = colours from GIDS */
   g->light[0] = 0.0;
   g->light[1] = 0.0;
   g->light[2] = -1.0;
   g->eye = D_EYE;
   strcpy( g->psfile, "renderplot.ps" );
   plotters = plotdevices();      /* Function to get a list with grdevices */
   strcpy( g->devnam, plotters[0] );
   g->transparencylevel = 0;
   g->plotslice = NO;
   g->theta = g->phi = 0.0;       /* default slice normal 0 0 -1 */
   g->apoint[0] = g->apoint[1] = g->apoint[2] = 0.0;   /* Def. point on slice */
   g->plotid = 0;
   g->interval = INTERVAL;
   g->timer = NULL;
   g->zoom = 1.0/ZOOM;
}




MAIN_PROGRAM_ENTRY
/*-------------------------------------------------------------------------*/
/* The macro MAIN_PROGRAM_ENTRY replaces the C-call main() to start the    */
/* main body of your GIPSY application. Variables defined as 'fchar' start */
/* with a capital.                                                         */
/*-------------------------------------------------------------------------*/
{
   globaltype   glob;


   init_c();                            /* Contact Hermes */

   {
      /* Start graphical user interface */
      fint   plotsize[2];
      fint   nitems = 2;
      fint   dfault = HIDDEN;
      fint   r;

      plotsize[0] = plotsize[1] = 532;
      r = userint_c( plotsize, &nitems, &dfault,
                     tofchar("PLOTSIZE="), tofchar(" ") );
      if (r == 1)
         plotsize[1] = plotsize[0];
      gui( (int) plotsize[0], (int) plotsize[1] );
   }

   setfblank_c( &blank );
   initializestruct( &glob );           /* Set default properties */


   /* Initialize PGPLOT */
   initplot( "3DPLOT" );

   /* Start scheduling the functions */
   (void) ScheduleKeyevent( quit,        "QUIT=",     KEYCHANGE, &glob );
   (void) ScheduleKeyevent( quit,        "FILE=",     KEYCHANGE, &glob );
   (void) ScheduleKeyevent( getset,      "INSET=",    KEYCHANGE, &glob );
   (void) ScheduleKeyevent( getbox,      "BOX=",      KEYCHANGE, &glob );
   (void) ScheduleKeyevent( setminmax,   "ZMINMAX=",  KEYCHANGE, &glob );
   (void) ScheduleKeyevent( getreal,     "CHARSIZE=", KEYCHANGE, &(glob.charsize) );
   (void) ScheduleKeyevent( getint,      "LWIDTH=",   KEYCHANGE, &(glob.lwidth) );
   (void) ScheduleKeyevent( getint,      "NCBAND=",   KEYCHANGE, &(glob.ncbands) );
   (void) ScheduleKeyevent( gettxt,      "XTITLE=",   KEYCHANGE, &(glob.xtitle) );
   (void) ScheduleKeyevent( gettxt,      "YTITLE=",   KEYCHANGE, &(glob.ytitle) );
   (void) ScheduleKeyevent( gettxt,      "ZTITLE=",   KEYCHANGE, &(glob.ztitle) );
   (void) ScheduleKeyevent( gettxt,      "PLOTTITLE=",KEYCHANGE, &(glob.ptitle) );
   (void) ScheduleKeyevent( colopt,      "COLOPTION=",KEYCHANGE, &glob );
   (void) ScheduleKeyevent( getreal,     "ROTATION=", KEYCHANGE, &(glob.rotation) );
   (void) ScheduleKeyevent( getreal,     "TILT=",     KEYCHANGE, &(glob.tilt) );
   (void) ScheduleKeyevent( getrgb,      "MONORGB=",  KEYCHANGE, &(glob.monorgb) );
   (void) ScheduleKeyevent( getrgb,      "BACKRGB=",  KEYCHANGE, &(glob.backrgb) );
   (void) ScheduleKeyevent( getlight,    "LIGHT=",    KEYCHANGE, &(glob.light) );
   (void) ScheduleKeyevent( getreal,     "EYE=",      KEYCHANGE, &(glob.eye) );
   (void) ScheduleKeyevent( getreal,     "SHINE=",    KEYCHANGE, &(glob.shine) );
   (void) ScheduleKeyevent( getreal,     "POLISH=",   KEYCHANGE, &(glob.polish) );
   (void) ScheduleKeyevent( getreal,     "DIFFUSE=",  KEYCHANGE, &(glob.diffuse) );
   (void) ScheduleKeyevent( getreal,     "ISOVAL=",   KEYCHANGE, &(glob.isoval) );
   (void) ScheduleKeyevent( toplotter,   "PLOT=",     KEYCHANGE, &glob );
   (void) ScheduleKeyevent( setplotter,  "PLOTTER=",  KEYCHANGE, &(glob.devnam) );
   (void) ScheduleKeyevent( showhelp,    "HELP=",     KEYCHANGE, NULL );
   (void) ScheduleKeyevent( getchr,      "PSFILE=",   KEYCHANGE, &(glob.psfile) );
   (void) ScheduleKeyevent( getint,      "TRANS=",    KEYCHANGE, &(glob.transparencylevel) );
   (void) ScheduleKeyevent( getreal,     "THETA=",    KEYCHANGE, &(glob.theta) );
   (void) ScheduleKeyevent( getreal,     "PHI=",      KEYCHANGE, &(glob.phi) );
   (void) ScheduleKeyevent( getxyz,      "APOINT=",   KEYCHANGE, &(glob.apoint) );
   (void) ScheduleKeyevent( dozoom,      "ZOOM=",     KEYCHANGE, &glob );
   (void) ScheduleKeyevent( makeplot,    "GO=",       KEYCHANGE, &glob );

   /* Initialize some fields */
   if (!TriggerKey( "CHARSIZE=" ))
   {
      wkeyf( "CHARSIZE=%.1f", glob.charsize );
   }
   if (!TriggerKey( "LWIDTH=" ))
   {
      wkeyf( "LWIDTH=%d", glob.lwidth );
   }
   if (!TriggerKey( "ROTATION=" ))
   {
      wkeyf( "ROTATION=%.2f", glob.rotation );
   }
   if (!TriggerKey( "TILT=" ))
   {
      wkeyf( "TILT=%.2f", glob.tilt );
   }
   if (!TriggerKey( "MONORGB=" ))
   {
      wkeyf( "MONORGB=%g %g %g", glob.monorgb[0], glob.monorgb[1], glob.monorgb[2] );
   }
   if (!TriggerKey( "BACKRGB=" ))
   {
      wkeyf( "BACKRGB=%g %g %g", glob.backrgb[0], glob.backrgb[1], glob.backrgb[2] );
   }
   if (!TriggerKey("POLISH="))
   {
      wkeyf( "POLISH=%g", glob.polish );
   }
   if (!TriggerKey("DIFFUSE="))
   {
      wkeyf( "DIFFUSE=%g", glob.diffuse );
   }
   if (!TriggerKey("SHINE="))
   {
      wkeyf( "SHINE=%g", glob.shine );
   }
   if (!TriggerKey("NCBAND="))
   {
      wkeyf( "NCBAND=%d", glob.ncbands );
   }
   if (!TriggerKey("LI_HOR="))
   {
      wkeyf( "LI_HOR=0.0" );
   }
   if (!TriggerKey("LI_VER="))
   {
      wkeyf( "LI_VER=0.0" );
   }
   if (!TriggerKey("LIGHT="))
   {
      wkeyf( "LIGHT=%g %g %g", glob.light[0], glob.light[1], glob.light[2] );
   }
   if (!TriggerKey("EYE="))
   {
      wkeyf( "EYE=%g", glob.eye );
   }
   if (!TriggerKey("PSFILE="))
   {
      wkeyf( "PSFILE=%s", glob.psfile );
   }
   if (!TriggerKey("PLOTTER="))
   {
      wkeyf( "PLOTTER=0" );
   }
   if (!TriggerKey("TRANS="))
   {
      wkeyf( "TRANS=0" );
   }
   if (!TriggerKey("INTERVAL="))
   {
      wkeyf( "INTERVAL=%d", INTERVAL );
   }
   if (!TriggerKey("FRAME="))
   {
      wkeyf( "FRAME=0" );
   }
   if (!TriggerKey("ZOOM="))
   {
      wkeyf( "ZOOM=%f", glob.zoom );
   }



   /* Some events are forced with the trigger_key routine */
   /* Order is important! */
   TriggerKey("INSET=");
   TriggerKey("TILT=");
   TriggerKey("CHARSIZE=");
   TriggerKey("LWIDTH=");
   TriggerKey("ROTATION=");
   TriggerKey("MONORGB=");
   TriggerKey("BACKRGB=");
   TriggerKey("POLISH=");
   TriggerKey("DIFFUSE=");
   TriggerKey("SHINE=");
   TriggerKey("NCBAND=");
   TriggerKey("LIGHT=");
   TriggerKey("EYE=");
   TriggerKey("PSFILE=");
   TriggerKey("TRANS=");
   TriggerKey("APOINT=");
   TriggerKey("THETA=");
   TriggerKey("PHI=");
   TriggerKey("MO_TILT=");
   TriggerKey("MO_ROT=");
   TriggerKey("INTERVAL=");   
   TriggerKey("FRAME=");
   TriggerKey("LI_HOR=");
   TriggerKey("LI_VER=");      
/*   TriggerKey("ZOOM=");*/

   MainLoop();

   return( EXIT_SUCCESS );
}
#<

#>            gui.c
/* gui.c -XT
                              COPYRIGHT (c) 1999
                        Kapteyn Astronomical Institute
         University of Groningen  -  9700 AV Groningen, The Netherlands

Author: J.P. Terlouw
*/

#define STATUSLINES    2            /* number of status lines */
#define ZOOMFACTOR     1.1892071    /* sqrt(sqrt(2.0)) */


#define MAINWIDTH 925

#define INSET_H      "Input (sub)set"
#define BOX_H        "Frame for input (sub)set. Empty field means entire set"
#define XTITLE_H     "X-axis label"
#define YTITLE_H     "Y-axis label"
#define ZTITLE_H     "Z-axis label"
#define PLOTTITLE_H  "Title of plot"
#define PSFILE_H     "Name of PostScript file on disk"
#define CHARSIZE_H   "Size of plot characters"
#define LWIDTH_H     "Width of the lines"
#define MONORGB_H    "The monochrome color (RGB)"
#define BACKRGB_H    "The background color (RGB)"
#define NCBAND_H     "Number of color bands"
#define POLISH_H     "Bright spot size"
#define DIFFUSE_H    "Diffusiveness, (0.0-1.0)"
#define LIGHT_H      "Direction of the light, x,y,z"
#define EYE_H        "Distance of eye"
#define ZOOM_H       "Zoom factor"
#define ZMINMAX_H    "Minmax of data to display"
#define ROTATION_H   "Horizontal angle of viewer wrt. cube"
#define TILT_H       "Vertical angle of viewer wrt. cube"
#define SHINE_H      "Shinyness"
#define TRANS_H      "Level of transparency 0=0% 1=25% 2=50% 3=75%"
#define ISOVAL_H     "Value for (3d) iso surface"
#define APOINT_H     "x,y,z of point on slice"
#define PHI_H        "Slice normal angle in XY plane"
#define THETA_H      "Slice normal angle in XZ plane"
#define LI_HOR_H     "Light horizontal position"
#define LI_VER_H     "Light vertical position"
#define MO_ROT_H     "Movie rotations"
#define MO_TILT_H    "Movie tilts"
#define INTERVAL_H   "Movie frame interval (ms)"
#define PLAY_H       "Play movie"

#include "stdio.h"
#include "stddef.h"
#include "math.h"
#include "gipsyc.h"
#include "userfio.h"
#include "ggi.h"
#include "plotdevices.h"
#include "animator.h"
#include "orientation.h"
#include "gui.h"

#define RAD(x) (0.017453293*(x))

static ident l_status[STATUSLINES], l_error;
static float li=0.0, lb=0.0;
static ident lidial, lbdial;
static int   lipos=0;

/* -------------------------------------------------------------------------- */
/*                                 handle_file                                */
/* -------------------------------------------------------------------------- */
/*  Keyword handler for the file menu.
 */
static void handle_file(ident id, char* key, int code, void *arg)
{
   fint entry=0;
    
   if (userfint(&entry, 1, 2, key, " ")==1) {
      switch (entry) {
         case 0: {
            GgiShowShell((ident)arg, TRUE);
            wkeyf(key);
            break;
         }
         case 2: {
            wkeyf("FILE=0");                            /* old FILE= keyword */
            break;
         }
         default: {
            errorf(1,"Illegal menu entry");
            break;
         }
      }
   }
}

/* -------------------------------------------------------------------------- */
/*                                 dozoom                                     */
/* -------------------------------------------------------------------------- */
/*  Step zoom factor.
 */
static void dozoom(ident id, char* key, int code, void *arg)
{
   bool button=toflog(FALSE);
   int  direction=(int)arg;
   
   (void)userflog(&button, 1, 2, key, " ");
   if (tobool(button)) {
      float factor;
      (void)userfreal(&factor, 1, 2, "ZOOM=", " ");
      if (!strcmp(key,"ZOOMIN=")) {
         factor *= ZOOMFACTOR;
      } else {
         factor /= ZOOMFACTOR;
      }
      wkeyf("ZOOM=%.2f", factor);
      wkeyf(key);
   }
}
         
/* -------------------------------------------------------------------------- */
/*                                 ps_seen                                    */
/* -------------------------------------------------------------------------- */
/*  Keyword handler for PSFILE=.
 */
static void ps_seen(ident id, char* key, int code, void *arg)
{
   GgiShowShell((ident)arg, FALSE);
}

/* -------------------------------------------------------------------------- */
/*                                 ps_ok                                      */
/* -------------------------------------------------------------------------- */
/*  Keyword handler for PS_OK=.
 */
static void ps_ok(ident id, char* key, int code, void *arg)
{
   bool button=toflog(FALSE);
   (void)userflog(&button, 1, 2, key, " ");
   if (button) {
      (void)TriggerKey("PSFILE=");
      wkeyf(key);
   }
}

/* -------------------------------------------------------------------------- */
/*                                 ps_can                                     */
/* -------------------------------------------------------------------------- */
/*  Keyword handler for PS_CANCEL=.
 */
static void ps_can(ident id, char* key, int code, void *arg)
{
   bool button=toflog(FALSE);
   (void)userflog(&button, 1, 2, key, " ");
   if (button) {
      GgiShowShell((ident)arg, FALSE);
      wkeyf(key);
   }
}

/* -------------------------------------------------------------------------- */
/*                                 light_angle                                */
/* -------------------------------------------------------------------------- */
/*  Keyword handler for light dials.
 */
static void light_angle(ident id, char* key, int code, void *arg)
{
   float x,y,z;
   float az=RAD(90.0-lb), el=RAD(li);
   float *val=(float*)arg;
   int   newpos;
   
   (void)userfreal(val, 1, 2, key, " ");
   x =  fabs(cos(el))*cos(az);
   y = -sin(el);
   z = -fabs(cos(el))*sin(az);
   wkeyf("LIGHT=%4.2f %4.2f %4.2f", x, y, z);
   if (val==&lb) {
      newpos = (lb>180)?1:-1;
      if (newpos!=lipos) {
         lipos=newpos;
         GgiSetRange(lidial, lipos==1?270.0:-90.0, lipos==1?-90.0:270.0);
      }
   } else {
      if (li>90.0) {
         li = 180-li;
         wkeyf("%s%.0f", key, li);
         wkeyf("LI_HOR=%.0f", (float)fmod((double)(-lb+360.0), 360.0));
      }
   }
}

/* -------------------------------------------------------------------------- */
/*                                 popann                                     */
/* -------------------------------------------------------------------------- */
/*  Keyword handler for the annotation pop-up
 */
static void popann(ident id, char *key, int code, void *arg)
{
   static bool state=FALSE;
   bool button=toflog(FALSE);
    
   (void)userflog(&button, 1, 2, key, " ");
   if (tobool(button)) {
      GgiShowShell((ident)arg, !state);
      state = !state;
      wkeyf(key);
   }
}

/* ========================================================================== */
/*                                 gui                                        */
/* -------------------------------------------------------------------------- */
/*  Interface routine to initialize the graphical user interface.
 */
extern void gui(int xsize, int ysize)
{
   int i;
   
   ident inset, box, xtitle, ytitle, ztitle, plottitle, psfile, charsize,
         monorgb, backrgb, ncband, diffuse, polish,
         eye, zminmax, rotation, tilt, shine, trans, go, help, coloption,
         plotter, file, gipsy, rotdial, tiltdial, isoval, apoint, theta, phi,
         thedial, phidial, plotmenu, doplot, lbtext, litext, psok, pscan,
         movie, cubeplot, zoom, zoomin, zoomout;
   ident annbutt, annclos;
   ident topref;
   ident filepop, dataform, topbar, colors, viewing, slice, annot;
         
   static char *coloptions[]={"Monochrome", "From GIDS", NULL};
   static char *file_entries[]={"PostScript file", "_LINE", "Exit", NULL};
   static char **plotters;
  

   GgiAutoLayout(FALSE);
   GgiPostponeRealize(TRUE);

   plotter   = GgiPlotField("3DPLOT", xsize, ysize);
   (void)GgiPlotColors(plotter, 128);

/*
 * Create the elements
 */
/* ========================== Containers =================================== */

   dataform = GgiForm("data", 1);
   topbar   = GgiForm("top", 1);
   colors   = GgiForm("colors", 1);
   viewing  = GgiForm("rest", 1);
   slice    = GgiForm("slice",1);
   annot    = GgiShell("annot");
   filepop  = GgiDialog("filepop");

/* ======================== Active elements ================================ */

/* --------------------------- Data Input ---------------------------------- */

   (void)GgiUseShell(dataform);
   inset     = GgiSetLabel(GgiTextField("INSET=", INSET_H, 40),
                           "Set", 80);
   box       = GgiSetLabel(GgiTextField("BOX=",   BOX_H, 40),
                           "Box", 80);
   zminmax   = GgiSetLabel(GgiTextField("ZMINMAX=", ZMINMAX_H, 20),
                           "Min, max", 80);
   isoval    = GgiSetLabel(GgiTextField("ISOVAL=", ISOVAL_H, 10),
                           "Isoval", 50);
                           
/* ------------------------------ Colors ----------------------------------- */

   (void)GgiUseShell(colors);
   coloption = GgiSetLabel(GgiMenu("COLOPTION=", "Color option", coloptions),
                           "COLOR", 0);
   ncband    = GgiSetLabel(GgiTextField("NCBAND=", NCBAND_H,  3),
                           "# Bands", 60);
   monorgb   = GgiSetLabel(GgiTextField("MONORGB=", MONORGB_H, 14),
                           "Mono color", 80);
   backrgb   = GgiSetLabel(GgiTextField("BACKRGB=", BACKRGB_H, 14),
                           "Backgr.", 68);
   diffuse   = GgiSetLabel(GgiTextField("DIFFUSE=", DIFFUSE_H,  3),
                           "Diffuse", 80);
   polish    = GgiSetLabel(GgiTextField("POLISH=", POLISH_H, 3),
                           "Polish", 47);
   shine     = GgiSetLabel(GgiTextField("SHINE=", SHINE_H, 3),
                           "Shine", 47);
   trans     = GgiSetLabel(GgiTextField("TRANS=", TRANS_H, 3),
                           "Transp.", 47);

/* ------------------------------ Viewing ---------------------------------- */

   (void)GgiUseShell(viewing);
   cubeplot  = GgiPlotField("CUBE", 100, 100);
   eye       = GgiSetLabel(GgiTextField("EYE=", EYE_H, 6),
                           "Eye", 0);                           
   zoom      = GgiSetLabel(GgiTextField("ZOOM=", ZOOM_H, 6),
                           "Zoom", 0);
   zoomin    = GgiSetLabel(GgiButton("ZOOMIN=",  NULL), "+", 0);
   zoomout   = GgiSetLabel(GgiButton("ZOOMOUT=", NULL), "-", 0);
   rotation  = GgiSetLabel(GgiTextField("ROTATION=", ROTATION_H,  6),
                           " ", 1);
   rotdial   = GgiSetLabel(GgiDial("ROTATION=", ROTATION_H,
                                    15, 180, -180, 4, 0.6, 1.0, 0.1,
                                    180.0, -180.0),
                           "Rotation", 0);
   GgiSetFormat(rotdial,"%.0f");
   GgiSetCircular(rotdial, TRUE);
   tilt      = GgiSetLabel(GgiTextField("TILT=", TILT_H,  6),
                           " ", 1);
   tiltdial  = GgiSetLabel(GgiDial("TILT=", TILT_H,               
                                    15, -90, 270, 4, 0.6, 1.0, 0.1,
                                    -180.0, 180.0),
                           "Tilt", 0);
   GgiSetFormat(tiltdial,"%.0f");
   GgiSetCircular(tiltdial, TRUE);
   lbtext    = GgiSetLabel(GgiTextField("LI_HOR=", LI_HOR_H,  6),
                           " ", 1);
   lbdial    = GgiSetLabel(GgiDial("LI_HOR=", "Light horizontal position",
                                    15, 0, 360, 3,  0.6, 1.0, 0.1, 0.0, 360.0),
                           "H-light", 0);
   GgiSetFormat(lbdial,"%.0f");
   GgiSetCircular(lbdial, TRUE);
   litext    = GgiSetLabel(GgiTextField("LI_VER=", LI_VER_H,  6),
                           " ", 1);
   lidial    = GgiSetLabel(GgiDial("LI_VER=", "Light vertical position",
                                    15, 0, 360, 3, 0.6, 1.0, 0.1, -90.0, 270.0),
                           "V-light", 0);
   GgiSetFormat(lidial,"%.0f");

/* ----------------------------   Slice ------------------------------------ */

   (void)GgiUseShell(slice);
   apoint    = GgiSetLabel(GgiTextField("APOINT=", APOINT_H, 6),
                           "Slice point:", 80);
   theta     = GgiSetLabel(GgiTextField("THETA=", THETA_H, 6),
                           "Theta", 80);
   thedial   = GgiSetLabel(GgiDial("THETA=", THETA_H,
                                    15, 0, 360, 3,  0.6, 1.0, 1.0, 0.0, 360.0),
                           NULL, 0);
   GgiSetFormat(thedial,"%.0f");
   GgiSetCircular(thedial, TRUE);
   phi       = GgiSetLabel(GgiTextField("PHI=", PHI_H, 6),
                           "Phi", 40);
   phidial   = GgiSetLabel(GgiDial("PHI=", PHI_H,
                                    15, 0, 360, 3, 0.6, 1.0, 1.0, -90.0, 270.0),
                           NULL, 0);
   GgiSetFormat(phidial,"%.0f");
   GgiSetCircular(phidial, TRUE);

/* ------------------------- Annotation ------------------------------------ */

   (void)GgiUseShell(annot);
   xtitle    = GgiSetLabel(GgiTextField("XTITLE=", XTITLE_H, 40),
                           "X-title", 80);
   ytitle    = GgiSetLabel(GgiTextField("YTITLE=", YTITLE_H, 40),
                           "Y-title", 80);
   ztitle    = GgiSetLabel(GgiTextField("ZTITLE=", ZTITLE_H, 40),
                           "Z-title", 80);                           
   plottitle = GgiSetLabel(GgiTextField("PLOTTITLE=", PLOTTITLE_H, 40),
                           "Plot title", 80);
   charsize  = GgiSetLabel(GgiTextField("CHARSIZE=", CHARSIZE_H,  5),
                           "Char. size", 80);
   annclos   = GgiSetLabel(GgiButton("ANNOT=", "Close window"),
                           "CLOSE", 0);

/* --------------------------Button & menu bar ----------------------------- */

   (void)GgiUseShell(topbar);
   file      = GgiSetLabel(GgiMenu("GUI_FILE=", NULL, file_entries), "FILE", 0);
   plotters  = plotdevices();
   plotmenu  = GgiMenu("PLOTTER=", "Select hardcopy plot device", plotters);
   doplot    = GgiSetLabel(GgiButton("PLOT=", "Send plot to file or plotter"),
                           "SAVE PLOT",0);
   help      = GgiButton("HELP=", NULL);
   annbutt   = GgiButton("ANNOT=", "Plot annotation");
   movie     = GgiButton("ANIMATOR=", "Animation controls");

/* -------------------------- File pop-up ---------------------------------- */

   (void)GgiUseShell(filepop);
   psfile    = GgiSetLabel(GgiTextField("PSFILE=", PSFILE_H, 40),
                           "PS file:", 80);
   psok     = GgiSetLabel(GgiButton("PS_OK=", NULL), "OK", 0);
   pscan    = GgiSetLabel(GgiButton("PS_CANCEL=", NULL), "CANCEL", 0);
   

/* -------------------------- Main window ---------------------------------- */

   (void)GgiUseShell(NULL);
   go        = GgiButton("GO=", "Start making plot");
   topref = go;
   l_error  = GgiSetLabel(GgiLabel("error"), " ", 0);
   GgiSetPosition(l_error,   10, plotter, 0, topref);
   topref = l_error;
   for (i=0; i<STATUSLINES; i++) {
      l_status[i] = GgiSetLabel(GgiLabel("status"), " ", 0);
      GgiSetPosition(l_status[i], 10, plotter, 0, topref);
      topref = l_status[i];
   }

   gipsy     = GgiLogo(NULL, 0, 0);
   

/*
 *  Layout the containers
 */
/* --------------------------- Data Input ---------------------------------- */
   GgiSetPosition(inset,   0, NULL, 0, NULL);
   GgiSetPosition(box,     0, NULL, 0, inset);
   GgiSetPosition(zminmax, 0, NULL, 0, box);
   GgiSetPosition(isoval,  0, zminmax, 0, box);
   GgiSetPosition(apoint,  0, NULL,    0, zminmax);
   GgiSetPosition(theta,   0, apoint,  0, zminmax);   
   GgiSetPosition(phi,     0, theta,   0, zminmax);      

/* --------------------------Button & menu bar ----------------------------- */
   GgiSetPosition(file,    0, NULL, 0, NULL);
   GgiSetPosition(plotmenu, 20, file, 0, NULL);
   GgiSetPosition(doplot,  0, plotmenu, 0, NULL);
   GgiSetPosition(help,  MAINWIDTH-GgiWidth(help), NULL, 0, NULL);
   GgiSetPosition(annbutt, -GgiWidth(annbutt)-GgiWidth(help)-10, help, 0, NULL);
   GgiSetPosition(movie, -GgiWidth(movie)-GgiWidth(annbutt)-10,annbutt,0, NULL);

/* ------------------------------ Colors ----------------------------------- */
   GgiSetPosition(coloption,80, NULL,       0, NULL);
   GgiSetPosition(ncband,    0, coloption,  0, NULL);
   GgiSetPosition(monorgb,   0, NULL,       0, coloption);
   GgiSetPosition(backrgb,   0, monorgb,    0, coloption);

   GgiSetPosition(diffuse,   0, NULL,       0, backrgb);
   GgiSetPosition(polish,    0, diffuse,    0, backrgb);
   GgiSetPosition(shine,     0, polish,     0, backrgb);
   GgiSetPosition(trans,     0, shine,      0, backrgb);

/* ------------------------------ Viewing ---------------------------------- */

   GgiSetPosition(cubeplot,  0, NULL,       0, NULL);
   GgiSetPosition(rotdial,   0, cubeplot,   0, NULL);
   GgiSetPosition(rotation,  0, cubeplot,   0, rotdial);
   GgiSetPosition(tiltdial,  0, rotdial,    0, NULL);
   GgiSetPosition(tilt,      0, rotdial,    0, tiltdial);
   GgiSetPosition(lbdial,   10, tiltdial,   0, NULL);
   GgiSetPosition(lbtext,   10, tiltdial,   0, lbdial);
   GgiSetPosition(lidial,    0, lbdial,     0, NULL);
   GgiSetPosition(litext,    0, lbdial,     0, lidial);
   GgiSetPosition(eye, -GgiWidth(eye)-1, litext,   0, cubeplot);
   GgiSetPosition(zoom, -GgiWidth(zoom)-1, rotation, 0, cubeplot);
   GgiSetPosition(zoomin,    0, zoom,       0, cubeplot);
   GgiSetPosition(zoomout,   0, zoomin,     0, cubeplot);

/* ----------------------------   Slice ------------------------------------ */

   GgiSetPosition(apoint,    0, NULL,       0, NULL);
   GgiSetPosition(theta ,    0, NULL,       0, apoint);
   GgiSetPosition(thedial,   0, theta,      0, apoint);
   GgiSetPosition(phi,       0, thedial,    0, apoint);
   GgiSetPosition(phidial,   0, phi,        0, apoint);

/* ------------------------- Annotation ------------------------------------ */
   GgiSetPosition(xtitle,    0, NULL,       0, NULL);
   GgiSetPosition(ytitle,    0, NULL,       0, xtitle);
   GgiSetPosition(ztitle,    0, NULL,       0, ytitle);   
   GgiSetPosition(plottitle, 0, NULL,       0, ztitle);
   GgiSetPosition(charsize,  0, NULL,       0, plottitle);
   GgiSetPosition(annclos,   0, NULL,       5, charsize);

/* -------------------------- File pop-up ---------------------------------- */

   GgiSetPosition(psfile,    0, NULL,       0, NULL);
   GgiSetPosition(psok,     0, NULL,       0, psfile);
   GgiSetPosition(pscan, -GgiWidth(pscan)-4, psfile, 4, psfile);

/* -------------------------- Main window ---------------------------------- */

   GgiSetPosition(topbar,    0, NULL,       0, NULL);
   GgiSetPosition(plotter,   0, NULL,      10, topbar);
   GgiSetPosition(dataform, 10, plotter,   10, topbar);
   GgiSetPosition(colors,   10, plotter,    0, dataform);
   GgiSetPosition(viewing,  10, plotter,    0, colors);
   GgiSetPosition(slice,    10, plotter,    0, viewing);
   GgiSetPosition(go,       -GgiWidth(go)-5,    slice, 5, slice);
   GgiSetPosition(gipsy,    -GgiWidth(gipsy),     topbar,
                            -GgiHeight(gipsy)+20, l_status[STATUSLINES-1]);
   
   Animator("ANIMATOR=");

   GgiRealize();
   Orientation("CUBE");

   ScheduleKeyevent(dozoom, "ZOOMIN=",  KEYCHANGE, NULL);
   ScheduleKeyevent(dozoom, "ZOOMOUT=", KEYCHANGE, NULL);
   ScheduleKeyevent(light_angle, "LI_VER=", KEYCHANGE, &li);
   ScheduleKeyevent(light_angle, "LI_HOR=", KEYCHANGE, &lb);
   ScheduleKeyevent(popann, "ANNOT=", KEYCHANGE, annot);
   ScheduleKeyevent(handle_file, "GUI_FILE=", KEYCHANGE, filepop);
   ScheduleKeyevent(ps_seen, "PSFILE=", KEYCHANGE, filepop);
   ScheduleKeyevent(ps_ok,   "PS_OK=", KEYCHANGE, NULL);
   ScheduleKeyevent(ps_can,  "PS_CANCEL=", KEYCHANGE, filepop);
}

/* ========================================================================== */
/*                                 gui_status                                 */
/* -------------------------------------------------------------------------- */
/*  Interface routine to display a status message.
 */ 
void gui_status(char *message, int lineno)
{
   char buffer[512];
   
   sprintf(buffer,(lineno%STATUSLINES)?"             %s":"Status: %s",message);
   GgiSetLabel(l_status[lineno%STATUSLINES], buffer, 0);
}

/* ========================================================================== */
/*                                 gui_error                                  */
/* -------------------------------------------------------------------------- */
/*  Interface routine to display an error message.
 */
void gui_error(char *message)
{
   char buffer[512];
   
   if (*message) {
      sprintf(buffer,"Error: %s",message);
      GgiSetLabel(l_error, buffer, 0);
   } else {
      GgiSetLabel(l_error, " ", 0);
   }
}

#if defined(TESTBED)  /* ++++++++++++++++++++++++++++++++++++++++++++++++++ */
#include "init.h"
#include "finis.h"
#include "cmain.h"
#include "pgplot.h"

static void setmessage(ident id, void *arg)
{
   static int mesno=0;
   static float chi2=1.23456; 
   char message[80];

   sprintf(message,"Status message %d (%o Oct, %X Hex)", mesno, mesno, mesno);
   gui_status(message,mesno); 
   sprintf(message,"%f", chi2); chi2 += 0.01234;
/*   gui_chi2(message); */
   
   mesno++;
}

static void seterror(ident id, void *arg)
{
   static int mesno=1;
   char message[80];  

   sprintf(message,"Error message %d (%o Oct, %X Hex)", mesno, mesno, mesno);
   mesno++;
   if (mesno%2) gui_error(message); else gui_error("");
}

static void go(ident id, char *key, int code, void *arg)
{
   static int count=0;
   static float half=0.5;
   bool button=toflog(FALSE);
   (void)userflog(&button, 1, 2, key, " ");
   if (tobool(button)) {
      char  txt[80];
      fchar text;
      text.a = txt; text.l = 79;
      pgpage_c();
      sprintf(txt, "Frame %d", count++);
      text.l = strlen(txt);
      pgtext_c(&half, &half, text);
      wkeyf(key);
   }
}

MAIN_PROGRAM_ENTRY
{
   fint zero=0, one=1;

   init_c();
   wkeyf("ZOOM=1");
   gui(535, 535);
   (void)ScheduleTimer(setmessage, 4 SECONDS, NULL);
   (void)ScheduleTimer(seterror,   15 SECONDS, NULL);
#if 1
   (void)ScheduleKeyevent(go, "GO=", KEYCHANGE, NULL);
   pgopen_c(tofchar("3DPLOT"));
#endif
   MainLoop();
}
#endif
#<

#>            orientation.c
/* orientation.c
                              COPYRIGHT (c) 1999
                        Kapteyn Astronomical Institute
         University of Groningen  -  9700 AV Groningen, The Netherlands

Author: J.P. Terlouw
*/ 

#define L -0.5
#define H  0.5
#define MSCALE 60.0

#define RAD 0.017453293

#include "gipsyc.h"
#include "stddef.h"
#include "math.h"
#include "userfio.h"
#include "ggi.h"
#include "pgplot.h"
#include "orientation.h"

typedef struct {
   float x;
   float y;
   float z;
} *point, _point;

static _point cube[8]={
   {L,L,L}, {H,L,L}, {H,H,L}, {L,H,L},        /* back plane  */
   {L,L,H}, {H,L,H}, {H,H,H}, {L,H,H}         /* front plane */
};

static _point rcube[8];
static int npoints=sizeof(cube)/sizeof(_point);
static float rot=0.0, tilt=0.0;
static fint  idev, isel;

/* -------------------------------------------------------------------------- */
/*                                 rotate                                     */
/* -------------------------------------------------------------------------- */
/*  Rotate an array of points and subsequently apply a perspective projection.
 *  Arguments: rotation r, tilt t (in radians), input and output arrays
 *  of points and the number of points.
 */
static void rotate(float r, float t, point in, point out, int npts)
{
   int i;
   
   float cosr = cos(r);
   float sinr = sin(r);
   float cost = cos(t);
   float sint = sin(t);
    
   for (i=0; i<npts; i++) {
      out->x =  in->x*cosr                   + in->z*sinr;
      out->y =  in->x*sint*sinr + in->y*cost - in->z*sint*cosr;
      out->z = -in->x*cost*sinr + in->y*sint + in->z*cost*cosr;

      out->x = out->x*(4.0+out->z)/4.0; /* poor man's perspective */
      out->y = out->y*(4.0+out->z)/4.0;

      in++; out++;
   }
}

/* -------------------------------------------------------------------------- */
/*                                 drawcube                                   */
/* -------------------------------------------------------------------------- */
/*  Draw the cube. Edges connected to the origin are white; the other
 *  edges are red.
 */
static void drawcube(void)
{
   static  fint white=1, red=2;

   pgsci_c(&red);
   pgmove_c(&rcube[0].x, &rcube[0].y);
   pgdraw_c(&rcube[1].x, &rcube[1].y);
   pgdraw_c(&rcube[2].x, &rcube[2].y);
   pgdraw_c(&rcube[3].x, &rcube[3].y);
   pgdraw_c(&rcube[0].x, &rcube[0].y);
   pgsci_c(&white);
   pgdraw_c(&rcube[4].x, &rcube[4].y);
   pgdraw_c(&rcube[5].x, &rcube[5].y);
   pgsci_c(&red);
   pgdraw_c(&rcube[6].x, &rcube[6].y);
   pgdraw_c(&rcube[7].x, &rcube[7].y);
   pgsci_c(&white);
   pgdraw_c(&rcube[4].x, &rcube[4].y);
   pgsci_c(&red);
   pgmove_c(&rcube[3].x, &rcube[3].y);
   pgdraw_c(&rcube[7].x, &rcube[7].y);
   pgmove_c(&rcube[2].x, &rcube[2].y);
   pgdraw_c(&rcube[6].x, &rcube[6].y);
   pgmove_c(&rcube[1].x, &rcube[1].y);
   pgdraw_c(&rcube[5].x, &rcube[5].y);
}

/* -------------------------------------------------------------------------- */
/*                                 updateplot                                 */
/* -------------------------------------------------------------------------- */
/*  Refresh the plot: transform the cube coordinates, clear previous plot
 *  and draw the cube.
 */
static void updateplot(void)
{
   rotate(rot*RAD, tilt*RAD, cube, rcube, npoints);
   pgpage_c();
   drawcube();
}

/* -------------------------------------------------------------------------- */
/*                                 changed                                    */
/* -------------------------------------------------------------------------- */
/*  ROTATION= and TILT= keyword handler. Reads the keyword and the
 *  updates the plot.
 */
static void changed(ident id, char *key, int code, void *arg)
{
   (void)userfreal((float*)arg, 1, 2, key, " ");
   pgqid_c(&isel);
   pgslct_c(&idev);
   updateplot();
   if (isel) pgslct_c(&isel);
}

/* -------------------------------------------------------------------------- */
/*                                 mouse                                      */
/* -------------------------------------------------------------------------- */
/*  Handle mouse input. Using a simple scheme, this routine modifies either
 *  the ROTATION= or the TILT= keyword, causing the cube to be redrawn.
 */
static void mouse(ident id, GgiPlotInfo info, void *arg)
{
   static float xp, yp;
   float dx, dy;
    
   if (info->state==ggiButn1) {
      dx = info->x - xp;
      dy = info->y - yp;
      if (fabs(dx)>fabs(dy)) {
         rot += dx*MSCALE;
         wkeyf("ROTATION=%.1f", rot);
      } else {
         tilt -= dy*MSCALE;
         wkeyf("TILT=%.1f", tilt);
      }
   }
   xp = info->x;
   yp = info->y;
}

/* ========================================================================== */
/*                                 Orientation                                */
/* -------------------------------------------------------------------------- */
/*  Initialize the cube orientation plot and interaction.
 */
void Orientation(char *device)
{
   float xmin=1.7*L, ymin=1.7*L, xmax=1.7*H, ymax=1.7*H;
   
   ScheduleKeyevent(changed, "ROTATION=", KEYCHANGE, &rot);
   ScheduleKeyevent(changed, "TILT=",     KEYCHANGE, &tilt);
   (void)userfreal(&rot,  1, 2, "ROTATION=", " ");
   (void)userfreal(&tilt, 1, 2, "TILT=",     " ");
   pgqid_c(&isel);
   idev = pgopen_c(tofchar(device));
   pgswin_c(&xmin, &xmax, &ymin, &ymax);
   updateplot();
   (void)ScheduleGgiPlotCursor(mouse, GgiPlotField(device, 0, 0), NULL);
   if (isel) pgslct_c(&isel);
}
#<

#>            srfplot.f
C
      SUBROUTINE SRFPLOT(Xmin,Xmax,Ymin,Ymax,
     #                   Z,N1,N2,SIZE,IWIDTH,XLBL,YLBL,TITL,
     #                   COLRD, DISPID, DATMIN, DATMAX, ROT, TILT,
     #                   MONORGB, BACKRGB, RLIGHT, DEYE, 
     #                   NBAND,SHIN, POLISH, DIF, WINDOW )
C     ---------------------------------------------------------------
C
      REAL          Xmin, Xmax, Ymin, Ymax
      REAL          Z(N1,N2)
      CHARACTER*(*) XLBL,YLBL,TITL
      LOGICAL       COLRD
      INTEGER       DISPID
      REAL          DATMIN, DATMAX
      REAL          ROT, TILT
      REAL          MONORGB(*), BACKRGB(*)
      REAL          RLIGHT(*)
      REAL          DEYE
      INTEGER       NBAND
      REAL          SHIN, POLISH, DIF
      REAL          WINDOW(4)
C
C@ subroutine srfplot( real, real, real, real, 
C@                     real, integer, integer, real,
C@                     integer, character, character, character,
C@                     logical, integer, real, real, real, real, 
C@                     real, real, real, real,
C@                     integer, real, real, real, real )
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C
C Purpose
C      This subroutine plots "data" defined on a regularly-spaced 
C   rectangular grid of points Z(I,J). With the default choice for the 
C   PGCELL routine that is linked, the output is a linearly-interpolated 
C   map (rather than coarse rectangular boxes).
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    Z        R*4    I    N1 x N2   The recatangular "data"-array.
C    Z        R*4    O    N1 x N2   A scaled, and clipped, version of 
C                                   the input array(!).
C    N1       I*4    I       -      The first dimension of array Z.
C    N2       I*4    I       -      The second dimension of array Z.
C    X        R*4    I      NX      Array of X-coordinates.
C    NX       I*4    I       -      Number of X-pixels to be plotted 
C                                  (usually = N1, but must be <= N1).
C    Y        R*4    I      NY      Array of Y-coordinates.
C    NY       I*4    I       -      Number of Y-pixels to be plotted 
C                                  (usually = N2, but must be <= N2).
C    SIZE     R*4    I       -      Character-size for plot (try 1.5).
C    IWIDTH   I*4    I       -      Line-width for plot (try 2).
C    XLBL     A*1    I     *(*)     Label for X-axis.
C    YLBL     A*1    I     *(*)     Label for Y-axis.
C    TITL     A*1    I     *(*)     Title for plot.
C
C History
C   Initial release.                                    DSS:  3 Jul 1992
C   Minor changes to conform with new PGCELL.           DSS:  6 Feb 1995
C   Put in option to over-lay contours.                 DSS: 21 Feb 1995
C   Now has proper 3-d surface surface rendering.       DSS: 27 Aug 1997
C   Fortran made LINUX-friendly!                        DSS: 15 Sep 1997
C-----------------------------------------------------------------------
C
C
      REAL          EYE(3),LIGHT(6),LATICE(3,3),LUTUSR(3,256)
      REAL          lutr(256), lutg(256), lutb(256)
      INTEGER       lutlen
      INTEGER       NCLUSR
      CHARACTER*80  message
      REAL          DIFUS
      INTEGER       mincol, maxcol, numcol, gblank
      INTEGER       IC1, IC2


      LIGHT(1) = RLIGHT(1)
      LIGHT(2) = RLIGHT(2)
      LIGHT(3) = RLIGHT(3)
      EYE(1) = 0.0
      EYE(2) = 0.0
      EYE(3) = DEYE
      IF (COLRD) THEN
C        Contact GIDS for the colour lut. Do not close the device.
         CALL gdi_getlut( dispid, lutr, lutg, lutb, lutlen )
         CALL gdi_cinfo(  dispid, mincol, maxcol, numcol, gblank )
         DO 2 i = 1,lutlen
            LUTUSR(1, i) = lutr(i)
            LUTUSR(2, i) = lutg(i)
            LUTUSR(3, i) = lutb(i)
C            write( message, '(F8.4, F8.4, F8.4)' )
C     #             LUTUSR(1, i), LUTUSR(2, i), LUTUSR(3, i)
C            CALL anyout( 16, message )
   2     CONTINUE 
      ENDIF
C
C
      NCB   = MAX(MIN(NBAND,numcol-1),1)
      SHIN  = MAX(MIN(SHIN,1.0),0.0)
      DIFUS = MAX(MIN(DIF,1.0),0.0)
C
      CALL EULER(LATICE,LIGHT,ROT,TILT)
      DHIGH = DATMAX
      DLOW  = DATMIN
      CALL PGPAPER(0.0,1.0)
      CALL PGQCOL(ICMIN,ICMAX)
      NCB=MIN(NCB,ICMAX-17+1)
      CALL PGSCH(SIZE)
      CALL PGSLW(IWIDTH)
      CALL PGVPORT(0.0,1.0,0.0,1.0)
      CALL PGWINDOW( WINDOW(1), WINDOW(3), WINDOW(2), WINDOW(4) )
      CALL PGBOX('BC',0.0,0,'BC',0.0,0)
      CALL SBFINT(BACKRGB,16,1,1,MAXBUF)
 
      IF (.NOT.COLRD) THEN
         IC1 = 17
         IC2 = ICMAX
         CALL COLINT(MONORGB,IC1,IC2,DIFUS,SHIN,POLISH)
      ELSE
         CALL anyout(16,'==============2D-COLOUR=================')
         NCLUSR = lutlen
         write( message, '(''Read '', I5, 
     #        ''entries from GIDS colour table'')' ) lutlen
         CALL anyout(16,message)
         write( message, '(''Number of colour indices from GIDS'',
     #         I5 )' ) numcol
         write( message, '(''Index for blank: '',I5)' ) gblank
         CALL anyout(16,message)
         write( message, '(''Min and max colour indices from GIDS'',
     #          I5,''and '', I5)' ) mincol, maxcol
         CALL anyout(16,message)
         write( message, '(''Min and max indices for current device: '',
     #          I5, I5)' ) ICMIN, ICMAX
         CALL anyout(16,message)
         write( message, '(''Number of colour bands (by user): '',
     #          I3 )' ) NCB
         CALL anyout(16,message)
         write( message, '(''Number of colours send to routine: '',
     #          I3 )' ) NCLUSR
         CALL anyout(16,message)
C
C        First free colour index is 17. Lower indices are reserved
C        for PGPLOT. First element of the lut array is the rgb of a blank.
C        This element must be skipped. The maximum colour index is 
C        is calculated by adding the number of colours to the lower
C        colour index.
C
         IC1 = 17
         IC2 = IC1+(maxcol-mincol+1)
         CALL COLSRF(LUTUSR(1,2),NCLUSR-1,1.0,IC1,IC2,NCB,
     #               DIFUS,SHIN,POLISH)
      ENDIF
C
      CALL SB2SRF(EYE,LATICE,Z,N1-1,N2-1,DLOW,DHIGH,1.0,
     #            IC1, IC2,
     *            NCB,LIGHT,LSHIN)
      CALL AXES3D(EYE,LATICE,Xmin,Xmax,Ymin,Ymax,XLBL,YLBL,SIZE,
     *              DLOW,DHIGH,Z(1,1),Z(N1,1),Z(N1,N2),Z(1,N2))
      CALL SBFCLS(1)
      CALL PGMTEXT('T',-1.2,0.5,0.5,TITL)
C    
      END
C
C
      SUBROUTINE EULER(LATICE,LIGHT,IA,IB)
C     ------------------------------------
C
      REAL         LATICE(3,*),LIGHT(6)
      REAL         IA, IB
      DATA         PIRAD /0.01745329252/

C
C
      NNN = 2
      IF (NNN.EQ.0) THEN
        SINA =-0.7071067814
        COSA =+0.7071067814
        SINB =-0.5
        COSB = 0.866025404
      ELSE
        SINA =-SIN(IA*PIRAD)
        COSA = COS(IA*PIRAD)
        SINB =-SIN(IB*PIRAD)
        COSB = COS(IB*PIRAD)
      ENDIF
      CALL ROTY(-0.5,-0.5,+0.5,U,V,W,SINA,COSA)
      CALL ROTX(U,V,W,LATICE(1,1),LATICE(2,1),Z1,SINB,COSB)
      LATICE(3,1)=Z1-1.0
      CALL ROTY(+0.5,-0.5,+0.5,U,V,W,SINA,COSA)
      CALL ROTX(U,V,W,LATICE(1,2),LATICE(2,2),Z2,SINB,COSB)
      LATICE(3,2)=Z2-1.0
      CALL ROTY(-0.5,-0.5,-0.5,U,V,W,SINA,COSA)
      CALL ROTX(U,V,W,LATICE(1,3),LATICE(2,3),Z3,SINB,COSB)
      LATICE(3,3)=Z3-1.0
      CALL ROTX(LIGHT(1),LIGHT(2),LIGHT(3),
     *          LIGHT(4),LIGHT(5),LIGHT(6),SINB,COSB)
      END
C
      SUBROUTINE ROTX(X,Y,Z,U,V,W,S,C)
C     --------------------------------
C
      U=X
      V=Y*C+Z*S
      W=-Y*S+Z*C
      END
C
      SUBROUTINE ROTY(X,Y,Z,U,V,W,S,C)
C     --------------------------------
C
      U=X*C-Z*S
      V=Y
      W=X*S+Z*C
      END
C
      SUBROUTINE AXES3D(EYE,LATICE,XMIN,XMAX,YMIN,YMAX,XLBL,YLBL,SIZE,
     *                  DLOW,DHIGH,D00,DX0,DXY,D0Y)
C     ----------------------------------------------------------------
C
      REAL          EYE(*),LATICE(3,*)
      REAL          PIVX(3),PIVY(3),ORX(3,2),ORY(3,2),LATCAB(3,2)
      CHARACTER*(*) XLBL,YLBL
C
      IF (XMAX.LE.XMIN .OR. YMAX.LE.YMIN) RETURN
      SCLA=0.15*SIZE
      AX=LATICE(1,2)-LATICE(1,1)
      AY=LATICE(2,2)-LATICE(2,1)
      AZ=LATICE(3,2)-LATICE(3,1)
      BX=LATICE(1,3)-LATICE(1,1)
      BY=LATICE(2,3)-LATICE(2,1)
      BZ=LATICE(3,3)-LATICE(3,1)
      CX=AY*BZ-BY*AZ
      CY=AZ*BX-BZ*AX
      CZ=AX*BY-BX*AY
      XSIGN=+1.0
      XSCL=-SCLA
      IF (CY*BZ.GT.0.0) THEN
        XSIGN=-1.0
        XSCL=1.0+SCLA
      ENDIF
      ORX(1,1)=XSIGN*AX
      ORX(2,1)=XSIGN*AY
      ORX(3,1)=XSIGN*AZ
      ORX(1,2)=XSIGN*BX
      ORX(2,2)=XSIGN*BY
      ORX(3,2)=XSIGN*BZ
      PIVX(1)=0.5*(LATICE(1,1)+LATICE(1,2))+XSCL*BX
      PIVX(2)=0.5*(LATICE(2,1)+LATICE(2,2))+XSCL*BY
      PIVX(3)=0.5*(LATICE(3,1)+LATICE(3,2))+XSCL*BZ
      CALL SBTEXT(EYE,XLBL,1,PIVX,0.5,ORX,SCLA*0.2)
      CALL AXNUMS(EYE,XMIN,XMAX,PIVX,ORX,SCLA,XSIGN)
      YSIGN=-1.0
      YSCL=-SCLA
      IF (CY*AZ.GT.0.0) THEN
        YSIGN=1.0
        YSCL=1.0+SCLA
      ENDIF
      ORY(1,1)=YSIGN*BX
      ORY(2,1)=YSIGN*BY
      ORY(3,1)=YSIGN*BZ
      ORY(1,2)=-YSIGN*AX
      ORY(2,2)=-YSIGN*AY
      ORY(3,2)=-YSIGN*AZ
      PIVY(1)=0.5*(LATICE(1,1)+LATICE(1,3))+YSCL*AX
      PIVY(2)=0.5*(LATICE(2,1)+LATICE(2,3))+YSCL*AY
      PIVY(3)=0.5*(LATICE(3,1)+LATICE(3,3))+YSCL*AZ
      CALL SBTEXT(EYE,YLBL,1,PIVY,0.5,ORY,SCLA*0.2)
      CALL AXNUMS(EYE,YMIN,YMAX,PIVY,ORY,SCLA,YSIGN)
      LATCAB(1,1)=LATICE(1,2)+BX
      LATCAB(2,1)=LATICE(2,2)+BY
      LATCAB(3,1)=LATICE(3,2)+BZ
      CALL SBLINE(EYE,LATICE(1,1),LATICE(1,2),1,.FALSE.)
      CALL SBLINE(EYE,LATICE(1,2),LATCAB(1,1),1,.FALSE.)
      CALL SBLINE(EYE,LATCAB(1,1),LATICE(1,3),1,.FALSE.)
      CALL SBLINE(EYE,LATICE(1,3),LATICE(1,1),1,.FALSE.)
      ZSCALE=1.0/MAX(DHIGH-DLOW,1.0E-20)
      FRACZ=MAX((D00-DLOW)*ZSCALE,0.0)
      LATCAB(1,2)=LATICE(1,1)+FRACZ*CX
      LATCAB(2,2)=LATICE(2,1)+FRACZ*CY
      LATCAB(3,2)=LATICE(3,1)+FRACZ*CZ
      CALL SBLINE(EYE,LATICE(1,1),LATCAB(1,2),1,.FALSE.)
      FRACZ=MAX((DX0-DLOW)*ZSCALE,0.0)
      LATCAB(1,2)=LATICE(1,2)+FRACZ*CX
      LATCAB(2,2)=LATICE(2,2)+FRACZ*CY
      LATCAB(3,2)=LATICE(3,2)+FRACZ*CZ
      CALL SBLINE(EYE,LATICE(1,2),LATCAB(1,2),1,.FALSE.)
      FRACZ=MAX((DXY-DLOW)*ZSCALE,0.0)
      LATCAB(1,2)=LATCAB(1,1)+FRACZ*CX
      LATCAB(2,2)=LATCAB(2,1)+FRACZ*CY
      LATCAB(3,2)=LATCAB(3,1)+FRACZ*CZ
      CALL SBLINE(EYE,LATCAB(1,1),LATCAB(1,2),1,.FALSE.)
      FRACZ=MAX((D0Y-DLOW)*ZSCALE,0.0)
      LATCAB(1,2)=LATICE(1,3)+FRACZ*CX
      LATCAB(2,2)=LATICE(2,3)+FRACZ*CY
      LATCAB(3,2)=LATICE(3,3)+FRACZ*CZ
      CALL SBLINE(EYE,LATICE(1,3),LATCAB(1,2),1,.FALSE.)
      END
C
      SUBROUTINE AXNUMS(EYE,XMIN,XMAX,PIVX,ORX,SCLA,XSIGN)
C     ----------------------------------------------------
C
      REAL      EYE(*),PIVX(*),ORX(3,*)
      REAL      END1(3),END2(3),PIVOT(3)
      CHARACTER NLBL*20
      DATA      FRTICK,FRNUM /0.02,0.10/
C
      XR=PGRND(XMAX-XMIN,NSUB)
      DX=XR/FLOAT(NSUB)
      IF (DX.LE.1.0E-20) RETURN
   1  XJ=DX*FLOAT(1+INT(XMIN/DX))
      IF ((XJ+DX).GE.XMAX) THEN
        DX=DX/2.0
        NSUB=NSUB*2
        GOTO 1
      ENDIF
      IF (XMIN.LT.0.0) XJ=XJ-DX
      XN=XSIGN/(XMAX-XMIN)
      XH=0.5*(XMIN+XMAX)
      DO 20 J=1,NSUB
        IF (XJ.GT.XMAX) RETURN
        XF=XN*(XJ-XH)
        DO 10 I=1,3
          END1(I)=PIVX(I)+XF*ORX(I,1)+SCLA*ORX(I,2)
          END2(I)=END1(I)-FRTICK*ORX(I,2)
          PIVOT(I)=END1(I)-FRNUM*ORX(I,2)
  10    CONTINUE
        IPOWER=INT(LOG10(ABS(XJ)+1.0E-10))-5
        IF (XJ.LT.1.0) IPOWER=IPOWER-1
        X=XJ/(10.0**IPOWER)
        IMANTS=NINT(X)
        CALL PGNUMB(IMANTS,IPOWER,0,NLBL,NC)
        CALL SBLINE(EYE,END1,END2,1,.FALSE.)
        CALL SBTEXT(EYE,NLBL,1,PIVOT,0.5,ORX,SCLA*0.15)
        XJ=XJ+DX
  20  CONTINUE
      END



#<

#>            isoplot.f
C
      SUBROUTINE ISOPLOT(Xmin,Xmax, Ymin, Ymax, Zmin, Zmax,
     #                   Z,N1,N2,N3,SIZE,IWIDTH,
     #                   XLBL,YLBL,ZLBL, TITL,
     #                   COLRD, DISPID, DATMIN, DATMAX, ROT, TILT,
     #                   MONRGB, BAKRGB, RLIGHT, DEYE, NCBAND, SHIN, 
     #                   POLISH, DIF, DSURF, ITRANS, 
     #                   SLPLOT, APNT, THETA, PHI, WINDOW )
C     ---------------------------------------------------------------
C
      REAL          Xmin, Xmax, Ymin, Ymax, Zmin, Zmax
      REAL          Z(N1,N2,N3)
      CHARACTER*(*) XLBL,YLBL,ZLBL,TITL
      LOGICAL       COLRD
      INTEGER       DISPID
      REAL          DATMIN, DATMAX
      REAL          ROT, TILT
      REAL          MONRGB(*), BAKRGB(*)
      REAL          RLIGHT(*)
      REAL          DEYE
      INTEGER       NCBAND
      REAL          SHIN, POLISH, DIF
      REAL          DSURF
      INTEGER       ITRANS
      LOGICAL       SLPLOT
      REAL          APNT(*)
      REAL          THETA, PHI
      REAL          WINDOW(4)
C
C
C Set up the Fortran to C interface:
C
C
C@ subroutine isoplot( real, real, real, real, real, real, 
C@                     real, integer, integer, integer, real, integer,
C@                     character,character,character,character,
C@                     logical, integer, real, real, real, real, 
C@                     real, real, real, real, integer, real,
C@                     real, real, real, integer, 
C@                     logical, real, real, real, real )
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    Z        R*4    I    N1 x N2   The rectangular "data"-array.
C    Z        R*4    O    N1 x N2   A scaled, and clipped, version of 
C                                   the input array(!).
C    N1       I*4    I       -      The first dimension of array Z.
C    N2       I*4    I       -      The second dimension of array Z.
C    X        R*4    I      NX      Array of X-coordinates.
C    NX       I*4    I       -      Number of X-pixels to be plotted 
C                                  (usually = N1, but must be <= N1).
C    Y        R*4    I      NY      Array of Y-coordinates.
C    NY       I*4    I       -      Number of Y-pixels to be plotted 
C                                  (usually = N2, but must be <= N2).
C    W        R*4    I       -      Dummy parameter (back-compatibility).
C    SIZE     R*4    I       -      Character-size for plot (try 1.5).
C    IWIDTH   I*4    I       -      Line-width for plot (try 2).
C    XLBL     A*1    I     *(*)     Label for X-axis.
C    YLBL     A*1    I     *(*)     Label for Y-axis.
C    ZLBL     A*1    I     *(*)     Title for plot.
C
C History
C   Initial release.                                    DSS:  3 Jul 1992
C   Minor changes to conform with new PGCELL.           DSS:  6 Feb 1995
C   Put in option to over-lay contours.                 DSS: 21 Feb 1995
C   Now has proper 3-d surface surface rendering.       DSS: 27 Aug 1997
C   Fortran made LINUX-friendly!                        DSS: 15 Sep 1997
C-----------------------------------------------------------------------
C
C
      REAL          EYE(3),LATICE(3,4),LUTUSR(3,256)
      REAL          lutr(256), lutg(256), lutb(256)
      INTEGER       lutlen
      INTEGER       NCLUSR
      LOGICAL       LSHIN
      INTEGER       MAXBUF
      CHARACTER*80  message
      REAL          DIFUS
      INTEGER       NCB
      INTEGER       mincol, maxcol, numcol, gblank
      INTEGER       IC1, IC2
      REAL          LIGHT(6)
      REAL          SLNORM(3)
      REAL          APOINT(3)
      DATA          PIRAD /0.01745329252/


C     Copy the input values. These input values cannot change
      SLNORM(1) =  SIN(PIRAD*THETA) * COS(PIRAD*PHI)
      SLNORM(2) =                     SIN(PIRAD*PHI)
      SLNORM(3) = -COS(PIRAD*THETA) * COS(PIRAD*PHI)

      write( message, '(''Unit cell slice plane normal:'',
     #       F8.4,F8.4,F8.4)' ) SLNORM(1),SLNORM(2),SLNORM(3)
      CALL anyout(16,message)

      APOINT(1) = APNT(1)
      APOINT(2) = APNT(2)
      APOINT(3) = APNT(3)
C     If the user wants a slice through the cube, a point in a plane  
C     and the normal of that plane must be entered. The values of
C     the point must be converted to values in a unit cell.      
      APOINT(1) = (APOINT(1) - Xmin) / (Xmax - Xmin)
      APOINT(2) = (APOINT(2) - Ymin) / (Ymax - Ymin)
      APOINT(3) = (APOINT(3) - Zmin) / (Zmax - Zmin)
C     Remember Z is negative behind the screen.
      APOINT(3) = -1.0 * APOINT(3)

      write( message, '(''Unit cell slice plane point:'',
     #       F8.4,F8.4,F8.4)' ) APOINT(1),APOINT(2),APOINT(3)
      CALL anyout(16,message)    
      
      LIGHT(1) = RLIGHT(1)
      LIGHT(2) = RLIGHT(2)
      LIGHT(3) = RLIGHT(3)
      EYE(1) = 0.0
      EYE(2) = 0.0
      EYE(3) = DEYE
      IF (COLRD) THEN
C        Contact GIDS for the colour lut
         CALL gdi_getlut( dispid, lutr, lutg, lutb, lutlen )
         CALL gdi_cinfo(  dispid, mincol, maxcol, numcol, gblank )
C         CALL gdi_close( dispid )
         DO 2 i = 1,lutlen
            LUTUSR(1, i) = lutr(i)
            LUTUSR(2, i) = lutg(i)
            LUTUSR(3, i) = lutb(i)
C            write( message, '(F8.4, F8.4, F8.4)' )
C     #             LUTUSR(1, i), LUTUSR(2, i), LUTUSR(3, i)
C            CALL anyout( 16, message )
   2     CONTINUE 
      ENDIF
C
C
      NCB   = MAX(MIN(NCBAND,numcol),1)
      SHIN  = MAX(MIN(SHIN,1.0),0.0)
      DIFUS = MAX(MIN(DIF,1.0),0.0)
      IF (SHIN .EQ. 0.0) THEN
         LSHIN = .FALSE.
      ELSE
         LSHIN = .TRUE.
      ENDIF
C      
      CALL EULER3(LATICE,LIGHT,SLNORM,APOINT,ROT,TILT)
      DHIGH = DATMAX
      DLOW = DATMIN
      CALL PGPAPER(0.0,1.0)
      CALL PGQCOL(ICMIN,ICMAX)
      NCB = MIN(NCB,ICMAX-17+1)
      CALL PGSCH(SIZE)
      CALL PGSLW(IWIDTH)
      CALL PGVPORT(0.0,1.0,0.0,1.0)
      CALL PGWINDOW( WINDOW(1), WINDOW(3), WINDOW(2), WINDOW(4) )
      CALL PGBOX('BC',0.0,0,'BC',0.0,0)

      MAXBUF = 0
      CALL SBFINT(BAKRGB,16,1,1,MAXBUF)
C
      IF (.NOT.COLRD) THEN
         IC1 = 17
         IC2 = ICMAX
         CALL COLINT(MONRGB,IC1,IC2,DIFUS,SHIN,POLISH)
      ELSE
         CALL anyout(16,'===============COLOUR=====================')
         NCLUSR = lutlen
         write( message, '(''Read '', I5, 
     #        ''entries from GIDS colour table'')' ) lutlen
         CALL anyout(16,message)
         write( message, '(''Number of colour indices from GIDS'',
     #         I5 )' ) numcol
         write( message, '(''Index for blank: '',I5)' ) gblank
         CALL anyout(16,message)
         write( message, '(''Min and max colour indices from GIDS'',
     #          I5,''and '', I5)' ) mincol, maxcol
         CALL anyout(16,message)
         write( message, '(''Min and max indices for current device: '',
     #          I5, I5)' ) ICMIN, ICMAX
         CALL anyout(16,message)
         write( message, '(''Number of colour bands (by user): '',
     #          I3 )' ) NCB
         CALL anyout(16,message)
         write( message, '(''Number of lut entries send: '',
     #          I3 )' ) NCLUSR
         CALL anyout(16,message)
C
C        First free colour index is 17. Lower indices are reserved
C        for PGPLOT. First element of the lut array is the rgb of a blank.
C        This element must be skipped. The maximum colour index is 
C        is calculated by adding the number of colours to the lower
C        colour index.
C
         IC1 = 17
         IC2 = IC1+(maxcol-mincol+1)
         CALL COLSRF(LUTUSR(1,2),NCLUSR-1,1.0,IC1,IC2,NCB,
     #               DIFUS,SHIN,POLISH)
      ENDIF
C
C If you want to rotate the light source also, replace LIGHT by LIGHT(4)
C
      IF (ITRANS .EQ. 0) THEN
         CALL SBSURF(EYE,LATICE,Z,N1-1,N2-1,N3-1,DSURF,IC1,IC2,
     #               LIGHT,LSHIN)
      ELSE
         CALL SBTSUR(EYE,LATICE,Z,N1-1,N2-1,N3-1,DSURF,IC1,IC2,
     #               LIGHT,LSHIN, ITRANS)
      ENDIF
C
      IF (SLPLOT) THEN
         CALL SBSLIC(EYE,LATICE,Z,N1-1,N2-1,N3-1,DATMIN,DATMAX,IC1,IC2,
     #               SLNORM,APOINT,7)
      ENDIF
      CALL AXES3D3(EYE,LATICE,Xmin,Xmax,Ymin,Ymax,Zmin,Zmax,
     #             XLBL,YLBL,ZLBL,SIZE,
     #             DLOW,DHIGH,Z(1,1,1),
     #             Z(N1,1,1),Z(N1,N2,1),Z(1,N2,1))
C      
      CALL SBFCLS(1)      
      CALL PGMTEXT('T',-1.2,0.5,0.5,TITL)     
      END
C
C
      SUBROUTINE EULER3(LATICE,LIGHT,SLNORM,APOINT,IA,IB)
C------------------------------------------------------------
C     Transform the lattice points 
C------------------------------------------------------------
C
C
      REAL         LATICE(3,*)
      REAL         LIGHT(6)
      REAL         SLNORM(3), APOINT(3)
      REAL         IA, IB
      REAL         x, y, z
      REAL         shift(3)
      DATA         shift /-0.5,-0.5,+0.5/
      DATA         PIRAD /0.01745329252/
C
C
      SINA =-SIN(IA*PIRAD)
      COSA = COS(IA*PIRAD)
      SINB =-SIN(IB*PIRAD)
      COSB = COS(IB*PIRAD)
C
      x = 0.0 + shift(1)
      y = 0.0 + shift(2)
      z = 0.0 + shift(3)
      CALL ROTY3(x,y,z,U,V,W,SINA,COSA)
      CALL ROTX3(U,V,W,LATICE(1,1),LATICE(2,1),Z1,SINB,COSB)
      LATICE(3,1)=Z1-1.0
      x = 1.0 + shift(1)
      y = 0.0 + shift(2)
      z = 0.0 + shift(3)
      CALL ROTY3(x,y,z,U,V,W,SINA,COSA)
      CALL ROTX3(U,V,W,LATICE(1,2),LATICE(2,2),Z2,SINB,COSB)
      LATICE(3,2)=Z2-1.0
      x = 0.0 + shift(1)
      y = 1.0 + shift(2)
      z = 0.0 + shift(3)
      CALL ROTY3(x,y,z,U,V,W,SINA,COSA)
      CALL ROTX3(U,V,W,LATICE(1,3),LATICE(2,3),Z3,SINB,COSB)
      LATICE(3,3)=Z3-1.0
      x = 0.0 + shift(1)
      y = 0.0 + shift(2)
      z =-1.0 + shift(3)
      CALL ROTY3(x,y,z,U,V,W,SINA,COSA)
      CALL ROTX3(U,V,W,LATICE(1,4),LATICE(2,4),Z0,SINB,COSB)
      LATICE(3,4)=Z0-1.0
C 
      x = SLNORM(1) + shift(1)
      y = SLNORM(2) + shift(2)
      z = SLNORM(3) + shift(3)
      CALL ROTY3(x,y,z,U,V,W,SINA,COSA)
      CALL ROTX3(U,V,W,SLNORM(1),SLNORM(2),Z0,SINB,COSB)
      SLNORM(3)=Z0-1.0

C     Convert rotated point to a direction

      SLNORM(1) = SLNORM(1) - LATICE(1,1)
      SLNORM(2) = SLNORM(2) - LATICE(2,1)
      SLNORM(3) = SLNORM(3) - LATICE(3,1)

      x = APOINT(1) + shift(1)
      y = APOINT(2) + shift(2)
      z = APOINT(3) + shift(3)
      CALL ROTY3(x,y,z,U,V,W,SINA,COSA)
      CALL ROTX3(U,V,W,APOINT(1),APOINT(2),Z0,SINB,COSB)
      APOINT(3)=Z0-1.0


      CALL ROTX3(LIGHT(1),LIGHT(2),LIGHT(3),
     *           LIGHT(4),LIGHT(5),LIGHT(6),SINB,COSB)

C      x = light(1) + shift(1)
C      y = light(2) + shift(2)
C      z = light(3) + shift(3)
C      CALL ROTY3(x,y,z,U,V,W,SINA,COSA)
C      CALL ROTX3(U,V,W,light(4),light(5),ZL,SINB,COSB)
C      light(6) = ZL - 1.0
C
C      CALL ROTX3(LIGHT(1,1),LIGHT(2,1),LIGHT(3,1),
C     *          LIGHT(1,2),LIGHT(2,2),LIGHT(3,2),SINB,COSB)
      END
C
      SUBROUTINE ROTX3(X,Y,Z,U,V,W,S,C)
C     --------------------------------
C
      U=X
      V=Y*C+Z*S
      W=-Y*S+Z*C
      END
C
      SUBROUTINE ROTY3(X,Y,Z,U,V,W,S,C)
C     --------------------------------
C
      U=X*C-Z*S
      V=Y
      W=X*S+Z*C
      END
C
C
C
      SUBROUTINE AXES3D3(EYE,LATICE,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,
     #                   XLBL,YLBL,ZLBL,SIZE,
     *                   DLOW,DHIGH,D00,DX0,DXY,D0Y)
C     ----------------------------------------------------------------
C
      REAL          XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX
      REAL          EYE(*),LATICE(3,*)
      REAL          PIVX(3),PIVY(3),ORX(3,2),ORY(3,2),LATCAB(3,2)
      REAL          PIVZ(3), ORZ(3,2)
      CHARACTER*(*) XLBL,YLBL,ZLBL
      INTEGER       COL1, COL2
C
      IF (XMAX.LE.XMIN .OR. YMAX.LE.YMIN) RETURN
      SCLA=0.15*SIZE
      AX=LATICE(1,2)-LATICE(1,1)
      AY=LATICE(2,2)-LATICE(2,1)
      AZ=LATICE(3,2)-LATICE(3,1)
      BX=LATICE(1,3)-LATICE(1,1)
      BY=LATICE(2,3)-LATICE(2,1)
      BZ=LATICE(3,3)-LATICE(3,1)
      EX=LATICE(1,4)-LATICE(1,1)
      EY=LATICE(2,4)-LATICE(2,1)
      EZ=LATICE(3,4)-LATICE(3,1)
      CX=AY*BZ-BY*AZ
      CY=AZ*BX-BZ*AX
      CZ=AX*BY-BX*AY
      XSIGN=+1.0
      XSCL=-SCLA
C      IF (CY*BZ.GT.0.0) THEN
C        XSIGN=-1.0
C        XSCL=1.0+SCLA
C      ENDIF
      ORX(1,1)=XSIGN*AX
      ORX(2,1)=XSIGN*AY
      ORX(3,1)=XSIGN*AZ
      ORX(1,2)=XSIGN*BX
      ORX(2,2)=XSIGN*BY
      ORX(3,2)=XSIGN*BZ
      PIVX(1)=0.5*(LATICE(1,1)+LATICE(1,2))+XSCL*BX
      PIVX(2)=0.5*(LATICE(2,1)+LATICE(2,2))+XSCL*BY
      PIVX(3)=0.5*(LATICE(3,1)+LATICE(3,2))+XSCL*BZ
      CALL SBTEXT(EYE,XLBL,1,PIVX,0.5,ORX,SCLA*0.2)
      CALL AXNUMS3(EYE,XMIN,XMAX,PIVX,ORX,SCLA,XSIGN,1)
      YSIGN=-1.0
      YSCL=-SCLA
C     IF (CY*AZ.GT.0.0) THEN
C       YSIGN=1.0
C       YSCL=1.0+SCLA
C     ENDIF
      ORY(1,1)=YSIGN*BX
      ORY(2,1)=YSIGN*BY
      ORY(3,1)=YSIGN*BZ
      ORY(1,2)=-YSIGN*AX
      ORY(2,2)=-YSIGN*AY
      ORY(3,2)=-YSIGN*AZ
      PIVY(1)=0.5*(LATICE(1,1)+LATICE(1,3))+YSCL*AX
      PIVY(2)=0.5*(LATICE(2,1)+LATICE(2,3))+YSCL*AY
      PIVY(3)=0.5*(LATICE(3,1)+LATICE(3,3))+YSCL*AZ
      CALL SBTEXT(EYE,YLBL,1,PIVY,0.5,ORY,SCLA*0.2)
      CALL AXNUMS3(EYE,YMIN,YMAX,PIVY,ORY,SCLA,YSIGN,1)

      
      ZSIGN=-1.0
      ZSCL=-SCLA
C      IF (CY*EZ.LT.0.0) THEN
C        ZSIGN=1.0
C        ZSCL=1.0+SCLA
C      ENDIF
      ORZ(1,1)=ZSIGN*EX
      ORZ(2,1)=ZSIGN*EY
      ORZ(3,1)=ZSIGN*EZ
      ORZ(1,2)=-ZSIGN*AX
      ORZ(2,2)=-ZSIGN*AY
      ORZ(3,2)=-ZSIGN*AZ
      PIVZ(1)=0.5*(LATICE(1,1)+LATICE(1,4))+ZSCL*AX
      PIVZ(2)=0.5*(LATICE(2,1)+LATICE(2,4))+ZSCL*AY
      PIVZ(3)=0.5*(LATICE(3,1)+LATICE(3,4))+ZSCL*AZ
      CALL SBTEXT(EYE,ZLBL,1,PIVZ,0.5,ORZ,SCLA*0.2)
      CALL AXNUMS3(EYE,ZMIN,ZMAX,PIVZ,ORZ,SCLA,ZSIGN,1)


C     Colour white (or foreground) for primary axes
      COL1 = 1
C     Colour red for secondary axes 
      COL2 = 2

      CALL SBLINE(EYE,LATICE(1,1),LATICE(1,2),COL1,.FALSE.)
      CALL SBLINE(EYE,LATICE(1,1),LATICE(1,3),COL1,.FALSE.)
      CALL SBLINE(EYE,LATICE(1,1),LATICE(1,4),COL1,.FALSE.)

      LATCAB(1,1)=LATICE(1,2)+BX
      LATCAB(2,1)=LATICE(2,2)+BY
      LATCAB(3,1)=LATICE(3,2)+BZ
      CALL SBLINE(EYE,LATICE(1,2),LATCAB(1,1),COL2,.FALSE.)
      CALL SBLINE(EYE,LATCAB(1,1),LATICE(1,3),COL2,.FALSE.)

      LATCAB(1,1)=LATICE(1,4)+BX
      LATCAB(2,1)=LATICE(2,4)+BY
      LATCAB(3,1)=LATICE(3,4)+BZ
      CALL SBLINE(EYE,LATICE(1,4),LATCAB(1,1),COL2,.FALSE.)
      CALL SBLINE(EYE,LATCAB(1,1),LATICE(1,3),COL2,.FALSE.)

      LATCAB(1,1)=LATICE(1,2)+BX
      LATCAB(2,1)=LATICE(2,2)+BY
      LATCAB(3,1)=LATICE(3,2)+BZ
      LATCAB(1,2)=LATCAB(1,1)+EX
      LATCAB(2,2)=LATCAB(2,1)+EY
      LATCAB(3,2)=LATCAB(3,1)+EZ
      CALL SBLINE(EYE,LATCAB(1,1),LATCAB(1,2),COL2,.FALSE.)
      LATCAB(1,1)=LATICE(1,2)+EX
      LATCAB(2,1)=LATICE(2,2)+EY
      LATCAB(3,1)=LATICE(3,2)+EZ
      CALL SBLINE(EYE,LATCAB(1,2),LATCAB(1,1),COL2,.FALSE.)     
      CALL SBLINE(EYE,LATCAB(1,1),LATICE(1,2),COL2,.FALSE.)
      
      LATCAB(1,2)=LATICE(1,1)+EX
      LATCAB(2,2)=LATICE(2,1)+EY
      LATCAB(3,2)=LATICE(3,1)+EZ
      CALL SBLINE(EYE,LATCAB(1,1),LATCAB(1,2),COL2,.FALSE.)

      LATCAB(1,1)=LATICE(1,1)+EX+BX
      LATCAB(2,1)=LATICE(2,1)+EY+BY
      LATCAB(3,1)=LATICE(3,1)+EZ+BZ
      LATCAB(1,2)=LATICE(1,1)+EX+AX+BX
      LATCAB(2,2)=LATICE(2,1)+EY+AY+BY
      LATCAB(3,2)=LATICE(3,1)+EZ+AZ+BZ
      CALL SBLINE(EYE,LATCAB(1,1),LATCAB(1,2),COL2,.FALSE.)

C      LATCAB(1,1)=LATICE(1,4)+EX
C      LATCAB(2,1)=LATICE(2,4)+EY
C      LATCAB(3,1)=LATICE(3,4)+EZ
C      CALL SBLINE(EYE,LATICE(1,4),LATCAB(1,1),1,.FALSE.)
C      CALL SBLINE(EYE,LATCAB(1,1),LATICE(1,3),1,.FALSE.)      

      END
C
      SUBROUTINE AXNUMS3(EYE,XMIN,XMAX,PIVX,ORX,SCLA,XSIGN,ICOL)
C     ---------------------------------------------------------
C
      REAL      EYE(*),PIVX(*),ORX(3,*)
      REAL      END1(3),END2(3),PIVOT(3)
      INTEGER   ICOL
      CHARACTER NLBL*20
      DATA      FRTICK,FRNUM /0.02,0.10/
C
      XR=PGRND(XMAX-XMIN,NSUB)
      DX=XR/FLOAT(NSUB)
      IF (DX.LE.1.0E-20) RETURN
   1  XJ=DX*FLOAT(1+INT(XMIN/DX))
      IF ((XJ+DX).GE.XMAX) THEN
        DX=DX/2.0
        NSUB=NSUB*2
        GOTO 1
      ENDIF
      IF (XMIN.LT.0.0) XJ=XJ-DX
      XN=XSIGN/(XMAX-XMIN)
      XH=0.5*(XMIN+XMAX)
      DO 20 J=1,NSUB
        IF (XJ.GT.XMAX) RETURN
        XF=XN*(XJ-XH)
        DO 10 I=1,3
          END1(I)=PIVX(I)+XF*ORX(I,1)+SCLA*ORX(I,2)
          END2(I)=END1(I)-FRTICK*ORX(I,2)
          PIVOT(I)=END1(I)-FRNUM*ORX(I,2)
  10    CONTINUE
        IPOWER=INT(LOG10(ABS(XJ)+1.0E-10))-5
        IF (XJ.LT.1.0) IPOWER=IPOWER-1
        X=XJ/(10.0**IPOWER)
        IMANTS=NINT(X)
        CALL PGNUMB(IMANTS,IPOWER,0,NLBL,NC)
        CALL SBLINE(EYE,END1,END2,ICOL,.FALSE.)
        CALL SBTEXT(EYE,NLBL,ICOL,PIVOT,0.5,ORX,SCLA*0.15)
        XJ=XJ+DX
  20  CONTINUE
      END

#<

#>            pgxtal.f
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE SBFINT(RGB,IC,IBMODE,IBUF,MAXBUF)
C     --------------------------------------------
C
      REAL             RGB(*)
C
      INCLUDE         'grpckg1.inc'
      CHARACTER*16     TYPE,CHR
      LOGICAL          LPS,LCOLOR,LPSINT
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
      REAL             RINIT(0:15),GINIT(0:15),BINIT(0:15)
      SAVE             LPSINT
      DATA             LPSINT /.FALSE./
      DATA     RINIT  /1.00,0.00,1.00,0.00,0.00,0.00,1.00,1.00,
     *                 1.00,0.50,0.00,0.00,0.50,1.00,0.33,0.67/
      DATA     GINIT  /1.00,0.00,0.00,1.00,0.00,1.00,0.00,1.00,
     *                 0.50,1.00,1.00,0.50,0.00,0.00,0.33,0.67/
      DATA     BINIT  /1.00,0.00,0.00,0.00,1.00,1.00,1.00,0.00,
     *                 0.00,0.00,0.50,1.00,1.00,0.50,0.33,0.67/
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      Initialises the software buffer for crystal-plotting. It should 
C    be called just once per plot (buffer), after PGWINDOW but before 
C    any crystal-related routines.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    RGB      R*4    I       3      The RGB values for the background.
C    IC       I*4    I       -      The index for the background colour.
C    IBMODE   I*4    I       -      Buffering mode for initialisation:
C                                     1 = Ordinary, default.
C                                     2 = Will want to save later.
C                                     3 = Initialise from saved buffers.
C    IBUF     I*4    I       -      Software buffer to be used (>=1).
C    MAXBUF   I*4    O       -      Maximum number of buffers available.
C
C Globals
C    SFTBUF
C    GRPCKG1.INC
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     PGQINF     Inquires about general PGPLOT information.
C     GREXEC     Dispatches command to appropriate device driver.
C     COLINT     Sets up a colour table.
C     SBRFIL     Fills a real aray with a constant.
C     SBRCOP     Copies the contents of one real array to another.
C     SBFIN0     Inquires about viewport and window dimensions.
C
C History
C   D. S. Sivia       4 Apr 1995  Initial release.
C   D. S. Sivia      14 Sep 1995  Set up default colour indicies for PS.
C   D. S. Sivia      20 Oct 1995  Ignore NBUNCH and fix to one!
C   D. S. Sivia      15 Nov 1995  Allow initialisation to/from saved 
C                                 buffers.
C   D. S. Sivia       2 Aug 1996  Replaced pgplot.inc with SBFIN0, and
C                                 made appropriate additions to SFTBUF.
C-----------------------------------------------------------------------
C
      CALL SBFIN0(XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *            YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC)
      LPS=.TRUE.
      NDOTS=100
      CALL PGQINF('TYPE',TYPE,LCHR)
      IF (TYPE.EQ.'PS' .OR. TYPE.EQ.'VPS') THEN
        LCOLOR=.FALSE.
        NXP=NINT(FLOAT(NDOTS)*XLEN/XPERIN)
        NYP=NINT(FLOAT(NDOTS)*YLEN/YPERIN)
      ELSEIF (TYPE.EQ.'CPS' .OR. TYPE.EQ.'VCPS') THEN
        LCOLOR=.TRUE.
        NXP=NINT(FLOAT(NDOTS)*XLEN/XPERIN)
        NYP=NINT(FLOAT(NDOTS)*YLEN/YPERIN)
      ELSE
        LPS=.FALSE.
        NBUF=0
        LCHR=LEN(CHR)
        CALL GREXEC(GRGTYP,4,RBUF,NBUF,CHR,LCHR)
        IF (CHR(7:7).EQ.'P') THEN
          NXP=1+NINT(XLEN)
          NYP=1+NINT(YLEN)
        ELSE
          STOP' Sorry, SFBINT does not support this device !'
        ENDIF
      ENDIF
      IBFMOD=IBMODE
      NTOT=NXP*NYP
      MAXBUF=INT(2000000/NTOT)-1
      IF (IBFMOD.EQ.2 .OR. IBFMOD.EQ.3) MAXBUF=MAXBUF-2 
      KSTART=NTOT*MAX(MIN(IBUF,MAXBUF),1)
      IF ((KSTART+NTOT).LE.2000000 .AND. MAXBUF.GE.1) THEN
        IF (IBFMOD.EQ.3) THEN
          IZSAVE=NTOT*(1+MAXBUF)+1
          ICSAVE=IZSAVE+NTOT
          CALL SBRCOP(SBBUFF(IZSAVE),SBBUFF(1),NTOT)
          CALL SBRCOP(SBBUFF(ICSAVE),SBBUFF(KSTART+1),NTOT)
        ELSE
          CALL SBRFIL(SBBUFF(1),-1.0E20,NTOT)
          CALL SBRFIL(SBBUFF(KSTART+1),FLOAT(IC),NTOT)
        ENDIF
      ELSE
        STOP' Sorry, the software buffer is too small !'
      ENDIF
      CALL COLINT(RGB,IC,IC,0.5,0.0,1.0)
      IF (LPS .AND. .NOT. LPSINT) THEN
        DO 10 I=0,15
          IF (LCOLOR) THEN
            IR(I)=NINT(255.0*RINIT(I))
            IG(I)=NINT(255.0*GINIT(I))
            IB(I)=NINT(255.0*BINIT(I))
          ELSE
            IR(I)=NINT(85.0*(RINIT(I)+GINIT(I)+BINIT(I)))
          ENDIF
  10    CONTINUE
        LPSINT=.TRUE.
      ENDIF
      END
C
      SUBROUTINE SBFIN0(XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                  YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC)
C     ---------------------------------------------------------
C
      DATA BIG,SMALL /1.0E+20,1.0E-20/
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      Obtain some viewport and window information about the current 
C    PGPLOT device, without directly accessing the common blocks in
C    pgplot.inc.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    XPERIN   R*4    O       -      Plot X scale in dots/inch.
C    YPERIN   R*4    O       -      Plot Y scale in dots/inch.
C    XOFF     R*4    O       -      Absolute coord of blc of viewport.
C    YOFF     R*4    O       -      Absolute coord of blc of viewport.
C    XLEN     R*4    O       -      Width of viewport in absolute coord.
C    YLEN     R*4    O       -      Height of viewport in absolute coord.
C    XORG     R*4    O       -      Absolute coord of world X=0.
C    YORG     R*4    O       -      Absolute coord of world Y=0.
C    XSCALE   R*4    O       -      Absolute units per world coord in X.
C    YSCALE   R*4    O       -      Absolute units per world coord in Y.
C    XBLC     R*4    O       -      World X coord at blc of window.
C    XTRC     R*4    O       -      World X coord at trc of window.
C    YBLC     R*4    O       -      World Y coord at blc of window.
C    YTRC     R*4    O       -      World Y coord at trc of window.
C
C Globals
C     None.
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     PGQVP      Inquires about viewport dimensions.
C     PGQWIN     Inquires about world coords of window.
C
C History
C   D. S. Sivia       2 Aug 1996  Initial release.
C-----------------------------------------------------------------------
C
      CALL PGQWIN(XBLC,XTRC,YBLC,YTRC)
      CALL PGQVP(1,XI1,XI2,YI1,YI2)
      CALL PGQVP(3,XOFF,XP2,YOFF,YP2)
      XLEN=ABS(XP2-XOFF)
      YLEN=ABS(YP2-YOFF)
      XPERIN=XLEN/(ABS(XI2-XI1)+SMALL)
      YPERIN=YLEN/(ABS(YI2-YI1)+SMALL)
      XWDIF=XTRC-XBLC
      YWDIF=YTRC-YBLC
      AXWDIF=BIG
      AYWDIF=BIG
      IF (ABS(XWDIF).GT.SMALL) AXWDIF=1.0/XWDIF
      IF (ABS(YWDIF).GT.SMALL) AYWDIF=1.0/YWDIF
      XSCALE=XLEN*AXWDIF
      YSCALE=YLEN*AYWDIF
      XORG=(XOFF*XTRC-XP2*XBLC)*AXWDIF
      YORG=(YOFF*YTRC-YP2*YBLC)*AYWDIF
      END
C
      SUBROUTINE SBFSAV(IBUF)
C     -----------------------
C
      LOGICAL          LPS,LCOLOR
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC

C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      Save a rendered picture-buffer, and its Z-buffer, for subsequent 
C    use in re-initialisation with SBFINT.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    IBUF     I*4    I       -      Software buffer to be saved (>=1).
C
C Globals
C    SFTBUF
C    GRPCKG1.INC
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     SBRCOP     Copies the contents of one real array to another.
C
C History
C   D. S. Sivia      15 Nov 1995  Initial release.
C-----------------------------------------------------------------------
C
      NTOT=NXP*NYP
      MAXBUF=INT(2000000/NTOT)-3
      IBUF1=MAX(IBUF,1)
      IF (IBUF1.GT.MAXBUF) RETURN
      KSTART=NTOT*IBUF1
      IZSAVE=NTOT*(1+MAXBUF)+1
      ICSAVE=IZSAVE+NTOT
      CALL SBRCOP(SBBUFF(1),SBBUFF(IZSAVE),NTOT)
      CALL SBRCOP(SBBUFF(KSTART+1),SBBUFF(ICSAVE),NTOT)
      END
C
      SUBROUTINE COLINT(RGB,IC1,IC2,DIFUSE,SHINE,POLISH)
C     --------------------------------------------------
C
      REAL             RGB(*)
C
      LOGICAL          LPS,LCOLOR
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC

C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      Initialises a colour table for a geometrical object. In general,
C    it is recommended that SHINE = 0.0 if DIFUSE > 0.0 and vice versa.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    RGB      R*4    I       3      Red, green and blue intenisty for 
C                                   fully-lit non-shiny object (0-1).
C    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be
C                                   used for shading.
C    DIFUSE   R*4    I       -      Diffusiveness of object (0-1).
C    SHINE    R*4    I       -      Whiteness of bright spot (0-1).
C    POLISH   R*4    I       -      Controls size of bright spot.
C
C Globals
C    SFTBUF
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     PGQCOL     Inquires about the colour capability.
C     PGSCR      Assigns an RGB value to a colour index.
C
C History
C   D. S. Sivia       4 Apr 1995  Initial release.
C   J. P. Terlouw    29 May 2000  Eliminated PostScript-specific code
C-----------------------------------------------------------------------
C
      IF (RGB(1).LT.0.0 .OR. RGB(1).GT.1.0) RETURN
      IF (RGB(2).LT.0.0 .OR. RGB(2).GT.1.0) RETURN
      IF (RGB(3).LT.0.0 .OR. RGB(3).GT.1.0) RETURN
      IF (DIFUSE.LT.0.0 .OR. DIFUSE.GT.1.0) RETURN
      IF (SHINE.LT.0.0 .OR. SHINE.GT.1.0) RETURN
      IF (IC2.LT.IC1) RETURN
      CALL PGQCOL(ICMIN,ICMAX)
      IF (IC1.LT.ICMIN .OR. IC2.GT.ICMAX) THEN
        WRITE(*,*)' Invalid colour-indicies for the chosen device !'
        RETURN
      ENDIF
      POLSH2=MAX(POLISH/2.0,0.5)
      NC=IC2-IC1
      IF (NC.EQ.0) THEN
        RED=RGB(1)
        GRN=RGB(2)
        BLU=RGB(3)
      ELSE
        GREY=0.0
        DGREY=1.0/FLOAT(NC)
        DR=DIFUSE*RGB(1)/FLOAT(NC)
        DG=DIFUSE*RGB(2)/FLOAT(NC)
        DB=DIFUSE*RGB(3)/FLOAT(NC)
        RED=MAX(RGB(1)*(1.0-DIFUSE),0.0)
        GRN=MAX(RGB(2)*(1.0-DIFUSE),0.0)
        BLU=MAX(RGB(3)*(1.0-DIFUSE),0.0)
        R=RED
        G=GRN
        B=BLU
      ENDIF
      DO 10 IC=IC1,IC2
        CALL PGSCR(IC,RED,GRN,BLU)
        R=R+DR
        G=G+DG
        B=B+DB
        GREY=GREY+DGREY
        POLSHN=SHINE*(GREY**POLSH2)
        RED=MIN(R+POLSHN,1.0)
        GRN=MIN(G+POLSHN,1.0)
        BLU=MIN(B+POLSHN,1.0)
  10  CONTINUE
      END
C
      SUBROUTINE COLTAB(RGB,NCOL,ALFA,IC1,IC2)
C     ----------------------------------------
C
      REAL             RGB(3,*)
C
      LOGICAL          LPS,LCOLOR
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC

C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      Initialises a colour table for a "grey-scale" map.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    RGB      R*4    I   3 X NCOL   Red, green and blue intenisty for 
C                                   the colour table.
C    NCOL     I*4    I       -      No. of colours in the input table.
C    ALFA     R*4    I       -      Contrast-factor (linear=1).
C    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be
C                                   used for the output.
C
C Globals
C    SFTBUF
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     PGQCOL     Inquires about the colour capability.
C     PGSCR      Assigns an RGB value to a colour index.
C
C History
C   D. S. Sivia      30 Apr 1995  Initial release.
C   J. P. Terlouw    29 May 2000  Eliminated PostScript-specific code
C-----------------------------------------------------------------------
C
      IF (IC2.LE.IC1) RETURN
      CALL PGQCOL(ICMIN,ICMAX)
      IF (IC1.LT.ICMIN .OR. IC2.GT.ICMAX) THEN
        WRITE(*,*)' Invalid colour-indicies for the chosen device !'
        RETURN
      ENDIF
      NC=IC2-IC1
      COL=0.0
      DCOL=1.0/FLOAT(NC)
      DO 10 I=0,NC
        COLALF=FLOAT(NCOL-1)*MIN(COL**ALFA,0.99999)
        ICOL=INT(COLALF)
        DICOL=COLALF-FLOAT(ICOL)
        RL=RGB(1,ICOL+1)+DICOL*(RGB(1,ICOL+2)-RGB(1,ICOL+1))
        GL=RGB(2,ICOL+1)+DICOL*(RGB(2,ICOL+2)-RGB(2,ICOL+1))
        BL=RGB(3,ICOL+1)+DICOL*(RGB(3,ICOL+2)-RGB(3,ICOL+1))
        R=MIN(MAX(RL,0.0),1.0)
        G=MIN(MAX(GL,0.0),1.0)
        B=MIN(MAX(BL,0.0),1.0)
        CALL PGSCR(IC1+I,R,G,B)
        COL=COL+DCOL
  10  CONTINUE
      END
C
      SUBROUTINE COLSRF(RGB,NCOL,ALFA,IC1,IC2,NCBAND,DIFUSE,SHINE,
     *                  POLISH)
C     ------------------------------------------------------------
C
      REAL             RGB(3,*)
C
      REAL             RGBOUT(3)
      LOGICAL          LPS,LCOLOR
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC

C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      Initialises a colour table for a 3-D surface rendering of a 2-D 
C   array of "data".
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    RGB      R*4    I   3 X NCOL   Red, green and blue intenisty for 
C                                   the colour table.
C    NCOL     I*4    I       -      No. of colours in the input table.
C    ALFA     R*4    I       -      Contrast-factor (linear=1).
C    IC1,IC2  I*4    I       -      Lowest and highest colour-index to
C                                   be used for the rendering.
C    NCBAND   I*4    I       -      Number of colour-bands for the
C                                   height, so that the number of shades
C                                   per band = (IC2-IC1+1)/NCBAND.
C    DIFUSE   R*4    I       -      Diffusiveness of object (0-1).
C    SHINE    R*4    I       -      Whiteness of bright spot (0-1).
C    POLISH   R*4    I       -      Controls size of bright spot.
C
C Globals
C    SFTBUF
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     PGQCOL     Inquires about the colour capability.
C
C History
C   D. S. Sivia      30 Oct 1995  Initial release.
C   J. P. Terlouw    29 May 2000  Eliminated PostScript-specific code
C-----------------------------------------------------------------------
C
      IF (IC2.LE.IC1) RETURN
      CALL PGQCOL(ICMIN,ICMAX)
      IF (IC1.LT.ICMIN .OR. IC2.GT.ICMAX) THEN
        WRITE(*,*)' Invalid colour-indicies for the chosen device !'
        RETURN
      ENDIF
      NSHADS=MAX((IC2-IC1+1)/MAX(NCBAND,1),1)
      COL=0.0
      DCOL=1.0/FLOAT(MAX(NCBAND-1,1))
      IC=IC1
      DO 10 I=1,NCBAND
        COLALF=FLOAT(NCOL-1)*MIN(COL**ALFA,0.99999)
        ICOL=INT(COLALF)
        DICOL=COLALF-FLOAT(ICOL)
        RL=RGB(1,ICOL+1)+DICOL*(RGB(1,ICOL+2)-RGB(1,ICOL+1))
        GL=RGB(2,ICOL+1)+DICOL*(RGB(2,ICOL+2)-RGB(2,ICOL+1))
        BL=RGB(3,ICOL+1)+DICOL*(RGB(3,ICOL+2)-RGB(3,ICOL+1))
        RGBOUT(1)=MIN(MAX(RL,0.0),1.0)
        RGBOUT(2)=MIN(MAX(GL,0.0),1.0)
        RGBOUT(3)=MIN(MAX(BL,0.0),1.0)
        CALL COLINT(RGBOUT,IC,IC+NSHADS-1,DIFUSE,SHINE,POLISH)
        IC=IC+NSHADS
        COL=COL+DCOL
  10  CONTINUE
      END
C
      SUBROUTINE SBFCLS(IBUF)
C     -----------------------
C
      INCLUDE        'grpckg1.inc'
      REAL            BUFFER(2050),RNDBUF(0:3050)
      INTEGER         VALUE(33)
      LOGICAL         LPS,LCOLOR,LSTART
      CHARACTER       INLINE*80,CHR*16
      CHARACTER*80    message
      CHARACTER*10    FMT120
C The array RNDBUF is used repeatedly for each call, but was not saved
C and caused problems using Linux. Therefore the save option is 
C added for RNDBUF (01-feb-1999)
      SAVE            LSTART, RNDBUF
      COMMON /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
      DATA            LODD,RNDSCL,RNDOFF,NRND /37614625,0.96,-0.5,3000/
      DATA            LSTART /.FALSE./
      DATA            FMT120 /'(33Z2.2)'/
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      Closes the software buffer for crystal-plotting, by outputing it
C    to the screen or writing out a postscript file (as appropriate).
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    IBUF     I*4    I       -      Software buffer to be output (>=1).
C
C Globals
C    SFTBUF
C    GRPCKG1.INC
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     GREXEC     Dispatches command to appropriate device driver.
C     PGBBUF     Recommended initial call (to start a PGPLOT buffer).
C     PGEBUF     Recommended final call (to end a PGPLOT buffer).
C
C History
C   D. S. Sivia       4 Apr 1995  Initial release.
C   D. S. Sivia      20 Oct 1995  Hardwire assumption that NGANG=1.
C   D. S. Sivia      21 Oct 1997  Made slightly friendlier for NT.
C   J. P. Terlouw    29 May 2000  Eliminated PostScript-specific code
C-----------------------------------------------------------------------
C
      NTOT=NXP*NYP
      MAXBUF=INT(2000000/NTOT)-1
      IF (IBFMOD.EQ.2 .OR. IBFMOD.EQ.3) MAXBUF=MAXBUF-2
      IF (IBUF.GT.MAXBUF) RETURN
      KEND=NTOT*MAX(IBUF,1)
      IF (.NOT. LSTART) THEN
        DO 10 I=0,NRND-1
  10      RNDBUF(I)=RNDSCL*(RAN(LODD)+RNDOFF)
        LSTART=.TRUE.
      ENDIF
      IF (LPS) THEN
        AT=FLOAT(NXP)/XLEN
        BT=0.0
        CT=0.0
        DT=FLOAT(NYP)/YLEN
        TX=-AT*XOFF
        TY=-DT*YOFF
        BUFFER(1)  = 0.0
        BUFFER(2)  = NXP
        BUFFER(3)  = NYP
        BUFFER(4)  = XOFF
        BUFFER(5)  = XOFF+XLEN
        BUFFER(6)  = YOFF
        BUFFER(7)  = YOFF+YLEN
        BUFFER(8)  = AT
        BUFFER(9)  = BT
        BUFFER(10) = CT
        BUFFER(11) = DT
        BUFFER(12) = TX
        BUFFER(13) = TY
        NBUF = 13
        LCHR = 0
        CALL GREXEC(GRGTYP, 26, BUFFER, NBUF, CHR, LCHR)
        NBUF = NXP + 1
        K = KEND + 1
        RND900=900.0
        BUFFER(1) = NXP
        DO 20 J = 1, NYP
          L=1+INT(RND900*(RNDBUF(J)-RNDOFF))
          CALL SBCLS0(BUFFER(2),SBBUFF(K),RNDBUF(L),NXP)
          CALL GREXEC(GRGTYP, 26, BUFFER, NBUF, CHR, LCHR)
          K=K+NXP
  20    CONTINUE
        BUFFER(1) = -1.0
        NBUF = 1
        CALL GREXEC(GRGTYP, 26, BUFFER, NBUF, CHR, LCHR)
      ELSE
        CALL PGBBUF
        NXP2=NXP+2
        K=KEND+1
        RND900=900.0
        BUFFER(1)=FLOAT(NINT(XOFF))
        BUFFER(2)=FLOAT(NINT(YOFF))
        DO 40 J=1,NYP          
          L=1+INT(RND900*(RNDBUF(J)-RNDOFF))
          CALL SBCLS0(BUFFER(3),SBBUFF(K),RNDBUF(L),NXP)
          CALL GREXEC(GRGTYP,26,BUFFER,NXP2,CHR,LCHR)
          K=K+NXP
          BUFFER(2)=BUFFER(2)+1.0
  40    CONTINUE
        CALL PGEBUF
      ENDIF
      END
C
      SUBROUTINE SBCLS0(A,B,C,N)
C     --------------------------
C
      REAL A(*),B(*),C(*)
C
      DO 10 I=1,N
  10    A(I)=FLOAT(NINT(B(I)+C(I)))
      END
C
      SUBROUTINE SBBALL(EYE,CENTRE,RADIUS,IC1,IC2,LIGHT,LSHINE,X0,Y0,R0)
C     ------------------------------------------------------------------
C
      REAL            EYE(*),CENTRE(*),LIGHT(*)
      LOGICAL         LSHINE

      REAL            SURF(3)
      REAL*8          ALFA,BETA,GAMA,XMU,A,B,C,DET,Q,DX0H,DY0H
      REAL*8          DZE,DZE2,DGAMZE,DBL1,DBL2,DSMALL
      REAL*8          XL0,XL1,HYP,SINPHI,COSPHI,R1,R2
      LOGICAL         LPS,LCOLOR
      COMMON /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      This subroutine plots a shiny or matt coloured ball. All 
C    (x,y,z) values are taken to be given in world coordinates. The 
C    z-component of the eye-poisition should be positive and that of
C    the ball-centre should be negative (< -radius); the viewing-screen
C    is fixed at z=0.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    EYE      R*4    I       3      (x,y,z) coordinate of eye-position.
C    CENTRE   R*4    I       3      (x,y,z) coordinate of ball-centre.
C    RADIUS   R*4    I       -      Radius of ball.
C    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be
C                                   used for shading.
C    LIGHT    R*4    I       3      (x,y,z) direction of flood-light.
C    LSHINE   L*1    I       -      Shiny ball if .TRUE., else diffuse.
C    X0,Y0    R*4    O       -      Centre of projected ball.
C    R0       R*4    O       -      Average radius of projected ball.
C
C Globals 
C    SFTBUF
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     SBGLOS     Works out colour-shade for surface of ball.
C
C History
C   D. S. Sivia       7 Apr 1995  Initial release.
C-----------------------------------------------------------------------
C
C Some initial checks.
C
      SMALL=1.0E-20
      DSMALL=DBLE(SMALL)
      IF (EYE(3).LE.0.0) RETURN
      IF (RADIUS.LE.0.0) RETURN
      IF (CENTRE(3).GT.-RADIUS) RETURN
C
C Calculate parameters of projected ellipse.
C
      DZE=DBLE(EYE(3))
      DZE2=DZE**2
      ALFA=DBLE(EYE(1)-CENTRE(1))
      BETA=DBLE(EYE(2)-CENTRE(2))
      GAMA=DBLE(EYE(3)-CENTRE(3))
      XMU=DBLE(RADIUS**2)-(ALFA**2+BETA**2+GAMA**2)
      A=XMU*(XMU+ALFA**2)
      B=XMU*ALFA*BETA
      C=XMU*(XMU+BETA**2)
      DET=ABS(A*C-B**2)+DSMALL
      DX0H=GAMA*XMU*DZE*(ALFA*C-BETA*B)/DET
      DY0H=GAMA*XMU*DZE*(BETA*A-ALFA*B)/DET
      Q=A*DX0H**2+2.0*B*DX0H*DY0H+C*DY0H**2-XMU*(XMU+GAMA**2)*DZE2
      X0H=SNGL(DX0H)
      Y0H=SNGL(DY0H)
      DX=(XTRC-XBLC)/FLOAT(NXP-1)
      DY=(YTRC-YBLC)/FLOAT(NYP-1)
      XDIF=SNGL(DSQRT(ABS(C*Q/DET)+DSMALL))
      XMIN=X0H-XDIF+EYE(1)
      XMAX=X0H+XDIF+EYE(1)
      IXMIN=INT((XMIN-XBLC)/DX)+2
      IXMAX=INT((XMAX-XBLC)/DX)+1
      IF (IXMIN.GT.NXP .OR. IXMAX.LT.1) RETURN
      YDIF=(DSQRT(ABS(A*Q/DET)+DSMALL))
      YMIN=Y0H-YDIF+EYE(2)
      YMAX=Y0H+YDIF+EYE(2)
      JYMIN=INT((YMIN-YBLC)/DY)+2
      JYMAX=INT((YMAX-YBLC)/DY)+1
      IF (JYMIN.GT.NYP .OR. JYMAX.LT.1) RETURN
      IF (JYMIN.LT.1) JYMIN=1
      IF (JYMAX.GT.NYP) JYMAX=NYP
      ZMAX=CENTRE(3)+RADIUS
      X0=X0H+EYE(1)
      Y0=Y0H+EYE(2)
      COREL=SNGL(DSQRT(ABS((B*B)/(A*C))+DSMALL))
      IF (COREL.GT.0.0001) THEN
        XL0=(A+C)/2.0D0
        XL1=XL0-DSQRT(ABS(XL0*XL0-DET)+DSMALL)
        HYP=DSQRT((XL1-A)**2+B**2+DSMALL)
        SINPHI=(XL1-A)/HYP
        COSPHI=B/HYP
      ELSE
        SINPHI=0.0D0
        COSPHI=1.0D0
      ENDIF
      R1=DSQRT(Q/(A*COSPHI*COSPHI+SINPHI*(C*SINPHI+2.0*B*COSPHI)))
      R2=DSQRT(Q/(A*SINPHI*SINPHI+COSPHI*(C*COSPHI-2.0*B*SINPHI)))
      R0=SNGL((R1+R2)/2.0D0)
C
C Fill the inside of the projected ellipse with the right colours.
C
      NC=IC2-IC1
      COL0=FLOAT(IC1)
      COLSCL=FLOAT(NC)
      XL2=LIGHT(1)**2+LIGHT(2)**2+LIGHT(3)**2
      XN2=RADIUS**2
      XNL2=1.0/SQRT(XN2*XL2+SMALL)
      XN3=1.0/(XN2+SMALL)
      YH=YBLC+DY*FLOAT(JYMIN-1)-EYE(2)
      DGAMZE=GAMA*DZE
      BA=SNGL(B/A)
      DO 20 JY=JYMIN,JYMAX
        YH2=YH**2
        BETAYH=BETA*YH
        YDIF=YH-Y0H
        XDIF=SNGL(DSQRT(ABS(A*Q-DET*DBLE(YDIF**2))+DSMALL)/A)
        XMIN=X0H-BA*YDIF-XDIF+EYE(1)
        XMAX=X0H-BA*YDIF+XDIF+EYE(1)
        IXMIN=INT((XMIN-XBLC)/DX)+2
        IXMAX=INT((XMAX-XBLC)/DX)+1
        IF (IXMIN.LE.NXP .AND. IXMAX.GE.1) THEN
          IF (IXMIN.LT.1) IXMIN=1
          IF (IXMAX.GT.NXP) IXMAX=NXP
          XH=XBLC+DX*FLOAT(IXMIN-1)-EYE(1)
          K=(JY-1)*NXP+IXMIN
          DO 10 IX=IXMIN,IXMAX
            IF (ZMAX.GT.SBBUFF(K)) THEN
              XH2=XH**2
              ALFAXH=ALFA*XH
              DBL1=DBLE(ALFAXH+BETAYH)-DGAMZE
              DBL2=DBLE(XH2+YH2)+DZE2
              XLM=SNGL((-DBL1-DSQRT(ABS(DBL1**2+XMU*DBL2)+DSMALL))/DBL2)
              SURF(3)=EYE(3)*(1.0-XLM)
              IF (SURF(3).GT.SBBUFF(K)) THEN
                SBBUFF(K)=SURF(3)
                IF (NC.EQ.0) THEN
                  SBBUFF(KSTART+K)=COL0
                ELSE
                  SURF(2)=EYE(2)+YH*XLM
                  SURF(1)=EYE(1)+XH*XLM
                  CALL SBGLOS(EYE,CENTRE,LIGHT,SURF,XNL2,XN3,SMALL,
     *                        LSHINE,COLOUR)
                  SBBUFF(KSTART+K)=COL0+COLOUR*COLSCL
                ENDIF
              ENDIF
            ENDIF
            K=K+1
            XH=XH+DX
  10      CONTINUE
        ENDIF
        YH=YH+DY
  20  CONTINUE
      END
C
      SUBROUTINE SBGLOS(EYE,CENTRE,LIGHT,SURF,XNL2,XN3,SMALL,LSHINE,
     *                  COLOUR)
C     --------------------------------------------------------------
C
C Support subroutine for SBBALL, to work out colour-shade.
C
      REAL    EYE(*),CENTRE(*),LIGHT(*),SURF(*)
      LOGICAL LSHINE
      REAL    NORMAL(3),REFLEC(3),VIEW(3)
C
      COLOUR=0.0
      XNL=0.0
      DO 10 I=1,3
        NORMAL(I)=SURF(I)-CENTRE(I)
        XNL=XNL+NORMAL(I)*LIGHT(I)
  10  CONTINUE
      IF (XNL.GE.0.0) RETURN
      IF (LSHINE) THEN
        RFNORM=(XNL+XNL)*XN3
        XRV=0.0
        DO 20 I=1,3
          VIEW(I)=EYE(I)-SURF(I)
          REFLEC(I)=LIGHT(I)-RFNORM*NORMAL(I)
          XRV=XRV+REFLEC(I)*VIEW(I)
  20    CONTINUE
        IF (XRV.LT.0.0) RETURN
        REF2=0.0
        VIEW2=0.0
        DO 30 I=1,3
          REF2=REF2+REFLEC(I)**2
          VIEW2=VIEW2+VIEW(I)**2
  30    CONTINUE
        COLOUR=MIN(XRV**2/(ABS(REF2*VIEW2)+SMALL),1.0)
      ELSE
        COLOUR=MIN(-XNL*XNL2,1.0)
      ENDIF
      END
C
      SUBROUTINE SBLINE(EYE,END1,END2,ICOL,LDASH)
C     -------------------------------------------
C
      REAL             EYE(*),END1(*),END2(*)
      LOGICAL          LDASH
C
      LOGICAL          LPS,LCOLOR
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
      DATA             NDASH1,NDASH2 /7,3/
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      This subroutine draws a straight line between two points. All 
C    (x,y,z) values are taken to be given in world coordinates. The 
C    z-component of the eye-poisition should be positive, while that 
C    of both the ends should be negative; the viewing-screen is fixed
C    at z=0.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    EYE      R*4    I       3      (x,y,z) coordinate of eye-position.
C    END1     R*4    I       3      (x,y,z) coordinate of end-1.
C    END2     R*4    I       3      (x,y,z) coordinate of end-2.
C    ICOL     I*4    I       -      Colour-index for line.
C    LDASH    L*1    I       -      Dashed line if .TRUE. (else cont.).
C
C Globals 
C    SFTBUF
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     SBLIN1     Calculates the projection of (x,y,z) on viewing screen.
C
C History
C   D. S. Sivia       4 Apr 1995  Initial release.
C   D. S. Sivia      25 Oct 1997  Prevent occasional Z-coordinate bug.
C-----------------------------------------------------------------------
C
C Some initial checks and clipping.
C
      SMALL=1.0E-10
      IF (EYE(3).LE.0.0) RETURN
      IF (END1(3).GE.0.0 .OR. END2(3).GE.0.0) RETURN
      CALL SBLIN1(EYE,END1(1),END1(2),END1(3),XW1,YW1)
      CALL SBLIN1(EYE,END2(1),END2(2),END2(3),XW2,YW2)
      XDIF=XW2-XW1
      YDIF=YW2-YW1
      IF ((ABS(XDIF)+ABS(YDIF)).LT.SMALL) RETURN
      IF (ABS(XDIF).LT.SMALL) XDIF=SMALL
      IF (ABS(YDIF).LT.SMALL) YDIF=SMALL
      IF (XW1.LE.XBLC) THEN
        IF (XW2.LE.XBLC) RETURN
        XLAM=(XBLC-XW1)/XDIF
        XW1=XW1+XLAM*XDIF
        YW1=YW1+XLAM*YDIF
      ELSEIF (XW1.GE.XTRC) THEN
        IF (XW2.GE.XTRC) RETURN
        XLAM=(XTRC-XW1)/XDIF
        XW1=XW1+XLAM*XDIF
        YW1=YW1+XLAM*YDIF
      ENDIF
      IF (YW1.LE.YBLC) THEN
        IF (YW2.LE.YBLC) RETURN
        YLAM=(YBLC-YW1)/YDIF
        XW1=XW1+YLAM*XDIF
        YW1=YW1+YLAM*YDIF
      ELSEIF (YW1.GE.YTRC) THEN
        IF (YW2.GE.YTRC) RETURN
        YLAM=(YTRC-YW1)/YDIF
        XW1=XW1+YLAM*XDIF
        YW1=YW1+YLAM*YDIF
      ENDIF
      IF (XW2.LE.XBLC) THEN
        XLAM=(XBLC-XW1)/XDIF
        XW2=XW1+XLAM*XDIF
        YW2=YW1+XLAM*YDIF
      ELSEIF (XW2.GE.XTRC) THEN
        XLAM=(XTRC-XW1)/XDIF
        XW2=XW1+XLAM*XDIF
        YW2=YW1+XLAM*YDIF
      ENDIF
      IF (YW2.LE.YBLC) THEN
        YLAM=(YBLC-YW1)/YDIF
        XW2=XW1+YLAM*XDIF
        YW2=YW1+YLAM*YDIF
      ELSEIF (YW2.GE.YTRC) THEN
        YLAM=(YTRC-YW1)/YDIF
        XW2=XW1+YLAM*XDIF
        YW2=YW1+YLAM*YDIF
      ENDIF
C
      COLOUR=FLOAT(ICOL)
      DX=FLOAT(NXP-1)/(XTRC-XBLC)
      X1=1.0+(XW1-XBLC)*DX
      X2=1.0+(XW2-XBLC)*DX
      XDIF=X2-X1
      DY=FLOAT(NYP-1)/(YTRC-YBLC)
      Y1=1.0+(YW1-YBLC)*DY
      Y2=1.0+(YW2-YBLC)*DY
      YDIF=Y2-Y1
      ZW1=END1(3)
      IF (ABS(XDIF).GE.ABS(YDIF)) THEN
        IF (ABS(XDIF).LT.SMALL) RETURN
        IF (X1.LE.X2) THEN
          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))
        ENDIF
        IF (ABS(C).LT.SMALL) C=SMALL
        D=D/C
        IF (ABS(D).LT.SMALL) D=SMALL
        DYJ=YDIF/XDIF
        IX1=NINT(X1)
        IX2=NINT(X2)
        YJ=Y1+DYJ*(FLOAT(IX1)-X1)
        DXX=1.0/DX
        IF (LDASH) THEN
          DYJJ=(NDASH1-NDASH2-1)*DYJ
          DO 20 II=IX1,IX2,NDASH1
            III=MIN(II+NDASH2,IX2)
            XX=XBLC-EYE(1)+DXX*FLOAT(II-1)
            DO 10 I=II,III
              K=NXP*(NINT(YJ)-1)+I
              Z=ZW1+(A*XX+B)/(XX+D)
              IF (Z.GT.SBBUFF(K)) THEN
                SBBUFF(K)=Z
                SBBUFF(KSTART+K)=COLOUR
              ENDIF
              YJ=YJ+DYJ
              XX=XX+DXX
  10        CONTINUE
            YJ=YJ+DYJJ
  20      CONTINUE
        ELSE
          XX=XBLC-EYE(1)+DXX*FLOAT(IX1-1)
          DO 30 I=IX1,IX2
            K=NXP*(NINT(YJ)-1)+I
            Z=ZW1+(A*XX+B)/(XX+D)
            IF (Z.GT.SBBUFF(K)) THEN
              SBBUFF(K)=Z
              SBBUFF(KSTART+K)=COLOUR
            ENDIF
            YJ=YJ+DYJ
            XX=XX+DXX
  30      CONTINUE
        ENDIF
      ELSE
        IF (ABS(YDIF).LT.SMALL) RETURN
        IF (Y1.LE.Y2) THEN
          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))
        ENDIF
        IF (ABS(C).LT.SMALL) C=SMALL
        D=D/C
        IF (ABS(D).LT.SMALL) D=SMALL
        DXI=XDIF/YDIF
        JY1=NINT(Y1)
        JY2=NINT(Y2)
        XI=X1+DXI*(FLOAT(JY1)-Y1)
        DYY=1.0/DY
        IF (LDASH) THEN
          DXII=(NDASH1-NDASH2-1)*DXI
          DO 50 JJ=JY1,JY2,NDASH1
            JJJ=MIN(JJ+NDASH2,JY2)
            YY=YBLC-EYE(2)+DYY*FLOAT(JJ-1)
            DO 40 J=JJ,JJJ
              K=NXP*(J-1)+NINT(XI)
              Z=ZW1+(A*YY+B)/(YY+D)
              IF (Z.GT.SBBUFF(K)) THEN
                SBBUFF(K)=Z
                SBBUFF(KSTART+K)=COLOUR
              ENDIF
              XI=XI+DXI
              YY=YY+DYY
  40        CONTINUE
            XI=XI+DXII
  50      CONTINUE
        ELSE
          YY=YBLC-EYE(2)+DYY*FLOAT(JY1-1)
          DO 60 J=JY1,JY2
            K=NXP*(J-1)+NINT(XI)
            Z=ZW1+(A*YY+B)/(YY+D)
            IF (Z.GT.SBBUFF(K)) THEN
              SBBUFF(K)=Z
              SBBUFF(KSTART+K)=COLOUR
            ENDIF
            XI=XI+DXI
            YY=YY+DYY
  60      CONTINUE
        ENDIF
      ENDIF
      END
C
      SUBROUTINE SBLIN1(EYE,X,Y,Z,XW,YW)
C     ----------------------------------
C
      REAL EYE(*)
C
      XLAM=EYE(3)/(EYE(3)-Z)
      XW=EYE(1)+XLAM*(X-EYE(1))
      YW=EYE(2)+XLAM*(Y-EYE(2))
      END
C
      SUBROUTINE SBPLAN(EYE,NV,VERT,IC1,IC2,LIGHT)
C     --------------------------------------------
C
      REAL             EYE(*),VERT(3,*),LIGHT(*)
C
      REAL*8           XLNORM,ZZ,DZZ
      REAL             XW(400),YW(400)
      LOGICAL          LPS,LCOLOR
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      This subroutine plots a diffusively-lit coloured plane; the user 
C    must ensure that all the verticies lie in a flat plane, and that 
C    the bounding polygon be convex (so that the angle at any vertex
C    <= 180 degs). All (x,y,z) values are taken to be given in world 
C    coordinates. The z-component of the eye-poisition should be 
C    positive and that of the vertices should be negative; the viewing-
C    screen is fixed at z=0.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    EYE      R*4    I       3      (x,y,z) coordinate of eye-position.
C    NV       R*4    I       -      No. of verticies (>=3).
C    VERT     R*4    I     3 x NV   (x,y,z) coordinate of verticies.
C    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be
C                                   used for the shading.
C    LIGHT    R*4    I       3      (x,y,z) direction of flood-light.
C
C Globals 
C    SFTBUF
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     SBLIN1     Calculates the projection of (x,y,z) on viewing screen.
C
C History
C   D. S. Sivia       4 Apr 1995  Initial release.
C   D. S. Sivia      24 Oct 1997 "Safe-guarded" some rounding errors.
C-----------------------------------------------------------------------
C
C Carry out some initial checks and calculate the coordinates of the 
C projected polygon.
C
      SMALL=1.0E-10
      SMALL2=SMALL**2
      IF (EYE(3).LE.SMALL) RETURN
      IF (NV.LT.3 .OR. NV.GT.400) RETURN
      DO 10 I=1,NV
  10    IF (VERT(3,I).GE.0.0) RETURN
      XMIN=+1.0E20
      XMAX=-1.0E20
      YMIN=+1.0E20
      YMAX=-1.0E20
      DO 20 I=1,NV
        CALL SBLIN1(EYE,VERT(1,I),VERT(2,I),VERT(3,I),XW(I),YW(I))
        IF (XW(I).LT.XMIN) THEN
          XMIN=XW(I)
          ILEFT=I
        ENDIF
        IF (YW(I).LT.YMIN) THEN
          YMIN=YW(I)
          JBOTOM=I
        ENDIF
        XMAX=MAX(XW(I),XMAX)
        YMAX=MAX(YW(I),YMAX)
  20  CONTINUE
      IF (XMIN.GE.XTRC .OR. XMAX.LE.XBLC) RETURN
      IF (YMIN.GE.YTRC .OR. YMAX.LE.YBLC) RETURN
C
C Find the outward normal seen by the eye, and activate the appropriate 
C colour.
C
      AX=VERT(1,2)-VERT(1,1)
      AY=VERT(2,2)-VERT(2,1)
      AZ=VERT(3,2)-VERT(3,1)
      BX=VERT(1,1)-VERT(1,NV)
      BY=VERT(2,1)-VERT(2,NV)
      BZ=VERT(3,1)-VERT(3,NV)
      XN=BY*AZ-AY*BZ
      YN=BZ*AX-AZ*BX
      ZN=BX*AY-AX*BY
      TEN=XN*(EYE(1)-VERT(1,1))+YN*(EYE(2)-VERT(2,1))
     *   +ZN*(EYE(3)-VERT(3,1))
      COLOUR=FLOAT(IC1)
      NC=IC2-IC1
      IF (NC.GT.0) THEN
        TNL=XN*LIGHT(1)+YN*LIGHT(2)+ZN*LIGHT(3)
        IF (TEN.LT.0.0) TNL=-TNL
        COSDIF=0.0
        IF (TNL.LT.0.0) THEN
          TN2=XN**2+YN**2+ZN**2
          TL2=LIGHT(1)**2+LIGHT(2)**2+LIGHT(3)**2
          COSDIF=MIN(-TNL/SQRT(TN2*TL2+SMALL2),1.0)
        ENDIF
        COLOUR=COLOUR+COSDIF*FLOAT(NC)
      ENDIF
C
C Plot the projected polygon.
C
      XLNORM=DBLE(EYE(3))*DBLE(TEN)
      EYENRM=XN*EYE(1)+YN*EYE(2)+ZN*EYE(3)
      DX=FLOAT(NXP-1)/(XTRC-XBLC)
      DY=FLOAT(NYP-1)/(YTRC-YBLC)
      DYJ=1.0/DY
      DXI=1.0/DX
      SAFER=0.0001
      IF ((XMAX-XMIN).GT.(YMAX-YMIN)) THEN
        JYMIN=INT((YMIN-YBLC)*DY)+2
        JYMAX=MIN(INT((YMAX-YBLC)*DY)+1,NYP)
        IF (JYMIN.GT.JYMAX) RETURN
        YJ=YBLC+(FLOAT(JYMIN-1)+SAFER)*DYJ
        NVL2=JBOTOM
        NVR2=JBOTOM
        J1=JYMIN
        DO 50 IVERT=1,NV
          IF (YJ.GT.YW(NVL2)) THEN
   1        NVL1=NVL2
            NVL2=NVL1-1
            IF (NVL2.LT.1) NVL2=NV
            IF (NVL2.EQ.JBOTOM) RETURN
            IF (YJ.GT.YW(NVL2)) GOTO 1
            YDIFL=YW(NVL2)-YW(NVL1)
            IF (ABS(YDIFL).LT.SMALL) YDIFL=SMALL
            GRADL=(XW(NVL2)-XW(NVL1))/YDIFL
          ENDIF
          IF (YJ.GT.YW(NVR2)) THEN
   2        NVR1=NVR2
            NVR2=NVR1+1
            IF (NVR2.GT.NV) NVR2=1
            IF (NVR2.EQ.JBOTOM) RETURN
            IF (YJ.GT.YW(NVR2)) GOTO 2
            YDIFR=YW(NVR2)-YW(NVR1)
            IF (ABS(YDIFR).LT.SMALL) YDIFR=SMALL
            GRADR=(XW(NVR2)-XW(NVR1))/YDIFR
          ENDIF
          IF (YW(NVL2).LT.YW(NVR2)) THEN
            J2=MIN(INT((YW(NVL2)-YBLC)*DY)+1,JYMAX)
          ELSE
            J2=MIN(INT((YW(NVR2)-YBLC)*DY)+1,JYMAX)
          ENDIF
          DO 40 J=J1,J2
            IF (J.GE.1) THEN
              XL=XW(NVL1)+GRADL*(YJ-YW(NVL1))
              XR=XW(NVR1)+GRADR*(YJ-YW(NVR1))
              ISTEP=1
              IX1=MAX(INT((XL-XBLC)*DX)+2,1)
              IX2=MIN(INT((XR-XBLC)*DX)+1,NXP)
              IF (IX1.GT.IX2) THEN
                ISTEP=-1
                IX1=MIN(IX1-1,NXP)
                IX2=MAX(IX2+1,1)
              ENDIF
              DZZ=DBLE(FLOAT(ISTEP)*DXI*XN)
              ZZ=DBLE(EYENRM-(XBLC+FLOAT(IX1-1)*DXI)*XN-YJ*YN)
              K=(J-1)*NXP+IX1
              DO 30 I=IX1,IX2,ISTEP
                Z=EYE(3)-SNGL(XLNORM/ZZ)
                IF (Z.GT.SBBUFF(K)) THEN
                  SBBUFF(K)=Z
                  SBBUFF(KSTART+K)=COLOUR
                ENDIF
                ZZ=ZZ-DZZ
                K=K+ISTEP
  30          CONTINUE
            ENDIF
            YJ=YJ+DYJ
  40      CONTINUE
          J1=J2+1
          IF (J1.GT.JYMAX) RETURN
  50    CONTINUE
      ELSE
        IXMIN=INT((XMIN-XBLC)*DX)+2
        IXMAX=MIN(INT((XMAX-XBLC)*DX)+1,NXP)
        IF (IXMIN.GT.IXMAX) RETURN
        XI=XBLC+(FLOAT(IXMIN-1)+SAFER)*DXI
        NVL2=ILEFT
        NVR2=ILEFT
        I1=IXMIN
        DO 80 IVERT=1,NV
          IF (XI.GT.XW(NVL2)) THEN
   3        NVL1=NVL2
            NVL2=NVL1-1
            IF (NVL2.LT.1) NVL2=NV
            IF (NVL2.EQ.ILEFT) RETURN
            IF (XI.GT.XW(NVL2)) GOTO 3
            XDIFL=XW(NVL2)-XW(NVL1)
            IF (ABS(XDIFL).LT.SMALL) XDIFL=SMALL
            GRADL=(YW(NVL2)-YW(NVL1))/XDIFL
          ENDIF
          IF (XI.GT.XW(NVR2)) THEN
   4        NVR1=NVR2
            NVR2=NVR1+1
            IF (NVR2.GT.NV) NVR2=1
            IF (NVR2.EQ.ILEFT) RETURN
            IF (XI.GT.XW(NVR2)) GOTO 4
            XDIFR=XW(NVR2)-XW(NVR1)
            IF (ABS(XDIFR).LT.SMALL) XDIFR=SMALL
            GRADR=(YW(NVR2)-YW(NVR1))/XDIFR
          ENDIF
          IF (XW(NVL2).LT.XW(NVR2)) THEN
            I2=MIN(INT((XW(NVL2)-XBLC)*DX)+1,IXMAX)
          ELSE
            I2=MIN(INT((XW(NVR2)-XBLC)*DX)+1,IXMAX)
          ENDIF
          DO 70 I=I1,I2
            IF (I.GE.1) THEN
              YL=YW(NVL1)+GRADL*(XI-XW(NVL1))
              YR=YW(NVR1)+GRADR*(XI-XW(NVR1))
              ISTEP=1
              JY1=MAX(INT((YL-YBLC)*DY)+2,1)
              JY2=MIN(INT((YR-YBLC)*DY)+1,NYP)
              IF (JY1.GT.JY2) THEN
                ISTEP=-1
                JY1=MIN(JY1-1,NYP)
                JY2=MAX(JY2+1,1)
              ENDIF
              DZZ=DBLE(FLOAT(ISTEP)*DYJ*YN)
              ZZ=DBLE(EYENRM-(YBLC+FLOAT(JY1-1)*DYJ)*YN-XI*XN)
              K=(JY1-1)*NXP+I
              KSTEP=ISTEP*NXP
              DO 60 J=JY1,JY2,ISTEP
                Z=EYE(3)-SNGL(XLNORM/ZZ)
                IF (Z.GT.SBBUFF(K)) THEN
                  SBBUFF(K)=Z
                  SBBUFF(KSTART+K)=COLOUR
                ENDIF
                ZZ=ZZ-DZZ
                K=K+KSTEP
  60          CONTINUE
            ENDIF
            XI=XI+DXI
  70      CONTINUE
          I1=I2+1
          IF (I1.GT.IXMAX) RETURN
  80    CONTINUE
      ENDIF
      END
C
      SUBROUTINE SBROD(EYE,END1,END2,RADIUS,IC1,IC2,LIGHT,NSIDES,LEND)
C     ----------------------------------------------------------------
C
      REAL     EYE(*),END1(*),END2(*),LIGHT(*)
      LOGICAL  LEND
C
      LOGICAL  LEND1,LSTART
      REAL     ENDVRT(3,361),SIDVRT(3,4)
      REAL     SINROT(361),COSROT(361)
      SAVE     LSTART,NROT0,SINROT,COSROT,SCLNRM
      DATA     NRTMAX,PI,LSTART /361,3.141592654,.FALSE./
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      This subroutine plots a diffusively-shaded coloured rod. All 
C    (x,y,z) values are taken to be given in world coordinates. The 
C    z-component of the eye-poisition should be positive and that of
C    the rod-ends should be negative (< -radius); the viewing-screen
C    is fixed at z=0.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    EYE      R*4    I       3      (x,y,z) coordinate of eye-position.
C    END1     R*4    I       3      (x,y,z) coordinate of rod-end 1.
C    END2     R*4    I       3      (x,y,z) coordinate of rod-end 2.
C    RADIUS   R*4    I       -      Radius of cylinderical rod.
C    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be
C                                   used for the shading.
C    LIGHT    R*4    I       3      (x,y,z) direction of flood-light.
C    NSIDES   I*4    I       -      The order of the polygon to be used
C                                   for the cross-section of the rod.
C    LEND     L*1    I       -      If true, plot the end of the rod.
C
C External Calls
C     SBLINE     Draws a straight line between two points.
C     SBPLAN     Plots a coloured plane.
C     SBROD1     Initialises the array of sines and coses, if necessary.
C     SBRCOP     Copies one real array to another.
C
C History
C   D. S. Sivia       4 Apr 1995  Initial release.
C   D. S. Sivia      22 Oct 1997  Increased NRTMAX from 73 to 361.
C-----------------------------------------------------------------------
C
C Some initial checks.
C
      IF (NSIDES.LE.2) THEN
        CALL SBLINE(EYE,END1,END2,IC2,.FALSE.)
        RETURN
      ENDIF
      SMALL=1.0E-20
      IF (EYE(3).LE.0.0) RETURN
      IF (RADIUS.LE.0.0) RETURN
      IF (END1(3).GT.-RADIUS .OR. END2(3).GT.-RADIUS) RETURN
      XL=END2(1)-END1(1)
      YL=END2(2)-END1(2)
      ZL=END2(3)-END1(3)
      RLENG2=XL**2+YL**2+ZL**2
      IF (RLENG2.LT.SMALL) RETURN
C
C Find out which end of the rod, if any, can be seen.
C
      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.LT.0.0) THEN
        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.LT.0.0) LEND1=.TRUE.
      ENDIF
      SINTHT=0.0
      COSTHT=1.0
      SINPHI=0.0
      COSPHI=1.0
      RXY2=XL**2+YL**2
      IF (RXY2.GT.SMALL) THEN
        RLENG=SQRT(RLENG2)
        RXY=SQRT(RXY2)
        SINTHT=+RXY/RLENG
        COSTHT=-ZL/RLENG  
        SINPHI=-YL/RXY
        COSPHI=-XL/RXY
      ENDIF
      IF (.NOT. LEND) LEND1=.FALSE.
C
C Sweep around the rod and plot the shaded surface.
C
      NROT=MIN(NSIDES+1,NRTMAX)
      CALL SBROD1(LSTART,NROT0,NROT,SINROT,COSROT,PI,SCLNRM)
      DO 10 I=1,NROT
        X=RADIUS*COSROT(I)
        Y=RADIUS*SINROT(I)
        ENDVRT(1,I)=X0+X*COSTHT*COSPHI-Y*SINPHI
        ENDVRT(2,I)=Y0+X*COSTHT*SINPHI+Y*COSPHI
        ENDVRT(3,I)=Z0-X*SINTHT
  10  CONTINUE
      DO 20 J=2,NROT
        I=J-1
        XN=SCLNRM*(ENDVRT(1,I)+ENDVRT(1,J)-X0-X0)
        YN=SCLNRM*(ENDVRT(2,I)+ENDVRT(2,J)-Y0-Y0)
        ZN=SCLNRM*(ENDVRT(3,I)+ENDVRT(3,J)-Z0-Z0)
        ENN2=(EYE(1)-X0-XN)*XN+(EYE(2)-Y0-YN)*YN+(EYE(3)-Z0-ZN)*ZN
        IF (ENN2.GT.0.0) THEN
          CALL SBRCOP(ENDVRT(1,I),SIDVRT(1,1),3)
          SIDVRT(1,2)=ENDVRT(1,I)+XL
          SIDVRT(2,2)=ENDVRT(2,I)+YL
          SIDVRT(3,2)=ENDVRT(3,I)+ZL
          SIDVRT(1,3)=ENDVRT(1,J)+XL
          SIDVRT(2,3)=ENDVRT(2,J)+YL
          SIDVRT(3,3)=ENDVRT(3,J)+ZL
          CALL SBRCOP(ENDVRT(1,J),SIDVRT(1,4),3)
          CALL SBPLAN(EYE,4,SIDVRT,IC1,IC2,LIGHT)
        ENDIF
  20  CONTINUE
      IF (LEND1) CALL SBPLAN(EYE,NROT-1,ENDVRT,IC1,IC2,LIGHT)
      END
C
      SUBROUTINE SBROD1(LSTART,NROT0,NROT,SINROT,COSROT,PI,SCLNRM)
C     ------------------------------------------------------------
C
      REAL    COSROT(*),SINROT(*)
      LOGICAL LSTART
C
      IF (LSTART .AND. NROT.EQ.NROT0) RETURN
      ROT=0.0
      DROT=2.0*PI/FLOAT(NROT-1)
      DO 10 I=1,NROT
        SINROT(I)=SIN(ROT)
        COSROT(I)=COS(ROT)
        ROT=ROT+DROT
  10  CONTINUE
      SCLNRM=0.5/COS(DROT/2.0)
      LSTART=.TRUE.
      NROT0=NROT
      END
C
      SUBROUTINE SBCONE(EYE,BASE,APEX,RADIUS,IC1,IC2,LIGHT,NSIDES)
C     ------------------------------------------------------------
C
      REAL     EYE(*),BASE(*),APEX(*),LIGHT(*)
C
      LOGICAL  LBASE,LSTART
      REAL     BASVRT(3,361),SIDVRT(3,3)
      REAL     SINROT(361),COSROT(361)
      SAVE     LSTART,NROT0,SINROT,COSROT,SCLNRM
      DATA     NRTMAX,PI,LSTART /361,3.141592654,.FALSE./
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      This subroutine plots a diffusively-shaded coloured right-angular
C    cone. All (x,y,z) values are taken to be given in world coordinates.
C    The z-component of the eye-poisition should be positive and that of
C    the base and appex of the cone should be negative (< -radius); the 
C    viewing-screen is fixed at z=0.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    EYE      R*4    I       3      (x,y,z) coordinate of eye-position.
C    BASE     R*4    I       3      (x,y,z) coordinate of the centre of
C                                   the base of the cone.
C    APEX     R*4    I       3      (x,y,z) coordinate of the apex.
C    RADIUS   R*4    I       -      Radius of the base of the cone.
C    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be
C                                   used for the shading.
C    LIGHT    R*4    I       3      (x,y,z) direction of flood-light.
C    NSIDES   I*4    I       -      The order of the polygon to be used
C                                   for the cross-section of the cone.
C
C External Calls
C     SBLINE     Draws a straight line between two points.
C     SBPLAN     Plots a coloured plane.
C     SBROD1     Initialises the array of sines and coses, if necessary.
C     SBRCOP     Copies one real array to another.
C
C History
C   D. S. Sivia      29 Jun 1995  Initial release.
C   D. S. Sivia      22 Oct 1997  Increased NRTMAX from 73 to 361.
C-----------------------------------------------------------------------
C
C Some initial checks.
C
      SMALL=1.0E-20
      IF (NSIDES.LE.2) RETURN
      IF (EYE(3).LE.0.0) RETURN
      IF (RADIUS.LE.0.0) RETURN
      IF (BASE(3).GT.-RADIUS .OR. APEX(3).GE.0.0) RETURN
      XL=APEX(1)-BASE(1)
      YL=APEX(2)-BASE(2)
      ZL=APEX(3)-BASE(3)
      RLENG2=XL**2+YL**2+ZL**2
      IF (RLENG2.LT.SMALL) RETURN
C
C Find out whether the base of the cone can be seen.
C
      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.LT.0.0) LBASE=.TRUE.
      SINTHT=0.0
      COSTHT=1.0
      SINPHI=0.0
      COSPHI=1.0
      RXY2=XL**2+YL**2
      IF (RXY2.GT.SMALL) THEN
        RLENG=SQRT(RLENG2)
        RXY=SQRT(RXY2)
        SINTHT=+RXY/RLENG
        COSTHT=-ZL/RLENG  
        SINPHI=-YL/RXY
        COSPHI=-XL/RXY
      ENDIF
C
C Sweep around the rod and plot the shaded surface.
C
      NROT=MIN(NSIDES+1,NRTMAX)
      CALL SBROD1(LSTART,NROT0,NROT,SINROT,COSROT,PI,SCLNRM)
      DO 10 I=1,NROT
        X=RADIUS*COSROT(I)
        Y=RADIUS*SINROT(I)
        BASVRT(1,I)=X0+X*COSTHT*COSPHI-Y*SINPHI
        BASVRT(2,I)=Y0+X*COSTHT*SINPHI+Y*COSPHI
        BASVRT(3,I)=Z0-X*SINTHT
  10  CONTINUE
      IF (LBASE) CALL SBPLAN(EYE,NROT-1,BASVRT,IC1,IC2,LIGHT)
      CALL SBRCOP(APEX,SIDVRT(1,3),3)
      DO 20 J=1,NROT-1
        CALL SBRCOP(BASVRT(1,J),SIDVRT(1,1),6)
        CALL SBPLAN(EYE,3,SIDVRT,IC1,IC2,LIGHT)
  20  CONTINUE
      END
C
      SUBROUTINE SBSLIC(EYE,LATICE,DENS,N1,N2,N3,DLOW,DHIGH,IC1,IC2,
     *                  SLNORM,APOINT,ICEDGE)
C     --------------------------------------------------------------
C
      REAL             EYE(*),LATICE(3,*),DENS(0:N1,0:N2,0:N3)
      REAL             SLNORM(*),APOINT(*)
C
      REAL*8           XLNORM,ZZ,DZZ
      REAL             BAS(3,3),MTRX(3,3)
      REAL             END1(3),END2(3),VERT(3,12),XW(20),YW(20)
      LOGICAL          LPS,LCOLOR,LVERT(12)
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      This subroutine plots a "grey-scale" slice through a unit-cell
C    of density. All (x,y,z) values are taken to be given in world 
C    coordinates. The z-component of the eye-poisition should be 
C    positive and that of all the lattice-vertices should be negative; 
C    the viewing-screen is fixed at z=0.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    EYE      R*4    I       3      (x,y,z) coordinate of eye-position.
C    LATICE   R*4    I     3 x 4    (x,y,z) coordinates of the origin
C                                   and the a, b & C lattice-vertices.
C    DENS     R*4    I     (N1+1)   The density at regular points within
C                        x (N2+1)   the unit cell, wrapped around so
C                        x (N3+1)   that DENS(0,J,K)=DENS(N1,J,K) etc..
C    N1,N2,N3 I*4    I       -      The dimensions of the unit-cell grid.
C    DLOW     R*4    I       -      Density for the lowest colour-index.
C    DHIGH    R*4    I       -      Density for the highest colour-index.
C    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be
C                                   used for the shading.
C    SLNORM   R*4    I       3      (x,y,z) direction of the normal to 
C                                   the slice to be "grey-scaled".
C    APONIT   R*4    I       3      (x,y,z) coordinate of a point within
C                                   the slice to be "grey-scaled".
C    ICEDGE   I*4    I       -      If >=0, it's the colour-index for the
C                                   boundary of the "grey-scaled" slice.
C
C Globals 
C    SFTBUF
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     SBSLC1     Plots a side of the unit cell and sees if it is cut by
C                the slice to be "grey-scaled".
C     SBSLC2     Calculates the coordinates of the projected polygon.
C     SLSLC3     Calculates the appropriate colour for a given pixel.
C     SBLIN1     Calculates the projection of (x,y,z) on viewing screen.
C
C History
C   D. S. Sivia      30 Apr 1995  Initial release.
C   D. S. Sivia       7 Jul 1995  Fixed some bug.
C   D. S. Sivia      24 Oct 1997 "Safe-guarded" some rounding errors.
C-----------------------------------------------------------------------
C
C Carry out some initial checks.
C
      SMALL=1.0E-10
      SMALL2=SMALL**2
      IF (EYE(3).LE.SMALL) RETURN
      IF (N1.LT.1 .OR. N2.LT.1 .OR. N3.LT.1) RETURN
      SNRM=1.0/SQRT(SLNORM(1)**2+SLNORM(2)**2+SLNORM(3)**2+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=DBLE(XN*XAE)+DBLE(YN*YAE)+DBLE(ZN*ZAE)
      COSNRM=SNGL(XLNORM/DSQRT(DBLE(XAE**2)+DBLE(YAE**2)+DBLE(ZAE**2)
     *      +DBLE(SMALL2)))
      IF (ABS(COSNRM).LT.0.001) RETURN
      DO 10 J=1,3
        BAS(1,J)=LATICE(1,J+1)-LATICE(1,1)
        BAS(2,J)=LATICE(2,J+1)-LATICE(2,1)
        BAS(3,J)=LATICE(3,J+1)-LATICE(3,1)
        BAS2J=BAS(1,J)**2+BAS(2,J)**2+BAS(3,J)**2
        IF (BAS2J.LT.SMALL2) RETURN
  10  CONTINUE
      COL0=FLOAT(IC1)
      CSCL=FLOAT(IC2-IC1)
      COLNRM=DHIGH-DLOW
      IF (ABS(COLNRM).LT.SMALL) RETURN
      DCOL=1.0/COLNRM
C
C Set up matrix for real-space to lattice-index transformation.
C
      DET=BAS(1,1)*BAS(2,2)*BAS(3,3)+BAS(1,2)*BAS(2,3)*BAS(3,1)
     *   +BAS(1,3)*BAS(2,1)*BAS(3,2)-BAS(3,1)*BAS(2,2)*BAS(1,3)
     *   -BAS(3,2)*BAS(2,3)*BAS(1,1)-BAS(3,3)*BAS(2,1)*BAS(1,2)
      IF (ABS(DET).LT.SMALL2) RETURN
      DETNRM=1.0/DET
      MTRX(1,1)=DETNRM*(BAS(2,2)*BAS(3,3)-BAS(2,3)*BAS(3,2))
      MTRX(1,2)=DETNRM*(BAS(2,3)*BAS(3,1)-BAS(2,1)*BAS(3,3))
      MTRX(1,3)=DETNRM*(BAS(2,1)*BAS(3,2)-BAS(2,2)*BAS(3,1))
      MTRX(2,1)=DETNRM*(BAS(3,2)*BAS(1,3)-BAS(3,3)*BAS(1,2))
      MTRX(2,2)=DETNRM*(BAS(3,3)*BAS(1,1)-BAS(3,1)*BAS(1,3))
      MTRX(2,3)=DETNRM*(BAS(3,1)*BAS(1,2)-BAS(3,2)*BAS(1,1))
      MTRX(3,1)=DETNRM*(BAS(1,2)*BAS(2,3)-BAS(1,3)*BAS(2,2))
      MTRX(3,2)=DETNRM*(BAS(1,3)*BAS(2,1)-BAS(1,1)*BAS(2,3))
      MTRX(3,3)=DETNRM*(BAS(1,1)*BAS(2,2)-BAS(1,2)*BAS(2,1))
C
C Draw the frame of the unit cell and calculate the coordinates of the 
C projected polygon.
C
      NVERT=0
      II=0
      DO 20 L=1,12,4
        I=II+2
        J=MOD(II+1,3)+2
        K=MOD(II+2,3)+2
        CALL SBSLC1(LATICE,LATICE(1,K),XN,YN,ZN,APOINT,LVERT(L),
     *              VERT(1,L),NVERT)
        END1(1)=LATICE(1,I)+LATICE(1,J)-LATICE(1,1)
        END1(2)=LATICE(2,I)+LATICE(2,J)-LATICE(2,1)
        END1(3)=LATICE(3,I)+LATICE(3,J)-LATICE(3,1)
        CALL SBSLC1(LATICE(1,I),END1,XN,YN,ZN,APOINT,LVERT(L+1),
     *              VERT(1,L+1),NVERT)
        CALL SBSLC1(LATICE(1,J),END1,XN,YN,ZN,APOINT,LVERT(L+2),
     *              VERT(1,L+2),NVERT)
        END2(1)=END1(1)+LATICE(1,K)-LATICE(1,1)
        END2(2)=END1(2)+LATICE(2,K)-LATICE(2,1)
        END2(3)=END1(3)+LATICE(3,K)-LATICE(3,1)
        CALL SBSLC1(END1,END2,XN,YN,ZN,APOINT,LVERT(L+3),
     *              VERT(1,L+3),NVERT)
        II=II+1
  20  CONTINUE
      IF (NVERT.LT.3) RETURN
      CALL SBSLC2(EYE,LVERT,VERT,NVERT,XN,YN,ZN,XW,YW,ICEDGE,ZDLINE)
C
C Paint the projected polygon slice.
C
      XMIN=+1.0E20
      XMAX=-1.0E20
      YMIN=+1.0E20
      YMAX=-1.0E20
      DO 30 I=1,NVERT
        IF (XW(I).LT.XMIN) THEN
          XMIN=XW(I)
          ILEFT=I
        ENDIF
        IF (YW(I).LT.YMIN) THEN
          YMIN=YW(I)
          JBOTOM=I
        ENDIF
        XMAX=MAX(XW(I),XMAX)
        YMAX=MAX(YW(I),YMAX)
  30  CONTINUE
      IF (XMIN.GE.XTRC .OR. XMAX.LE.XBLC) RETURN
      IF (YMIN.GE.YTRC .OR. YMAX.LE.YBLC) RETURN
C
      EYENRM=XN*EYE(1)+YN*EYE(2)+ZN*EYE(3)
      DX=FLOAT(NXP-1)/(XTRC-XBLC)
      DY=FLOAT(NYP-1)/(YTRC-YBLC)
      DYJ=1.0/DY
      DXI=1.0/DX
      SAFER=0.0001
      IF ((XMAX-XMIN).GT.(YMAX-YMIN)) THEN
        JYMIN=INT((YMIN-YBLC)*DY)+2
        JYMAX=MIN(INT((YMAX-YBLC)*DY)+1,NYP)
        IF (JYMIN.GT.JYMAX) RETURN
        YJ=YBLC+(FLOAT(JYMIN-1)+SAFER)*DYJ
        NVL2=JBOTOM
        NVR2=JBOTOM
        J1=JYMIN
        DO 60 IVERT=1,NVERT
          IF (YJ.GT.YW(NVL2)) THEN
   1        NVL1=NVL2
            NVL2=NVL1-1
            IF (NVL2.LT.1) NVL2=NVERT
            IF (NVL2.EQ.JBOTOM) RETURN
            IF (YJ.GT.YW(NVL2)) GOTO 1
            YDIFL=YW(NVL2)-YW(NVL1)
            IF (ABS(YDIFL).LT.SMALL) YDIFL=SMALL
            GRADL=(XW(NVL2)-XW(NVL1))/YDIFL
          ENDIF
          IF (YJ.GT.YW(NVR2)) THEN
   2        NVR1=NVR2
            NVR2=NVR1+1
            IF (NVR2.GT.NVERT) NVR2=1
            IF (NVR2.EQ.JBOTOM) RETURN
            IF (YJ.GT.YW(NVR2)) GOTO 2
            YDIFR=YW(NVR2)-YW(NVR1)
            IF (ABS(YDIFR).LT.SMALL) YDIFR=SMALL
            GRADR=(XW(NVR2)-XW(NVR1))/YDIFR
          ENDIF
          IF (YW(NVL2).LT.YW(NVR2)) THEN
            J2=MIN(INT((YW(NVL2)-YBLC)*DY)+1,JYMAX)
          ELSE
            J2=MIN(INT((YW(NVR2)-YBLC)*DY)+1,JYMAX)
          ENDIF
          DO 50 J=J1,J2
            IF (J.GE.1) THEN
              XL=XW(NVL1)+GRADL*(YJ-YW(NVL1))
              XR=XW(NVR1)+GRADR*(YJ-YW(NVR1))
              ISTEP=1
              IX1=MAX(INT((XL-XBLC)*DX)+2,1)
              IX2=MIN(INT((XR-XBLC)*DX)+1,NXP)
              IF (IX1.GT.IX2) THEN
                ISTEP=-1
                IX1=MIN(IX1-1,NXP)
                IX2=MAX(IX2+1,1)
              ENDIF
              XI=XBLC+FLOAT(IX1-1)*DXI
              SDXI=FLOAT(ISTEP)*DXI
              DZZ=DBLE(SDXI*XN)
              ZZ=DBLE(EYENRM-XI*XN-YJ*YN)
              K=(J-1)*NXP+IX1
              DO 40 I=IX1,IX2,ISTEP
                XLAMDA=SNGL(XLNORM/ZZ)
                Z=EYE(3)*(1.0-XLAMDA)
                IF ((Z-SBBUFF(K)).GT.ZDLINE) THEN
                  SBBUFF(K)=Z
                  X=EYE(1)+XLAMDA*(XI-EYE(1))-LATICE(1,1)
                  Y=EYE(2)+XLAMDA*(YJ-EYE(2))-LATICE(2,1)
                  Z=Z-LATICE(3,1)
                  CALL SBSLC3(DENS,N1,N2,N3,X,Y,Z,MTRX,DLOW,DCOL,COLOUR)
                  SBBUFF(KSTART+K)=COL0+CSCL*COLOUR
                ENDIF
                XI=XI+SDXI
                ZZ=ZZ-DZZ
                K=K+ISTEP
  40          CONTINUE
            ENDIF
            YJ=YJ+DYJ
  50      CONTINUE
          J1=J2+1
          IF (J1.GT.JYMAX) RETURN
  60    CONTINUE
      ELSE
        IXMIN=INT((XMIN-XBLC)*DX)+2
        IXMAX=MIN(INT((XMAX-XBLC)*DX)+1,NXP)
        IF (IXMIN.GT.IXMAX) RETURN
        XI=XBLC+(FLOAT(IXMIN-1)+SAFER)*DXI
        NVL2=ILEFT
        NVR2=ILEFT
        I1=IXMIN
        DO 90 IVERT=1,NVERT
          IF (XI.GT.XW(NVL2)) THEN
   3        NVL1=NVL2
            NVL2=NVL1-1
            IF (NVL2.LT.1) NVL2=NVERT
            IF (NVL2.EQ.ILEFT) RETURN
            IF (XI.GT.XW(NVL2)) GOTO 3
            XDIFL=XW(NVL2)-XW(NVL1)
            IF (ABS(XDIFL).LT.SMALL) XDIFL=SMALL
            GRADL=(YW(NVL2)-YW(NVL1))/XDIFL
          ENDIF
          IF (XI.GT.XW(NVR2)) THEN
   4        NVR1=NVR2
            NVR2=NVR1+1
            IF (NVR2.GT.NVERT) NVR2=1
            IF (NVR2.EQ.ILEFT) RETURN
            IF (XI.GT.XW(NVR2)) GOTO 4
            XDIFR=XW(NVR2)-XW(NVR1)
            IF (ABS(XDIFR).LT.SMALL) XDIFR=SMALL
            GRADR=(YW(NVR2)-YW(NVR1))/XDIFR
          ENDIF
          IF (XW(NVL2).LT.XW(NVR2)) THEN
            I2=MIN(INT((XW(NVL2)-XBLC)*DX)+1,IXMAX)
          ELSE
            I2=MIN(INT((XW(NVR2)-XBLC)*DX)+1,IXMAX)
          ENDIF
          DO 80 I=I1,I2
            IF (I.GE.1) THEN
              YL=YW(NVL1)+GRADL*(XI-XW(NVL1))
              YR=YW(NVR1)+GRADR*(XI-XW(NVR1))
              ISTEP=1
              JY1=MAX(INT((YL-YBLC)*DY)+2,1)
              JY2=MIN(INT((YR-YBLC)*DY)+1,NYP)
              IF (JY1.GT.JY2) THEN
                ISTEP=-1
                JY1=MIN(JY1-1,NYP)
                JY2=MAX(JY2+1,1)
              ENDIF
              YJ=YBLC+FLOAT(JY1-1)*DYJ
              SDYJ=FLOAT(ISTEP)*DYJ
              DZZ=DBLE(SDYJ*YN)
              ZZ=DBLE(EYENRM-YJ*YN-XI*XN)
              K=(JY1-1)*NXP+I
              KSTEP=ISTEP*NXP
              DO 70 J=JY1,JY2,ISTEP
                XLAMDA=SNGL(XLNORM/ZZ)
                Z=EYE(3)*(1.0-XLAMDA)
                IF ((Z-SBBUFF(K)).GT.ZDLINE) THEN
                  SBBUFF(K)=Z
                  X=EYE(1)+XLAMDA*(XI-EYE(1))-LATICE(1,1)
                  Y=EYE(2)+XLAMDA*(YJ-EYE(2))-LATICE(2,1)
                  Z=Z-LATICE(3,1)
                  CALL SBSLC3(DENS,N1,N2,N3,X,Y,Z,MTRX,DLOW,DCOL,COLOUR)
                  SBBUFF(KSTART+K)=COL0+CSCL*COLOUR
                ENDIF
                YJ=YJ+SDYJ
                ZZ=ZZ-DZZ
                K=K+KSTEP
  70          CONTINUE
            ENDIF
            XI=XI+DXI
  80      CONTINUE
          I1=I2+1
          IF (I1.GT.IXMAX) RETURN
  90    CONTINUE
      ENDIF
      END
C
      SUBROUTINE SBSLC1(END1,END2,XN,YN,ZN,APOINT,LVERT,VERT,NVERT)
C     -------------------------------------------------------------
C
      REAL    END1(*),END2(*),APOINT(*),VERT(*)
      LOGICAL LVERT
C
      LVERT=.FALSE.
      X12=END2(1)-END1(1)
      Y12=END2(2)-END1(2)
      Z12=END2(3)-END1(3)
      DENOM=XN*X12+YN*Y12+ZN*Z12
      COSNRM=DENOM/SQRT(X12**2+Y12**2+Z12**2+1.0E-20)
      IF (ABS(COSNRM).LT.0.001) RETURN
      XLAM=(XN*(APOINT(1)-END1(1))+YN*(APOINT(2)-END1(2))
     *     +ZN*(APOINT(3)-END1(3)))/DENOM
      IF (XLAM.GE.0.0 .AND. XLAM.LE.1.0) THEN
        LVERT=.TRUE.
        NVERT=NVERT+1
        VERT(1)=END1(1)+XLAM*X12
        VERT(2)=END1(2)+XLAM*Y12
        VERT(3)=END1(3)+XLAM*Z12
        IF (VERT(3).GE.0.0) NVERT=-1000
      ENDIF
      END
C
      SUBROUTINE SBSLC2(EYE,LVERT,VERT,NVERT,XN,YN,ZN,XW,YW,ICOL,ZDIF)
C     ----------------------------------------------------------------
C
      REAL    EYE(*),VERT(3,*),XW(*),YW(*),ANGLE(12)
      INTEGER ISORT(12)
      LOGICAL LVERT(*)
C
      IV1=0
      XBAR=0.0
      YBAR=0.0
      ZBAR=0.0
      ZMIN=+1.0E20
      ZMAX=-1.0E20
      DO 10 K=1,12
        ZMIN=MIN(ZMIN,VERT(3,K))
        ZMAX=MAX(ZMAX,VERT(3,K))
        IF (LVERT(K)) THEN
          IF (IV1.LE.0) IV1=K
          XBAR=XBAR+VERT(1,K)
          YBAR=YBAR+VERT(2,K)
          ZBAR=ZBAR+VERT(3,K)
        ENDIF
  10  CONTINUE
      ZDIF=(ZMAX-ZMIN)/5000.0
      XBAR=XBAR/FLOAT(NVERT)
      YBAR=YBAR/FLOAT(NVERT)
      ZBAR=ZBAR/FLOAT(NVERT)
      XREF=VERT(1,IV1)-XBAR
      YREF=VERT(2,IV1)-YBAR
      ZREF=VERT(3,IV1)-ZBAR
      REFNRM=1.0/SQRT(XREF**2+YREF**2+ZREF**2+1.0E-20)
      XREF=XREF*REFNRM
      YREF=YREF*REFNRM
      ZREF=ZREF*REFNRM
      XNRM=YREF*ZN-YN*ZREF
      YNRM=ZREF*XN-ZN*XREF
      ZNRM=XREF*YN-XN*YREF
      J=1
      ANGLE(J)=0.0
      ISORT(J)=IV1
      CALL SBLIN1(EYE,VERT(1,IV1),VERT(2,IV1),VERT(3,IV1),XW(J),YW(J))
      DO 40 K=IV1+1,12
        IF (LVERT(K)) THEN
          J=J+1
          XVEC=VERT(1,K)-XBAR
          YVEC=VERT(2,K)-YBAR
          ZVEC=VERT(3,K)-ZBAR
          X=XVEC*XREF+YVEC*YREF+ZVEC*ZREF
          Y=XVEC*XNRM+YVEC*YNRM+ZVEC*ZNRM
          ANGJ=ATAN2(Y,X)
          CALL SBLIN1(EYE,VERT(1,K),VERT(2,K),VERT(3,K),XWJ,YWJ)
          DO 20 I=1,J-1
  20        IF (ANGJ.LT.ANGLE(I)) GOTO 1
   1      II=I
           DO 30 I=J,II+1,-1
            XW(I)=XW(I-1)
            YW(I)=YW(I-1)
            ANGLE(I)=ANGLE(I-1)
            ISORT(I)=ISORT(I-1)
  30      CONTINUE
          XW(II)=XWJ
          YW(II)=YWJ
          ANGLE(II)=ANGJ
          ISORT(II)=K
        ENDIF
  40  CONTINUE
      IF (ICOL.GE.0.0) THEN
        DO 50 I=1,NVERT-1
          J=ISORT(I)
          K=ISORT(I+1)
          CALL SBLINE(EYE,VERT(1,J),VERT(1,K),ICOL,.FALSE.)
  50    CONTINUE
        CALL SBLINE(EYE,VERT(1,K),VERT(1,ISORT(1)),ICOL,.FALSE.)
      ENDIF
      END
C
      SUBROUTINE SBSLC3(DENS,N1,N2,N3,X,Y,Z,BAS,DLOW,DCOL,COLOUR)
C     -----------------------------------------------------------
C
      REAL DENS(0:N1,0:N2,0:N3),BAS(3,*)
      DATA RMIN,RMAX /0.00001,0.99999/
C
      XI=MIN(MAX(X*BAS(1,1)+Y*BAS(2,1)+Z*BAS(3,1),RMIN),RMAX)*FLOAT(N1)
      YJ=MIN(MAX(X*BAS(1,2)+Y*BAS(2,2)+Z*BAS(3,2),RMIN),RMAX)*FLOAT(N2)
      ZK=MIN(MAX(X*BAS(1,3)+Y*BAS(2,3)+Z*BAS(3,3),RMIN),RMAX)*FLOAT(N3)
      I=INT(XI)
      J=INT(YJ)
      K=INT(ZK)
      II=I+1
      JJ=J+1
      KK=K+1
      DX=XI-FLOAT(I)
      DY=YJ-FLOAT(J)
      DZ=ZK-FLOAT(K)
      D1=(1.0-DX)*(DENS(I,J,K)+DY*(DENS(I,JJ,K)-DENS(I,J,K)))
     *       +DX*(DENS(II,J,K)+DY*(DENS(II,JJ,K)-DENS(II,J,K)))
      D2=(1.0-DX)*(DENS(I,J,KK)+DY*(DENS(I,JJ,KK)-DENS(I,J,KK)))
     *       +DX*(DENS(II,J,KK)+DY*(DENS(II,JJ,KK)-DENS(II,J,KK)))
      COLOUR=MIN(MAX((D1+DZ*(D2-D1)-DLOW)*DCOL,RMIN),RMAX)
      END
C
      SUBROUTINE SBSURF(EYE,LATICE,DENS,N1,N2,N3,DSURF,IC1,IC2,LIGHT,
     *                  LSHINE)
C     ---------------------------------------------------------------
C
      REAL             EYE(*),LATICE(3,*),DENS(0:N1,0:N2,0:N3),LIGHT(*)
      LOGICAL          LSHINE
C
      REAL*8           XLNORM,PNEYE(3),DSMAL2
      REAL             BAS(3,3),MTRX
      REAL             XYZ(3),DXYZ(3,3),FRCXYZ(12),DDXYZ(3,12,2)
      REAL             DLOCAL(8),VERT(3,12),GRDSCL(3)
      LOGICAL          LPS,LCOLOR,LEMPTY
      INTEGER          IVERT(8)
      COMMON  /SRFCOM/ GRDCUB(3,8),MTRX(3,3),ORIG(3),XL2,COL0,COLSCL
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      This subroutine plots an iso-surface through a unit-cell of
C    density. All (x,y,z) values are taken to be given in world 
C    coordinates. The z-component of the eye-poisition should be 
C    positive and that of all the lattice-vertices should be negative; 
C    the viewing-screen is fixed at z=0.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    EYE      R*4    I       3      (x,y,z) coordinate of eye-position.
C    LATICE   R*4    I     3 x 4    (x,y,z) coordinates of the origin
C                                   and the a, b & C lattice-vertices.
C    DENS     R*4    I     (N1+1)   The density at regular points within
C                        x (N2+1)   the unit cell, wrapped around so
C                        x (N3+1)   that DENS(0,J,K)=DENS(N1,J,K) etc..
C    N1,N2,N3 I*4    I       -      The dimensions of the unit-cell grid.
C    DSURF    R*4    I       -      Density for the iso-surface.
C    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be
C                                   used for the shading.
C    LIGHT    R*4    I       3      (x,y,z) direction of flood-light.
C    LSHINE   L*1    I       -      Shiny surface if TRUE, else diffuse.
C
C Globals 
C    SFTBUF
C    SRFCOM
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     SBSRF0     A quick check in case there are no iso-surafces.
C     SBSRF1     Anlayses a 2-d box in the surface of the unit-cell.
C     SBSRF2     Paints a 2-d box in the surface of the unit-cell.
C     SBSRF3     Analyses a 3-d box within the unit-cell.
C     SBSRF4     Initialises the gradients for a 3-d box.
C     SBSRF5     Breaks up the iso-surface in a 3-d box into triangles.
C     SBSRF6     Paints a triangular patch of an iso-surface.
C
C History
C   D. S. Sivia       3 May 1995  Initial release.
C   D. S. Sivia       7 Jul 1995  Fixed bug in determinant calculation.
C   D. S. Sivia      20 Oct 1995  Speeded up computations slightly.
C   D. S. Sivia      13 Dec 1995  A bit more tinkering for speed.
C   D. S. Sivia      14 Jun 1996  Completely new algorithm!
C   D. S. Sivia      24 Oct 1997 "Safe-guarded" some rounding errors.
C-----------------------------------------------------------------------
C
C Carry out some initial checks.
C
      SMALL=1.0E-10
      SMALL2=SMALL**2
      DSMAL2=DBLE(SMALL2)
      IF (EYE(3).LE.SMALL) RETURN
      IF (N1.LT.1 .OR. N2.LT.1 .OR. N3.LT.1) RETURN
      XL2=LIGHT(1)**2+LIGHT(2)**2+LIGHT(3)**2
      IF (XL2.LT.SMALL) RETURN
      IF (LATICE(3,1).GE.0.0) RETURN
      ZFAR=LATICE(3,2)+LATICE(3,3)+LATICE(3,4)-2.0*LATICE(3,1)
      IF (ZFAR.GE.0.0) RETURN
      DO 10 J=1,3
        IF (LATICE(3,J+1).GE.0.0) RETURN
        BAS(1,J)=LATICE(1,J+1)-LATICE(1,1)
        BAS(2,J)=LATICE(2,J+1)-LATICE(2,1)
        BAS(3,J)=LATICE(3,J+1)-LATICE(3,1)
        IF ((ZFAR-BAS(3,J)).GE.0.0) RETURN
        BAS2J=BAS(1,J)**2+BAS(2,J)**2+BAS(3,J)**2
        IF (BAS2J.LT.SMALL2) RETURN
  10  CONTINUE
      NTOT=(N1+1)*(N2+1)*(N3+1)
      CALL SBSRF0(DENS,NTOT,DSURF,LEMPTY)


      IF (LEMPTY) RETURN
C
C Set up matrix for real-space to lattice-index transformation.
C
      XN1=0.99999*FLOAT(N1)
      XN2=0.99999*FLOAT(N2)
      XN3=0.99999*FLOAT(N3)
      DET=BAS(1,1)*BAS(2,2)*BAS(3,3)+BAS(1,2)*BAS(2,3)*BAS(3,1)
     *   +BAS(1,3)*BAS(2,1)*BAS(3,2)-BAS(3,1)*BAS(2,2)*BAS(1,3)
     *   -BAS(3,2)*BAS(2,3)*BAS(1,1)-BAS(3,3)*BAS(2,1)*BAS(1,2)
      IF (ABS(DET).LT.SMALL2) RETURN
      DETNRM=1.0/DET
      MTRX(1,1)=XN1*DETNRM*(BAS(2,2)*BAS(3,3)-BAS(2,3)*BAS(3,2))
      MTRX(1,2)=XN2*DETNRM*(BAS(2,3)*BAS(3,1)-BAS(2,1)*BAS(3,3))
      MTRX(1,3)=XN3*DETNRM*(BAS(2,1)*BAS(3,2)-BAS(2,2)*BAS(3,1))
      MTRX(2,1)=XN1*DETNRM*(BAS(3,2)*BAS(1,3)-BAS(3,3)*BAS(1,2))
      MTRX(2,2)=XN2*DETNRM*(BAS(3,3)*BAS(1,1)-BAS(3,1)*BAS(1,3))
      MTRX(2,3)=XN3*DETNRM*(BAS(3,1)*BAS(1,2)-BAS(3,2)*BAS(1,1))
      MTRX(3,1)=XN1*DETNRM*(BAS(1,2)*BAS(2,3)-BAS(1,3)*BAS(2,2))
      MTRX(3,2)=XN2*DETNRM*(BAS(1,3)*BAS(2,1)-BAS(1,1)*BAS(2,3))
      MTRX(3,3)=XN3*DETNRM*(BAS(1,1)*BAS(2,2)-BAS(1,2)*BAS(2,1))
      CALL SBRCOP(LATICE,ORIG,3)
C
C Some general initialisations.
C
      DDSURF=MAX(ABS(DSURF),SMALL)
      IF (DSURF.LT.0.0) DDSURF=-DDSURF
      GRDSCL(1)=-0.5/(DDSURF*FLOAT(N1))
      GRDSCL(2)=-0.5/(DDSURF*FLOAT(N2))
      GRDSCL(3)=-0.5/(DDSURF*FLOAT(N3))
      COL0=FLOAT(IC1)
      COLSCL=FLOAT(IC2-IC1)
      DO 30 I=1,3
        DXYZ(I,1)=BAS(I,1)/FLOAT(N1)
        DXYZ(I,2)=BAS(I,2)/FLOAT(N2)
        DXYZ(I,3)=BAS(I,3)/FLOAT(N3)
        DDXYZ(I,1,1)=0.0
        DDXYZ(I,1,2)=DXYZ(I,1)
        DDXYZ(I,2,1)=DDXYZ(I,1,1)+DDXYZ(I,1,2)
        DDXYZ(I,2,2)=DXYZ(I,2)
        DDXYZ(I,3,1)=DDXYZ(I,2,1)+DDXYZ(I,2,2)
        DDXYZ(I,3,2)=-DXYZ(I,1)
        DDXYZ(I,4,1)=DDXYZ(I,3,1)+DDXYZ(I,3,2)
        DDXYZ(I,4,2)=-DXYZ(I,2)
        DO 20 J=1,4
          DDXYZ(I,J+4,1)=DDXYZ(I,J,1)
          DDXYZ(I,J+4,2)=DXYZ(I,3)
          DDXYZ(I,J+8,1)=DDXYZ(I,J,1)+DXYZ(I,3)
          DDXYZ(I,J+8,2)=DDXYZ(I,J,2)
  20    CONTINUE
  30  CONTINUE

C
C First paint the edges of the lattice.
C
      DO 60 IFACE=1,3
        I=IFACE
        J=MOD(IFACE,3)+1
        K=MOD(J,3)+1
        IF (IFACE.EQ.1) THEN
          IN=N1
          JN=N2
        ELSEIF (IFACE.EQ.2) THEN
          IN=N2
          JN=N3
        ELSE
          IN=N3
          JN=N1
        ENDIF
        KK=0
        XN=BAS(2,J)*BAS(3,I)-BAS(2,I)*BAS(3,J)
        YN=BAS(3,J)*BAS(1,I)-BAS(3,I)*BAS(1,J)
        ZN=BAS(1,J)*BAS(2,I)-BAS(1,I)*BAS(2,J)
        DNRM=SQRT(XN**2+YN**2+ZN**2+SMALL2)
        PNEYE(1)=DBLE(EYE(1)-0.5*(LATICE(1,I+1)+LATICE(1,J+1)))
        PNEYE(2)=DBLE(EYE(2)-0.5*(LATICE(2,I+1)+LATICE(2,J+1)))
        PNEYE(3)=DBLE(EYE(3)-0.5*(LATICE(3,I+1)+LATICE(3,J+1)))
        DEYE=SNGL(DSQRT(PNEYE(1)**2+PNEYE(2)**2+PNEYE(3)**2+DSMAL2))
        XLNORM=DBLE(XN)*PNEYE(1)+DBLE(YN)*PNEYE(2)+DBLE(ZN)*PNEYE(3)
        COSSEE=SNGL(XLNORM)/(DEYE*DNRM)
        IF (COSSEE.LT.0.001) THEN
          KK=N3
          IF (IFACE.EQ.2) KK=N1
          IF (IFACE.EQ.3) KK=N2
          PNEYE(1)=PNEYE(1)+DBLE(BAS(1,K))
          PNEYE(2)=PNEYE(2)+DBLE(BAS(2,K))
          PNEYE(3)=PNEYE(3)+DBLE(BAS(3,K))
          DEYE=SNGL(DSQRT(PNEYE(1)**2+PNEYE(2)**2+PNEYE(3)**2+DSMAL2))
          XLNORM=DBLE(XN)*PNEYE(1)+DBLE(YN)*PNEYE(2)+DBLE(ZN)*PNEYE(3)
          COSSEE=-SNGL(XLNORM)/(DEYE*DNRM)
        ENDIF
        IF (COSSEE.GT.0.001) THEN
          XYZ1=FLOAT(KK)*DXYZ(1,K)+LATICE(1,1)
          XYZ2=FLOAT(KK)*DXYZ(2,K)+LATICE(2,1)
          XYZ3=FLOAT(KK)*DXYZ(3,K)+LATICE(3,1)
          DO 50 J1=1,JN
            J0=J1-1
            DO 40 I1=1,IN
              I0=I1-1
              IF (IFACE.EQ.1) THEN
                DLOCAL(1)=DENS(I0,J0,KK)-DSURF
                DLOCAL(2)=DENS(I1,J0,KK)-DSURF
                DLOCAL(3)=DENS(I1,J1,KK)-DSURF
                DLOCAL(4)=DENS(I0,J1,KK)-DSURF
              ELSEIF (IFACE.EQ.2) THEN
                DLOCAL(1)=DENS(KK,I0,J0)-DSURF
                DLOCAL(2)=DENS(KK,I1,J0)-DSURF
                DLOCAL(3)=DENS(KK,I1,J1)-DSURF
                DLOCAL(4)=DENS(KK,I0,J1)-DSURF
              ELSE
                DLOCAL(1)=DENS(J0,KK,I0)-DSURF
                DLOCAL(2)=DENS(J0,KK,I1)-DSURF
                DLOCAL(3)=DENS(J1,KK,I1)-DSURF
                DLOCAL(4)=DENS(J1,KK,I0)-DSURF
              ENDIF
              CALL SBSRF1(DLOCAL,IBSIDE,FRCXYZ)
              IF (IBSIDE.NE.0) THEN
                XYZ(1)=XYZ1+DXYZ(1,I)*FLOAT(I0)
                XYZ(2)=XYZ2+DXYZ(2,I)*FLOAT(I0)
                XYZ(3)=XYZ3+DXYZ(3,I)*FLOAT(I0)
                CALL SBSRF2(XYZ,DXYZ(1,I),DXYZ(1,J),IBSIDE,FRCXYZ,VERT,
     *                      EYE,LIGHT,LSHINE)
              ENDIF
  40        CONTINUE
            XYZ1=XYZ1+DXYZ(1,J)
            XYZ2=XYZ2+DXYZ(2,J)
            XYZ3=XYZ3+DXYZ(3,J)
  50      CONTINUE
        ENDIF
  60  CONTINUE
C
C Step through each "cube" in the lattice, and paint any isosurfaces
C found therein.
C
      X00K=LATICE(1,1)
      Y00K=LATICE(2,1)
      Z00K=LATICE(3,1)
      DO 90 K1=1,N3
        K0=K1-1
        DO 80 J1=1,N2
          J0=J1-1
          X0JK=X00K+DXYZ(1,2)*FLOAT(J0)
          Y0JK=Y00K+DXYZ(2,2)*FLOAT(J0)
          Z0JK=Z00K+DXYZ(3,2)*FLOAT(J0)
          DO 70 I1=1,N1
            I0=I1-1
            DLOCAL(1)=DENS(I0,J0,K0)-DSURF
            DLOCAL(2)=DENS(I1,J0,K0)-DSURF
            DLOCAL(3)=DENS(I1,J1,K0)-DSURF
            DLOCAL(4)=DENS(I0,J1,K0)-DSURF
            DLOCAL(5)=DENS(I0,J0,K1)-DSURF
            DLOCAL(6)=DENS(I1,J0,K1)-DSURF
            DLOCAL(7)=DENS(I1,J1,K1)-DSURF
            DLOCAL(8)=DENS(I0,J1,K1)-DSURF
            CALL SBSRF3(DLOCAL,IVERT,FRCXYZ,ISUMV,ISUMF)
            IF (ISUMV.NE.0) THEN
              XYZ(1)=X0JK+DXYZ(1,1)*FLOAT(I0)
              XYZ(2)=Y0JK+DXYZ(2,1)*FLOAT(I0)
              XYZ(3)=Z0JK+DXYZ(3,1)*FLOAT(I0)
              CALL SBSRF4(DENS,N1,N2,N3,I0,J0,K0,GRDSCL,BAS,GRDCUB)
              CALL SBSRF5(XYZ,DDXYZ,ISUMV,ISUMF,IVERT,FRCXYZ,VERT,EYE,
     *                    LIGHT,LSHINE)
            ENDIF
  70      CONTINUE
  80    CONTINUE
        X00K=X00K+DXYZ(1,3)
        Y00K=Y00K+DXYZ(2,3)
        Z00K=Z00K+DXYZ(3,3)
  90  CONTINUE
      END
C
      SUBROUTINE SBSRF0(DENS,NTOT,DSURF,LEMPTY)
C     -----------------------------------------
C
      REAL    DENS(*)
      LOGICAL LEMPTY
C
      LEMPTY=.TRUE.
      DO 10 I=1,NTOT
        IF (DENS(I).GT.DSURF) THEN
          LEMPTY=.FALSE.
          RETURN
        ENDIF
  10  CONTINUE
      END
C
      SUBROUTINE SBSRF1(D,IB,DF)
C     --------------------------
C
      REAL D(*),DF(*)
      DATA SMALL /1.0E-20/
C
      IB=0
      IF (D(1).GE.0.0) IB=1
      IF (D(2).GE.0.0) IB=IB+2
      IF (D(3).GE.0.0) IB=IB+4
      IF (D(4).GE.0.0) IB=IB+8
      IF (IB.EQ.0 .OR. IB.EQ.15) RETURN
      DO 10 I=1,4
        J=1+MOD(I,4)
        IF (D(I)*D(J).LT.-SMALL) THEN
          DI=ABS(D(I))
          DF(I)=DI/(DI+ABS(D(J)))
        ENDIF
  10  CONTINUE
      END
C
      SUBROUTINE SBSRF2(XYZ,D1,D2,IB,FRC,VERT,EYE,LIGHT,LSHINE)
C     ---------------------------------------------------------
C
      REAL    XYZ(*),D1(*),D2(*),FRC(*),VERT(3,*),EYE(*),LIGHT(*)
      LOGICAL LSHINE
C
      IF (IB.EQ.15) THEN
        DO 10 I=1,3
          VERT(I,1)=XYZ(I)
          VERT(I,2)=XYZ(I)+D1(I)
          VERT(I,3)=VERT(I,2)+D2(I)
          VERT(I,4)=XYZ(I)+D2(I)
  10    CONTINUE
        CALL SBSRF6(EYE,4,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.1) THEN
        DO 20 I=1,3
          VERT(I,1)=XYZ(I)
          VERT(I,2)=VERT(I,1)+FRC(1)*D1(I)
          VERT(I,3)=XYZ(I)+(1.0-FRC(4))*D2(I)
  20    CONTINUE
        CALL SBSRF6(EYE,3,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.2) THEN
        DO 30 I=1,3
          VERT(I,1)=XYZ(I)+D1(I)
          VERT(I,2)=VERT(I,1)+FRC(2)*D2(I)
          VERT(I,3)=XYZ(I)+FRC(1)*D1(I)
  30    CONTINUE
        CALL SBSRF6(EYE,3,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.4) THEN
        DO 40 I=1,3
          VERT(I,1)=XYZ(I)+D1(I)+D2(I)
          VERT(I,2)=VERT(I,1)-FRC(3)*D1(I)
          VERT(I,3)=VERT(I,1)-(1.0-FRC(2))*D2(I)
  40    CONTINUE
        CALL SBSRF6(EYE,3,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.8) THEN
        DO 50 I=1,3
          VERT(I,1)=XYZ(I)+D2(I)
          VERT(I,2)=VERT(I,1)-FRC(4)*D2(I)
          VERT(I,3)=VERT(I,1)+(1.0-FRC(3))*D1(I)
  50    CONTINUE
        CALL SBSRF6(EYE,3,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.7) THEN
        DO 60 I=1,3
          VERT(I,1)=XYZ(I)
          VERT(I,2)=VERT(I,1)+D1(I)
          VERT(I,3)=VERT(I,2)+D2(I)
          VERT(I,4)=VERT(I,3)-FRC(3)*D1(I)
          VERT(I,5)=XYZ(I)+(1.0-FRC(4))*D2(I)
  60    CONTINUE
        CALL SBSRF6(EYE,5,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.14) THEN
        DO 70 I=1,3
          VERT(I,1)=XYZ(I)+D1(I)
          VERT(I,2)=VERT(I,1)+D2(I)
          VERT(I,3)=XYZ(I)+D2(I)
          VERT(I,4)=XYZ(I)+(1.0-FRC(4))*D2(I)
          VERT(I,5)=XYZ(I)+FRC(1)*D1(I)
  70    CONTINUE
        CALL SBSRF6(EYE,5,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.13) THEN
        DO 80 I=1,3
          VERT(I,1)=XYZ(I)+D1(I)+D2(I)
          VERT(I,2)=XYZ(I)+D2(I)
          VERT(I,3)=XYZ(I)
          VERT(I,4)=XYZ(I)+FRC(1)*D1(I)
          VERT(I,5)=XYZ(I)+D1(I)+FRC(2)*D2(I)
  80    CONTINUE
        CALL SBSRF6(EYE,5,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.11) THEN
        DO 90 I=1,3
          VERT(I,1)=XYZ(I)+D2(I)
          VERT(I,2)=XYZ(I)
          VERT(I,3)=XYZ(I)+D1(I)
          VERT(I,4)=VERT(I,3)+FRC(2)*D2(I)
          VERT(I,5)=VERT(I,1)+(1.0-FRC(3))*D1(I)
  90    CONTINUE
        CALL SBSRF6(EYE,5,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.3) THEN
        DO 100 I=1,3
          VERT(I,1)=XYZ(I)
          VERT(I,2)=XYZ(I)+D1(I)
          VERT(I,3)=VERT(I,2)+FRC(2)*D2(I)
          VERT(I,4)=XYZ(I)+(1.0-FRC(4))*D2(I)
 100    CONTINUE
        CALL SBSRF6(EYE,4,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.6) THEN
        DO 110 I=1,3
          VERT(I,1)=XYZ(I)+D1(I)
          VERT(I,2)=VERT(I,1)+D2(I)
          VERT(I,3)=VERT(I,2)-FRC(3)*D1(I)
          VERT(I,4)=XYZ(I)+FRC(1)*D1(I)
 110    CONTINUE
        CALL SBSRF6(EYE,4,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.12) THEN
        DO 120 I=1,3
          VERT(I,1)=XYZ(I)+D1(I)+D2(I)
          VERT(I,2)=XYZ(I)+D2(I)
          VERT(I,3)=VERT(I,2)-FRC(4)*D2(I)
          VERT(I,4)=XYZ(I)+D1(I)+FRC(2)*D2(I)
 120    CONTINUE
        CALL SBSRF6(EYE,4,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.9) THEN
        DO 130 I=1,3
          VERT(I,1)=XYZ(I)+D2(I)
          VERT(I,2)=XYZ(I)
          VERT(I,3)=XYZ(I)+FRC(1)*D1(I)
          VERT(I,4)=VERT(I,1)+(1.0-FRC(3))*D1(I)
 130    CONTINUE
        CALL SBSRF6(EYE,4,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.5) THEN
        DO 140 I=1,3
          VERT(I,1)=XYZ(I)
          VERT(I,2)=VERT(I,1)+FRC(1)*D1(I)
          VERT(I,3)=XYZ(I)+(1.0-FRC(4))*D2(I)
          VERT(I,4)=XYZ(I)+D1(I)+D2(I)
          VERT(I,5)=VERT(I,4)-FRC(3)*D1(I)
          VERT(I,6)=VERT(I,4)-(1.0-FRC(2))*D2(I)
 140    CONTINUE
        CALL SBSRF6(EYE,3,VERT,LSHINE,LIGHT,0) 
        CALL SBSRF6(EYE,3,VERT(1,4),LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.10) THEN
        DO 150 I=1,3
          VERT(I,1)=XYZ(I)+D1(I)
          VERT(I,2)=VERT(I,1)+FRC(2)*D2(I)
          VERT(I,3)=XYZ(I)+FRC(1)*D1(I)
          VERT(I,4)=XYZ(I)+D2(I)
          VERT(I,5)=VERT(I,4)-FRC(4)*D2(I)
          VERT(I,6)=VERT(I,4)+(1.0-FRC(3))*D1(I)
 150    CONTINUE
        CALL SBSRF6(EYE,3,VERT,LSHINE,LIGHT,0) 
        CALL SBSRF6(EYE,3,VERT(1,4),LSHINE,LIGHT,0) 
      ENDIF
      END
C
      SUBROUTINE SBSRF3(D,IVERT,DF,ISUMV,ISUMF)
C     -----------------------------------------
C
      REAL    D(*),DF(*)
      INTEGER IVERT(*),IC(8)
      DATA    SMALL /1.0E-20/
C
      ISUMV=0
      DO 10 I=1,8
        IF (D(I).LT.0.0) THEN
          IC(I)=0
        ELSE
          IC(I)=1
          ISUMV=ISUMV+1
        ENDIF
  10  CONTINUE
      IF (ISUMV.EQ.0 .OR. ISUMV.EQ.8) THEN
        ISUMV=0
        RETURN
      ENDIF
      IF (ISUMV.GT.4) THEN
        ISUMV=8-ISUMV
        DO 20 I=1,8
  20      IC(I)=MOD(IC(I)+1,2)
      ENDIF
      J=0
      DO 30 I=1,8
        IF (IC(I).EQ.1) THEN
          J=J+1
          IVERT(J)=I
        ENDIF
  30  CONTINUE
      ISUMF=0
      DO 40 I=1,4
        J=1+MOD(I,4)
        IF (D(I)*D(J).LT.-SMALL) THEN
          DI=ABS(D(I))
          DF(I)=DI/(DI+ABS(D(J)))
          ISUMF=ISUMF+1
        ENDIF
        K=I+4
        IF (D(I)*D(K).LT.-SMALL) THEN
          DI=ABS(D(I))
          DF(K)=DI/(DI+ABS(D(K)))
          ISUMF=ISUMF+1
        ENDIF
        L=J+4
        IF (D(K)*D(L).LT.-SMALL) THEN
          DK=ABS(D(K))
          DF(I+8)=DK/(DK+ABS(D(L)))
          ISUMF=ISUMF+1
        ENDIF
  40  CONTINUE
      END
C
      SUBROUTINE SBSRF4(DENS,N1,N2,N3,I0,J0,K0,GRDSCL,BAS,GRD)
C     --------------------------------------------------------
C
      REAL DENS(0:N1,0:N2,0:N3),GRDSCL(*),BAS(3,*),GRD(3,*)
      REAL G(3,8)
C
      IM=I0-1
      IF (IM.LT.0) IM=N1
      JM=J0-1
      IF (JM.LT.0) JM=N2
      KM=K0-1
      IF (KM.LT.0) KM=N3
      I1=I0+1
      J1=J0+1
      K1=K0+1
      IP=I1+1
      IF (IP.GT.N1) IP=0
      JP=J1+1
      IF (JP.GT.N2) JP=0
      KP=K1+1
      IF (KP.GT.N3) KP=0
      G(1,1)=GRDSCL(1)*(DENS(I1,J0,K0)-DENS(IM,J0,K0))
      G(2,1)=GRDSCL(2)*(DENS(I0,J1,K0)-DENS(I0,JM,K0))
      G(3,1)=GRDSCL(3)*(DENS(I0,J0,K1)-DENS(I0,J0,KM))
      G(1,2)=GRDSCL(1)*(DENS(IP,J0,K0)-DENS(I0,J0,K0))
      G(2,2)=GRDSCL(2)*(DENS(I1,J1,K0)-DENS(I1,JM,K0))
      G(3,2)=GRDSCL(3)*(DENS(I1,J0,K1)-DENS(I1,J0,KM))
      G(1,3)=GRDSCL(1)*(DENS(IP,J1,K0)-DENS(I0,J1,K0))
      G(2,3)=GRDSCL(2)*(DENS(I1,JP,K0)-DENS(I1,J0,K0))
      G(3,3)=GRDSCL(3)*(DENS(I1,J1,K1)-DENS(I1,J1,KM))
      G(1,4)=GRDSCL(1)*(DENS(I1,J1,K0)-DENS(IM,J1,K0))
      G(2,4)=GRDSCL(2)*(DENS(I0,JP,K0)-DENS(I0,J0,K0))
      G(3,4)=GRDSCL(3)*(DENS(I0,J1,K1)-DENS(I0,J1,KM))
      G(1,5)=GRDSCL(1)*(DENS(I1,J0,K1)-DENS(IM,J0,K1))
      G(2,5)=GRDSCL(2)*(DENS(I0,J1,K1)-DENS(I0,JM,K1))
      G(3,5)=GRDSCL(3)*(DENS(I0,J0,KP)-DENS(I0,J0,K0))
      G(1,6)=GRDSCL(1)*(DENS(IP,J0,K1)-DENS(I0,J0,K1))
      G(2,6)=GRDSCL(2)*(DENS(I1,J1,K1)-DENS(I1,JM,K1))
      G(3,6)=GRDSCL(3)*(DENS(I1,J0,KP)-DENS(I1,J0,K0))
      G(1,7)=GRDSCL(1)*(DENS(IP,J1,K1)-DENS(I0,J1,K1))
      G(2,7)=GRDSCL(2)*(DENS(I1,JP,K1)-DENS(I1,J0,K1))
      G(3,7)=GRDSCL(3)*(DENS(I1,J1,KP)-DENS(I1,J1,K0))
      G(1,8)=GRDSCL(1)*(DENS(I1,J1,K1)-DENS(IM,J1,K1))
      G(2,8)=GRDSCL(2)*(DENS(I0,JP,K1)-DENS(I0,J0,K1))
      G(3,8)=GRDSCL(3)*(DENS(I0,J1,KP)-DENS(I0,J1,K0))
      DO 20 J=1,8
        DO 10 I=1,3
  10      GRD(I,J)=G(1,J)*BAS(I,1)+G(2,J)*BAS(I,2)+G(3,J)*BAS(I,3)
  20  CONTINUE
      END
C
      SUBROUTINE SBSRF5(XYZ,DXYZ,ISV,ISF,IV,FRC,VERT,EYE,LIGHT,LSHINE)
C     ----------------------------------------------------------------
C
      REAL    XYZ(*),DXYZ(3,12,*),FRC(*),VERT(3,*),EYE(*),LIGHT(*)
      INTEGER IV(*),IV4MAP(12)
      LOGICAL LSHINE
      DATA    IV4MAP /12,8,4,3,11,7,6,2,10,9,5,1/
C
      IF (ISV.EQ.1) THEN
        CALL SBSF5A(XYZ,DXYZ,FRC,VERT,IV(1),EYE,LSHINE,LIGHT)
      ELSEIF (ISV.EQ.2) THEN
        IF (ISF.EQ.6) THEN
          CALL SBSF5A(XYZ,DXYZ,FRC,VERT,IV(1),EYE,LSHINE,LIGHT)
          CALL SBSF5A(XYZ,DXYZ,FRC,VERT,IV(2),EYE,LSHINE,LIGHT)
        ELSE
          IJDIF=IV(2)-IV(1)
          IF (IV(1).LE.4) THEN
            IF (IV(2).LE.4) THEN
              K2=IV(1)
              IF (IJDIF.EQ.3) K2=IV(2)
            ELSE
              K2=IV(2)
            ENDIF
          ELSE
            K2=IV(1)+4
            IF (IJDIF.EQ.3) K2=IV(2)+4
          ENDIF
          CALL SBSF5B(XYZ,DXYZ,FRC,VERT,K2,EYE,LSHINE,LIGHT,1)
        ENDIF
      ELSEIF (ISV.EQ.3) THEN
        IF (ISF.EQ.9) THEN
          DO 10 I=1,3
  10        CALL SBSF5A(XYZ,DXYZ,FRC,VERT,IV(I),EYE,LSHINE,LIGHT)
        ELSEIF (ISF.EQ.6) THEN
          DO 20 I1=1,3
            I2=1+MOD(I1,3)
            I=MIN(I1,I2)
            J=MAX(I1,I2)
            K2=0
            IJDIF=IV(J)-IV(I)
            IF (IV(I).LE.4) THEN
              IF (IV(J).LE.4) THEN
                IF (IJDIF.EQ.1) THEN
                  K2=IV(I)
                ELSEIF (IJDIF.EQ.3) THEN
                  K2=IV(J)
                ENDIF
              ELSE
                IF (IJDIF.EQ.4) K2=IV(J)
              ENDIF
            ELSE
              IF (IJDIF.EQ.1) THEN
                K2=IV(I)+4
              ELSEIF (IJDIF.EQ.3) THEN
                K2=IV(J)+4
              ENDIF
            ENDIF
            IF (K2.GT.0) GOTO 1
  20      CONTINUE
   1      CALL SBSF5B(XYZ,DXYZ,FRC,VERT,K2,EYE,LSHINE,LIGHT,1)
        ELSE
          K3=IV(1)+IV(2)+IV(3)-5+2*(IV(1)/5+2*(IV(2)/5)+IV(3)/5)
          CALL SBSF5C(XYZ,DXYZ,FRC,VERT,K3,EYE,LSHINE,LIGHT)
        ENDIF
      ELSE
        IF (ISF.EQ.12) THEN
          DO 30 I=1,4
  30        CALL SBSF5A(XYZ,DXYZ,FRC,VERT,IV(I),EYE,LSHINE,LIGHT)
        ELSEIF (ISF.EQ.4) THEN
          K4=(IV(1)+IV(2)+IV(3)+IV(4)-6)/4
          IF ((IV(2)-IV(1)).EQ.3) K4=6
          CALL SBSF5B(XYZ,DXYZ,FRC,VERT,K4,EYE,LSHINE,LIGHT,2)
        ELSEIF (ISF.EQ.6) THEN
          IF (IV(3).LE.4) THEN
            K3=IV(1)+IV(2)+IV(3)-6
            K4=MOD((IV(4)+K3),4)+3*K3
          ELSE
            IF (IV(2).GE.5) THEN
              K3=IV(2)+IV(3)+IV(4)-18
              K4=IV4MAP(MOD((IV(1)+K3),4)+3*K3)
            ELSE
              K4=12+IV(3)-IV(2)
              IF ((IV(1)+IV(2)+IV(3)+IV(4)).EQ.22) K4=29-K4
            ENDIF
          ENDIF
          CALL SBSF5D(XYZ,DXYZ,FRC,VERT,K4,EYE,LSHINE,LIGHT)
        ELSE
          K4=IV(1)+IV(2)+IV(3)+IV(4)
          IF (K4.EQ.16 .OR. K4.EQ.20) THEN          
            CALL SBSF5B(XYZ,DXYZ,FRC,VERT,IV(3),EYE,LSHINE,LIGHT,1)
            CALL SBSF5B(XYZ,DXYZ,FRC,VERT,IV(4),EYE,LSHINE,LIGHT,1)
          ELSEIF (K4.EQ.18) THEN
            K4A=IV(1)
            IF ((IV(2)-K4A).EQ.3) K4A=4
            K4B=9+MOD(K4A+1,4)
            CALL SBSF5B(XYZ,DXYZ,FRC,VERT,K4A,EYE,LSHINE,LIGHT,1)
            CALL SBSF5B(XYZ,DXYZ,FRC,VERT,K4B,EYE,LSHINE,LIGHT,1)
          ELSE
            IF (K4.EQ.14) THEN
              K4A=IV(4)
              K3=IV(1)+IV(2)+IV(3)-5+2*(IV(1)/5+2*(IV(2)/5)+IV(3)/5)
            ELSEIF (K4.EQ.22) THEN
              K4A=IV(1)
              K3=IV(2)+IV(3)+IV(4)-5+2*(IV(2)/5+2*(IV(3)/5)+IV(4)/5)
            ELSE
              IF (MOD((IV(1)+IV(2)),2).EQ.0) THEN
                IF (IV(4).EQ.6 .OR. (IV(3)-IV(2)).EQ.2) THEN
                  K4A=IV(2)
                  K3=IV(1)+IV(3)+IV(4)-5+2*(IV(1)/5+2*(IV(3)/5)+IV(4)/5)
                ELSE
                  K4A=IV(1)
                  K3=IV(2)+IV(3)+IV(4)-5+2*(IV(2)/5+2*(IV(3)/5)+IV(4)/5)
                ENDIF
              ELSE
                IF (IV(1).EQ.3 .OR. (IV(3)-IV(2)).EQ.2) THEN
                  K4A=IV(3)
                  K3=IV(1)+IV(2)+IV(4)-5+2*(IV(1)/5+2*(IV(2)/5)+IV(4)/5)
                ELSE
                  K4A=IV(4)
                  K3=IV(1)+IV(2)+IV(3)-5+2*(IV(1)/5+2*(IV(2)/5)+IV(3)/5)
                ENDIF
              ENDIF
            ENDIF
            CALL SBSF5A(XYZ,DXYZ,FRC,VERT,K4A,EYE,LSHINE,LIGHT)
            CALL SBSF5C(XYZ,DXYZ,FRC,VERT,K3,EYE,LSHINE,LIGHT)
          ENDIF
        ENDIF
      ENDIF
      END
C
      SUBROUTINE SBSF5A(XYZ,DXYZ,FRC,VERT,IV,EYE,LSHINE,LIGHT)
C     ---------------------------------------------------------
C
      REAL    XYZ(*),DXYZ(3,12,*),FRC(*),VERT(3,*),EYE(*),LIGHT(*)
      LOGICAL LSHINE
C
      IF (IV.LE.4) THEN
        J=IV
        K=1+MOD(IV+2,4)
        L=IV+4
      ELSE
        J=IV+4
        K=9+MOD(IV-2,4)
        L=IV
      ENDIF
      DO 10 I=1,3
        VERT(I,1)=XYZ(I)+DXYZ(I,J,1)+FRC(J)*DXYZ(I,J,2)
        VERT(I,2)=XYZ(I)+DXYZ(I,K,1)+FRC(K)*DXYZ(I,K,2)
        VERT(I,3)=XYZ(I)+DXYZ(I,L,1)+FRC(L)*DXYZ(I,L,2)
  10  CONTINUE
      CALL SBSRF6(EYE,3,VERT,LSHINE,LIGHT,1) 
      END  
C
      SUBROUTINE SBSF5B(XYZ,DXYZ,FRC,VERT,KK,EYE,LSHINE,LIGHT,LL)
C     ------------------------------------------------------------
C
      REAL    XYZ(*),DXYZ(3,12,*),FRC(*),VERT(3,*),EYE(*),LIGHT(*)
      INTEGER IVL(4,12,2)
      LOGICAL LSHINE
      DATA    IVL /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,24*0/
C
      J=IVL(1,KK,LL)
      K=IVL(2,KK,LL)
      L=IVL(3,KK,LL)
      M=IVL(4,KK,LL)
      DO 10 I=1,3
        VERT(I,1)=XYZ(I)+DXYZ(I,J,1)+FRC(J)*DXYZ(I,J,2)
        VERT(I,2)=XYZ(I)+DXYZ(I,K,1)+FRC(K)*DXYZ(I,K,2)
        VERT(I,3)=XYZ(I)+DXYZ(I,L,1)+FRC(L)*DXYZ(I,L,2)
        VERT(I,4)=XYZ(I)+DXYZ(I,M,1)+FRC(M)*DXYZ(I,M,2)
        VERT(I,5)=VERT(I,1)
        VERT(I,6)=0.25*(VERT(I,1)+VERT(I,2)+VERT(I,3)+VERT(I,4))
  10  CONTINUE
      DO 20 I=1,4
        CALL SBRCOP(VERT(1,I),VERT(1,7),6)
        CALL SBSRF6(EYE,3,VERT(1,6),LSHINE,LIGHT,1)
  20  CONTINUE
      END  
C
      SUBROUTINE SBSF5C(XYZ,DXYZ,FRC,VERT,K3,EYE,LSHINE,LIGHT)
C     ---------------------------------------------------------
C
      REAL    XYZ(*),DXYZ(3,12,*),FRC(*),VERT(3,*),EYE(*),LIGHT(*)
      INTEGER IV3(5,24)
      LOGICAL LSHINE
      DATA    IV3 /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/
C
      J=IV3(1,K3)
      K=IV3(2,K3)
      L=IV3(3,K3)
      M=IV3(4,K3)
      N=IV3(5,K3)
      DO 10 I=1,3
        VERT(I,1)=XYZ(I)+DXYZ(I,J,1)+FRC(J)*DXYZ(I,J,2)
        VERT(I,2)=XYZ(I)+DXYZ(I,K,1)+FRC(K)*DXYZ(I,K,2)
        VERT(I,3)=XYZ(I)+DXYZ(I,L,1)+FRC(L)*DXYZ(I,L,2)
        VERT(I,4)=XYZ(I)+DXYZ(I,M,1)+FRC(M)*DXYZ(I,M,2)
        VERT(I,5)=XYZ(I)+DXYZ(I,N,1)+FRC(N)*DXYZ(I,N,2)
        VERT(I,6)=VERT(I,1)
        VERT(I,7)=0.2*(VERT(I,1)+VERT(I,2)+VERT(I,3)+VERT(I,4)+
     *                 VERT(I,5))
  10  CONTINUE
      DO 20 I=1,5
        CALL SBRCOP(VERT(1,I),VERT(1,8),6)
        CALL SBSRF6(EYE,3,VERT(1,7),LSHINE,LIGHT,1)
  20  CONTINUE
      END
C
      SUBROUTINE SBSF5D(XYZ,DXYZ,FRC,VERT,K4,EYE,LSHINE,LIGHT)
C     ---------------------------------------------------------
C
      REAL    XYZ(*),DXYZ(3,12,*),FRC(*),VERT(3,*),EYE(*),LIGHT(*)
      INTEGER IV4(6,16)
      LOGICAL LSHINE
      DATA    IV4 /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/
      DATA    VNORM /0.1666666667/
C
      CALL SBRFIL(VERT(1,8),0.0,3)
      DO 20 J=1,6
        K=IV4(J,K4)
        DO 10 I=1,3
          VERT(I,J)=XYZ(I)+DXYZ(I,K,1)+FRC(K)*DXYZ(I,K,2)
          VERT(I,8)=VERT(I,8)+VERT(I,J)
  10    CONTINUE
  20  CONTINUE
      CALL SBRCOP(VERT,VERT(1,7),3)
      DO 30 I=1,3
  30    VERT(I,8)=VERT(I,8)*VNORM
      DO 40 I=1,6
        CALL SBRCOP(VERT(1,I),VERT(1,9),6)
        CALL SBSRF6(EYE,3,VERT(1,8),LSHINE,LIGHT,1)
  40  CONTINUE
      END
C
      SUBROUTINE SBSRF6(EYE,NV,VERT,LSHINE,LIGHT,INSIDE)
C     --------------------------------------------------
C
      REAL             EYE(*),VERT(3,*),LIGHT(*)
      LOGICAL          LSHINE
C
      REAL*8           XLNORM,ZZ,DZZ
      REAL             XW(20),YW(20),MTRX
      LOGICAL          LPS,LCOLOR
      COMMON  /SRFCOM/ GRDCUB(3,8),MTRX(3,3),ORIG(3),XL2,COL0,COLSCL
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
C
C Carry out some initial checks and calculate the coordinates of the 
C projected triangle.
C
      IF (NV.LT.3 .OR. NV.GT.10) RETURN
      SMALL=1.0E-10
      XMIN=+1.0E20
      XMAX=-1.0E20
      YMIN=+1.0E20
      YMAX=-1.0E20
      DO 10 I=1,NV
        CALL SBLIN1(EYE,VERT(1,I),VERT(2,I),VERT(3,I),XW(I),YW(I))
        IF (XW(I).LT.XMIN) THEN
          XMIN=XW(I)
          ILEFT=I
        ENDIF
        IF (YW(I).LT.YMIN) THEN
          YMIN=YW(I)
          JBOTOM=I
        ENDIF
        XMAX=MAX(XW(I),XMAX)
        YMAX=MAX(YW(I),YMAX)
  10  CONTINUE
      IF (XMIN.GE.XTRC .OR. XMAX.LE.XBLC) RETURN
      IF (YMIN.GE.YTRC .OR. YMAX.LE.YBLC) RETURN
C
C Find the outward normal seen by the eye.
C
      AX=VERT(1,2)-VERT(1,1)
      AY=VERT(2,2)-VERT(2,1)
      AZ=VERT(3,2)-VERT(3,1)
      BX=VERT(1,1)-VERT(1,NV)
      BY=VERT(2,1)-VERT(2,NV)
      BZ=VERT(3,1)-VERT(3,NV)
      XN=BY*AZ-AY*BZ
      YN=BZ*AX-AZ*BX
      ZN=BX*AY-AX*BY
      TEN=XN*(EYE(1)-VERT(1,1))+YN*(EYE(2)-VERT(2,1))
     *   +ZN*(EYE(3)-VERT(3,1))
      IF (TEN.LT.0.0) THEN
        XN=-XN
        YN=-YN
        ZN=-ZN
        TEN=-TEN
      ENDIF
C
C Plot the projected triangle.
C
      XLNORM=DBLE(TEN)
      EYENRM=XN*EYE(1)+YN*EYE(2)+ZN*EYE(3)
      DX=FLOAT(NXP-1)/(XTRC-XBLC)
      DY=FLOAT(NYP-1)/(YTRC-YBLC)
      DYJ=1.0/DY
      DXI=1.0/DX
      SAFER=0.0001
      IF ((XMAX-XMIN).GT.(YMAX-YMIN)) THEN
        JYMIN=INT((YMIN-YBLC)*DY)+2
        JYMAX=MIN(INT((YMAX-YBLC)*DY)+1,NYP)
        IF (JYMIN.GT.JYMAX) RETURN
        YJ=YBLC+(FLOAT(JYMIN-1)+SAFER)*DYJ
        NVL2=JBOTOM
        NVR2=JBOTOM
        J1=JYMIN
        DO 40 IVERT=1,NV
          IF (YJ.GT.YW(NVL2)) THEN
   1        NVL1=NVL2
            NVL2=NVL1-1
            IF (NVL2.LT.1) NVL2=NV
            IF (NVL2.EQ.JBOTOM) RETURN
            IF (YJ.GT.YW(NVL2)) GOTO 1
            YDIFL=YW(NVL2)-YW(NVL1)
            IF (ABS(YDIFL).LT.SMALL) YDIFL=SMALL
            GRADL=(XW(NVL2)-XW(NVL1))/YDIFL
          ENDIF
          IF (YJ.GT.YW(NVR2)) THEN
   2        NVR1=NVR2
            NVR2=NVR1+1
            IF (NVR2.GT.NV) NVR2=1
            IF (NVR2.EQ.JBOTOM) RETURN
            IF (YJ.GT.YW(NVR2)) GOTO 2
            YDIFR=YW(NVR2)-YW(NVR1)
            IF (ABS(YDIFR).LT.SMALL) YDIFR=SMALL
            GRADR=(XW(NVR2)-XW(NVR1))/YDIFR
          ENDIF
          IF (YW(NVL2).LT.YW(NVR2)) THEN
            J2=MIN(INT((YW(NVL2)-YBLC)*DY)+1,JYMAX)
          ELSE
            J2=MIN(INT((YW(NVR2)-YBLC)*DY)+1,JYMAX)
          ENDIF
          DO 30 J=J1,J2
            IF (J.GE.1) THEN
              XL=XW(NVL1)+GRADL*(YJ-YW(NVL1))
              XR=XW(NVR1)+GRADR*(YJ-YW(NVR1))
              ISTEP=1
              IX1=MAX(INT((XL-XBLC)*DX)+2,1)
              IX2=MIN(INT((XR-XBLC)*DX)+1,NXP)
              IF (IX1.GT.IX2) THEN
                ISTEP=-1
                IX1=MIN(IX1-1,NXP)
                IX2=MAX(IX2+1,1)
              ENDIF
              XI=XBLC+FLOAT(IX1-1)*DXI
              SDXI=FLOAT(ISTEP)*DXI
              DZZ=DBLE(SDXI*XN)
              ZZ=DBLE(EYENRM-XI*XN-YJ*YN)
              K=(J-1)*NXP+IX1
              DO 20 I=IX1,IX2,ISTEP
                XLAMDA=SNGL(XLNORM/ZZ)
                Z=EYE(3)*(1.0-XLAMDA)
                IF (Z.GT.SBBUFF(K)) THEN
                  SBBUFF(K)=Z
                  X=EYE(1)+XLAMDA*(XI-EYE(1))
                  Y=EYE(2)+XLAMDA*(YJ-EYE(2))
                  IF (INSIDE.EQ.0) THEN
                    GX=XN
                    GY=YN
                    GZ=ZN
                  ELSE
                    CALL SBSF6A(X,Y,Z,ORIG,MTRX,GRDCUB,GX,GY,GZ)
                  ENDIF
                  CALL SBSF6B(EYE,X,Y,Z,GX,GY,GZ,LIGHT,XL2,LSHINE,CLR)
                  SBBUFF(KSTART+K)=COL0+COLSCL*CLR
                ENDIF
                XI=XI+SDXI
                ZZ=ZZ-DZZ
                K=K+ISTEP
  20          CONTINUE
            ENDIF
            YJ=YJ+DYJ
  30      CONTINUE
          J1=J2+1
          IF (J1.GT.JYMAX) RETURN
  40    CONTINUE
      ELSE
        IXMIN=INT((XMIN-XBLC)*DX)+2
        IXMAX=MIN(INT((XMAX-XBLC)*DX)+1,NXP)
        IF (IXMIN.GT.IXMAX) RETURN
        XI=XBLC+(FLOAT(IXMIN-1)+SAFER)*DXI
        NVL2=ILEFT
        NVR2=ILEFT
        I1=IXMIN
        DO 70 IVERT=1,NV
          IF (XI.GT.XW(NVL2)) THEN
   3        NVL1=NVL2
            NVL2=NVL1-1
            IF (NVL2.LT.1) NVL2=NV
            IF (NVL2.EQ.ILEFT) RETURN
            IF (XI.GT.XW(NVL2)) GOTO 3
            XDIFL=XW(NVL2)-XW(NVL1)
            IF (ABS(XDIFL).LT.SMALL) XDIFL=SMALL
            GRADL=(YW(NVL2)-YW(NVL1))/XDIFL
          ENDIF
          IF (XI.GT.XW(NVR2)) THEN
   4        NVR1=NVR2
            NVR2=NVR1+1
            IF (NVR2.GT.NV) NVR2=1
            IF (NVR2.EQ.ILEFT) RETURN
            IF (XI.GT.XW(NVR2)) GOTO 4
            XDIFR=XW(NVR2)-XW(NVR1)
            IF (ABS(XDIFR).LT.SMALL) XDIFR=SMALL
            GRADR=(YW(NVR2)-YW(NVR1))/XDIFR
          ENDIF
          IF (XW(NVL2).LT.XW(NVR2)) THEN
            I2=MIN(INT((XW(NVL2)-XBLC)*DX)+1,IXMAX)
          ELSE
            I2=MIN(INT((XW(NVR2)-XBLC)*DX)+1,IXMAX)
          ENDIF
          DO 60 I=I1,I2
            IF (I.GE.1) THEN
              YL=YW(NVL1)+GRADL*(XI-XW(NVL1))
              YR=YW(NVR1)+GRADR*(XI-XW(NVR1))
              ISTEP=1
              JY1=MAX(INT((YL-YBLC)*DY)+2,1)
              JY2=MIN(INT((YR-YBLC)*DY)+1,NYP)
              IF (JY1.GT.JY2) THEN
                ISTEP=-1
                JY1=MIN(JY1-1,NYP)
                JY2=MAX(JY2+1,1)
              ENDIF
              YJ=YBLC+FLOAT(JY1-1)*DYJ
              SDYJ=FLOAT(ISTEP)*DYJ
              DZZ=DBLE(SDYJ*YN)
              ZZ=DBLE(EYENRM-YJ*YN-XI*XN)
              K=(JY1-1)*NXP+I
              KSTEP=ISTEP*NXP
              DO 50 J=JY1,JY2,ISTEP
                XLAMDA=SNGL(XLNORM/ZZ)
                Z=EYE(3)*(1.0-XLAMDA)
                IF (Z.GT.SBBUFF(K)) THEN
                  SBBUFF(K)=Z
                  X=EYE(1)+XLAMDA*(XI-EYE(1))
                  Y=EYE(2)+XLAMDA*(YJ-EYE(2))
                  IF (INSIDE.EQ.0) THEN
                    GX=XN
                    GY=YN
                    GZ=ZN
                  ELSE
                    CALL SBSF6A(X,Y,Z,ORIG,MTRX,GRDCUB,GX,GY,GZ)
                  ENDIF
                  CALL SBSF6B(EYE,X,Y,Z,GX,GY,GZ,LIGHT,XL2,LSHINE,CLR)
                  SBBUFF(KSTART+K)=COL0+COLSCL*CLR
                ENDIF
                YJ=YJ+SDYJ
                ZZ=ZZ-DZZ
                K=K+KSTEP
  50          CONTINUE
            ENDIF
            XI=XI+DXI
  60      CONTINUE
          I1=I2+1
          IF (I1.GT.IXMAX) RETURN
  70    CONTINUE
      ENDIF
      END
C
      SUBROUTINE SBSF6A(X,Y,Z,ORIG,MTRX,GRD,XN,YN,ZN)
C     -----------------------------------------------
C
      REAL ORIG(*),MTRX(3,*),GRD(3,*)
      DATA ZERO,ONE /0.00001,0.99999/
C
      X0=X-ORIG(1)
      Y0=Y-ORIG(2)
      Z0=Z-ORIG(3)
      XI=X0*MTRX(1,1)+Y0*MTRX(2,1)+Z0*MTRX(3,1)
      YJ=X0*MTRX(1,2)+Y0*MTRX(2,2)+Z0*MTRX(3,2)
      ZK=X0*MTRX(1,3)+Y0*MTRX(2,3)+Z0*MTRX(3,3)
      DX=MIN(ONE,MAX(ZERO,XI-FLOAT(INT(XI))))
      DY=MIN(ONE,MAX(ZERO,YJ-FLOAT(INT(YJ))))
      DZ=MIN(ONE,MAX(ZERO,ZK-FLOAT(INT(ZK))))
      XN1=(1.0-DX)*(GRD(1,1)+DY*(GRD(1,4)-GRD(1,1)))
     *        +DX*(GRD(1,2)+DY*(GRD(1,3)-GRD(1,2)))
      XN2=(1.0-DX)*(GRD(1,5)+DY*(GRD(1,8)-GRD(1,5)))
     *        +DX*(GRD(1,6)+DY*(GRD(1,7)-GRD(1,6)))
      XN=XN1+DZ*(XN2-XN1)
      YN1=(1.0-DX)*(GRD(2,1)+DY*(GRD(2,4)-GRD(2,1)))
     *        +DX*(GRD(2,2)+DY*(GRD(2,3)-GRD(2,2)))
      YN2=(1.0-DX)*(GRD(2,5)+DY*(GRD(2,8)-GRD(2,5)))
     *        +DX*(GRD(2,6)+DY*(GRD(2,7)-GRD(2,6)))
      YN=YN1+DZ*(YN2-YN1)
      ZN1=(1.0-DX)*(GRD(3,1)+DY*(GRD(3,4)-GRD(3,1)))
     *        +DX*(GRD(3,2)+DY*(GRD(3,3)-GRD(3,2)))
      ZN2=(1.0-DX)*(GRD(3,5)+DY*(GRD(3,8)-GRD(3,5)))
     *        +DX*(GRD(3,6)+DY*(GRD(3,7)-GRD(3,6)))
      ZN=ZN1+DZ*(ZN2-ZN1)
      END
C
      SUBROUTINE SBSF6B(EYE,X,Y,Z,XN,YN,ZN,LIGHT,XL2,LSHINE,COLOUR)
C     -------------------------------------------------------------
C
      REAL    EYE(*),LIGHT(*)
      LOGICAL LSHINE
      DATA    SMALL2 /1.0E-20/
C
      COLOUR=0.0
      XNL=XN*LIGHT(1)+YN*LIGHT(2)+ZN*LIGHT(3)
      IF (XNL.GE.0.0) RETURN
      XN2=XN**2+YN**2+ZN**2+SMALL2
      IF (LSHINE) THEN
        RFNORM=2.0*XNL/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.LT.0.0) RETURN
        V2=VX**2+VY**2+VZ**2
        COLOUR=MIN(XRV**2/(ABS(XL2*V2)+SMALL2),1.0)
      ELSE
        COLOUR=MIN(-XNL/SQRT(ABS(XL2*XN2)+SMALL2),1.0)
      ENDIF
      END
C
      SUBROUTINE SB2SRF(EYE,LATICE,DENS,N1,N2,DLOW,DHIGH,DVERT,IC1,IC2,
     *                  NCBAND,LIGHT,LSHINE)
C     -----------------------------------------------------------------
C
      REAL             EYE(*),LATICE(3,*),DENS(0:N1,0:N2),LIGHT(*)
      LOGICAL          LSHINE
C
      REAL*8           XLNORM,ZZ,DZZ,DSMAL2
      REAL             LATIC2(3,4),BAS(3,3),MTRX(3,3)
      REAL             VERT(3,8),XW(20),YW(20),GRDSCL(3)
      LOGICAL          LPS,LCOLOR
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      This subroutine plots a 3-d surface given a 2-d unit-cell
C    of density. All (x,y,z) values are taken to be given in world 
C    coordinates. The z-component of the eye-poisition should be 
C    positive and that of all the lattice-vertices should be negative; 
C    the viewing-screen is fixed at z=0.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    EYE      R*4    I       3      (x,y,z) coordinate of eye-position.
C    LATICE   R*4    I     3 x 3    (x,y,z) coordinates of the origin
C                                   and the a and b lattice-vertices.
C    DENS     R*4    I     (N1+1)   The density at regular points within
C                        x (N2+1)   the unit cell, wrapped around so
C                                   that DENS(0,J)=DENS(N1,J) etc..
C    N1,N2    I*4    I       -      The dimensions of the unit-cell grid.
C    DLOW     R*4    I       -      Lowest density to be plotted.
C    DHIGH    R*4    I       -      Highest density to be plotted.
C    DVERT    R*4    I       -      "Vertical" world-coordinate length
C                                   corresponding to density-range.
C    IC1,IC2  I*4    I       -      Lowest and highest colour-index to
C                                   be used for the rendering.
C    NCBAND   I*4    I       -      Number of colour-bands for the
C                                   height, so that the number of shades
C                                   per band = (IC2-IC1+1)/NCBAND.
C    LIGHT    R*4    I       3      (x,y,z) direction of flood-light.
C    LSHINE   L*1    I       -      Shiny surface if TRUE, else diffuse.
C
C Globals 
C    SFTBUF
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     SBLIN1     Calculates the projection of (x,y,z) on viewing screen.
C     SB2SR1     Calculates vertecies of triangular breakdown of grid.
C     SB2SR3     Calculates the normal of the surface.
C     SB2SR4     Calculates the appropriate colour for a given pixel.
C
C History
C   D. S. Sivia        1 Jun 1995  Initial release.
C   D. S. Sivia        7 Jul 1995  Fixed bug in determinant calculation.
C   D. S. Sivia       20 Oct 1995  Speeded up computations slightly.
C   D. S. Sivia       26 Oct 1995  Completely new algorithm!
C   D. S. Sivia       24 Oct 1997 "Safe-guarded" some rounding errors.
C-----------------------------------------------------------------------
C
C Carry out some initial checks.
C
      BIG=1.0E20
      SMALL=1.0E-10
      SMALL2=SMALL**2
      DSMAL2=DBLE(SMALL2)
      IF (EYE(3).LE.SMALL) RETURN
      IF (N1.LT.1 .OR. N2.LT.1) RETURN
      DRANGE=DHIGH-DLOW
      IF (DRANGE.LE.SMALL) RETURN
      XL2=LIGHT(1)**2+LIGHT(2)**2+LIGHT(3)**2
      IF (XL2.LT.SMALL) RETURN
      DO 10 I=1,3
        BAS(I,1)=LATICE(I,2)-LATICE(I,1)
        BAS(I,2)=LATICE(I,3)-LATICE(I,1)
  10  CONTINUE
      CX=BAS(2,1)*BAS(3,2)-BAS(2,2)*BAS(3,1)
      CY=BAS(3,1)*BAS(1,2)-BAS(3,2)*BAS(1,1)
      CZ=BAS(1,1)*BAS(2,2)-BAS(1,2)*BAS(2,1)
      CSCL=DVERT/SQRT(CX**2+CY**2+CZ**2+SMALL**2)
      BAS(1,3)=CX*CSCL
      BAS(2,3)=CY*CSCL
      BAS(3,3)=CZ*CSCL
      DMIN=MIN(DLOW,0.0)
      DMAX=MAX(DHIGH,0.0)
      ORGSCL=DMIN/(DMAX-DMIN+SMALL)
      DO 11 I=1,3
        LATIC2(I,1)=LATICE(I,1)+ORGSCL*BAS(I,3)
        LATIC2(I,2)=LATIC2(I,1)+BAS(I,1)
        LATIC2(I,3)=LATIC2(I,1)+BAS(I,2)
        LATIC2(I,4)=LATIC2(I,1)+BAS(I,3)
  11  CONTINUE
      IF (LATIC2(3,1).GE.0.0) RETURN
      ZFAR=LATIC2(3,2)+LATIC2(3,3)+LATIC2(3,4)-2.0*LATIC2(3,1)
      IF (ZFAR.GE.0.0) RETURN
      DO 12 J=1,3
        IF (LATIC2(3,J+1).GE.0.0) RETURN
        IF ((ZFAR-BAS(3,J)).GE.0.0) RETURN
        BAS2J=BAS(1,J)**2+BAS(2,J)**2+BAS(3,J)**2
        IF (BAS2J.LT.SMALL2) RETURN
  12  CONTINUE
      EYLAT1=EYE(1)-LATIC2(1,1)
      EYLAT2=EYE(2)-LATIC2(2,1)
      NTOT=(N1+1)*(N2+1)
C
C Set up matrix for real-space to lattice-index transformation.
C
      SAFE=0.0001
      XN1=0.99999*FLOAT(N1)
      XN2=0.99999*FLOAT(N2)
      XN3=0.99999
      DET=BAS(1,1)*BAS(2,2)*BAS(3,3)+BAS(1,2)*BAS(2,3)*BAS(3,1)
     *   +BAS(1,3)*BAS(2,1)*BAS(3,2)-BAS(3,1)*BAS(2,2)*BAS(1,3)
     *   -BAS(3,2)*BAS(2,3)*BAS(1,1)-BAS(3,3)*BAS(2,1)*BAS(1,2)
      IF (ABS(DET).LT.SMALL2) RETURN
      DETNRM=1.0/DET
      MTRX(1,1)=XN1*DETNRM*(BAS(2,2)*BAS(3,3)-BAS(2,3)*BAS(3,2))
      MTRX(1,2)=XN2*DETNRM*(BAS(2,3)*BAS(3,1)-BAS(2,1)*BAS(3,3))
      MTRX(1,3)=XN3*DETNRM*(BAS(2,1)*BAS(3,2)-BAS(2,2)*BAS(3,1))
      MTRX(2,1)=XN1*DETNRM*(BAS(3,2)*BAS(1,3)-BAS(3,3)*BAS(1,2))
      MTRX(2,2)=XN2*DETNRM*(BAS(3,3)*BAS(1,1)-BAS(3,1)*BAS(1,3))
      MTRX(2,3)=XN3*DETNRM*(BAS(3,1)*BAS(1,2)-BAS(3,2)*BAS(1,1))
      MTRX(3,1)=XN1*DETNRM*(BAS(1,2)*BAS(2,3)-BAS(1,3)*BAS(2,2))
      MTRX(3,2)=XN2*DETNRM*(BAS(1,3)*BAS(2,1)-BAS(1,1)*BAS(2,3))
      MTRX(3,3)=XN3*DETNRM*(BAS(1,1)*BAS(2,2)-BAS(1,2)*BAS(2,1))
C
C Some general initialisations.
C
      GRDSCL(1)=-FLOAT(N1)
      GRDSCL(2)=-FLOAT(N2)
      GRDSCL(3)=1.0/DRANGE
      IF (IC2.LT.IC1) RETURN
      NSHADS=MAX((IC2-IC1+1)/MAX(NCBAND,1),1)
      COLSCL=FLOAT(NSHADS-1)
      COL0=FLOAT(IC1)
      DKSCL=0.9999*FLOAT((IC2-IC1+1)/NSHADS)
      DX=FLOAT(NXP-1)/(XTRC-XBLC)
      DY=FLOAT(NYP-1)/(YTRC-YBLC)
      DYJ=1.0/DY
      DXI=1.0/DX
C
C New algorithm here: divide each box of 4 grid-points into four 
C triangles and paint them.
C
      DO 70 JLAT=1,N2
        DO 60 ILAT=1,N1
          CALL SB2SR1(ILAT,JLAT,DENS,N1,N2,DLOW,DRANGE,BAS,LATIC2,VERT)
          DO 50 IV=1,4
            CALL SBRCOP(VERT(1,IV),VERT(1,6),6)
            XMIN=+BIG
            XMAX=-BIG
            YMIN=+BIG
            YMAX=-BIG
            DO 20 I=1,3
              II=5+I
              CALL SBLIN1(EYE,VERT(1,II),VERT(2,II),VERT(3,II),
     *                    XW(I),YW(I))
              IF (XW(I).LT.XMIN) THEN
                XMIN=XW(I)
                ILEFT=I
              ENDIF
              IF (YW(I).LT.YMIN) THEN
                YMIN=YW(I)
                JBOTOM=I
              ENDIF
              XMAX=MAX(XW(I),XMAX)
              YMAX=MAX(YW(I),YMAX)
  20        CONTINUE
            IF (XMIN.GE.XTRC .OR. XMAX.LE.XBLC) GOTO 50
            IF (YMIN.GE.YTRC .OR. YMAX.LE.YBLC) GOTO 50
            AX=VERT(1,7)-VERT(1,6)
            AY=VERT(2,7)-VERT(2,6)
            AZ=VERT(3,7)-VERT(3,6)
            BX=VERT(1,6)-VERT(1,8)
            BY=VERT(2,6)-VERT(2,8)
            BZ=VERT(3,6)-VERT(3,8)
            XN=BY*AZ-AY*BZ
            YN=BZ*AX-AZ*BX
            ZN=BX*AY-AX*BY
            TEN=XN*(EYE(1)-VERT(1,6))+YN*(EYE(2)-VERT(2,6))
     *         +ZN*(EYE(3)-VERT(3,6))
            XLNORM=DBLE(TEN)
            EYENRM=XN*EYE(1)+YN*EYE(2)+ZN*EYE(3)
            SAFER=0.0001
            IF ((XMAX-XMIN).GT.(YMAX-YMIN)) THEN
              JYMIN=INT((YMIN-YBLC)*DY)+2
              JYMAX=MIN(INT((YMAX-YBLC)*DY)+1,NYP)
              IF (JYMIN.GT.JYMAX) GOTO 50
              YJ=YBLC+(FLOAT(JYMIN-1)+SAFER)*DYJ
              NVL2=JBOTOM
              NVR2=JBOTOM
              J1=JYMIN
              DO 30 IVERT=1,3
                IF (YJ.GT.YW(NVL2)) THEN
   1              NVL1=NVL2
                  NVL2=NVL1-1
                  IF (NVL2.LT.1) NVL2=3
                  IF (NVL2.EQ.JBOTOM) GOTO 50
                  IF (YJ.GT.YW(NVL2)) GOTO 1
                  YDIFL=YW(NVL2)-YW(NVL1)
                  IF (ABS(YDIFL).LT.SMALL) YDIFL=SMALL
                  GRADL=(XW(NVL2)-XW(NVL1))/YDIFL
                ENDIF
                IF (YJ.GT.YW(NVR2)) THEN
   2              NVR1=NVR2
                  NVR2=NVR1+1
                  IF (NVR2.GT.3) NVR2=1
                  IF (NVR2.EQ.JBOTOM) GOTO 50
                  IF (YJ.GT.YW(NVR2)) GOTO 2
                  YDIFR=YW(NVR2)-YW(NVR1)
                  IF (ABS(YDIFR).LT.SMALL) YDIFR=SMALL
                  GRADR=(XW(NVR2)-XW(NVR1))/YDIFR
                ENDIF
                IF (YW(NVL2).LT.YW(NVR2)) THEN
                  J2=MIN(INT((YW(NVL2)-YBLC)*DY)+1,JYMAX)
                ELSE
                  J2=MIN(INT((YW(NVR2)-YBLC)*DY)+1,JYMAX)
                ENDIF
                DO 29 J=J1,J2
                  IF (J.GE.1) THEN
                    XL=XW(NVL1)+GRADL*(YJ-YW(NVL1))
                    XR=XW(NVR1)+GRADR*(YJ-YW(NVR1))
                    ISTEP=1
                    IX1=MAX(INT((XL-XBLC)*DX)+2,1)
                    IX2=MIN(INT((XR-XBLC)*DX)+1,NXP)
                    IF (IX1.GT.IX2) THEN
                      ISTEP=-1
                      IX1=MIN(IX1-1,NXP)
                      IX2=MAX(IX2+1,1)
                    ENDIF
                    XI=XBLC+FLOAT(IX1-1)*DXI
                    DXISTP=FLOAT(ISTEP)*DXI
                    DZZ=DBLE(DXISTP*XN)
                    ZZ=DBLE(EYENRM-XI*XN-YJ*YN)
                    K=(J-1)*NXP+IX1
                    DO 28 I=IX1,IX2,ISTEP
                      XLAMDA=SNGL(XLNORM/ZZ)
                      Z=EYE(3)*(1.0-XLAMDA)
                      IF (Z.GT.SBBUFF(K)) THEN
                        SBBUFF(K)=Z
                        IF (IC1.EQ.IC2) THEN
                          SBBUFF(K+KSTART)=COL0
                        ELSE
                          XDI=EYLAT1+XLAMDA*(XI-EYE(1))
                          YDJ=EYLAT2+XLAMDA*(YJ-EYE(2))
                          ZDK=Z-LATIC2(3,1)
                          IF (NCBAND.GT.1) THEN
                            DK=MAX(MIN((XDI*MTRX(1,3)+YDJ*MTRX(2,3)
     *                        +ZDK*MTRX(3,3)),XN3),SAFE)
                            COL0=FLOAT(IC1+NSHADS*INT(DK*DKSCL))
                          ENDIF
                          DI=MAX(MIN((XDI*MTRX(1,1)+YDJ*MTRX(2,1)
     *                      +ZDK*MTRX(3,1)),XN1),SAFE)
                          DJ=MAX(MIN((XDI*MTRX(1,2)+YDJ*MTRX(2,2)
     *                      +ZDK*MTRX(3,2)),XN2),SAFE)
                          CALL SB2SR3(DENS,N1,N2,DI,DJ,BAS,GX,GY,GZ,
     *                                GRDSCL)
                          CALL SB2SR4(EYE,XI,YJ,0.0,GX,GY,GZ,LIGHT,
     *                                XL2,SMALL2,LSHINE,COLOUR)
                          SBBUFF(K+KSTART)=COL0+COLOUR*COLSCL
                        ENDIF
                      ENDIF
                      XI=XI+DXISTP
                      ZZ=ZZ-DZZ
                      K=K+ISTEP
  28                CONTINUE
                  ENDIF
                  YJ=YJ+DYJ
  29            CONTINUE
                J1=J2+1
                IF (J1.GT.JYMAX) GOTO 50
  30          CONTINUE
            ELSE
              IXMIN=INT((XMIN-XBLC)*DX)+2
              IXMAX=MIN(INT((XMAX-XBLC)*DX)+1,NXP)
              IF (IXMIN.GT.IXMAX) GOTO 50
              XI=XBLC+(FLOAT(IXMIN-1)+SAFER)*DXI
              NVL2=ILEFT
              NVR2=ILEFT
              I1=IXMIN
              DO 40 IVERT=1,3
                IF (XI.GT.XW(NVL2)) THEN
   3              NVL1=NVL2
                  NVL2=NVL1-1
                  IF (NVL2.LT.1) NVL2=3
                  IF (NVL2.EQ.ILEFT) GOTO 50
                  IF (XI.GT.XW(NVL2)) GOTO 3
                  XDIFL=XW(NVL2)-XW(NVL1)
                  IF (ABS(XDIFL).LT.SMALL) XDIFL=SMALL
                  GRADL=(YW(NVL2)-YW(NVL1))/XDIFL
                ENDIF
                IF (XI.GT.XW(NVR2)) THEN
   4              NVR1=NVR2
                  NVR2=NVR1+1
                  IF (NVR2.GT.3) NVR2=1
                  IF (NVR2.EQ.ILEFT) GOTO 50
                  IF (XI.GT.XW(NVR2)) GOTO 4
                  XDIFR=XW(NVR2)-XW(NVR1)
                  IF (ABS(XDIFR).LT.SMALL) XDIFR=SMALL
                  GRADR=(YW(NVR2)-YW(NVR1))/XDIFR
               ENDIF
                IF (XW(NVL2).LT.XW(NVR2)) THEN
                  I2=MIN(INT((XW(NVL2)-XBLC)*DX)+1,IXMAX)
                ELSE
                  I2=MIN(INT((XW(NVR2)-XBLC)*DX)+1,IXMAX)
                ENDIF
                DO 39 I=I1,I2
                  IF (I.GE.1) THEN
                    YL=YW(NVL1)+GRADL*(XI-XW(NVL1))
                    YR=YW(NVR1)+GRADR*(XI-XW(NVR1))
                    JSTEP=1
                    JY1=MAX(INT((YL-YBLC)*DY)+2,1)
                    JY2=MIN(INT((YR-YBLC)*DY)+1,NYP)
                    IF (JY1.GT.JY2) THEN
                      JSTEP=-1
                      JY1=MIN(JY1-1,NYP)
                      JY2=MAX(JY2+1,1)
                    ENDIF
                    YJ=YBLC+FLOAT(JY1-1)*DYJ
                    DYJSTP=FLOAT(JSTEP)*DYJ
                    DZZ=DBLE(DYJSTP*YN)
                    ZZ=DBLE(EYENRM-YJ*YN-XI*XN)
                    K=(JY1-1)*NXP+I
                    KSTEP=JSTEP*NXP
                    DO 38 J=JY1,JY2,JSTEP
                      XLAMDA=SNGL(XLNORM/ZZ)
                      Z=EYE(3)*(1.0-XLAMDA)
                      IF (Z.GT.SBBUFF(K)) THEN
                        SBBUFF(K)=Z
                        IF (IC1.EQ.IC2) THEN
                          SBBUFF(K+KSTART)=COL0
                        ELSE
                          XDI=EYLAT1+XLAMDA*(XI-EYE(1))
                          YDJ=EYLAT2+XLAMDA*(YJ-EYE(2))
                          ZDK=Z-LATIC2(3,1)
                          IF (NCBAND.GT.1) THEN
                            DK=MAX(MIN((XDI*MTRX(1,3)+YDJ*MTRX(2,3)
     *                        +ZDK*MTRX(3,3)),XN3),SAFE)
                            COL0=FLOAT(IC1+NSHADS*INT(DK*DKSCL))
                          ENDIF
                          DI=MAX(MIN((XDI*MTRX(1,1)+YDJ*MTRX(2,1)
     *                      +ZDK*MTRX(3,1)),XN1),SAFE)
                          DJ=MAX(MIN((XDI*MTRX(1,2)+YDJ*MTRX(2,2)
     *                      +ZDK*MTRX(3,2)),XN2),SAFE)
                          CALL SB2SR3(DENS,N1,N2,DI,DJ,BAS,GX,GY,GZ,
     *                                GRDSCL)
                          CALL SB2SR4(EYE,XI,YJ,0.0,GX,GY,GZ,LIGHT,
     *                                XL2,SMALL2,LSHINE,COLOUR)
                          SBBUFF(K+KSTART)=COL0+COLOUR*COLSCL
                        ENDIF
                      ENDIF
                      YJ=YJ+DYJSTP
                      ZZ=ZZ-DZZ
                      K=K+KSTEP
  38                CONTINUE
                  ENDIF
                  XI=XI+DXI
  39            CONTINUE
                I1=I2+1
                IF (I1.GT.IXMAX) GOTO 50
  40          CONTINUE
            ENDIF
  50      CONTINUE
  60    CONTINUE
  70  CONTINUE
      END
C
      SUBROUTINE SB2SR1(I1,J1,DENS,N1,N2,DLOW,DRANGE,BAS,LATICE,VERT)
C     ---------------------------------------------------------------
C
      REAL DENS(0:N1,0:N2),BAS(3,*),LATICE(*),VERT(3,*)
C
      I0=I1-1
      J0=J1-1
      XNORM=1.0/FLOAT(N1)
      YNORM=1.0/FLOAT(N2)
      ZNORM=1.0/DRANGE
      D00=MAX(MIN((DENS(I0,J0)-DLOW)*ZNORM,1.0),0.0)
      D10=MAX(MIN((DENS(I1,J0)-DLOW)*ZNORM,1.0),0.0)
      D11=MAX(MIN((DENS(I1,J1)-DLOW)*ZNORM,1.0),0.0)
      D01=MAX(MIN((DENS(I0,J1)-DLOW)*ZNORM,1.0),0.0)
      X0=FLOAT(I0)*XNORM
      X1=FLOAT(I1)*XNORM
      Y0=FLOAT(J0)*YNORM
      Y1=FLOAT(J1)*YNORM
      VERT(1,1)=X0*BAS(1,1)+Y0*BAS(1,2)+D00*BAS(1,3)+LATICE(1)
      VERT(2,1)=X0*BAS(2,1)+Y0*BAS(2,2)+D00*BAS(2,3)+LATICE(2)
      VERT(3,1)=X0*BAS(3,1)+Y0*BAS(3,2)+D00*BAS(3,3)+LATICE(3)
      VERT(1,2)=X1*BAS(1,1)+Y0*BAS(1,2)+D10*BAS(1,3)+LATICE(1)
      VERT(2,2)=X1*BAS(2,1)+Y0*BAS(2,2)+D10*BAS(2,3)+LATICE(2)
      VERT(3,2)=X1*BAS(3,1)+Y0*BAS(3,2)+D10*BAS(3,3)+LATICE(3)
      VERT(1,3)=X1*BAS(1,1)+Y1*BAS(1,2)+D11*BAS(1,3)+LATICE(1)
      VERT(2,3)=X1*BAS(2,1)+Y1*BAS(2,2)+D11*BAS(2,3)+LATICE(2)
      VERT(3,3)=X1*BAS(3,1)+Y1*BAS(3,2)+D11*BAS(3,3)+LATICE(3)
      VERT(1,4)=X0*BAS(1,1)+Y1*BAS(1,2)+D01*BAS(1,3)+LATICE(1)
      VERT(2,4)=X0*BAS(2,1)+Y1*BAS(2,2)+D01*BAS(2,3)+LATICE(2)
      VERT(3,4)=X0*BAS(3,1)+Y1*BAS(3,2)+D01*BAS(3,3)+LATICE(3)
      VERT(1,5)=VERT(1,1)
      VERT(2,5)=VERT(2,1)
      VERT(3,5)=VERT(3,1)
      XM=0.5*FLOAT(I0+I1)*XNORM
      YM=0.5*FLOAT(J0+J1)*YNORM
      DM=0.25*(DENS(I0,J0)+DENS(I1,J0)+DENS(I1,J1)+DENS(I0,J1))
      DM=MAX(MIN((DM-DLOW)*ZNORM,1.0),0.0)
      VERT(1,8)=XM*BAS(1,1)+YM*BAS(1,2)+DM*BAS(1,3)+LATICE(1)
      VERT(2,8)=XM*BAS(2,1)+YM*BAS(2,2)+DM*BAS(2,3)+LATICE(2)
      VERT(3,8)=XM*BAS(3,1)+YM*BAS(3,2)+DM*BAS(3,3)+LATICE(3)
      END
C
      SUBROUTINE SB2SR3(DENS,N1,N2,XI,YJ,BAS,XN,YN,ZN,GRDSCL)
C     -------------------------------------------------------
C
      REAL DENS(0:N1,0:N2),BAS(3,*),GRDSCL(*)
C
      I=INT(XI)
      J=INT(YJ)
      II=I+1
      JJ=J+1
      DX=XI-FLOAT(I)
      DY=YJ-FLOAT(J)
      CALL S2SR3A(I,DX,N1,IM,I0,IP,DDX)
      XM=DENS(IM,J)+DY*(DENS(IM,JJ)-DENS(IM,J))
      X0=DENS(I0,J)+DY*(DENS(I0,JJ)-DENS(I0,J))
      XP=DENS(IP,J)+DY*(DENS(IP,JJ)-DENS(IP,J))
      GX=GRDSCL(1)*GRDSCL(3)*((1.0-DDX)*(X0-XM)+DDX*(XP-X0))
      CALL S2SR3A(J,DY,N2,JM,J0,JP,DDY)
      YM=DENS(I,JM)+DX*(DENS(II,JM)-DENS(I,JM))
      Y0=DENS(I,J0)+DX*(DENS(II,J0)-DENS(I,J0))
      YP=DENS(I,JP)+DX*(DENS(II,JP)-DENS(I,JP))
      GY=GRDSCL(2)*GRDSCL(3)*((1.0-DDY)*(Y0-YM)+DDY*(YP-Y0))
      GZ=1.0
      XN=GX*BAS(1,1)+GY*BAS(1,2)+GZ*BAS(1,3)
      YN=GX*BAS(2,1)+GY*BAS(2,2)+GZ*BAS(2,3)
      ZN=GX*BAS(3,1)+GY*BAS(3,2)+GZ*BAS(3,3)
      END
C
      SUBROUTINE S2SR3A(I,DX,NX,IM,I0,IP,DDX)
C     ---------------------------------------
C
      IF (DX.LT.0.5) THEN
        DDX=DX+0.5
        I0=I
        IM=I0-1
        IP=I0+1
        IF (IM.LT.0) IM=NX
      ELSE
        DDX=DX-0.5
        I0=I+1
        IM=I0-1
        IP=I0+1
        IF (IP.GT.NX) IP=0
      ENDIF
      END
C
      SUBROUTINE SB2SR4(EYE,X,Y,Z,XN,YN,ZN,LIGHT,XL2,SMALL2,LSHINE,
     *                  COLOUR)
C     -------------------------------------------------------------
C
      REAL    EYE(*),LIGHT(*)
      LOGICAL LSHINE
C
      COLOUR=0.0
      XNL=XN*LIGHT(1)+YN*LIGHT(2)+ZN*LIGHT(3)
      IF (XNL.GE.0.0) RETURN
      XN2=XN**2+YN**2+ZN**2+SMALL2
      IF (LSHINE) THEN
        RFNORM=2.0*XNL/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.LT.0.0) RETURN
        V2=VX**2+VY**2+VZ**2
        COLOUR=MIN(XRV**2/(ABS(XL2*V2)+SMALL2),1.0)
      ELSE
        COLOUR=MIN(-XNL/SQRT(ABS(XL2*XN2)+SMALL2),1.0)
      ENDIF
      END
C
      SUBROUTINE SBPLNT(EYE,NV,VERT,IC1,IC2,LIGHT,ITRANS)
C     ---------------------------------------------------
C
      REAL             EYE(*),VERT(3,*),LIGHT(*)
C
      REAL*8           XLNORM,ZZ,DZZ
      REAL             XW(400),YW(400)
      LOGICAL          LPS,LCOLOR
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      This subroutine plots a diffusively-lit, semi-transparent, 
C    coloured plane; the use must ensure that all the verticies lie in a
C    flat plane, and that the bounding polygon be convex (so that the 
C    angle at any vertex <= 180 degs). All (x,y,z) values are taken to 
C    be given in world coordinates. The z-component of the eye-poisition
C    should be positive and that of the vertices should be negative; the
C    viewing-screen is fixed at z=0.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    EYE      R*4    I       3      (x,y,z) coordinate of eye-position.
C    NV       R*4    I       -      No. of verticies (>=3).
C    VERT     R*4    I     3 x NV   (x,y,z) coordinate of verticies.
C    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be
C                                   used for the shading.
C    LIGHT    R*4    I       3      (x,y,z) direction of flood-light.
C    ITRANS   I*4    I       -      Level of transparency:
C                                        1 = 25%; 2 = 50%; 3 = 75%.
C
C Globals 
C    SFTBUF
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     SBLIN1     Calculates the projection of (x,y,z) on viewing screen.
C
C History
C   D. S. Sivia      21 Aug 1995  Initial release.
C   D. S. Sivia      24 Oct 1997 "Safe-guarded" some rounding errors.
C-----------------------------------------------------------------------
C
C Carry out some initial checks and calculate the coordinates of the 
C projected polygon.
C
      SMALL=1.0E-10
      SMALL2=SMALL**2
      IF (EYE(3).LE.SMALL) RETURN
      IF (NV.LT.3 .OR. NV.GT.400) RETURN
      DO 10 I=1,NV
  10    IF (VERT(3,I).GE.0.0) RETURN
      XMIN=+1.0E20
      XMAX=-1.0E20
      YMIN=+1.0E20
      YMAX=-1.0E20
      DO 20 I=1,NV
        CALL SBLIN1(EYE,VERT(1,I),VERT(2,I),VERT(3,I),XW(I),YW(I))
        IF (XW(I).LT.XMIN) THEN
          XMIN=XW(I)
          ILEFT=I
        ENDIF
        IF (YW(I).LT.YMIN) THEN
          YMIN=YW(I)
          JBOTOM=I
        ENDIF
        XMAX=MAX(XW(I),XMAX)
        YMAX=MAX(YW(I),YMAX)
  20  CONTINUE
      IF (XMIN.GE.XTRC .OR. XMAX.LE.XBLC) RETURN
      IF (YMIN.GE.YTRC .OR. YMAX.LE.YBLC) RETURN
C
C Find the outward normal seen by the eye, and activate the appropriate 
C colour.
C
      AX=VERT(1,2)-VERT(1,1)
      AY=VERT(2,2)-VERT(2,1)
      AZ=VERT(3,2)-VERT(3,1)
      BX=VERT(1,1)-VERT(1,NV)
      BY=VERT(2,1)-VERT(2,NV)
      BZ=VERT(3,1)-VERT(3,NV)
      XN=BY*AZ-AY*BZ
      YN=BZ*AX-AZ*BX
      ZN=BX*AY-AX*BY
      TEN=XN*(EYE(1)-VERT(1,1))+YN*(EYE(2)-VERT(2,1))
     *   +ZN*(EYE(3)-VERT(3,1))
      COLOUR=FLOAT(IC1)
      NC=IC2-IC1
      IF (NC.GT.0) THEN
        TNL=XN*LIGHT(1)+YN*LIGHT(2)+ZN*LIGHT(3)
        IF (TEN.LT.0.0) TNL=-TNL
        COSDIF=0.0
        IF (TNL.LT.0.0) THEN
          TN2=XN**2+YN**2+ZN**2
          TL2=LIGHT(1)**2+LIGHT(2)**2+LIGHT(3)**2
          COSDIF=MIN(-TNL/SQRT(TN2*TL2+SMALL2),1.0)
        ENDIF
        COLOUR=COLOUR+COSDIF*FLOAT(NC)
      ENDIF
C
C Plot the projected polygon.
C
      ITLEVL=MAX(MIN(ITRANS,3),1)
      XLNORM=DBLE(EYE(3))*DBLE(TEN)
      EYENRM=XN*EYE(1)+YN*EYE(2)+ZN*EYE(3)
      DX=FLOAT(NXP-1)/(XTRC-XBLC)
      DY=FLOAT(NYP-1)/(YTRC-YBLC)
      DYJ=1.0/DY
      DXI=1.0/DX
      SAFER=0.0001
      IF ((XMAX-XMIN).GT.(YMAX-YMIN)) THEN
        JYMIN=INT((YMIN-YBLC)*DY)+2
        JYMAX=MIN(INT((YMAX-YBLC)*DY)+1,NYP)
        IF (JYMIN.GT.JYMAX) RETURN
        YJ=YBLC+(FLOAT(JYMIN-1)+SAFER)*DYJ
        NVL2=JBOTOM
        NVR2=JBOTOM
        J1=JYMIN
        DO 50 IVERT=1,NV
          IF (YJ.GT.YW(NVL2)) THEN
   1        NVL1=NVL2
            NVL2=NVL1-1
            IF (NVL2.LT.1) NVL2=NV
            IF (NVL2.EQ.JBOTOM) RETURN
            IF (YJ.GT.YW(NVL2)) GOTO 1
            YDIFL=YW(NVL2)-YW(NVL1)
            IF (ABS(YDIFL).LT.SMALL) YDIFL=SMALL
            GRADL=(XW(NVL2)-XW(NVL1))/YDIFL
          ENDIF
          IF (YJ.GT.YW(NVR2)) THEN
   2        NVR1=NVR2
            NVR2=NVR1+1
            IF (NVR2.GT.NV) NVR2=1
            IF (NVR2.EQ.JBOTOM) RETURN
            IF (YJ.GT.YW(NVR2)) GOTO 2
            YDIFR=YW(NVR2)-YW(NVR1)
            IF (ABS(YDIFR).LT.SMALL) YDIFR=SMALL
            GRADR=(XW(NVR2)-XW(NVR1))/YDIFR
          ENDIF
          IF (YW(NVL2).LT.YW(NVR2)) THEN
            J2=MIN(INT((YW(NVL2)-YBLC)*DY)+1,JYMAX)
          ELSE
            J2=MIN(INT((YW(NVR2)-YBLC)*DY)+1,JYMAX)
          ENDIF
          DO 40 J=J1,J2
            IF (J.GE.1) THEN
              JTEST=MOD(J,2)
              IF (ITLEVL.EQ.3 .AND. JTEST.EQ.1) GOTO 39
              XL=XW(NVL1)+GRADL*(YJ-YW(NVL1))
              XR=XW(NVR1)+GRADR*(YJ-YW(NVR1))
              ISTEP=1
              IX1=MAX(INT((XL-XBLC)*DX)+2,1)
              IX2=MIN(INT((XR-XBLC)*DX)+1,NXP)
              IF (IX1.GT.IX2) THEN
                ISTEP=-1
                IX1=MIN(IX1-1,NXP)
                IX2=MAX(IX2+1,1)
              ENDIF
              DZZ=DBLE(FLOAT(ISTEP)*DXI*XN)
              ZZ=DBLE(EYENRM-(XBLC+FLOAT(IX1-1)*DXI)*XN-YJ*YN)
              K=(J-1)*NXP+IX1
              DO 30 I=IX1,IX2,ISTEP
                ITEST=MOD(I,2)
                IF (ITLEVL.EQ.1) THEN
                  IF ((ITEST+JTEST).EQ.0) GOTO 29
                ELSEIF (ITLEVL.EQ.2) THEN
                  IF ((ITEST+JTEST).EQ.1) GOTO 29
                ELSE
                  IF (ITEST.EQ.1) GOTO 29
                ENDIF
                Z=EYE(3)-SNGL(XLNORM/ZZ)
                IF (Z.GT.SBBUFF(K)) THEN
                  SBBUFF(K)=Z
                  SBBUFF(KSTART+K)=COLOUR
                ENDIF
  29            ZZ=ZZ-DZZ
                K=K+ISTEP
  30          CONTINUE
            ENDIF
  39        YJ=YJ+DYJ
  40      CONTINUE
          J1=J2+1
          IF (J1.GT.JYMAX) RETURN
  50    CONTINUE
      ELSE
        IXMIN=INT((XMIN-XBLC)*DX)+2
        IXMAX=MIN(INT((XMAX-XBLC)*DX)+1,NXP)
        IF (IXMIN.GT.IXMAX) RETURN
        XI=XBLC+(FLOAT(IXMIN-1)+SAFER)*DXI
        NVL2=ILEFT
        NVR2=ILEFT
        I1=IXMIN
        DO 80 IVERT=1,NV
          IF (XI.GT.XW(NVL2)) THEN
   3        NVL1=NVL2
            NVL2=NVL1-1
            IF (NVL2.LT.1) NVL2=NV
            IF (NVL2.EQ.ILEFT) RETURN
            IF (XI.GT.XW(NVL2)) GOTO 3
            XDIFL=XW(NVL2)-XW(NVL1)
            IF (ABS(XDIFL).LT.SMALL) XDIFL=SMALL
            GRADL=(YW(NVL2)-YW(NVL1))/XDIFL
          ENDIF
          IF (XI.GT.XW(NVR2)) THEN
   4        NVR1=NVR2
            NVR2=NVR1+1
            IF (NVR2.GT.NV) NVR2=1
            IF (NVR2.EQ.ILEFT) RETURN
            IF (XI.GT.XW(NVR2)) GOTO 4
            XDIFR=XW(NVR2)-XW(NVR1)
            IF (ABS(XDIFR).LT.SMALL) XDIFR=SMALL
            GRADR=(YW(NVR2)-YW(NVR1))/XDIFR
          ENDIF
          IF (XW(NVL2).LT.XW(NVR2)) THEN
            I2=MIN(INT((XW(NVL2)-XBLC)*DX)+1,IXMAX)
          ELSE
            I2=MIN(INT((XW(NVR2)-XBLC)*DX)+1,IXMAX)
          ENDIF
          DO 70 I=I1,I2
            IF (I.GE.1) THEN
              ITEST=MOD(I,2)
              IF (ITLEVL.EQ.3 .AND. ITEST.EQ.1) GOTO 69
              YL=YW(NVL1)+GRADL*(XI-XW(NVL1))
              YR=YW(NVR1)+GRADR*(XI-XW(NVR1))
              ISTEP=1
              JY1=MAX(INT((YL-YBLC)*DY)+2,1)
              JY2=MIN(INT((YR-YBLC)*DY)+1,NYP)
              IF (JY1.GT.JY2) THEN
                ISTEP=-1
                JY1=MIN(JY1-1,NYP)
                JY2=MAX(JY2+1,1)
              ENDIF
              DZZ=DBLE(FLOAT(ISTEP)*DYJ*YN)
              ZZ=DBLE(EYENRM-(YBLC+FLOAT(JY1-1)*DYJ)*YN-XI*XN)
              K=(JY1-1)*NXP+I
              KSTEP=ISTEP*NXP
              DO 60 J=JY1,JY2,ISTEP
                JTEST=MOD(J,2)
                IF (ITLEVL.EQ.1) THEN
                  IF ((ITEST+JTEST).EQ.0) GOTO 59
                ELSEIF (ITLEVL.EQ.2) THEN
                  IF ((ITEST+JTEST).EQ.1) GOTO 59
                ELSE
                  IF (JTEST.EQ.1) GOTO 59
                ENDIF
                Z=EYE(3)-SNGL(XLNORM/ZZ)
                IF (Z.GT.SBBUFF(K)) THEN
                  SBBUFF(K)=Z
                  SBBUFF(KSTART+K)=COLOUR
                ENDIF
  59            ZZ=ZZ-DZZ
                K=K+KSTEP
  60          CONTINUE
            ENDIF
  69        XI=XI+DXI
  70      CONTINUE
          I1=I2+1
          IF (I1.GT.IXMAX) RETURN
  80    CONTINUE
      ENDIF
      END
C
      SUBROUTINE SBELIP(EYE,CENTRE,PAXES,IC1,IC2,LIGHT,LSHINE,ICLINE,
     *                  ANGLIN,X0,Y0,R0)
C     ---------------------------------------------------------------
C
      REAL            EYE(*),CENTRE(*),PAXES(3,*),LIGHT(*)
      LOGICAL         LSHINE
C
      REAL            SURF(3),EVEC(3,3),ENRM(3)
      REAL*8          DXE,DYE,DZE,DZE2,DWZE,DXH,DYH,DUXH,DVYH
      REAL*8          ALFA,BETA,GAMA,QXX,QYY,QZZ,QXY,QYZ,QZX,U,V,W,XMU
      REAL*8          DBL0,DBL1,DBL2,A,B,C,DET,Q,DX0H,DY0H,DSMALL
      REAL*8          XL0,XL1,HYP,SINPHI,COSPHI,R1,R2
      LOGICAL         LPS,LCOLOR
      COMMON /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      This subroutine plots a shiny or matt coloured elliptical ball. 
C    All (x,y,z) values are taken to be given in world coordinates. The 
C    z-component of the eye-poisition should be positive and that of
C    the ball-centre should be negative (< -radius); the viewing-screen
C    is fixed at z=0.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    EYE      R*4    I       3      (x,y,z) coordinate of eye-position.
C    CENTRE   R*4    I       3      (x,y,z) coordinate of ball-centre.
C    PAXES    R*4    I     3 x 3    Principal axes of the elliposid.
C    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be
C                                   used for shading.
C    LIGHT    R*4    I       3      (x,y,z) direction of flood-light.
C    LSHINE   L*1    I       -      Shiny ball if .TRUE., else diffuse.
C    ICLINE   I*4    I       -      If >=0, colour index for lines on
C                                   surface of ellipsoid.
C    ANGLIN   R*4    I       -      Width of lines: +/- degs.
C    X0,Y0    R*4    O       -      Centre of projected ball.
C    R0       R*4    O       -      Average radius of projected ball.
C
C Globals 
C    SFTBUF
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     SBEGLS     Works out colour-shade for surface of ellipsoid.
C
C History
C   D. S. Sivia       8 Sep 1995  Initial release.
C   D. S. Sivia      29 Sep 1995  Pass down angular-width of lines.
C-----------------------------------------------------------------------
C
C Set up standard ellipsoid and carry out some initial checks.
C
      SMALL=1.0E-20
      DSMALL=DBLE(SMALL)
      IF (EYE(3).LE.0.0) RETURN
      EVAL1=PAXES(1,1)**2+PAXES(2,1)**2+PAXES(3,1)**2
      EVAL2=PAXES(1,2)**2+PAXES(2,2)**2+PAXES(3,2)**2
      EVAL3=PAXES(1,3)**2+PAXES(2,3)**2+PAXES(3,3)**2
      IF (EVAL1.LT.SMALL .OR. EVAL2.LT.SMALL .OR. EVAL3.LT.SMALL) RETURN
      EVAL1=1.0/EVAL1
      EVAL2=1.0/EVAL2
      EVAL3=1.0/EVAL3
      ENRM(1)=SQRT(EVAL1)
      ENRM(2)=SQRT(EVAL2)
      ENRM(3)=SQRT(EVAL3)
      DO 20 J=1,3
        DO 10 I=1,3
  10      EVEC(I,J)=PAXES(I,J)*ENRM(J)
  20  CONTINUE
      DOTSUM=EVEC(1,1)*EVEC(1,2)+EVEC(2,1)*EVEC(2,2)+EVEC(3,1)*EVEC(3,2)
     *      +EVEC(1,2)*EVEC(1,3)+EVEC(2,2)*EVEC(2,3)+EVEC(3,2)*EVEC(3,3)
     *      +EVEC(1,3)*EVEC(1,1)+EVEC(2,3)*EVEC(2,1)+EVEC(3,3)*EVEC(3,1)
      IF (DOTSUM.GT.0.001) RETURN
      QXX=DBLE(EVAL1*EVEC(1,1)**2+EVAL2*EVEC(1,2)**2+EVAL3*EVEC(1,3)**2)
      QYY=DBLE(EVAL1*EVEC(2,1)**2+EVAL2*EVEC(2,2)**2+EVAL3*EVEC(2,3)**2)
      QZZ=DBLE(EVAL1*EVEC(3,1)**2+EVAL2*EVEC(3,2)**2+EVAL3*EVEC(3,3)**2)
      QXY=DBLE(EVAL1*EVEC(1,1)*EVEC(2,1)+EVAL2*EVEC(1,2)*EVEC(2,2)
     *        +EVAL3*EVEC(1,3)*EVEC(2,3))
      QYZ=DBLE(EVAL1*EVEC(2,1)*EVEC(3,1)+EVAL2*EVEC(2,2)*EVEC(3,2)
     *        +EVAL3*EVEC(2,3)*EVEC(3,3))
      QZX=DBLE(EVAL1*EVEC(3,1)*EVEC(1,1)+EVAL2*EVEC(3,2)*EVEC(1,2)
     *        +EVAL3*EVEC(3,3)*EVEC(1,3))
      DBL1=(QYZ*QXX-QXY*QZX)/(QXY**2-QXX*QYY)
      DBL2=(QYZ*QXY-QYY*QZX)/(QXX*QYY-QXY**2)
      A=QXX*DBL2**2+QYY*DBL1**2+QZZ
      B=QXY*DBL1*DBL2+QYZ*DBL1+QZX*DBL2
      ZMAX=CENTRE(3)+SNGL((DSQRT(B**2+A)-B)/A)
      IF (ZMAX.GT.-SMALL) RETURN
C
C Calculate some useful parameters.
C
      DXE=DBLE(EYE(1))
      DYE=DBLE(EYE(2))
      DZE=DBLE(EYE(3))
      DZE2=DZE**2
      ALFA=DBLE(EYE(1)-CENTRE(1))
      BETA=DBLE(EYE(2)-CENTRE(2))
      GAMA=DBLE(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
      XMU=QXX*ALFA**2+QYY*BETA**2+QZZ*GAMA**2+2.0D0*(ALFA*BETA*QXY
     *    +BETA*GAMA*QYZ+GAMA*ALFA*QZX)-1.0D0
      A=XMU*QXX-U**2
      B=XMU*QXY-U*V
      C=XMU*QYY-V**2
      DET=ABS(A*C-B**2)+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
      Q=DZE2*(W**2-XMU*QZZ)+A*DX0H**2+2.0D0*B*DX0H*DY0H+C*DY0H**2
      X0H=SNGL(DX0H)
      Y0H=SNGL(DY0H)
      DX=(XTRC-XBLC)/FLOAT(NXP-1)
      DY=(YTRC-YBLC)/FLOAT(NYP-1)
      XDIF=SNGL(DSQRT(ABS(C*Q/DET)+DSMALL))
      XMIN=X0H-XDIF+EYE(1)
      XMAX=X0H+XDIF+EYE(1)
      IXMIN=INT((XMIN-XBLC)/DX)+2
      IXMAX=INT((XMAX-XBLC)/DX)+1
      IF (IXMIN.GT.NXP .OR. IXMAX.LT.1) RETURN
      YDIF=(DSQRT(ABS(A*Q/DET)+DSMALL))
      YMIN=Y0H-YDIF+EYE(2)
      YMAX=Y0H+YDIF+EYE(2)
      JYMIN=INT((YMIN-YBLC)/DY)+2
      JYMAX=INT((YMAX-YBLC)/DY)+1
      IF (JYMIN.GT.NYP .OR. JYMAX.LT.1) RETURN
      IF (JYMIN.LT.1) JYMIN=1
      IF (JYMAX.GT.NYP) JYMAX=NYP
      X0=X0H+EYE(1)
      Y0=Y0H+EYE(2)
      COREL=SNGL(DSQRT(ABS((B*B)/(A*C))+DSMALL))
      IF (COREL.GT.0.0001) THEN
        XL0=(A+C)/2.0D0
        XL1=XL0-DSQRT(ABS(XL0*XL0-DET)+DSMALL)
        HYP=DSQRT((XL1-A)**2+B**2+DSMALL)
        SINPHI=(XL1-A)/HYP
        COSPHI=B/HYP
      ELSE
        SINPHI=0.0D0
        COSPHI=1.0D0
      ENDIF
      R1=DSQRT(Q/(A*COSPHI*COSPHI+SINPHI*(C*SINPHI+2.0*B*COSPHI)))
      R2=DSQRT(Q/(A*SINPHI*SINPHI+COSPHI*(C*COSPHI-2.0*B*SINPHI)))
      R0=SNGL((R1+R2)/2.0D0)
C
C Fill the inside of the projected ellipse with the right colours.
C
      COSMIN=MAX(SIN(ABS(ANGLIN/57.29578)),0.0001)
      NC=IC2-IC1
      COL0=FLOAT(IC1)
      COLSCL=FLOAT(NC)
      COLINE=FLOAT(ICLINE)
      XL2=LIGHT(1)**2+LIGHT(2)**2+LIGHT(3)**2
      YH=YBLC+DY*FLOAT(JYMIN-1)-EYE(2)
      DWZE=W*DZE
      BA=SNGL(B/A)
      DO 40 JY=JYMIN,JYMAX
        DYH=DBLE(YH)
        DVYH=V*DYH
        DBL0=QZZ*DZE2+DYH*(QYY*DYH-2.0D0*QYZ*DZE)
        YDIF=YH-Y0H
        XDIF=SNGL(DSQRT(ABS(A*Q-DET*DBLE(YDIF**2))+DSMALL)/A)
        XMIN=X0H-BA*YDIF-XDIF+EYE(1)
        XMAX=X0H-BA*YDIF+XDIF+EYE(1)
        IXMIN=INT((XMIN-XBLC)/DX)+2
        IXMAX=INT((XMAX-XBLC)/DX)+1
        IF (IXMIN.LE.NXP .AND. IXMAX.GE.1) THEN
          IF (IXMIN.LT.1) IXMIN=1
          IF (IXMAX.GT.NXP) IXMAX=NXP
          XH=XBLC+DX*FLOAT(IXMIN-1)-EYE(1)
          K=(JY-1)*NXP+IXMIN
          DO 30 IX=IXMIN,IXMAX
            IF (ZMAX.GT.SBBUFF(K)) THEN
              DXH=DBLE(XH)
              DUXH=U*DXH
              DBL1=DUXH+DVYH-DWZE
              DBL2=DBL0+DXH*(QXX*DXH+2.0D0*(QXY*DYH-QZX*DZE))
              XLM=SNGL((-DBL1-DSQRT(ABS(DBL1**2-XMU*DBL2)+DSMALL))/DBL2)
              SURF(3)=EYE(3)*(1.0-XLM)
              IF (SURF(3).GT.SBBUFF(K)) THEN
                SBBUFF(K)=SURF(3)
                IF (NC.EQ.0) THEN
                  SBBUFF(KSTART+K)=COL0
                ELSE
                  SURF(2)=EYE(2)+YH*XLM
                  SURF(1)=EYE(1)+XH*XLM
                  CALL SBEGLS(EYE,CENTRE,LIGHT,SURF,XL2,QXX,QYY,QZZ,QXY,
     *              QYZ,QZX,SMALL,LSHINE,COLOUR,EVEC,ICLINE,COSMIN)
                  IF (COLOUR.GT.2.0) THEN
                    SBBUFF(KSTART+K)=COLINE
                  ELSE
                    SBBUFF(KSTART+K)=COL0+COLOUR*COLSCL
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
            K=K+1
            XH=XH+DX
  30      CONTINUE
        ENDIF
        YH=YH+DY
  40  CONTINUE
      END
C
      SUBROUTINE SBEGLS(EYE,CENTRE,LIGHT,SURF,XL2,QXX,QYY,QZZ,QXY,QYZ,
     *                  QZX,SMALL,LSHINE,COLOUR,EVEC,ICLINE,COSANG)
C     ----------------------------------------------------------------
C
C Support subroutine for SBELIP, to work out colour-shade.
C
      REAL    EYE(*),CENTRE(*),LIGHT(*),SURF(*),EVEC(3,*)
      REAL*8  QXX,QYY,QZZ,QXY,QYZ,QZX,DDX,DDY,DDZ
      LOGICAL LSHINE
      REAL    NORMAL(3),REFLEC(3),VIEW(3)
C
      COLOUR=0.0
      DX=SURF(1)-CENTRE(1)
      DY=SURF(2)-CENTRE(2)
      DZ=SURF(3)-CENTRE(3)
      IF (ICLINE.GE.0) THEN
        SNORM=1.0/SQRT(DX**2+DY**2+DZ**2)
        COS1=ABS(SNORM*(DX*EVEC(1,1)+DY*EVEC(2,1)+DZ*EVEC(3,1)))
        COS2=ABS(SNORM*(DX*EVEC(1,2)+DY*EVEC(2,2)+DZ*EVEC(3,2)))
        COS3=ABS(SNORM*(DX*EVEC(1,3)+DY*EVEC(2,3)+DZ*EVEC(3,3)))
        COSMIN=MIN(COS1,COS2,COS3)
        IF (COSMIN.LT.COSANG) THEN
          COLOUR=10.0
          RETURN
        ENDIF
      ENDIF
      DDX=DBLE(DX)
      DDY=DBLE(DY)
      DDZ=DBLE(DZ)
      NORMAL(1)=SNGL(QXX*DDX+QXY*DDY+QZX*DDZ)
      NORMAL(2)=SNGL(QXY*DDX+QYY*DDY+QYZ*DDZ)
      NORMAL(3)=SNGL(QZX*DDX+QYZ*DDY+QZZ*DDZ)
      XN2=0.0
      XNL=0.0
      DO 10 I=1,3
        XNL=XNL+NORMAL(I)*LIGHT(I)
        XN2=XN2+NORMAL(I)**2
  10  CONTINUE
      IF (XNL.GE.0.0) RETURN
      IF (LSHINE) THEN
        RFNORM=(XNL+XNL)/(XN2+SMALL)
        XRV=0.0
        DO 20 I=1,3
          VIEW(I)=EYE(I)-SURF(I)
          REFLEC(I)=LIGHT(I)-RFNORM*NORMAL(I)
          XRV=XRV+REFLEC(I)*VIEW(I)
  20    CONTINUE
        IF (XRV.LT.0.0) RETURN
        REF2=0.0
        VIEW2=0.0
        DO 30 I=1,3
          REF2=REF2+REFLEC(I)**2
          VIEW2=VIEW2+VIEW(I)**2
  30    CONTINUE
        COLOUR=MIN(XRV**2/(ABS(REF2*VIEW2)+SMALL),1.0)
      ELSE
        COLOUR=MIN(-XNL/SQRT(XN2*XL2+SMALL),1.0)
      ENDIF
      END
C
      SUBROUTINE SBTEXT(EYE,TEXT,ICOL,PIVOT,FJUST,ORIENT,SIZE)
C     --------------------------------------------------------
C
      REAL          EYE(*),PIVOT(*),ORIENT(3,2)
      CHARACTER*(*) TEXT
C
      INCLUDE      'grpckg1.inc'
      REAL          END1(3),END2(3)
      INTEGER       SYMBOL(256),XYGRID(300),XYBASE,XYLEFT
      LOGICAL       LSTART,UNUSED
      SAVE          LSTART
      DATA          LSTART,SMALL,IJFLAG /.FALSE.,1.0E-10,-64/
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      Write a text string in 3-d perspective. All (x,y,z) values are 
C    taken to be given in world coordinates. The z-component of the 
C    eye-poisition should be positive and that of the text string should 
C    be negative; the viewing-screen is fixed at z=0.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    EYE      R*4    I       3      (x,y,z) coordinate of eye-position.
C    TEXT     C*1    I       *      The text string to be written.
C    ICOL     I*4    I       -      Colour index for text.
C    PIVOT    R*4    I       3      (x,y,z) coordinate of pivot point.
C    FJUST    R*4    I       -      Position of pivot along the text: 
C                                   0.0=left, 0.5=centre, 1.0=right.
C    ORIENT   R*4    I     3 x 2    (x,y,z) for X-length and Y-height
C                                   directions of the text.
C    SIZE     R*4    I       -      Height of the reference symbol "A".
C
C Globals
C    GRPCKG1.INC
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     GRSY00     Initialises font description.
C     GRSYDS     Decodes string into a list of Hershey symbol numbers.
C     GRSYXD     Obtains the polyline representation of a given symbol.
C     GRLEN      Calculates the length of the string.
C     SBLINE     Draws a 3-d line in perspective.
C
C History
C   D. S. Sivia      14 Sep 1995  Initial release.
C   D. S. Sivia      11 Oct 1995  Modified a J DO LOOP for a Pentium!
C-----------------------------------------------------------------------
C
C Carry out some initial checks.
C
      IF (EYE(3).LE.SMALL) RETURN
      IF (FJUST.LT.0.0 .OR. FJUST.GT.1.0) RETURN
      IF (SIZE.LT.SMALL) RETURN
      XLEN=SQRT(ORIENT(1,1)**2+ORIENT(2,1)**2+ORIENT(3,1)**2)
      YLEN=SQRT(ORIENT(1,2)**2+ORIENT(2,2)**2+ORIENT(3,2)**2)
      IF (XLEN.LT.SMALL .OR. YLEN.LT.SMALL) RETURN
      COSANG=(ORIENT(1,1)*ORIENT(1,2)+ORIENT(2,1)*ORIENT(2,2)+
     *        ORIENT(3,1)*ORIENT(3,2))/(XLEN*YLEN)
      IF (ABS(COSANG).GT.0.001) RETURN
      IF (.NOT.LSTART) THEN
        CALL GRSY00
        LSTART=.TRUE.
      ENDIF
      NCHAR=MIN(LEN(TEXT),256)
      DO 10 I=NCHAR,1,-1
  10    IF (TEXT(I:I).NE.' ') GOTO 1
   1  NCHMAX=I
      IF (NCHMAX.LT.1) RETURN
      DO 20 I=1,NCHMAX
  20    IF (TEXT(I:I).NE.' ') GOTO 2
   2  NCHMIN=I
C
C Calculate the parameters for the Hershey --> world coordinates 
C transformation.
C
      CALL GRLEN(TEXT(NCHMIN:NCHMAX),D)
      D=D*2.5/GRCFAC(GRCIDE)
      CALL GRSYDS(ISYMBA,NSYMBS,'A',1)
      CALL GRSYXD(ISYMBA,XYGRID,UNUSED)
      TSCL=SIZE/FLOAT(XYGRID(3)-XYGRID(2))
      XNORM=TSCL/XLEN
      YNORM=TSCL/YLEN
      XX=ORIENT(1,1)*XNORM
      XY=ORIENT(2,1)*XNORM
      XZ=ORIENT(3,1)*XNORM
      YX=ORIENT(1,2)*YNORM
      YY=ORIENT(2,2)*YNORM
      YZ=ORIENT(3,2)*YNORM
      X0=PIVOT(1)-FJUST*D*XX
      Y0=PIVOT(2)-FJUST*D*XY
      Z0=PIVOT(3)-FJUST*D*XZ
      Z1=PIVOT(3)+(1.0-FJUST)*D*XZ
      IF (Z0.GT.-SMALL .OR. Z1.GT.-SMALL) RETURN
C
C Write out the text string, character by character.
C
      DX=0.0
      DY=0.0
      DZ=0.0
      FNTBAS=0.0
      FNTFAC=1.0
      IFNTLV=0
      CALL GRSYDS(SYMBOL,NSYMBS,TEXT(NCHMIN:NCHMAX),1)
      DO 40 K=1,NSYMBS
        KSYMB=SYMBOL(K)
        IF (KSYMB.LT.0) THEN
          IF (KSYMB.EQ.-1) THEN
            IFNTLV=IFNTLV+1
            FNTBAS=FNTBAS+16.0*FNTFAC
            FNTFAC=0.75**ABS(IFNTLV)
          ELSEIF (KSYMB.EQ.-2) THEN
            IFNTLV=IFNTLV-1
            FNTFAC=0.75**ABS(IFNTLV)
            FNTBAS=FNTBAS-16.0*FNTFAC
          ELSEIF (KSYMB.EQ.-3) THEN
            X0=X0-DX
            Y0=Y0-DY
            Z0=Z0-DZ
          END IF
          GOTO 40
        ENDIF
        CALL GRSYXD(KSYMB,XYGRID,UNUSED)
        IF (.NOT. UNUSED) THEN
          XYBASE=XYGRID(2)
          XYLEFT=XYGRID(4)
          RLX=FLOAT(XYGRID(6)-XYLEFT)*FNTFAC
          RLY=FLOAT(XYGRID(7)-XYBASE)*FNTFAC+FNTBAS
          END1(1)=X0+RLX*XX+RLY*YX
          END1(2)=Y0+RLX*XY+RLY*YY
          END1(3)=Z0+RLX*XZ+RLY*YZ
          J=8
          DO 30 JJ=8,298,2
            IX=XYGRID(J)
            JY=XYGRID(J+1)
            IF (JY.EQ.IJFLAG) GOTO 3
            IF (IX.EQ.IJFLAG) THEN
              J=J+2
              RLX=FLOAT(XYGRID(J)-XYLEFT)*FNTFAC
              RLY=FLOAT(XYGRID(J+1)-XYBASE)*FNTFAC+FNTBAS
              END1(1)=X0+RLX*XX+RLY*YX
              END1(2)=Y0+RLX*XY+RLY*YY
              END1(3)=Z0+RLX*XZ+RLY*YZ
            ELSE
              RLX=FLOAT(IX-XYLEFT)*FNTFAC
              RLY=FLOAT(JY-XYBASE)*FNTFAC+FNTBAS
              END2(1)=X0+RLX*XX+RLY*YX
              END2(2)=Y0+RLX*XY+RLY*YY
              END2(3)=Z0+RLX*XZ+RLY*YZ
              CALL SBLINE(EYE,END1,END2,ICOL,.FALSE.)
              CALL SBRCOP(END2,END1,3)
            ENDIF
            J=J+2            
  30      CONTINUE
        ENDIF
  3     XL=FNTFAC*FLOAT(XYGRID(5)-XYLEFT)
        DX=XL*XX
        DY=XL*XY
        DZ=XL*XZ
        X0=X0+DX
        Y0=Y0+DY
        Z0=Z0+DZ
  40  CONTINUE
      END
C
      SUBROUTINE SBCPLN(EYE,LATICE,IC1,IC2,LIGHT,SLNORM,APOINT,ICEDGE,
     *                  ITRANS)
C     ----------------------------------------------------------------
C
      REAL    EYE(*),LATICE(3,*),LIGHT(*)
      REAL    SLNORM(*),APOINT(*)
C
      REAL    END1(3),END2(3),VERT1(3,12),VERT2(3,12)
      LOGICAL LVERT(12)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      This subroutine plots a diffusively-lit, semi-transparent, 
C    coloured plane through a unit cell. All (x,y,z) values are taken to
C    be given in world coordinates. The z-component of the eye-poisition 
C    should be positive and that of all the lattice-vertices should be 
C    negative; the viewing-screen is fixed at z=0.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    EYE      R*4    I       3      (x,y,z) coordinate of eye-position.
C    LATICE   R*4    I     3 x 4    (x,y,z) coordinates of the origin
C                                   and the a, b & C lattice-vertices.
C    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be
C                                   used for the shading.
C    LIGHT    R*4    I       3      (x,y,z) direction of flood-light.
C    SLNORM   R*4    I       3      (x,y,z) direction of normal to plane.
C    APONIT   R*4    I       3      (x,y,z) coordinate of a point within
C                                   the plane.
C    ICEDGE   I*4    I       -      If >=0, it's the colour-index for
C                                   the boundary of the plane.
C    ITRANS   I*4    I       -      Level of transparency:
C                                     0 = 0%; 1 = 25%; 2 = 50%; 3 = 75%.
C
C Globals 
C    None
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     SBSLC1     Checks whether a side of the unit cell is cut by the
C                plane & calculates the coordinates of the intersection.
C     SBCPL1     Order the verticies of the polygon-of-intersection.
C     SBLIN1     Calculates the projection of (x,y,z) on viewing screen.
C     SBPLAN     Plots a coloured plane.
C     SBPLNT     Plots a semi-transparent coloured plane.
C
C History
C   D. S. Sivia      26 Sep 1995  Initial release.
C-----------------------------------------------------------------------
C
C Carry out some initial checks.
C
      SMALL=1.0E-10
      SMALL2=SMALL**2
      IF (EYE(3).LE.SMALL) RETURN
      SNRM=1.0/SQRT(SLNORM(1)**2+SLNORM(2)**2+SLNORM(3)**2+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=DBLE(XN*XAE)+DBLE(YN*YAE)+DBLE(ZN*ZAE)
      COSNRM=SNGL(XLNORM/DSQRT(DBLE(XAE**2)+DBLE(YAE**2)+DBLE(ZAE**2)
     *      +DBLE(SMALL2)))
      IF (ABS(COSNRM).LT.0.001) RETURN
      DO 10 J=1,3
        DX=LATICE(1,J+1)-LATICE(1,1)
        DY=LATICE(2,J+1)-LATICE(2,1)
        DZ=LATICE(3,J+1)-LATICE(3,1)
        D2=DX**2+DY**2+DZ**2
        IF (D2.LT.SMALL2) RETURN
  10  CONTINUE
C
C Calculate the coordinates of the polygon-of-intersection between the
C the plane and the edges of the unit cell.
C
      NVERT=0
      II=0
      DO 20 L=1,12,4
        I=II+2
        J=MOD(II+1,3)+2
        K=MOD(II+2,3)+2
        CALL SBSLC1(LATICE,LATICE(1,K),XN,YN,ZN,APOINT,LVERT(L),
     *              VERT1(1,L),NVERT)
        END1(1)=LATICE(1,I)+LATICE(1,J)-LATICE(1,1)
        END1(2)=LATICE(2,I)+LATICE(2,J)-LATICE(2,1)
        END1(3)=LATICE(3,I)+LATICE(3,J)-LATICE(3,1)
        CALL SBSLC1(LATICE(1,I),END1,XN,YN,ZN,APOINT,LVERT(L+1),
     *              VERT1(1,L+1),NVERT)
        CALL SBSLC1(LATICE(1,J),END1,XN,YN,ZN,APOINT,LVERT(L+2),
     *              VERT1(1,L+2),NVERT)
        END2(1)=END1(1)+LATICE(1,K)-LATICE(1,1)
        END2(2)=END1(2)+LATICE(2,K)-LATICE(2,1)
        END2(3)=END1(3)+LATICE(3,K)-LATICE(3,1)
        CALL SBSLC1(END1,END2,XN,YN,ZN,APOINT,LVERT(L+3),
     *              VERT1(1,L+3),NVERT)
        II=II+1
  20  CONTINUE
      IF (NVERT.LT.3) RETURN
      CALL SBCPL1(EYE,LVERT,VERT1,VERT2,NVERT,XN,YN,ZN,ICEDGE,ZDLINE)
C
C Plot the plane.
C
      ITLEVL=MAX(MIN(ITRANS,3),0)
      IF (ITLEVL.EQ.0) THEN
        CALL SBPLAN(EYE,NVERT,VERT2,IC1,IC2,LIGHT)
      ELSE
        CALL SBPLNT(EYE,NVERT,VERT2,IC1,IC2,LIGHT,ITLEVL)
      ENDIF
      END
C
      SUBROUTINE SBCPL1(EYE,LVERT,VERT1,VERT2,NVERT,XN,YN,ZN,ICOL,ZDIF)
C     -----------------------------------------------------------------
C
      REAL    EYE(*),VERT1(3,*),VERT2(3,*),VERT3(3),ANGLE(12)
      INTEGER ISORT(12)
      LOGICAL LVERT(*)
C
      IV1=0
      XBAR=0.0
      YBAR=0.0
      ZBAR=0.0
      ZMIN=+1.0E20
      ZMAX=-1.0E20
      DO 10 K=1,12
        ZMIN=MIN(ZMIN,VERT1(3,K))
        ZMAX=MAX(ZMAX,VERT1(3,K))
        IF (LVERT(K)) THEN
          IF (IV1.LE.0) IV1=K
          XBAR=XBAR+VERT1(1,K)
          YBAR=YBAR+VERT1(2,K)
          ZBAR=ZBAR+VERT1(3,K)
        ENDIF
  10  CONTINUE
      ZDIF=(ZMAX-ZMIN)/5000.0
      XBAR=XBAR/FLOAT(NVERT)
      YBAR=YBAR/FLOAT(NVERT)
      ZBAR=ZBAR/FLOAT(NVERT)
      XREF=VERT1(1,IV1)-XBAR
      YREF=VERT1(2,IV1)-YBAR
      ZREF=VERT1(3,IV1)-ZBAR
      REFNRM=1.0/SQRT(XREF**2+YREF**2+ZREF**2+1.0E-20)
      XREF=XREF*REFNRM
      YREF=YREF*REFNRM
      ZREF=ZREF*REFNRM
      XNRM=YREF*ZN-YN*ZREF
      YNRM=ZREF*XN-ZN*XREF
      ZNRM=XREF*YN-XN*YREF
      J=1
      ANGLE(J)=0.0
      ISORT(J)=IV1
      CALL SBRCOP(VERT1(1,IV1),VERT2(1,J),3)
      DO 40 K=IV1+1,12
        IF (LVERT(K)) THEN
          J=J+1
          XVEC=VERT1(1,K)-XBAR
          YVEC=VERT1(2,K)-YBAR
          ZVEC=VERT1(3,K)-ZBAR
          X=XVEC*XREF+YVEC*YREF+ZVEC*ZREF
          Y=XVEC*XNRM+YVEC*YNRM+ZVEC*ZNRM
          ANGJ=ATAN2(Y,X)
          CALL SBRCOP(VERT1(1,K),VERT3,3)
          DO 20 I=1,J-1
  20        IF (ANGJ.LT.ANGLE(I)) GOTO 1
   1      II=I
           DO 30 I=J,II+1,-1
            CALL SBRCOP(VERT2(1,I-1),VERT2(1,I),3)
            ANGLE(I)=ANGLE(I-1)
            ISORT(I)=ISORT(I-1)
  30      CONTINUE
          CALL SBRCOP(VERT3,VERT2(1,II),3)
          ANGLE(II)=ANGJ
          ISORT(II)=K
        ENDIF
  40  CONTINUE
      IF (ICOL.GE.0.0) THEN
        DO 50 I=1,NVERT-1
          J=ISORT(I)
          K=ISORT(I+1)
          CALL SBLINE(EYE,VERT1(1,J),VERT1(1,K),ICOL,.FALSE.)
  50    CONTINUE
        CALL SBLINE(EYE,VERT1(1,K),VERT1(1,ISORT(1)),ICOL,.FALSE.)
      ENDIF
      END
C
      SUBROUTINE SBTBAL(EYE,CENTRE,RADIUS,IC1,IC2,LIGHT,LSHINE,X0,Y0,R0,
     *                  ITRANS)
C     ------------------------------------------------------------------
C
      REAL            EYE(*),CENTRE(*),LIGHT(*)
      LOGICAL         LSHINE

      REAL            SURF(3)
      REAL*8          ALFA,BETA,GAMA,XMU,A,B,C,DET,Q,DX0H,DY0H
      REAL*8          DZE,DZE2,DGAMZE,DBL1,DBL2,DSMALL
      REAL*8          XL0,XL1,HYP,SINPHI,COSPHI,R1,R2
      LOGICAL         LPS,LCOLOR
      COMMON /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      This subroutine plots a semi-transparent shiny or matt coloured 
C    ball. All (x,y,z) values are taken to be given in world coordinates.
C    The z-component of the eye-poisition should be positive and that of
C    the ball-centre should be negative (< -radius); the viewing-screen
C    is fixed at z=0.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    EYE      R*4    I       3      (x,y,z) coordinate of eye-position.
C    CENTRE   R*4    I       3      (x,y,z) coordinate of ball-centre.
C    RADIUS   R*4    I       -      Radius of ball.
C    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be
C                                   used for shading.
C    LIGHT    R*4    I       3      (x,y,z) direction of flood-light.
C    LSHINE   L*1    I       -      Shiny ball if .TRUE., else diffuse.
C    X0,Y0    R*4    O       -      Centre of projected ball.
C    R0       R*4    O       -      Average radius of projected ball.
C    ITRANS   I*4    I       -      Level of transparency:
C                                        1 = 25%; 2 = 50%; 3 = 75%.
C
C Globals 
C    SFTBUF
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     SBGLOS     Works out colour-shade for surface of ball.
C
C History
C   D. S. Sivia       8 Jul 1996  Initial release.
C-----------------------------------------------------------------------
C
C Some initial checks.
C
      SMALL=1.0E-20
      DSMALL=DBLE(SMALL)
      IF (EYE(3).LE.0.0) RETURN
      IF (RADIUS.LE.0.0) RETURN
      IF (CENTRE(3).GT.-RADIUS) RETURN
C
C Calculate parameters of projected ellipse.
C
      DZE=DBLE(EYE(3))
      DZE2=DZE**2
      ALFA=DBLE(EYE(1)-CENTRE(1))
      BETA=DBLE(EYE(2)-CENTRE(2))
      GAMA=DBLE(EYE(3)-CENTRE(3))
      XMU=DBLE(RADIUS**2)-(ALFA**2+BETA**2+GAMA**2)
      A=XMU*(XMU+ALFA**2)
      B=XMU*ALFA*BETA
      C=XMU*(XMU+BETA**2)
      DET=ABS(A*C-B**2)+DSMALL
      DX0H=GAMA*XMU*DZE*(ALFA*C-BETA*B)/DET
      DY0H=GAMA*XMU*DZE*(BETA*A-ALFA*B)/DET
      Q=A*DX0H**2+2.0*B*DX0H*DY0H+C*DY0H**2-XMU*(XMU+GAMA**2)*DZE2
      X0H=SNGL(DX0H)
      Y0H=SNGL(DY0H)
      DX=(XTRC-XBLC)/FLOAT(NXP-1)
      DY=(YTRC-YBLC)/FLOAT(NYP-1)
      XDIF=SNGL(DSQRT(ABS(C*Q/DET)+DSMALL))
      XMIN=X0H-XDIF+EYE(1)
      XMAX=X0H+XDIF+EYE(1)
      IXMIN=INT((XMIN-XBLC)/DX)+2
      IXMAX=INT((XMAX-XBLC)/DX)+1
      IF (IXMIN.GT.NXP .OR. IXMAX.LT.1) RETURN
      YDIF=(DSQRT(ABS(A*Q/DET)+DSMALL))
      YMIN=Y0H-YDIF+EYE(2)
      YMAX=Y0H+YDIF+EYE(2)
      JYMIN=INT((YMIN-YBLC)/DY)+2
      JYMAX=INT((YMAX-YBLC)/DY)+1
      IF (JYMIN.GT.NYP .OR. JYMAX.LT.1) RETURN
      IF (JYMIN.LT.1) JYMIN=1
      IF (JYMAX.GT.NYP) JYMAX=NYP
      ZMAX=CENTRE(3)+RADIUS
      X0=X0H+EYE(1)
      Y0=Y0H+EYE(2)
      COREL=SNGL(DSQRT(ABS((B*B)/(A*C))+DSMALL))
      IF (COREL.GT.0.0001) THEN
        XL0=(A+C)/2.0D0
        XL1=XL0-DSQRT(ABS(XL0*XL0-DET)+DSMALL)
        HYP=DSQRT((XL1-A)**2+B**2+DSMALL)
        SINPHI=(XL1-A)/HYP
        COSPHI=B/HYP
      ELSE
        SINPHI=0.0D0
        COSPHI=1.0D0
      ENDIF
      R1=DSQRT(Q/(A*COSPHI*COSPHI+SINPHI*(C*SINPHI+2.0*B*COSPHI)))
      R2=DSQRT(Q/(A*SINPHI*SINPHI+COSPHI*(C*COSPHI-2.0*B*SINPHI)))
      R0=SNGL((R1+R2)/2.0D0)
C
C Fill the inside of the projected ellipse with the right colours.
C
      ITLEVL=MAX(MIN(ITRANS,3),1)
      NC=IC2-IC1
      COL0=FLOAT(IC1)
      COLSCL=FLOAT(NC)
      XL2=LIGHT(1)**2+LIGHT(2)**2+LIGHT(3)**2
      XN2=RADIUS**2
      XNL2=1.0/SQRT(XN2*XL2+SMALL)
      XN3=1.0/(XN2+SMALL)
      YH=YBLC+DY*FLOAT(JYMIN-1)-EYE(2)
      DGAMZE=GAMA*DZE
      BA=SNGL(B/A)
      DO 20 JY=JYMIN,JYMAX
        JTEST=MOD(JY,2)
        IF (ITLEVL.EQ.3 .AND. JTEST.EQ.1) GOTO 19
        YH2=YH**2
        BETAYH=BETA*YH
        YDIF=YH-Y0H
        XDIF=SNGL(DSQRT(ABS(A*Q-DET*DBLE(YDIF**2))+DSMALL)/A)
        XMIN=X0H-BA*YDIF-XDIF+EYE(1)
        XMAX=X0H-BA*YDIF+XDIF+EYE(1)
        IXMIN=INT((XMIN-XBLC)/DX)+2
        IXMAX=INT((XMAX-XBLC)/DX)+1
        IF (IXMIN.LE.NXP .AND. IXMAX.GE.1) THEN
          IF (IXMIN.LT.1) IXMIN=1
          IF (IXMAX.GT.NXP) IXMAX=NXP
          XH=XBLC+DX*FLOAT(IXMIN-1)-EYE(1)
          K=(JY-1)*NXP+IXMIN
          DO 10 IX=IXMIN,IXMAX
            ITEST=MOD(IX,2)
            IF (ITLEVL.EQ.1) THEN
              IF ((ITEST+JTEST).EQ.0) GOTO 9
            ELSEIF (ITLEVL.EQ.2) THEN
              IF ((ITEST+JTEST).EQ.1) GOTO 9
            ELSE
              IF (ITEST.EQ.1) GOTO 9
            ENDIF
            IF (ZMAX.GT.SBBUFF(K)) THEN
              XH2=XH**2
              ALFAXH=ALFA*XH
              DBL1=DBLE(ALFAXH+BETAYH)-DGAMZE
              DBL2=DBLE(XH2+YH2)+DZE2
              XLM=SNGL((-DBL1-DSQRT(ABS(DBL1**2+XMU*DBL2)+DSMALL))/DBL2)
              SURF(3)=EYE(3)*(1.0-XLM)
              IF (SURF(3).GT.SBBUFF(K)) THEN
                SBBUFF(K)=SURF(3)
                IF (NC.EQ.0) THEN
                  SBBUFF(KSTART+K)=COL0
                ELSE
                  SURF(2)=EYE(2)+YH*XLM
                  SURF(1)=EYE(1)+XH*XLM
                  CALL SBGLOS(EYE,CENTRE,LIGHT,SURF,XNL2,XN3,SMALL,
     *                        LSHINE,COLOUR)
                  SBBUFF(KSTART+K)=COL0+COLOUR*COLSCL
                ENDIF
              ENDIF
            ENDIF
   9        K=K+1
            XH=XH+DX
  10      CONTINUE
        ENDIF
  19    YH=YH+DY
  20  CONTINUE
      END
C
      SUBROUTINE SBTSUR(EYE,LATICE,DENS,N1,N2,N3,DSURF,IC1,IC2,LIGHT,
     *                  LSHINE,ITRANS)
C     ---------------------------------------------------------------
C
      REAL             EYE(*),LATICE(3,*),DENS(0:N1,0:N2,0:N3),LIGHT(*)
      LOGICAL          LSHINE
C
      REAL*8           XLNORM,PNEYE(3),DSMAL2
      REAL             BAS(3,3),MTRX
      REAL             XYZ(3),DXYZ(3,3),FRCXYZ(12),DDXYZ(3,12,2)
      REAL             DLOCAL(8),VERT(3,12),GRDSCL(3)
      LOGICAL          LPS,LCOLOR,LEMPTY
      INTEGER          IVERT(8)
      COMMON  /SRFCOM/ GRDCUB(3,8),MTRX(3,3),ORIG(3),XL2,COL0,COLSCL
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      This subroutine plots a semi-transparent iso-surface through a 
C    unit-cell of density. All (x,y,z) values are taken to be given in 
C    world coordinates. The z-component of the eye-poisition should be 
C    positive and that of all the lattice-vertices should be negative; 
C    the viewing-screen is fixed at z=0.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    EYE      R*4    I       3      (x,y,z) coordinate of eye-position.
C    LATICE   R*4    I     3 x 4    (x,y,z) coordinates of the origin
C                                   and the a, b & C lattice-vertices.
C    DENS     R*4    I     (N1+1)   The density at regular points within
C                        x (N2+1)   the unit cell, wrapped around so
C                        x (N3+1)   that DENS(0,J,K)=DENS(N1,J,K) etc..
C    N1,N2,N3 I*4    I       -      The dimensions of the unit-cell grid.
C    DSURF    R*4    I       -      Density for the iso-surface.
C    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be
C                                   used for the shading.
C    LIGHT    R*4    I       3      (x,y,z) direction of flood-light.
C    LSHINE   L*1    I       -      Shiny surface if TRUE, else diffuse.
C    ITRANS   I*4    I       -      Level of transparency:
C                                        1 = 25%; 2 = 50%; 3 = 75%.
C
C Globals 
C    SFTBUF
C    SRFCOM
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     SBSRF0     A quick check in case there are no iso-surafces.
C     SBSRF1     Anlayses a 2-d box in the surface of the unit-cell.
C     SBTSF2     Paints a 2-d box in the surface of the unit-cell.
C     SBSRF3     Analyses a 3-d box within the unit-cell.
C     SBSRF4     Initialises the gradients for a 3-d box.
C     SBTSF5     Breaks up the iso-surface in a 3-d box into triangles.
C     SBTSF6     Paints a triangular patch of a semi-transp iso-surface.
C
C History
C   D. S. Sivia       9 Jul 1996  Initial release.
C   D. S. Sivia      24 Oct 1997 "Safe-guarded" some rounding errors.
C-----------------------------------------------------------------------
C
C Carry out some initial checks.
C
      SMALL=1.0E-10
      SMALL2=SMALL**2
      DSMAL2=DBLE(SMALL2)
      IF (EYE(3).LE.SMALL) RETURN
      IF (N1.LT.1 .OR. N2.LT.1 .OR. N3.LT.1) RETURN
      XL2=LIGHT(1)**2+LIGHT(2)**2+LIGHT(3)**2
      IF (XL2.LT.SMALL) RETURN
      IF (LATICE(3,1).GE.0.0) RETURN
      ZFAR=LATICE(3,2)+LATICE(3,3)+LATICE(3,4)-2.0*LATICE(3,1)
      IF (ZFAR.GE.0.0) RETURN
      DO 10 J=1,3
        IF (LATICE(3,J+1).GE.0.0) RETURN
        BAS(1,J)=LATICE(1,J+1)-LATICE(1,1)
        BAS(2,J)=LATICE(2,J+1)-LATICE(2,1)
        BAS(3,J)=LATICE(3,J+1)-LATICE(3,1)
        IF ((ZFAR-BAS(3,J)).GE.0.0) RETURN
        BAS2J=BAS(1,J)**2+BAS(2,J)**2+BAS(3,J)**2
        IF (BAS2J.LT.SMALL2) RETURN
  10  CONTINUE
      NTOT=(N1+1)*(N2+1)*(N3+1)
      CALL SBSRF0(DENS,NTOT,DSURF,LEMPTY)
      IF (LEMPTY) RETURN
C
C Set up matrix for real-space to lattice-index transformation.
C
      XN1=0.99999*FLOAT(N1)
      XN2=0.99999*FLOAT(N2)
      XN3=0.99999*FLOAT(N3)
      DET=BAS(1,1)*BAS(2,2)*BAS(3,3)+BAS(1,2)*BAS(2,3)*BAS(3,1)
     *   +BAS(1,3)*BAS(2,1)*BAS(3,2)-BAS(3,1)*BAS(2,2)*BAS(1,3)
     *   -BAS(3,2)*BAS(2,3)*BAS(1,1)-BAS(3,3)*BAS(2,1)*BAS(1,2)
      IF (ABS(DET).LT.SMALL2) RETURN
      DETNRM=1.0/DET
      MTRX(1,1)=XN1*DETNRM*(BAS(2,2)*BAS(3,3)-BAS(2,3)*BAS(3,2))
      MTRX(1,2)=XN2*DETNRM*(BAS(2,3)*BAS(3,1)-BAS(2,1)*BAS(3,3))
      MTRX(1,3)=XN3*DETNRM*(BAS(2,1)*BAS(3,2)-BAS(2,2)*BAS(3,1))
      MTRX(2,1)=XN1*DETNRM*(BAS(3,2)*BAS(1,3)-BAS(3,3)*BAS(1,2))
      MTRX(2,2)=XN2*DETNRM*(BAS(3,3)*BAS(1,1)-BAS(3,1)*BAS(1,3))
      MTRX(2,3)=XN3*DETNRM*(BAS(3,1)*BAS(1,2)-BAS(3,2)*BAS(1,1))
      MTRX(3,1)=XN1*DETNRM*(BAS(1,2)*BAS(2,3)-BAS(1,3)*BAS(2,2))
      MTRX(3,2)=XN2*DETNRM*(BAS(1,3)*BAS(2,1)-BAS(1,1)*BAS(2,3))
      MTRX(3,3)=XN3*DETNRM*(BAS(1,1)*BAS(2,2)-BAS(1,2)*BAS(2,1))
      CALL SBRCOP(LATICE,ORIG,3)
C
C Some general initialisations.
C
      DDSURF=MAX(ABS(DSURF),SMALL)
      IF (DSURF.LT.0.0) DDSURF=-DDSURF
      GRDSCL(1)=-0.5/(DDSURF*FLOAT(N1))
      GRDSCL(2)=-0.5/(DDSURF*FLOAT(N2))
      GRDSCL(3)=-0.5/(DDSURF*FLOAT(N3))
      COL0=FLOAT(IC1)
      COLSCL=FLOAT(IC2-IC1)
      DO 30 I=1,3
        DXYZ(I,1)=BAS(I,1)/FLOAT(N1)
        DXYZ(I,2)=BAS(I,2)/FLOAT(N2)
        DXYZ(I,3)=BAS(I,3)/FLOAT(N3)
        DDXYZ(I,1,1)=0.0
        DDXYZ(I,1,2)=DXYZ(I,1)
        DDXYZ(I,2,1)=DDXYZ(I,1,1)+DDXYZ(I,1,2)
        DDXYZ(I,2,2)=DXYZ(I,2)
        DDXYZ(I,3,1)=DDXYZ(I,2,1)+DDXYZ(I,2,2)
        DDXYZ(I,3,2)=-DXYZ(I,1)
        DDXYZ(I,4,1)=DDXYZ(I,3,1)+DDXYZ(I,3,2)
        DDXYZ(I,4,2)=-DXYZ(I,2)
        DO 20 J=1,4
          DDXYZ(I,J+4,1)=DDXYZ(I,J,1)
          DDXYZ(I,J+4,2)=DXYZ(I,3)
          DDXYZ(I,J+8,1)=DDXYZ(I,J,1)+DXYZ(I,3)
          DDXYZ(I,J+8,2)=DDXYZ(I,J,2)
  20    CONTINUE
  30  CONTINUE
C
C First paint the edges of the lattice.
C
      DO 60 IFACE=1,3
        I=IFACE
        J=MOD(IFACE,3)+1
        K=MOD(J,3)+1
        IF (IFACE.EQ.1) THEN
          IN=N1
          JN=N2
        ELSEIF (IFACE.EQ.2) THEN
          IN=N2
          JN=N3
        ELSE
          IN=N3
          JN=N1
        ENDIF
        KK=0
        XN=BAS(2,J)*BAS(3,I)-BAS(2,I)*BAS(3,J)
        YN=BAS(3,J)*BAS(1,I)-BAS(3,I)*BAS(1,J)
        ZN=BAS(1,J)*BAS(2,I)-BAS(1,I)*BAS(2,J)
        DNRM=SQRT(XN**2+YN**2+ZN**2+SMALL2)
        PNEYE(1)=DBLE(EYE(1)-0.5*(LATICE(1,I+1)+LATICE(1,J+1)))
        PNEYE(2)=DBLE(EYE(2)-0.5*(LATICE(2,I+1)+LATICE(2,J+1)))
        PNEYE(3)=DBLE(EYE(3)-0.5*(LATICE(3,I+1)+LATICE(3,J+1)))
        DEYE=SNGL(DSQRT(PNEYE(1)**2+PNEYE(2)**2+PNEYE(3)**2+DSMAL2))
        XLNORM=DBLE(XN)*PNEYE(1)+DBLE(YN)*PNEYE(2)+DBLE(ZN)*PNEYE(3)
        COSSEE=SNGL(XLNORM)/(DEYE*DNRM)
        IF (COSSEE.LT.0.001) THEN
          KK=N3
          IF (IFACE.EQ.2) KK=N1
          IF (IFACE.EQ.3) KK=N2
          PNEYE(1)=PNEYE(1)+DBLE(BAS(1,K))
          PNEYE(2)=PNEYE(2)+DBLE(BAS(2,K))
          PNEYE(3)=PNEYE(3)+DBLE(BAS(3,K))
          DEYE=SNGL(DSQRT(PNEYE(1)**2+PNEYE(2)**2+PNEYE(3)**2+DSMAL2))
          XLNORM=DBLE(XN)*PNEYE(1)+DBLE(YN)*PNEYE(2)+DBLE(ZN)*PNEYE(3)
          COSSEE=-SNGL(XLNORM)/(DEYE*DNRM)
        ENDIF
        IF (COSSEE.GT.0.001) THEN
          XYZ1=FLOAT(KK)*DXYZ(1,K)+LATICE(1,1)
          XYZ2=FLOAT(KK)*DXYZ(2,K)+LATICE(2,1)
          XYZ3=FLOAT(KK)*DXYZ(3,K)+LATICE(3,1)
          DO 50 J1=1,JN
            J0=J1-1
            DO 40 I1=1,IN
              I0=I1-1
              IF (IFACE.EQ.1) THEN
                DLOCAL(1)=DENS(I0,J0,KK)-DSURF
                DLOCAL(2)=DENS(I1,J0,KK)-DSURF
                DLOCAL(3)=DENS(I1,J1,KK)-DSURF
                DLOCAL(4)=DENS(I0,J1,KK)-DSURF
              ELSEIF (IFACE.EQ.2) THEN
                DLOCAL(1)=DENS(KK,I0,J0)-DSURF
                DLOCAL(2)=DENS(KK,I1,J0)-DSURF
                DLOCAL(3)=DENS(KK,I1,J1)-DSURF
                DLOCAL(4)=DENS(KK,I0,J1)-DSURF
              ELSE
                DLOCAL(1)=DENS(J0,KK,I0)-DSURF
                DLOCAL(2)=DENS(J0,KK,I1)-DSURF
                DLOCAL(3)=DENS(J1,KK,I1)-DSURF
                DLOCAL(4)=DENS(J1,KK,I0)-DSURF
              ENDIF
              CALL SBSRF1(DLOCAL,IBSIDE,FRCXYZ)
              IF (IBSIDE.NE.0) THEN
                XYZ(1)=XYZ1+DXYZ(1,I)*FLOAT(I0)
                XYZ(2)=XYZ2+DXYZ(2,I)*FLOAT(I0)
                XYZ(3)=XYZ3+DXYZ(3,I)*FLOAT(I0)
                CALL SBTSF2(XYZ,DXYZ(1,I),DXYZ(1,J),IBSIDE,FRCXYZ,VERT,
     *                      EYE,LIGHT,LSHINE,ITRANS)
              ENDIF
  40        CONTINUE
            XYZ1=XYZ1+DXYZ(1,J)
            XYZ2=XYZ2+DXYZ(2,J)
            XYZ3=XYZ3+DXYZ(3,J)
  50      CONTINUE
        ENDIF
  60  CONTINUE
C
C Step through each "cube" in the lattice, and paint any isosurfaces
C found therein.
C
      X00K=LATICE(1,1)
      Y00K=LATICE(2,1)
      Z00K=LATICE(3,1)
      DO 90 K1=1,N3
        K0=K1-1
        DO 80 J1=1,N2
          J0=J1-1
          X0JK=X00K+DXYZ(1,2)*FLOAT(J0)
          Y0JK=Y00K+DXYZ(2,2)*FLOAT(J0)
          Z0JK=Z00K+DXYZ(3,2)*FLOAT(J0)
          DO 70 I1=1,N1
            I0=I1-1
            DLOCAL(1)=DENS(I0,J0,K0)-DSURF
            DLOCAL(2)=DENS(I1,J0,K0)-DSURF
            DLOCAL(3)=DENS(I1,J1,K0)-DSURF
            DLOCAL(4)=DENS(I0,J1,K0)-DSURF
            DLOCAL(5)=DENS(I0,J0,K1)-DSURF
            DLOCAL(6)=DENS(I1,J0,K1)-DSURF
            DLOCAL(7)=DENS(I1,J1,K1)-DSURF
            DLOCAL(8)=DENS(I0,J1,K1)-DSURF
            CALL SBSRF3(DLOCAL,IVERT,FRCXYZ,ISUMV,ISUMF)
            IF (ISUMV.NE.0) THEN
              XYZ(1)=X0JK+DXYZ(1,1)*FLOAT(I0)
              XYZ(2)=Y0JK+DXYZ(2,1)*FLOAT(I0)
              XYZ(3)=Z0JK+DXYZ(3,1)*FLOAT(I0)
              CALL SBSRF4(DENS,N1,N2,N3,I0,J0,K0,GRDSCL,BAS,GRDCUB)
              CALL SBTSF5(XYZ,DDXYZ,ISUMV,ISUMF,IVERT,FRCXYZ,VERT,EYE,
     *                    LIGHT,LSHINE,ITRANS)
            ENDIF
  70      CONTINUE
  80    CONTINUE
        X00K=X00K+DXYZ(1,3)
        Y00K=Y00K+DXYZ(2,3)
        Z00K=Z00K+DXYZ(3,3)
  90  CONTINUE
      END
C
      SUBROUTINE SBTSF2(XYZ,D1,D2,IB,FRC,VERT,EYE,LIGHT,LSHINE,ITRANS)
C     ----------------------------------------------------------------
C
      REAL    XYZ(*),D1(*),D2(*),FRC(*),VERT(3,*),EYE(*),LIGHT(*)
      LOGICAL LSHINE
C
      IF (IB.EQ.15) THEN
        DO 10 I=1,3
          VERT(I,1)=XYZ(I)
          VERT(I,2)=XYZ(I)+D1(I)
          VERT(I,3)=VERT(I,2)+D2(I)
          VERT(I,4)=XYZ(I)+D2(I)
  10    CONTINUE
        CALL SBTSF6(ITRANS,EYE,4,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.1) THEN
        DO 20 I=1,3
          VERT(I,1)=XYZ(I)
          VERT(I,2)=VERT(I,1)+FRC(1)*D1(I)
          VERT(I,3)=XYZ(I)+(1.0-FRC(4))*D2(I)
  20    CONTINUE
        CALL SBTSF6(ITRANS,EYE,3,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.2) THEN
        DO 30 I=1,3
          VERT(I,1)=XYZ(I)+D1(I)
          VERT(I,2)=VERT(I,1)+FRC(2)*D2(I)
          VERT(I,3)=XYZ(I)+FRC(1)*D1(I)
  30    CONTINUE
        CALL SBTSF6(ITRANS,EYE,3,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.4) THEN
        DO 40 I=1,3
          VERT(I,1)=XYZ(I)+D1(I)+D2(I)
          VERT(I,2)=VERT(I,1)-FRC(3)*D1(I)
          VERT(I,3)=VERT(I,1)-(1.0-FRC(2))*D2(I)
  40    CONTINUE
        CALL SBTSF6(ITRANS,EYE,3,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.8) THEN
        DO 50 I=1,3
          VERT(I,1)=XYZ(I)+D2(I)
          VERT(I,2)=VERT(I,1)-FRC(4)*D2(I)
          VERT(I,3)=VERT(I,1)+(1.0-FRC(3))*D1(I)
  50    CONTINUE
        CALL SBTSF6(ITRANS,EYE,3,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.7) THEN
        DO 60 I=1,3
          VERT(I,1)=XYZ(I)
          VERT(I,2)=VERT(I,1)+D1(I)
          VERT(I,3)=VERT(I,2)+D2(I)
          VERT(I,4)=VERT(I,3)-FRC(3)*D1(I)
          VERT(I,5)=XYZ(I)+(1.0-FRC(4))*D2(I)
  60    CONTINUE
        CALL SBTSF6(ITRANS,EYE,5,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.14) THEN
        DO 70 I=1,3
          VERT(I,1)=XYZ(I)+D1(I)
          VERT(I,2)=VERT(I,1)+D2(I)
          VERT(I,3)=XYZ(I)+D2(I)
          VERT(I,4)=XYZ(I)+(1.0-FRC(4))*D2(I)
          VERT(I,5)=XYZ(I)+FRC(1)*D1(I)
  70    CONTINUE
        CALL SBTSF6(ITRANS,EYE,5,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.13) THEN
        DO 80 I=1,3
          VERT(I,1)=XYZ(I)+D1(I)+D2(I)
          VERT(I,2)=XYZ(I)+D2(I)
          VERT(I,3)=XYZ(I)
          VERT(I,4)=XYZ(I)+FRC(1)*D1(I)
          VERT(I,5)=XYZ(I)+D1(I)+FRC(2)*D2(I)
  80    CONTINUE
        CALL SBTSF6(ITRANS,EYE,5,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.11) THEN
        DO 90 I=1,3
          VERT(I,1)=XYZ(I)+D2(I)
          VERT(I,2)=XYZ(I)
          VERT(I,3)=XYZ(I)+D1(I)
          VERT(I,4)=VERT(I,3)+FRC(2)*D2(I)
          VERT(I,5)=VERT(I,1)+(1.0-FRC(3))*D1(I)
  90    CONTINUE
        CALL SBTSF6(ITRANS,EYE,5,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.3) THEN
        DO 100 I=1,3
          VERT(I,1)=XYZ(I)
          VERT(I,2)=XYZ(I)+D1(I)
          VERT(I,3)=VERT(I,2)+FRC(2)*D2(I)
          VERT(I,4)=XYZ(I)+(1.0-FRC(4))*D2(I)
 100    CONTINUE
        CALL SBTSF6(ITRANS,EYE,4,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.6) THEN
        DO 110 I=1,3
          VERT(I,1)=XYZ(I)+D1(I)
          VERT(I,2)=VERT(I,1)+D2(I)
          VERT(I,3)=VERT(I,2)-FRC(3)*D1(I)
          VERT(I,4)=XYZ(I)+FRC(1)*D1(I)
 110    CONTINUE
        CALL SBTSF6(ITRANS,EYE,4,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.12) THEN
        DO 120 I=1,3
          VERT(I,1)=XYZ(I)+D1(I)+D2(I)
          VERT(I,2)=XYZ(I)+D2(I)
          VERT(I,3)=VERT(I,2)-FRC(4)*D2(I)
          VERT(I,4)=XYZ(I)+D1(I)+FRC(2)*D2(I)
 120    CONTINUE
        CALL SBTSF6(ITRANS,EYE,4,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.9) THEN
        DO 130 I=1,3
          VERT(I,1)=XYZ(I)+D2(I)
          VERT(I,2)=XYZ(I)
          VERT(I,3)=XYZ(I)+FRC(1)*D1(I)
          VERT(I,4)=VERT(I,1)+(1.0-FRC(3))*D1(I)
 130    CONTINUE
        CALL SBTSF6(ITRANS,EYE,4,VERT,LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.5) THEN
        DO 140 I=1,3
          VERT(I,1)=XYZ(I)
          VERT(I,2)=VERT(I,1)+FRC(1)*D1(I)
          VERT(I,3)=XYZ(I)+(1.0-FRC(4))*D2(I)
          VERT(I,4)=XYZ(I)+D1(I)+D2(I)
          VERT(I,5)=VERT(I,4)-FRC(3)*D1(I)
          VERT(I,6)=VERT(I,4)-(1.0-FRC(2))*D2(I)
 140    CONTINUE
        CALL SBTSF6(ITRANS,EYE,3,VERT,LSHINE,LIGHT,0) 
        CALL SBTSF6(ITRANS,EYE,3,VERT(1,4),LSHINE,LIGHT,0) 
      ELSEIF (IB.EQ.10) THEN
        DO 150 I=1,3
          VERT(I,1)=XYZ(I)+D1(I)
          VERT(I,2)=VERT(I,1)+FRC(2)*D2(I)
          VERT(I,3)=XYZ(I)+FRC(1)*D1(I)
          VERT(I,4)=XYZ(I)+D2(I)
          VERT(I,5)=VERT(I,4)-FRC(4)*D2(I)
          VERT(I,6)=VERT(I,4)+(1.0-FRC(3))*D1(I)
 150    CONTINUE
        CALL SBTSF6(ITRANS,EYE,3,VERT,LSHINE,LIGHT,0) 
        CALL SBTSF6(ITRANS,EYE,3,VERT(1,4),LSHINE,LIGHT,0) 
      ENDIF
      END
C
      SUBROUTINE SBTSF5(XYZ,DXYZ,ISV,ISF,IV,FRC,VERT,EYE,LIGHT,LSHINE,
     *                  ITRANS)
C     ----------------------------------------------------------------
C
      REAL    XYZ(*),DXYZ(3,12,*),FRC(*),VERT(3,*),EYE(*),LIGHT(*)
      INTEGER IV(*),IV4MAP(12)
      LOGICAL LSHINE
      DATA    IV4MAP /12,8,4,3,11,7,6,2,10,9,5,1/
C
      IF (ISV.EQ.1) THEN
        CALL STSF5A(ITRANS,XYZ,DXYZ,FRC,VERT,IV(1),EYE,LSHINE,LIGHT)
      ELSEIF (ISV.EQ.2) THEN
        IF (ISF.EQ.6) THEN
          CALL STSF5A(ITRANS,XYZ,DXYZ,FRC,VERT,IV(1),EYE,LSHINE,LIGHT)
          CALL STSF5A(ITRANS,XYZ,DXYZ,FRC,VERT,IV(2),EYE,LSHINE,LIGHT)
        ELSE
          IJDIF=IV(2)-IV(1)
          IF (IV(1).LE.4) THEN
            IF (IV(2).LE.4) THEN
              K2=IV(1)
              IF (IJDIF.EQ.3) K2=IV(2)
            ELSE
              K2=IV(2)
            ENDIF
          ELSE
            K2=IV(1)+4
            IF (IJDIF.EQ.3) K2=IV(2)+4
          ENDIF
          CALL STSF5B(ITRANS,XYZ,DXYZ,FRC,VERT,K2,EYE,LSHINE,LIGHT,1)
        ENDIF
      ELSEIF (ISV.EQ.3) THEN
        IF (ISF.EQ.9) THEN
          DO 10 I=1,3
  10        CALL STSF5A(ITRANS,XYZ,DXYZ,FRC,VERT,IV(I),EYE,LSHINE,LIGHT)
        ELSEIF (ISF.EQ.6) THEN
          DO 20 I1=1,3
            I2=1+MOD(I1,3)
            I=MIN(I1,I2)
            J=MAX(I1,I2)
            K2=0
            IJDIF=IV(J)-IV(I)
            IF (IV(I).LE.4) THEN
              IF (IV(J).LE.4) THEN
                IF (IJDIF.EQ.1) THEN
                  K2=IV(I)
                ELSEIF (IJDIF.EQ.3) THEN
                  K2=IV(J)
                ENDIF
              ELSE
                IF (IJDIF.EQ.4) K2=IV(J)
              ENDIF
            ELSE
              IF (IJDIF.EQ.1) THEN
                K2=IV(I)+4
              ELSEIF (IJDIF.EQ.3) THEN
                K2=IV(J)+4
              ENDIF
            ENDIF
            IF (K2.GT.0) GOTO 1
  20      CONTINUE
   1      CALL STSF5B(ITRANS,XYZ,DXYZ,FRC,VERT,K2,EYE,LSHINE,LIGHT,1)
        ELSE
          K3=IV(1)+IV(2)+IV(3)-5+2*(IV(1)/5+2*(IV(2)/5)+IV(3)/5)
          CALL STSF5C(ITRANS,XYZ,DXYZ,FRC,VERT,K3,EYE,LSHINE,LIGHT)
        ENDIF
      ELSE
        IF (ISF.EQ.12) THEN
          DO 30 I=1,4
  30        CALL STSF5A(ITRANS,XYZ,DXYZ,FRC,VERT,IV(I),EYE,LSHINE,LIGHT)
        ELSEIF (ISF.EQ.4) THEN
          K4=(IV(1)+IV(2)+IV(3)+IV(4)-6)/4
          IF ((IV(2)-IV(1)).EQ.3) K4=6
          CALL STSF5B(ITRANS,XYZ,DXYZ,FRC,VERT,K4,EYE,LSHINE,LIGHT,2)
        ELSEIF (ISF.EQ.6) THEN
          IF (IV(3).LE.4) THEN
            K3=IV(1)+IV(2)+IV(3)-6
            K4=MOD((IV(4)+K3),4)+3*K3
          ELSE
            IF (IV(2).GE.5) THEN
              K3=IV(2)+IV(3)+IV(4)-18
              K4=IV4MAP(MOD((IV(1)+K3),4)+3*K3)
            ELSE
              K4=12+IV(3)-IV(2)
              IF ((IV(1)+IV(2)+IV(3)+IV(4)).EQ.22) K4=29-K4
            ENDIF
          ENDIF
          CALL STSF5D(ITRANS,XYZ,DXYZ,FRC,VERT,K4,EYE,LSHINE,LIGHT)
        ELSE
          K4=IV(1)+IV(2)+IV(3)+IV(4)
          IF (K4.EQ.16 .OR. K4.EQ.20) THEN          
            CALL STSF5B(ITRANS,XYZ,DXYZ,FRC,VERT,IV(3),EYE,LSHINE,
     *                  LIGHT,1)
            CALL STSF5B(ITRANS,XYZ,DXYZ,FRC,VERT,IV(4),EYE,LSHINE,
     *                  LIGHT,1)
          ELSEIF (K4.EQ.18) THEN
            K4A=IV(1)
            IF ((IV(2)-K4A).EQ.3) K4A=4
            K4B=9+MOD(K4A+1,4)
            CALL STSF5B(ITRANS,XYZ,DXYZ,FRC,VERT,K4A,EYE,LSHINE,LIGHT,1)
            CALL STSF5B(ITRANS,XYZ,DXYZ,FRC,VERT,K4B,EYE,LSHINE,LIGHT,1)
          ELSE
            IF (K4.EQ.14) THEN
              K4A=IV(4)
              K3=IV(1)+IV(2)+IV(3)-5+2*(IV(1)/5+2*(IV(2)/5)+IV(3)/5)
            ELSEIF (K4.EQ.22) THEN
              K4A=IV(1)
              K3=IV(2)+IV(3)+IV(4)-5+2*(IV(2)/5+2*(IV(3)/5)+IV(4)/5)
            ELSE
              IF (MOD((IV(1)+IV(2)),2).EQ.0) THEN
                IF (IV(4).EQ.6 .OR. (IV(3)-IV(2)).EQ.2) THEN
                  K4A=IV(2)
                  K3=IV(1)+IV(3)+IV(4)-5+2*(IV(1)/5+2*(IV(3)/5)+IV(4)/5)
                ELSE
                  K4A=IV(1)
                  K3=IV(2)+IV(3)+IV(4)-5+2*(IV(2)/5+2*(IV(3)/5)+IV(4)/5)
                ENDIF
              ELSE
                IF (IV(1).EQ.3 .OR. (IV(3)-IV(2)).EQ.2) THEN
                  K4A=IV(3)
                  K3=IV(1)+IV(2)+IV(4)-5+2*(IV(1)/5+2*(IV(2)/5)+IV(4)/5)
                ELSE
                  K4A=IV(4)
                  K3=IV(1)+IV(2)+IV(3)-5+2*(IV(1)/5+2*(IV(2)/5)+IV(3)/5)
                ENDIF
              ENDIF
            ENDIF
            CALL STSF5A(ITRANS,XYZ,DXYZ,FRC,VERT,K4A,EYE,LSHINE,LIGHT)
            CALL STSF5C(ITRANS,XYZ,DXYZ,FRC,VERT,K3,EYE,LSHINE,LIGHT)
          ENDIF
        ENDIF
      ENDIF
      END
C
      SUBROUTINE STSF5A(ITRANS,XYZ,DXYZ,FRC,VERT,IV,EYE,LSHINE,LIGHT)
C     ---------------------------------------------------------------
C
      REAL    XYZ(*),DXYZ(3,12,*),FRC(*),VERT(3,*),EYE(*),LIGHT(*)
      LOGICAL LSHINE
C
      IF (IV.LE.4) THEN
        J=IV
        K=1+MOD(IV+2,4)
        L=IV+4
      ELSE
        J=IV+4
        K=9+MOD(IV-2,4)
        L=IV
      ENDIF
      DO 10 I=1,3
        VERT(I,1)=XYZ(I)+DXYZ(I,J,1)+FRC(J)*DXYZ(I,J,2)
        VERT(I,2)=XYZ(I)+DXYZ(I,K,1)+FRC(K)*DXYZ(I,K,2)
        VERT(I,3)=XYZ(I)+DXYZ(I,L,1)+FRC(L)*DXYZ(I,L,2)
  10  CONTINUE
      CALL SBTSF6(ITRANS,EYE,3,VERT,LSHINE,LIGHT,1) 
      END  
C
      SUBROUTINE STSF5B(ITRANS,XYZ,DXYZ,FRC,VERT,KK,EYE,LSHINE,LIGHT,LL)
C     ------------------------------------------------------------------
C
      REAL    XYZ(*),DXYZ(3,12,*),FRC(*),VERT(3,*),EYE(*),LIGHT(*)
      INTEGER IVL(4,12,2)
      LOGICAL LSHINE
      DATA    IVL /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,24*0/
C
      J=IVL(1,KK,LL)
      K=IVL(2,KK,LL)
      L=IVL(3,KK,LL)
      M=IVL(4,KK,LL)
      DO 10 I=1,3
        VERT(I,1)=XYZ(I)+DXYZ(I,J,1)+FRC(J)*DXYZ(I,J,2)
        VERT(I,2)=XYZ(I)+DXYZ(I,K,1)+FRC(K)*DXYZ(I,K,2)
        VERT(I,3)=XYZ(I)+DXYZ(I,L,1)+FRC(L)*DXYZ(I,L,2)
        VERT(I,4)=XYZ(I)+DXYZ(I,M,1)+FRC(M)*DXYZ(I,M,2)
        VERT(I,5)=VERT(I,1)
        VERT(I,6)=0.25*(VERT(I,1)+VERT(I,2)+VERT(I,3)+VERT(I,4))
  10  CONTINUE
      DO 20 I=1,4
        CALL SBRCOP(VERT(1,I),VERT(1,7),6)
        CALL SBTSF6(ITRANS,EYE,3,VERT(1,6),LSHINE,LIGHT,1)
  20  CONTINUE
      END  
C
      SUBROUTINE STSF5C(ITRANS,XYZ,DXYZ,FRC,VERT,K3,EYE,LSHINE,LIGHT)
C     ---------------------------------------------------------------
C
      REAL    XYZ(*),DXYZ(3,12,*),FRC(*),VERT(3,*),EYE(*),LIGHT(*)
      INTEGER IV3(5,24)
      LOGICAL LSHINE
      DATA    IV3 /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/
C
      J=IV3(1,K3)
      K=IV3(2,K3)
      L=IV3(3,K3)
      M=IV3(4,K3)
      N=IV3(5,K3)
      DO 10 I=1,3
        VERT(I,1)=XYZ(I)+DXYZ(I,J,1)+FRC(J)*DXYZ(I,J,2)
        VERT(I,2)=XYZ(I)+DXYZ(I,K,1)+FRC(K)*DXYZ(I,K,2)
        VERT(I,3)=XYZ(I)+DXYZ(I,L,1)+FRC(L)*DXYZ(I,L,2)
        VERT(I,4)=XYZ(I)+DXYZ(I,M,1)+FRC(M)*DXYZ(I,M,2)
        VERT(I,5)=XYZ(I)+DXYZ(I,N,1)+FRC(N)*DXYZ(I,N,2)
        VERT(I,6)=VERT(I,1)
        VERT(I,7)=0.2*(VERT(I,1)+VERT(I,2)+VERT(I,3)+VERT(I,4)+
     *                 VERT(I,5))
  10  CONTINUE
      DO 20 I=1,5
        CALL SBRCOP(VERT(1,I),VERT(1,8),6)
        CALL SBTSF6(ITRANS,EYE,3,VERT(1,7),LSHINE,LIGHT,1)
  20  CONTINUE
      END
C
      SUBROUTINE STSF5D(ITRANS,XYZ,DXYZ,FRC,VERT,K4,EYE,LSHINE,LIGHT)
C     ---------------------------------------------------------------
C
      REAL    XYZ(*),DXYZ(3,12,*),FRC(*),VERT(3,*),EYE(*),LIGHT(*)
      INTEGER IV4(6,16)
      LOGICAL LSHINE
      DATA    IV4 /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/
      DATA    VNORM /0.1666666667/
C
      CALL SBRFIL(VERT(1,8),0.0,3)
      DO 20 J=1,6
        K=IV4(J,K4)
        DO 10 I=1,3
          VERT(I,J)=XYZ(I)+DXYZ(I,K,1)+FRC(K)*DXYZ(I,K,2)
          VERT(I,8)=VERT(I,8)+VERT(I,J)
  10    CONTINUE
  20  CONTINUE
      CALL SBRCOP(VERT,VERT(1,7),3)
      DO 30 I=1,3
  30    VERT(I,8)=VERT(I,8)*VNORM
      DO 40 I=1,6
        CALL SBRCOP(VERT(1,I),VERT(1,9),6)
        CALL SBTSF6(ITRANS,EYE,3,VERT(1,8),LSHINE,LIGHT,1)
  40  CONTINUE
      END
C
      SUBROUTINE SBTSF6(ITRANS,EYE,NV,VERT,LSHINE,LIGHT,INSIDE)
C     ---------------------------------------------------------
C
      REAL             EYE(*),VERT(3,*),LIGHT(*)
      LOGICAL          LSHINE
C
      REAL*8           XLNORM,ZZ,DZZ
      REAL             XW(20),YW(20),MTRX
      LOGICAL          LPS,LCOLOR
      COMMON  /SRFCOM/ GRDCUB(3,8),MTRX(3,3),ORIG(3),XL2,COL0,COLSCL
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
C
C Carry out some initial checks and calculate the coordinates of the 
C projected triangle.
C
      IF (NV.LT.3 .OR. NV.GT.10) RETURN
      SMALL=1.0E-10
      XMIN=+1.0E20
      XMAX=-1.0E20
      YMIN=+1.0E20
      YMAX=-1.0E20
      DO 10 I=1,NV
        CALL SBLIN1(EYE,VERT(1,I),VERT(2,I),VERT(3,I),XW(I),YW(I))
        IF (XW(I).LT.XMIN) THEN
          XMIN=XW(I)
          ILEFT=I
        ENDIF
        IF (YW(I).LT.YMIN) THEN
          YMIN=YW(I)
          JBOTOM=I
        ENDIF
        XMAX=MAX(XW(I),XMAX)
        YMAX=MAX(YW(I),YMAX)
  10  CONTINUE
      IF (XMIN.GE.XTRC .OR. XMAX.LE.XBLC) RETURN
      IF (YMIN.GE.YTRC .OR. YMAX.LE.YBLC) RETURN
C
C Find the outward normal seen by the eye.
C
      AX=VERT(1,2)-VERT(1,1)
      AY=VERT(2,2)-VERT(2,1)
      AZ=VERT(3,2)-VERT(3,1)
      BX=VERT(1,1)-VERT(1,NV)
      BY=VERT(2,1)-VERT(2,NV)
      BZ=VERT(3,1)-VERT(3,NV)
      XN=BY*AZ-AY*BZ
      YN=BZ*AX-AZ*BX
      ZN=BX*AY-AX*BY
      TEN=XN*(EYE(1)-VERT(1,1))+YN*(EYE(2)-VERT(2,1))
     *   +ZN*(EYE(3)-VERT(3,1))
      IF (TEN.LT.0.0) THEN
        XN=-XN
        YN=-YN
        ZN=-ZN
        TEN=-TEN
      ENDIF
C
C Plot the projected triangle.
C
      ITLEVL=MAX(MIN(ITRANS,3),1)
      XLNORM=DBLE(TEN)
      EYENRM=XN*EYE(1)+YN*EYE(2)+ZN*EYE(3)
      DX=FLOAT(NXP-1)/(XTRC-XBLC)
      DY=FLOAT(NYP-1)/(YTRC-YBLC)
      DYJ=1.0/DY
      DXI=1.0/DX
      SAFER=0.0001
      IF ((XMAX-XMIN).GT.(YMAX-YMIN)) THEN
        JYMIN=INT((YMIN-YBLC)*DY)+2
        JYMAX=MIN(INT((YMAX-YBLC)*DY)+1,NYP)
        IF (JYMIN.GT.JYMAX) RETURN
        YJ=YBLC+(FLOAT(JYMIN-1)+SAFER)*DYJ
        NVL2=JBOTOM
        NVR2=JBOTOM
        J1=JYMIN
        DO 40 IVERT=1,NV
          IF (YJ.GT.YW(NVL2)) THEN
   1        NVL1=NVL2
            NVL2=NVL1-1
            IF (NVL2.LT.1) NVL2=NV
            IF (NVL2.EQ.JBOTOM) RETURN
            IF (YJ.GT.YW(NVL2)) GOTO 1
            YDIFL=YW(NVL2)-YW(NVL1)
            IF (ABS(YDIFL).LT.SMALL) YDIFL=SMALL
            GRADL=(XW(NVL2)-XW(NVL1))/YDIFL
          ENDIF
          IF (YJ.GT.YW(NVR2)) THEN
   2        NVR1=NVR2
            NVR2=NVR1+1
            IF (NVR2.GT.NV) NVR2=1
            IF (NVR2.EQ.JBOTOM) RETURN
            IF (YJ.GT.YW(NVR2)) GOTO 2
            YDIFR=YW(NVR2)-YW(NVR1)
            IF (ABS(YDIFR).LT.SMALL) YDIFR=SMALL
            GRADR=(XW(NVR2)-XW(NVR1))/YDIFR
          ENDIF
          IF (YW(NVL2).LT.YW(NVR2)) THEN
            J2=MIN(INT((YW(NVL2)-YBLC)*DY)+1,JYMAX)
          ELSE
            J2=MIN(INT((YW(NVR2)-YBLC)*DY)+1,JYMAX)
          ENDIF
          DO 30 J=J1,J2
            IF (J.GE.1) THEN
              JTEST=MOD(J,2)
              IF (ITLEVL.EQ.3 .AND. JTEST.EQ.1) GOTO 29
              XL=XW(NVL1)+GRADL*(YJ-YW(NVL1))
              XR=XW(NVR1)+GRADR*(YJ-YW(NVR1))
              ISTEP=1
              IX1=MAX(INT((XL-XBLC)*DX)+2,1)
              IX2=MIN(INT((XR-XBLC)*DX)+1,NXP)
              IF (IX1.GT.IX2) THEN
                ISTEP=-1
                IX1=MIN(IX1-1,NXP)
                IX2=MAX(IX2+1,1)
              ENDIF
              XI=XBLC+FLOAT(IX1-1)*DXI
              SDXI=FLOAT(ISTEP)*DXI
              DZZ=DBLE(SDXI*XN)
              ZZ=DBLE(EYENRM-XI*XN-YJ*YN)
              K=(J-1)*NXP+IX1
              DO 20 I=IX1,IX2,ISTEP
                ITEST=MOD(I,2)
                IF (ITLEVL.EQ.1) THEN
                  IF ((ITEST+JTEST).EQ.0) GOTO 19
                ELSEIF (ITLEVL.EQ.2) THEN
                  IF ((ITEST+JTEST).EQ.1) GOTO 19
                ELSE
                  IF (ITEST.EQ.1) GOTO 19
                ENDIF
                XLAMDA=SNGL(XLNORM/ZZ)
                Z=EYE(3)*(1.0-XLAMDA)
                IF (Z.GT.SBBUFF(K)) THEN
                  SBBUFF(K)=Z
                  X=EYE(1)+XLAMDA*(XI-EYE(1))
                  Y=EYE(2)+XLAMDA*(YJ-EYE(2))
                  IF (INSIDE.EQ.0) THEN
                    GX=XN
                    GY=YN
                    GZ=ZN
                  ELSE
                    CALL SBSF6A(X,Y,Z,ORIG,MTRX,GRDCUB,GX,GY,GZ)
                  ENDIF
                  CALL SBSF6B(EYE,X,Y,Z,GX,GY,GZ,LIGHT,XL2,LSHINE,CLR)
                  SBBUFF(KSTART+K)=COL0+COLSCL*CLR
                ENDIF
  19            XI=XI+SDXI
                ZZ=ZZ-DZZ
                K=K+ISTEP
  20          CONTINUE
            ENDIF
  29        YJ=YJ+DYJ
  30      CONTINUE
          J1=J2+1
          IF (J1.GT.JYMAX) RETURN
  40    CONTINUE
      ELSE
        IXMIN=INT((XMIN-XBLC)*DX)+2
        IXMAX=MIN(INT((XMAX-XBLC)*DX)+1,NXP)
        IF (IXMIN.GT.IXMAX) RETURN
        XI=XBLC+(FLOAT(IXMIN-1)+SAFER)*DXI
        NVL2=ILEFT
        NVR2=ILEFT
        I1=IXMIN
        DO 70 IVERT=1,NV
          IF (XI.GT.XW(NVL2)) THEN
   3        NVL1=NVL2
            NVL2=NVL1-1
            IF (NVL2.LT.1) NVL2=NV
            IF (NVL2.EQ.ILEFT) RETURN
            IF (XI.GT.XW(NVL2)) GOTO 3
            XDIFL=XW(NVL2)-XW(NVL1)
            IF (ABS(XDIFL).LT.SMALL) XDIFL=SMALL
            GRADL=(YW(NVL2)-YW(NVL1))/XDIFL
          ENDIF
          IF (XI.GT.XW(NVR2)) THEN
   4        NVR1=NVR2
            NVR2=NVR1+1
            IF (NVR2.GT.NV) NVR2=1
            IF (NVR2.EQ.ILEFT) RETURN
            IF (XI.GT.XW(NVR2)) GOTO 4
            XDIFR=XW(NVR2)-XW(NVR1)
            IF (ABS(XDIFR).LT.SMALL) XDIFR=SMALL
            GRADR=(YW(NVR2)-YW(NVR1))/XDIFR
          ENDIF
          IF (XW(NVL2).LT.XW(NVR2)) THEN
            I2=MIN(INT((XW(NVL2)-XBLC)*DX)+1,IXMAX)
          ELSE
            I2=MIN(INT((XW(NVR2)-XBLC)*DX)+1,IXMAX)
          ENDIF
          DO 60 I=I1,I2
            IF (I.GE.1) THEN
              ITEST=MOD(I,2)
              IF (ITLEVL.EQ.3 .AND. ITEST.EQ.1) GOTO 59
              YL=YW(NVL1)+GRADL*(XI-XW(NVL1))
              YR=YW(NVR1)+GRADR*(XI-XW(NVR1))
              ISTEP=1
              JY1=MAX(INT((YL-YBLC)*DY)+2,1)
              JY2=MIN(INT((YR-YBLC)*DY)+1,NYP)
              IF (JY1.GT.JY2) THEN
                ISTEP=-1
                JY1=MIN(JY1-1,NYP)
                JY2=MAX(JY2+1,1)
              ENDIF
              YJ=YBLC+FLOAT(JY1-1)*DYJ
              SDYJ=FLOAT(ISTEP)*DYJ
              DZZ=DBLE(SDYJ*YN)
              ZZ=DBLE(EYENRM-YJ*YN-XI*XN)
              K=(JY1-1)*NXP+I
              KSTEP=ISTEP*NXP
              DO 50 J=JY1,JY2,ISTEP
                JTEST=MOD(J,2)
                IF (ITLEVL.EQ.1) THEN
                  IF ((ITEST+JTEST).EQ.0) GOTO 49
                ELSEIF (ITLEVL.EQ.2) THEN
                  IF ((ITEST+JTEST).EQ.1) GOTO 49
                ELSE
                  IF (JTEST.EQ.1) GOTO 49
                ENDIF
                XLAMDA=SNGL(XLNORM/ZZ)
                Z=EYE(3)*(1.0-XLAMDA)
                IF (Z.GT.SBBUFF(K)) THEN
                  SBBUFF(K)=Z
                  X=EYE(1)+XLAMDA*(XI-EYE(1))
                  Y=EYE(2)+XLAMDA*(YJ-EYE(2))
                  IF (INSIDE.EQ.0) THEN
                    GX=XN
                    GY=YN
                    GZ=ZN
                  ELSE
                    CALL SBSF6A(X,Y,Z,ORIG,MTRX,GRDCUB,GX,GY,GZ)
                  ENDIF
                  CALL SBSF6B(EYE,X,Y,Z,GX,GY,GZ,LIGHT,XL2,LSHINE,CLR)
                  SBBUFF(KSTART+K)=COL0+COLSCL*CLR
                ENDIF
  49            YJ=YJ+SDYJ
                ZZ=ZZ-DZZ
                K=K+KSTEP
  50          CONTINUE
            ENDIF
  59        XI=XI+DXI
  60      CONTINUE
          I1=I2+1
          IF (I1.GT.IXMAX) RETURN
  70    CONTINUE
      ENDIF
      END
C
      SUBROUTINE SBFBKG(IC1,IC2,ISHADE)
C     ---------------------------------
C
      LOGICAL          LPS,LCOLOR
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      Sets the shading for the background. This routine should be
C    called after SBFINT, and COLINT or COLTAB, but before any objects
C    are plotted.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    IC1,IC2  I*4    I       -      Lowest & highest colour-index to be
C                                   used for the shading.
C    ISHADE   I*4    I       -      Order of shading (IC1-->IC2 - IC1):
C                                      1 - Bottom to top.
C                                      2 - Left to right.
C                                      3 - Bottom-left to top-right.
C                                      4 - Top-left to bottom-right.
C                                      5 - Bottom, middle and top.
C                                      6 - Left, middle and right.
C                                      7 - Rectangular zoom to centre.
C                                      8 - Elliptical zoom to centre.
C Globals
C    SFTBUF
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     SBRFIL     Fills a real aray with a constant.
C
C History
C   D. S. Sivia      12 Oct 1995  Initial release.
C-----------------------------------------------------------------------
C
      IF (IBFMOD.EQ.2) RETURN
      NC=IC2-IC1
      NTOT=NXP*NYP
      IF (NC.EQ.0) THEN
        CALL SBRFIL(SBBUFF(KSTART+1),FLOAT(IC1),NTOT)
        RETURN
      ENDIF
      IF (ISHADE.EQ.1) THEN
        COL=FLOAT(IC1)
        DCOL=0.9999*FLOAT(NC)/FLOAT(NYP-1)
        K=KSTART+1
        DO 1 J=1,NYP
           CALL SBRFIL(SBBUFF(K),COL,NXP)
           K=K+NXP
           COL=COL+DCOL
   1    CONTINUE
      ELSEIF (ISHADE.EQ.2) THEN
        COL=FLOAT(IC1)
        DCOL=0.9999*FLOAT(NC)/FLOAT(NXP-1)
        DO 11 I=1,NXP
          DO 10 K=KSTART+I,KSTART+NTOT,NXP
  10        SBBUFF(K)=COL
          COL=COL+DCOL
  11    CONTINUE
      ELSEIF (ISHADE.EQ.3) THEN
        XN=FLOAT(NXP-1)
        YN=FLOAT(NYP-1)
        COL0=FLOAT(IC1)+0.0001*FLOAT(NC)
        DCOL=0.9998*FLOAT(NC)/(XN**2+YN**2)
        K=KSTART+1
        DO 21 J=0,NYP-1
          YNJ=YN*FLOAT(J)
          DO 20 I=0,NXP-1
            SBBUFF(K)=COL0+DCOL*(XN*FLOAT(I)+YNJ)
            K=K+1
  20      CONTINUE
  21    CONTINUE
      ELSEIF (ISHADE.EQ.4) THEN
        XN=FLOAT(NXP-1)
        YN=FLOAT(1-NYP)
        COL0=FLOAT(IC1)+0.0001*FLOAT(NC)
        DCOL=0.9998*FLOAT(NC)/(XN**2+YN**2)
        K=KSTART+1
        DO 31 J=1,NYP
          YNJ=YN*FLOAT(J-NYP)
          DO 30 I=0,NXP-1
            SBBUFF(K)=COL0+DCOL*(XN*FLOAT(I)+YNJ)
            K=K+1
  30      CONTINUE
  31    CONTINUE
      ELSEIF (ISHADE.EQ.5) THEN
        NYP1=1
        NYP2=NYP/2
        COL=FLOAT(IC1)
        DCOL=0.9999*FLOAT(NC)/FLOAT(NYP2-NYP1)
        K=KSTART+1
        DO 41 L=1,2
          IF (L.EQ.2) THEN
            NYP1=NYP2+1
            NYP2=NYP
            COL=FLOAT(IC2)
            DCOL=-0.9999*FLOAT(NC)/FLOAT(NYP2-NYP1)
          ENDIF
          DO 40 J=NYP1,NYP2
             CALL SBRFIL(SBBUFF(K),COL,NXP)
             K=K+NXP
             COL=COL+DCOL
  40       CONTINUE
  41    CONTINUE
      ELSEIF (ISHADE.EQ.6) THEN
        NXP1=1
        NXP2=NXP/2
        COL=FLOAT(IC1)
        DCOL=0.9999*FLOAT(NC)/FLOAT(NXP2-NXP1)
        DO 52 L=1,2
          IF (L.EQ.2) THEN
            NXP1=NXP2+1
            NXP2=NXP
            COL=FLOAT(IC2)
            DCOL=-0.9999*FLOAT(NC)/FLOAT(NXP2-NXP1)
          ENDIF
          DO 51 I=NXP1,NXP2
            DO 50 K=KSTART+I,KSTART+NTOT,NXP
  50          SBBUFF(K)=COL
            COL=COL+DCOL
  51      CONTINUE
  52    CONTINUE
      ELSEIF (ISHADE.EQ.7) THEN
        NXP2=NXP/2+1
        NYP2=NYP/2+1
        XN=1.0/FLOAT(NXP2-1)
        YN=1.0/FLOAT(NYP2-1)
        COL0=FLOAT(IC2)
        DCOL=-0.9999*FLOAT(NC)
        K=KSTART+1
        DO 61 J=1,NYP
          YNJ=ABS(YN*FLOAT(J-NYP2))
          DO 60 I=1,NXP
            XNI=ABS(XN*FLOAT(I-NXP2))
            SBBUFF(K)=COL0+DCOL*MAX(XNI,YNJ)
            K=K+1
  60      CONTINUE
  61    CONTINUE
      ELSEIF (ISHADE.EQ.8) THEN
        NXP2=NXP/2+1
        NYP2=NYP/2+1
        XN=1.0/FLOAT(NXP2-1)
        YN=1.0/FLOAT(NYP2-1)
        COL0=FLOAT(IC2)
        DCOL=-0.9999*FLOAT(NC)
        K=KSTART+1
        DO 71 J=1,NYP
          YNJ=(YN*FLOAT(J-NYP2))**2
          DO 70 I=1,NXP
            XNI=(XN*FLOAT(I-NXP2))**2
            SBBUFF(K)=COL0+DCOL*MIN(XNI+YNJ,1.0)
            K=K+1
  70      CONTINUE
  71    CONTINUE
      ENDIF
      END
C
      SUBROUTINE SBQINF(XLEFT,XRIGHT,YBOT,YTOP,ZBMIN,ZBMAX)
C     -----------------------------------------------------
C
      LOGICAL          LPS,LCOLOR
      COMMON  /SFTBUF/ SBBUFF(2000000),NXP,NYP,IBFMOD,KSTART,
     *                 IR(0:255),IG(0:255),IB(0:255),LPS,LCOLOR,
     *                 XOFF,XLEN,XORG,XSCALE,XPERIN,XBLC,XTRC,
     *                 YOFF,YLEN,YORG,YSCALE,YPERIN,YBLC,YTRC
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Purpose
C      Passes back some useful information about the software buffer
C    and canvas to be plotted. All (x,y,z) values are taken to be given
C    in world coordinates.
C
C Parameters
C   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
C    XLEFT    R*4    O       -      X-coord of left-hand of window.
C    XRIGHT   R*4    O       -      X-coord of right-hand of window.
C    YBOT     R*4    O       -      Y-coord of bottom of window.
C    YTOP     R*4    O       -      Y-coord of top of window.
C    ZBMIN    R*4    O       -      Minimum Z for distance buffer.
C    ZBMAX    R*4    O       -      Maximum Z for distance buffer.
C
C Globals
C    SFTBUF
C
C External Calls
C   SUBROUTINE   DESCRIPTION
C     None.
C
C History
C   D. S. Sivia       6 Jul 1995  Initial release.
C-----------------------------------------------------------------------
C
      XLEFT=XBLC
      XRIGHT=XTRC
      YBOT=YBLC
      YTOP=YTRC
C
      NTOT=NXP*NYP
      ZBMIN=0.0
      ZBMAX=-1.0E20
      DO 10 I=1,NTOT
        ZBMIN=MIN(SBBUFF(I),ZBMIN)
        ZBMAX=MAX(SBBUFF(I),ZBMAX)
  10  CONTINUE
      END
C
C***<vector utility routines>*******************************************
C
      SUBROUTINE SBRFIL(X,A,N)
C     ------------------------
C
      REAL X(*)
C
      DO 10 I=1,N
  10    X(I)=A
      END
C
      SUBROUTINE SBRCOP(X,Y,N)
C     ------------------------
C
      REAL X(*),Y(*)
C
      DO 10 I=1,N
  10    Y(I)=X(I)
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
#<

#>            plotdevices.c
#include "stddef.h"
#include "stdlib.h"
#include "gipsyc.h"
#include "grexec.h"
#include "plotdevices.h"

#define MAXDEVLEN 20
#define MAXDEVS   40

extern char **plotdevices(void)
{
   fint   ndevs, idev, ifunc, nbuf, lchr;
   float  rbuf;
   fchar  chr;
   int    mdevs=0;                           /* number of matching devices */
   char   capabilities[MAXDEVLEN];
   char   **devnames=(char**)calloc(MAXDEVS+1,sizeof(char**));
    
   idev = 0; ifunc = 0; nbuf  = 1; lchr  = 1;
   grexec_c(&idev, &ifunc, &rbuf, &nbuf, chr, &lchr);
   ndevs = (fint)rbuf;
   chr.l = MAXDEVLEN;
   for (idev=1; idev<=ndevs && mdevs<MAXDEVS; idev++) {
      chr.a = capabilities;
      ifunc = 4; nbuf  = 1; lchr  = 1;
      grexec_c(&idev, &ifunc, &rbuf, &nbuf, chr, &lchr);
      if ( capabilities[0]=='H' && 
           capabilities[6]!='N') {
         mdevs++;
         chr.a = (char*)calloc(MAXDEVLEN+1,1);
         ifunc = 1; nbuf  = 1; lchr  = 1;
         grexec_c(&idev, &ifunc, &rbuf, &nbuf, chr, &lchr);
         chr.a[lchr] = '\0';
         devnames[mdevs-1] = chr.a;
      }
   }
   devnames[mdevs] = NULL;
   return devnames;
}
#<

#>            animator.c
/* animator.c
                              COPYRIGHT (c) 1998
                        Kapteyn Astronomical Institute
         University of Groningen  -  9700 AV Groningen, The Netherlands

Author: J.P. Terlouw
*/

#define NAME      "Animator"
#define DEFFRAMES 20       /* default number of movie frames */
#define FLEN       6       /* text fields length in limits pane */
#define COLSIZE    4       /* text fields column size */

#define LEFT(a,b)  GgiSetPosition(a, -GgiWidth(a)-GgiWidth(b)-4, b, -GgiWidth(a)+7, b)

#include "gipsyc.h"
#include "stddef.h"
#include "stdio.h"
#include "string.h"
#include "math.h"
#include "userfio.h"
#include "ggi.h"
#include "animator.h"


static ident s_animator;
static ident s_prev, f_box, val_box;
static ident loasta, stosta, loaend, stoend;
static ident t_frames, b_build;
static ident frame_t, frame_g, speed_t, speed_g;
static ident back_b, forw_b, bafo_b;
static ident l_header;
static ident closebut;

typedef struct {
   char   key[KEYLEN];
   char   label[20];
   int    nelems;
   float  start[3];
   float  incr[3];
   bool   active;
} key_info; 

static key_info keys[]={
   {"ROTATION=", "Rotation",    1, {0.0,0.0,0.0}, {0.0,0.0,0.0}, FALSE},
   {"TILT=",     "Tilt",        1, {0.0,0.0,0.0}, {0.0,0.0,0.0}, FALSE},
   {"LI_HOR=",   "Hor. light",  1, {0.0,0.0,0.0}, {0.0,0.0,0.0}, FALSE},
   {"LI_VER=",   "Vert. light", 1, {0.0,0.0,0.0}, {0.0,0.0,0.0}, FALSE},
   {"ISOVAL=",   "Isoval",      1, {0.0,0.0,0.0}, {0.0,0.0,0.0}, FALSE},
   {"APOINT=",   "Slice point", 3, {0.0,0.0,0.0}, {0.0,0.0,0.0}, FALSE},
   {"THETA=",    "Theta",       1, {0.0,0.0,0.0}, {0.0,0.0,0.0}, FALSE},
   {"PHI=",      "Phi",         1, {0.0,0.0,0.0}, {0.0,0.0,0.0}, FALSE}
};

static int   nkeys=sizeof(keys)/sizeof(key_info);
static fint  nframes;
static int   lastframe;
static ident plotter;
static int   interval;
static int   expect=0;
static int   frame=-1;
static int   increment=1;
static bool  hew=FALSE;
static bool  framepending=FALSE;
static bool  building=FALSE;

/* -------------------------------------------------------------------------- */
/*                                 nextframe                                  */
/* -------------------------------------------------------------------------- */
/*  nextframe() increments frame according to the current settings
 */
static void nextframe(void)
{
   frame += increment;
   if (hew) {
      if (frame<0) {
         frame = 1;
         increment = 1;
      } else if (frame>lastframe) {
         frame = lastframe-1;
         increment = -1;
      }
   } else {
      frame = (frame+lastframe+1)%(lastframe+1);
   }
}

/* -------------------------------------------------------------------------- */
/*                                 key_update                                 */
/* -------------------------------------------------------------------------- */
/* key_update() changes all "active" keyword values for a given frame.
 */
static void key_update(int frame)
{
   int j, k;
   
   for (j=0; j<nkeys; j++) {
      if (keys[j].active) {
         char keyval[80];
         strcpy(keyval, keys[j].key);
         for (k=0; k<keys[j].nelems; k++) {
            float start = keys[j].start[k];
            float incr = keys[j].incr[k];
            sprintf(keyval+strlen(keyval), "%.2f ", start+frame*incr); 
         }
         wkeyf(keyval);                      /* write parameter value */
      }
   }
}

/* -------------------------------------------------------------------------- */
/*                                 popshell                                   */
/* -------------------------------------------------------------------------- */
/*  Keyword handler causing the shell to be popped up or down.
 */
static void popshell(ident id, char *key, int code, void *arg)
{  
   static bool state=FALSE;
   bool button=toflog(FALSE);
 
   (void)userflog(&button, 1, 2, key, " ");
   if (tobool(button)) {
      GgiShowShell((ident)arg, !state);
      state = !state;
      wkeyf(key);
   }
}

/* -------------------------------------------------------------------------- */
/*                                 loadvalues                                 */
/* -------------------------------------------------------------------------- */
/*  Keyword handler loading values from main controls.
 */
static void loadvalues(ident id, char *key, int code, void *arg)
{  
   bool button=toflog(FALSE);
   key_info *thiskey;
   char  *prefix=(char *)arg;
   char  valbuf[41];
   fchar keyval;
 
   keyval.a = valbuf; keyval.l = 40;
   (void)userflog(&button, 1, 2, key, " ");
   if (tobool(button)) {
      for (thiskey=keys; thiskey<keys+nkeys; thiskey++) {
         int nread=userftext(keyval, 2, thiskey->key, " ");
         if (nread>0) {
            valbuf[nread] = '\0';
            wkeyf("%s%s%s", prefix, thiskey->key, valbuf);
         }
      }
      wkeyf(key);
   }
}

/* -------------------------------------------------------------------------- */
/*                                 storevalues                                */
/* -------------------------------------------------------------------------- */
/*  Keyword handler storing values to main controls.
 */
static void storevalues(ident id, char *key, int code, void *arg)
{  
   bool button=toflog(FALSE);
   key_info *thiskey;
   char  *prefix=(char *)arg;
   char  valbuf[41];
   fchar keyval;
   char  keyword[KEYLEN];
   int   nread;

   keyval.a = valbuf; keyval.l = 40;
   (void)userflog(&button, 1, 2, key, " ");
   if (tobool(button)) {
      for (thiskey=keys; thiskey<keys+nkeys; thiskey++) {
         sprintf(keyword, "%s%s", prefix, thiskey->key);
         nread = userftext(keyval, 2, keyword, " ");
         if (nread>0) {
            valbuf[nread] = '\0';
            wkeyf("%s%s", thiskey->key, valbuf);
         }
      }
      wkeyf(key);
   }
}

/* -------------------------------------------------------------------------- */
/*                                 build                                      */
/* -------------------------------------------------------------------------- */
/*  Keyword handler building the animation.
 */
static void build(ident id, char *key, int code, void *arg)
{
   bool button=toflog(FALSE);
   char  startkey[KEYLEN], endkey[KEYLEN];
   int i, j;
   
   (void)userflog(&button, 1, 2, key, " ");
   if (tobool(button)) {
      building = TRUE;
      GgiDeactivate(val_box);       /* protect from inadvertent modification */
      GgiDeactivate(frame_t);
      GgiDeactivate(frame_g);
      GgiDeactivate(back_b);
      GgiDeactivate(bafo_b);
      GgiDeactivate(forw_b);
      (void)userfint(&nframes, 1, 2, "NFRAMES=", " ");
      if (nframes<2) {
         rejectf("NFRAMES=", "Not enough...");
         wkeyf(key);
         return;
      }
      nframes = GgiPlotFrames(plotter, nframes);      /* request plot frames */
      wkeyf("NFRAMES=%d", nframes);                   /* we got this many    */
      if (nframes<2) {
         rejectf("NFRAMES=", "Not enough...");
         wkeyf(key);
         return;
      }
      GgiSetRange(frame_g, 0.0, (float)(nframes-1));  /* adjust slider range */
/*
 *    prepare control structs
 */
      for (i=0; i<nkeys; i++) {
         keys[i].active = FALSE;
         sprintf(startkey, "START_%s", keys[i].key);
         sprintf(endkey, "END_%s", keys[i].key);
         if (userfreal(keys[i].start, keys[i].nelems, 2, startkey, " ")>0) {
            if (userfreal(keys[i].incr, keys[i].nelems, 2, endkey, " ")>0) {
               for (j=0; j<keys[i].nelems; j++) {
                  keys[i].incr[j] = (keys[i].incr[j]-keys[i].start[j])/(nframes-1);
                  if (keys[i].incr[j] != 0.0) keys[i].active = TRUE;
               }
            }
         }
         if (!keys[i].active) {
            wkeyf(startkey);
            wkeyf(endkey);
         }
      }
/*
 *   generate frames
 */
      for (i=0; i<nframes && building; i++) {
         lastframe = i;
         key_update(i);
         wkeyf("GO=YES");                          /* generate plot */
         wkeyf("FRAME=%d", i);                     /* display frame counter */
         GgiHandleEvents();                        /* process queued events */
         GgiPlotRecord(plotter, i);                /* record the plot */
      }
      wkeyf(key);                                  /* clear BUILD button */
   } else {
      building = FALSE;
   }
   GgiActivate(val_box);                           /* allow changes again */
   GgiActivate(frame_t);
   GgiActivate(frame_g);
   GgiActivate(back_b);
   GgiActivate(bafo_b);
   GgiActivate(forw_b);
   GgiSetRange(frame_g, 0.0, (float)(lastframe));  /* adjust slider again */
}

/* -------------------------------------------------------------------------- */
/*                                 realspeed                                  */
/* -------------------------------------------------------------------------- */
/*  Keyword handler converting logarithmic to real speed.
 */
static void realspeed(ident id, char *key, int code, void *arg)
{
   float speed;
    
   if (!expect) {
      expect++;
      (void)userfreal(&speed, 1, 2, key, " ");
      wkeyf("%s%.1f", (char*)arg, exp(speed));
      interval = 1000.0/exp(speed);
   } else expect--;
}

/* -------------------------------------------------------------------------- */
/*                                 logspeed                                   */
/* -------------------------------------------------------------------------- */
/*  Keyword handler converting real to logarithmic speed and updating
 *  the frame interval.
 */
static void logspeed(ident id, char *key, int code, void *arg)
{
   float speed;
    
   if (!expect) {
      (void)userfreal(&speed, 1, 2, key, " ");
      if (speed>0.5) {
         wkeyf("%s%.1f", (char*)arg, log(speed));
         expect++;
         interval = 1000.0/speed;
      }
   } else expect--;
}

/* -------------------------------------------------------------------------- */
/*                                 showframe                                  */
/* -------------------------------------------------------------------------- */
/*  Keyword handler displaying specified frame.
 */
static void showframe(ident id, char *key, int code, void *arg)
{
   fint f;

   if (building) return;  /* display only */    
   framepending = FALSE;
   (void)userfint(&f, 1, 2, key, " ");
   frame = f;
   if (frame>=0 && frame<nframes) {
      GgiPlotShow(plotter, frame);
      key_update(frame);
   }
}

/* -------------------------------------------------------------------------- */
/*                                 player                                     */
/* -------------------------------------------------------------------------- */
static void player(ident id, void *arg)
{
   ident *timer=(ident *)arg;
   static int prvint=-1;
    
   if (!framepending) {             /* only if previous frame has been shown */
      nextframe();
      wkeyf("FRAME=%d", frame);
      framepending = TRUE;
   }
   if (interval != prvint) {
      prvint = interval;
      Deschedule(timer);
      *timer = ScheduleTimer(player, interval, timer);
   }
}


/* -------------------------------------------------------------------------- */
/*                                 playmovie                                  */
/* -------------------------------------------------------------------------- */
/*  Keyword handler for starting and stopping the movie.
 */
static void playmovie(ident id, char *key, int code, void *arg)
{
   bool button=toflog(FALSE);
   static ident timer;
    
   (void)userflog(&button, 1, 2, key, " ");
   button = tobool(button);
   if (button && !timer) {
      timer = ScheduleTimer(player, interval, &timer);
      GgiDeactivate(val_box);
      GgiDeactivate(b_build);
   } else if (timer && !button) {
      Deschedule(&timer);
      GgiActivate(val_box);
      GgiActivate(b_build);
   }
}

/* -------------------------------------------------------------------------- */
/*                                 momode                                     */
/* -------------------------------------------------------------------------- */
/*  Keyword handler for setting movie direction and  back-and-forward mode.
 */
static void momode(ident id, char *key, int code, void *arg)
{
   bool button=toflog(FALSE);
   static char playing[KEYLEN]="";

   (void)userflog(&button, 1, 2, key, " ");
   if (tobool(button)) {
      if (!strcmp(key,"BACK=")) {
         hew = FALSE;
         increment = -1;
         wkeyf("BAFO= FORW=");
      } else if (!strcmp(key,"BAFO=")) {
         hew = TRUE;
         wkeyf("BACK= FORW=");
      } else {
         hew = FALSE;
         increment =  1;
         wkeyf("BACK= BAFO=");
      }
      if (!playing[0]) {
         wkeyf("PLAY=YES");
      }
      strcpy(playing,key);
   } else {
      if (!strcmp(key,playing)) {
         wkeyf("PLAY=NO");
         strcpy(playing,"");
      }
   }
}

/* ========================================================================== */
/*                                 Animator                                   */
/* -------------------------------------------------------------------------- */
/*  Animator() creates a pop-up shell for controlling animated sequenced.
 *  The argument 'key' is the GIPSY keyword (type LOGICAL)
 *  which, when set to "YES", will cause the shell to be popped up or down.
 *  The same keyword is used for the <CLOSE> button in the shell.
 */
void Animator(char *key)
{    
   s_animator = GgiShell(NAME);
   s_prev = GgiUseShell(s_animator);
   l_header = GgiLabel(" Animation controls");
   closebut = GgiSetLabel(GgiButton(key, "Close window"), "CLOSE", 0);
   f_box = GgiForm(NAME, 2);
   (void)GgiUseShell(f_box);
  
/*  --------------------  Movie building section ---------------------------- */

   b_build  = GgiButton("BUILD=", "Start or stop making movie");
   {
      key_info *thiskey;
      ident    firstcol=NULL, start, end;
      ident    leftref, topref;
      ident    l_load, l_store;
      char     keybuf[KEYLEN];
      int      rows, cols;
      
      val_box = GgiForm(NAME, 1);
      (void)GgiUseShell(val_box);
      thiskey=keys;
      leftref = NULL;
      for (cols=0; cols<((nkeys-1)/COLSIZE+1); cols++) {
         ident colbox = GgiForm(NAME, 0);
         topref = NULL;
         (void)GgiUseShell(colbox);
         for (rows=0; rows<COLSIZE && cols*COLSIZE+rows<nkeys; rows++) {
            sprintf(keybuf, "START_%s", thiskey->key);
            start = GgiSetLabel(GgiTextField(keybuf, NULL, FLEN),
                                thiskey->label, 65);
            sprintf(keybuf, "END_%s", thiskey->key);
            end   = GgiSetLabel(GgiTextField(keybuf, NULL, FLEN), "->", 20);
            GgiSetPosition(start, 0, NULL,  0, topref);
            GgiSetPosition(end,   0, start, 0, topref);
            topref = start;
            thiskey++;
         }
         (void)GgiUseShell(val_box);
         GgiSetPosition(colbox, 0, leftref, 0, NULL);
         if (!firstcol) firstcol = colbox;
         leftref = colbox;
      }
      l_load  = GgiLabel("Load:");
      loasta  = GgiSetLabel(GgiButton("LOAD_START=",
                            "Copy main controls\nto start condition"),
                            "Start", 0);
      loaend  = GgiSetLabel(GgiButton("LOAD_END=",
                            "Copy main controls\nto end condition"),
                            "End", 0);
      l_store = GgiLabel("Store:");
      stosta = GgiSetLabel(GgiButton("STORE_START=",
                             "Copy start condition\nto main controls"),
                           "Start", 0);
      stoend = GgiSetLabel(GgiButton("STORE_END=",
                             "Copy end condition\nto main controls"),
                           "End", 0);
      t_frames = GgiSetLabel(
                    GgiTextField("NFRAMES=", "Number of movie frames", 3),
                    "#frames", 0);
      GgiSetPosition(l_load,   20, NULL,    7, firstcol);
      GgiSetPosition(loasta,    0, l_load,  5, firstcol);
      GgiSetPosition(loaend,    0, loasta,  5, firstcol);
      GgiSetPosition(l_store,  20, loaend,  7, firstcol);
      GgiSetPosition(stosta,    0, l_store, 5, firstcol);
      GgiSetPosition(stoend,    0, stosta,  5, firstcol);
      GgiSetPosition(t_frames, 20, stoend,  5, firstcol);
     }
   GgiSetPosition(val_box,  0, NULL, 0, NULL);
   GgiSetPosition(b_build,  0, NULL, 0, val_box);

/*  --------------------  Movie control section ----------------------------- */

   (void)GgiUseShell(f_box);

   back_b  = GgiSetLabel(GgiButton("BACK=", NULL), "< <", 0);
   bafo_b  = GgiSetLabel(GgiButton("BAFO=", NULL), "<->", 0);
   forw_b  = GgiSetLabel(GgiButton("FORW=", NULL), "> >", 0);
   GgiDeactivate(back_b);
   GgiDeactivate(bafo_b);
   GgiDeactivate(forw_b);

   frame_t = GgiSetLabel(GgiTextField("FRAME=", "Current frame", 4),
                         "Frame", 45);
   GgiDeactivate(frame_t);
   frame_g = GgiSetLabel(GgiGauge("FRAME=", NULL, 150, 0.0, 100.0), " ", 1);
   GgiSetFormat(frame_g, "%.0f");
   GgiDeactivate(frame_g);
   speed_t = GgiSetLabel(GgiTextField("SPEED=", "Speed (frames/s)", 4),
                         "Speed", 45);
   speed_g = GgiSetLabel(GgiGauge("LSP=", NULL, 150,
                                   log(5.0), log(30.0)), " ", 1);

   GgiSetPosition(back_b,  0, NULL,    0, b_build);
   GgiSetPosition(bafo_b,  0, back_b,  0, b_build);
   GgiSetPosition(forw_b,  0, bafo_b,  0, b_build);

   GgiSetPosition(frame_t, 10, forw_b,  0, val_box);
   GgiSetPosition(frame_g,  0, frame_t, 0, val_box);
   GgiSetPosition(speed_t, 10, forw_b,  0, frame_t);
   GgiSetPosition(speed_g,  0, speed_t, 0, frame_t);
     


   (void)GgiUseShell(s_animator);
   GgiSetPosition(l_header, 0, NULL, 0, NULL);
   GgiSetPosition(f_box, 0, NULL, 0, l_header);
   GgiSetPosition(closebut, 0, NULL, 0, f_box);
   (void)GgiUseShell(s_prev);
   ScheduleKeyevent(popshell, key, KEYCHANGE, s_animator);
   ScheduleKeyevent(loadvalues,  "LOAD_START=",  KEYCHANGE, "START_");
   ScheduleKeyevent(loadvalues,  "LOAD_END=",    KEYCHANGE, "END_");
   ScheduleKeyevent(storevalues, "STORE_START=", KEYCHANGE, "START_");
   ScheduleKeyevent(storevalues, "STORE_END=",   KEYCHANGE, "END_");
   ScheduleKeyevent(build, "BUILD=",   KEYCHANGE, NULL);
   ScheduleKeyevent(realspeed, "LSP=", KEYCHANGE, "SPEED=");
   ScheduleKeyevent(logspeed, "SPEED=", KEYCHANGE, "LSP=");
   ScheduleKeyevent(showframe, "FRAME=", KEYCHANGE, NULL);
   ScheduleKeyevent(playmovie, "PLAY=", KEYCHANGE, NULL);
   ScheduleKeyevent(momode, "FORW=", KEYCHANGE, NULL);
   ScheduleKeyevent(momode, "BAFO=", KEYCHANGE, NULL);
   ScheduleKeyevent(momode, "BACK=", KEYCHANGE, NULL);
   wkeyf("PLAY=");
   if (!TriggerKey("NFRAMES=")) wkeyf("NFRAMES=%d", DEFFRAMES);
   if (!TriggerKey("SPEED=")) wkeyf("SPEED=10");
   wkeyf("BACK= BAFO= FORW=");
   plotter = GgiPlotField("3DPLOT", 0, 0);
}
#<
