.OP LS=10001 LI=1 CB RT ES=< ET=> OC UC=0 BI=77 IF=2
.EL I
I
I $Id: CodeIftran,v 1.7.8.1 2010-03-17 20:51:58 brownrig Exp $
I
I***********************************************************************
I  V A S P A C K T   -   I N T R O D U C T I O N
I***********************************************************************
I
I This file contains the code of a vector and streamline package called
I VASPACKT.  Double-spaced headers like the one above set off the major
I portions of the file.  Included are implementation instructions,
I user-level routines, and internal routines.
I
I***********************************************************************
I  V A S P A C K T   -   I M P L E M E N T A T I O N
I***********************************************************************
I
I The master version of VASPACKT is written in IFTRAN, an extended form
I of FORTRAN which provides many conveniences.  Running it through the
I IFTRAN preprocessor yields a standard FORTRAN 77 file, which is the
I version distributed as a part of NCAR Graphics.
I
I VASPACKT requires various parts of the NCAR Graphics package to have
I been implemented; in particular, it uses the support routines I1MACH
I and SETER, various routines from SPPS, various GKS routines, and a
I few routines from EZMAP, PLOTCHAR, and TDPACK.
I
I***********************************************************************
I  V A S P A C K T   -   I F T R A N   D E F I N I T I O N S
I***********************************************************************
I
I Implementor-settable variables
I ----------- -------- ---------
I
I $LOCV$ is the length of certain character variables.  Do not use a
I value less than 25.  Values greater than 500 are probably too large.
I
.RE /$LOCV$/500/
I
I $MCLR$ is the maximum number of colors that one will be able to use
I in coloring streamlines.
I
.RE /$MCLR$/255/
I
I $NBIW$ is the number of "blocks" of integer workspace to be provided
I for.  The user of VASPACKT supplies a single integer workspace array.
I When one of the VASPACKT routines requires a block of space within the
I array, it calls VTGIWS to request the space.  VTGIWS finds or makes
I room within the integer workspace array (which may require moving
I things around), and then sets parameters IInn (a base address) and
I LInn (a length) to tell the caller where the requested space is.
I Note: If the value of $NBIW$ is made larger than 9, the code setting
I up the equivalence statements defining IInn and LInn must be changed.
I
.RE /$NBIW$/2/
I
I $NBRW$ is the number of "blocks" of real workspace to be provided
I for.  The user of VASPACKT supplies a single real workspace array.
I When one of the VASPACKT routines requires a block of space within the
I array, it calls VTGRWS to request the space.  VTGRWS finds or makes
I room within the real workspace array (which may require moving things
I around), and then sets parameters IRnn (a base address) and LRnn (a
I length) to tell the caller where the requested space is.  Note: If
I the value of $NBRW$ is made larger than 9, the code setting up the
I equivalence statements defining IRnn and LRnn must be changed.
I
.RE /$NBRW$/2/
I
I The VASPACKT common blocks
I --- -------- ------ ------
I
I The following SAVE block contains all of the VASPACKT common blocks.
I For descriptions of all of the variables, see the commenting in the
I block data routine VTBLDA, below.
I
.SAVE VTCOMN
C
C VTCOM1 contains integer and real variables.
C
        COMMON /VTCOM1/ AHAW,AHLN,AHLR,AHSP,AHSR
        COMMON /VTCOM1/ ANIL,ANM1,ANM2,ANZF,AVEL,CHWM,CXIL,CXZF
        COMMON /VTCOM1/ CYIL,CYZF,DCNU,DCNV,DCNW,DMAX
        COMMON /VTCOM1/ DMIN,DVAL  !  REUSE FOR FLOWMIN AND FLOWMAX?
        COMMON /VTCOM1/ EMAX,EPSI
        COMMON /VTCOM1/ IBIL,IBZF,ICIL,ICLR($MCLR$)
        COMMON /VTCOM1/ ICSG,ICST,ICTT,ICTV,ICZF,IDBG,IISP
        COMMON /VTCOM1/ IIWS($NBIW$),IIWU,ILBC,IMPF
        COMMON /VTCOM1/ INIL  !  NEEDED? (INFORMATIONAL LABEL INDEX)
        COMMON /VTCOM1/ INIT,IPAI,IPIS
        COMMON /VTCOM1/ IPIL,IPZF,IRNG,IRWS($NBRW$),IRWU,ISET,ISTA(625)
        COMMON /VTCOM1/ ISVT,ITBM,IWSO,IZFF,JODP,JOMA
        COMMON /VTCOM1/ JOTZ,LCTM,LEA1,LEA2,LEA3,LEE1,LEE2,LEE3
        COMMON /VTCOM1/ LIWB,LIWK,LIWS($NBIW$),LNLG
        COMMON /VTCOM1/ LOEN,LOPN,LOTN
        COMMON /VTCOM1/ LRWK,LRWS($NBRW$)
        COMMON /VTCOM1/ LSDD,LSDL,LSDM,LTIL,LTZF,MIRO,NCLR
        COMMON /VTCOM1/ NDGL,NEDG,NEXL,NEXT,NEXU
        COMMON /VTCOM1/ NLBS  !  NEEDED? (NUMBER OF LABELS)
        COMMON /VTCOM1/ NLSD,NLZF,NOMF,NPNT
        COMMON /VTCOM1/ NR04  !  NEEDED? (LABEL-LIST MANAGEMENT)
        COMMON /VTCOM1/ NSDL,NSDR,NTRI,OORV,PCPX,PCPY,PCPZ
        COMMON /VTCOM1/ PITH  !  NEEDED? (STREAMLINE INTERPOLATION)
        COMMON /VTCOM1/ SCFS,SCFU  !  NEEDED? (SCALE FACTORS)
        COMMON /VTCOM1/ SLLN,SLLR,SLPS,SLPR,SLSP,SLSR,SVSP,SVSR
        COMMON /VTCOM1/ TTLL,TTLR,TTSP,TTSR,TVAL(0:<$MCLR$+1>)
        COMMON /VTCOM1/ UVPB,UVPL,UVPR,UVPS,UVPT,UWDB,UWDL
        COMMON /VTCOM1/ UWDR,UWDT,VFRA,VRLN,VRLR,VRMG,VRMR
        COMMON /VTCOM1/ VVMM
        COMMON /VTCOM1/ WCIL,WCZF,WLIL,WLZF
        COMMON /VTCOM1/ WWIL,WWZF
        COMMON /VTCOM1/ XLBC,XMAX,XMIN,XVPL,XVPR,XWDL,XWDR
        COMMON /VTCOM1/ YLBC,YMAX,YMIN,YVPB,YVPT,YWDB,YWDT,ZMAX,ZMIN
C
.IF <$NBIW$.GE.1>
        EQUIVALENCE (IIWS(1),II01),(LIWS(1),LI01)
.ENDIF
.IF <$NBIW$.GE.2>
        EQUIVALENCE (IIWS(2),II02),(LIWS(2),LI02)
.ENDIF
.IF <$NBIW$.GE.3>
        EQUIVALENCE (IIWS(3),II03),(LIWS(3),LI03)
.ENDIF
.IF <$NBIW$.GE.4>
        EQUIVALENCE (IIWS(4),II04),(LIWS(4),LI04)
.ENDIF
.IF <$NBIW$.GE.5>
        EQUIVALENCE (IIWS(5),II05),(LIWS(5),LI05)
.ENDIF
.IF <$NBIW$.GE.6>
        EQUIVALENCE (IIWS(6),II06),(LIWS(6),LI06)
.ENDIF
.IF <$NBIW$.GE.7>
        EQUIVALENCE (IIWS(7),II07),(LIWS(7),LI07)
.ENDIF
.IF <$NBIW$.GE.8>
        EQUIVALENCE (IIWS(8),II08),(LIWS(8),LI08)
.ENDIF
.IF <$NBIW$.GE.9>
        EQUIVALENCE (IIWS(9),II09),(LIWS(9),LI09)
.ENDIF
.IF <$NBRW$.GE.1>
        EQUIVALENCE (IRWS(1),IR01),(LRWS(1),LR01)
.ENDIF
.IF <$NBRW$.GE.2>
        EQUIVALENCE (IRWS(2),IR02),(LRWS(2),LR02)
.ENDIF
.IF <$NBRW$.GE.3>
        EQUIVALENCE (IRWS(3),IR03),(LRWS(3),LR03)
.ENDIF
.IF <$NBRW$.GE.4>
        EQUIVALENCE (IRWS(4),IR04),(LRWS(4),LR04)
.ENDIF
.IF <$NBRW$.GE.5>
        EQUIVALENCE (IRWS(5),IR05),(LRWS(5),LR05)
.ENDIF
.IF <$NBRW$.GE.6>
        EQUIVALENCE (IRWS(6),IR06),(LRWS(6),LR06)
.ENDIF
.IF <$NBRW$.GE.7>
        EQUIVALENCE (IRWS(7),IR07),(LRWS(7),LR07)
.ENDIF
.IF <$NBRW$.GE.8>
        EQUIVALENCE (IRWS(8),IR08),(LRWS(8),LR08)
.ENDIF
.IF <$NBRW$.GE.9>
        EQUIVALENCE (IRWS(9),IR09),(LRWS(9),LR09)
.ENDIF
.IF <$SAVE-COMMON$.NE.0>
        SAVE   /VTCOM1/
.ENDIF
C
C VTCOM2 holds character parameters.
C
        COMMON /VTCOM2/ CHEX,CTMA,CTMB,FRMT
        COMMON /VTCOM2/ TXIL,TXZF
        CHARACTER*13 CHEX
        CHARACTER*$LOCV$ CTMA,CTMB
        CHARACTER*8 FRMT
        CHARACTER*128 TXIL
        CHARACTER*64 TXZF
.IF <$SAVE-COMMON$.NE.0>
        SAVE   /VTCOM2/
.ENDIF
.END

I***********************************************************************
I  V A S P A C K T   -   B L O C K   D A T A   ( D E F A U L T S )
I***********************************************************************


      SUBROUTINE VTBLDA
C
C Calling this do-nothing subroutine forces "ld" to load the following
C block data routine (but only if they are in the same ".f" file).
C
        RETURN
C
      END
C
CNOSPLIT - makes Fsplit put next routine in same file as last routine.
C
      BLOCKDATA VTBLDAX
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Below are descriptions of all the COMMON variables and default values
C for those which require defaults.
C
C AHAW and AHLN are the parameters 'AHA' and 'AHL', which are the
C angular width and length, respectively, of the arrowheads to be
C used on a streamline.  AHLR is the "realized" length of an arrowhead,
C computed as needed.
C
        DATA AHAW,AHLN / 30.,.04 /
C
C AHSP is the parameter 'AHS', which is the spacing of arrowheads along
C a streamline.  AHSR is a "realized" value of AHSP and is computed as
C necessary.
C
        DATA AHSP / .16 /
C
C ANIL is the parameter 'ILA', which is the angle, in degrees, at which
C the informational label is to be written.
C
        DATA ANIL / 0. /
C
C ANM1 and ANM2 are the parameters 'AM1' and 'AM2', maximum angles to
C be allowed between any pair of velocity vectors at the vertices of a
C triangle being considered.  The first serves to limit the placement
C of curly vectors and the starting positions of streamline generators
C and streamlines, while the second serves to terminate streamline
C generators and streamlines.
C
        DATA ANM1,ANM2 / 90. , 0. /
C
C ANZF is the parameter 'ZFA', which is the angle, in degrees, at which
C the zero-field label is to be written.
C
        DATA ANZF / 0. /
C
C AVEL is the parameter 'AEL' (for retrieval only), which is the average
C edge length in the triangular mesh.
C
        DATA AVEL / 0. /
C
C CHEX is used to hold the character string which stands between the
C mantissa and the exponent of a numeric value.
C
C CHWM is the parameter 'CWM', the character-width multiplier.
C
        DATA CHWM / 1. /
C
C CTMA and CTMB are character-variable temporaries, used for various
C purposes throughout the code.  CTMA is the parameter 'CTM'.
C
        DATA CTMA,CTMB / ' ',' ' /
C
C CXZF and CYZF are the parameters 'ZFX' and 'ZFY', which are the X and
C Y coordinates of a basepoint relative to which the zero-field
C label is to be positioned.  These coordinates are given in a
C fractional coordinate system superimposed on the user-system window.
C
        DATA CXZF,CYZF / .50,.50 /
C
C CXIL and CYIL are the parameters 'ILX' and 'ILY', which are the X and
C Y coordinates of a basepoint relative to which the informational label
C is to be positioned.  These coordinates are given in a fractional
C coordinate system superimposed on the user-system window.
C
        DATA CXIL,CYIL / .98,-.02 /
C
C DCNU, DCNV, and DCNW are the direction cosines for the normal to the
C plane of the triangle, computed for use by the routine VTCUDR when it
C is asked to draw arrowheads (so that they will lie in the plane of
C the triangle).
C
        DATA DCNU,DCNV,DCNW / 0.,0.,1. /
C
C DMAX and DMIN are the parameters 'DMX' and 'DMN', the maximum and
C minimum velocity-vector magnitudes in the user's array of data.
C
        DATA DMAX,DMIN / 0.,0. /
C
C DVAL is the parameter 'DVA', which holds a data value.
C
        DATA DVAL / 0. /
C
C EMAX is equal to MAX(XMAX-XMIN,YMAX-YMIN,ZMAX-ZMIN) and is computed
C by VTMESH.  It is given a default value only because its value can
C be retrieved as the value of the parameter 'EOM'.
C
        DATA EMAX / 0. /
C
C EPSI is a machine "epsilon", whose real value is computed as required.
C
C FRMT is a format to be used by the routine VTNUMB.  It is constructed
C as needed by the routine VTINRC.
C
C IBIL is the parameter 'ILB', which is zero if no box is to be drawn
C around the informational label.  Adding 1 to the value causes the box
C to be drawn and adding 2 to it causes the box to be filled.
C
        DATA IBIL / 0 /
C
C IBZF is the parameter 'ZFB', which is zero if no box is to be drawn
C around the zero-field label.  Adding 1 to the value causes the box
C to be drawn and adding 2 to it causes the box to be filled.
C
        DATA IBZF / 0 /
C
C ICIL is the parameter 'ILC', which determines the color of the
C informational label.
C
        DATA ICIL / -1 /
C
C ICZF is the parameter 'ZFC', which determines the color of the
C zero-field label.
C
        DATA ICZF / -1 /
C
C ICLR is the parameter array 'CLR', which holds color indices for use
C on streamlines.
C
        DATA ICLR / $MCLR$*1 /
C
C ICSG and ICTT are the parameters 'SGC', 'STC', and 'TTC', which
C determine the colors of streamline generator lines, subtriangle
C lines,  and termination test lines, respectively.  (These are
C drawn only when debugging is turned on.)
C
        DATA ICSG,ICST,ICTT / 1 , 1 , 1 /
C
C ICTV is the parameter 'CTV', which is the "Color Value Threshold
C Control", saying whether streamlines are to be colored and, if so,
C how the colors are to be determined.
C
        DATA ICTV / 0 /
C
C IDBG is the parameter 'DBG', a debug flag.  This is mostly for use
C by the developer.  When set non-zero, it causes debug information to
C be plotted.
C
        DATA IDBG / 0 /
C
C IISP is the parameter 'ISP', which says how to interpret the size
C parameters.  If 'ISP' = 0, all size parameters are treated as actual
C values in 3-space, commensurate with the coordinates of the mesh
C points themselves; if 'ISP' = 1, they are treated as multiples of
C the maximum extent of the mesh in 3-space.
C
        DATA IISP / 0 /
C
C IIWS is an array of base indices in the integer work array.  LIWS is
C an associated array of lengths.  For each I for which LIWS(I) is not
C zero, IIWS(I)+1 is the index of the first word, and IIWS(I)+LIWS(I)
C the index of the last word, of a portion of the integer work array
C reserved for some particular purpose.
C
        DATA IIWS,LIWS / $NBIW$*0 , $NBIW$*0 /
C
C IIWU is the parameter 'IWU', which may be used to find out how much
C space was used in the integer workspace.
C
        DATA IIWU / 0 /
C
C ILBC is the parameter 'LBC', the color-index specifier for area fill
C of label boxes.
C
        DATA ILBC / 0 /
C
C IMPF is the parameter 'MAP', the mapping flag.
C
        DATA IMPF / 0 /
C
C INIL is used to save the index of the informational label in the list
C of labels.
C
C INIT is a flag indicating whether some necessary constants have been
C computed yet or not.
C
        DATA INIT / 0 /
C
C IPAI is the parameter 'PAI', which is the index for parameter arrays.
C
        DATA IPAI / 0 /
C
C IPIS is the parameter 'PIS', which indicates the number of points to
C interpolate between each pair of points defining a streamline.
C
        DATA IPIS / 0 /
C
C IPIL is the parameter 'ILP', specifying how the informational label
C is to be positioned.
C
        DATA IPIL / 4 /
C
C IPZF is the parameter 'ZFP', specifying how the zero-field label
C is to be positioned.
C
        DATA IPZF / 0 /
C
C IRNG is the parameter 'RNG', specifying by how many steps the random
C number generator is to be spun up during initialization of VTCVDM,
C VTSLDM, and VTSVDM.
C
        DATA IRNG / 0 /
C
C IRWS is an array of base indices in the real work array.  LRWS is an
C associated array of lengths.  For each I for which LRWS(I) is not
C zero, IRWS(I)+1 is the index of the first word, and IRWS(I)+LRWS(I)
C the index of the last word, of a portion of the real work array
C reserved for some particular purpose.
C
        DATA IRWS,LRWS / $NBRW$*0 , $NBRW$*0 /
C
C IRWU is the parameter 'RWU', which may be used to find out how much
C space was used in the real workspace.
C
        DATA IRWU / 0 /
C
C ISET is the parameter 'SET', which says whether or not VASPACKT is to
C call SET.
C
        DATA ISET / 1 /
C
C ISTA is a table, dimensioned 25x25, of subtriangle bit masks for use
C by the routines VTTSOM and VTTPOM.  If I and J are the indices of two
C subtriangles of a triangle (1.LE.I,J.LE.25), then ISTA(I,J) contains
C 1 bits for triangles forming a connected path from subtriangle I to
C subtriangle J.  (See the file "CreateTable.f".)
C
        DATA (ISTA(I),I=  1, 70) /
     +          1,       3,       7,      15,      31,      63,     127,
     +        255,     511,     515,    1539,    2063,    6159,   14351,
     +      30735,   57407,   67075,  198147,  269827,  794115, 1079311,
     +    2295299, 6489603, 9373187,23266819,       3,       2,       6,
     +         14,      30,      62,     126,     254,     510,     514,
     +       1538,    2062,    6158,   14350,   30734,   57406,   67074,
     +     198146,  269826,  794114, 1079310, 2295298, 6489602, 9182722,
     +   23266818,       7,       6,       4,      12,      28,      60,
     +        124,     252,     508,     518,    3084,    2060,    6156,
     +       8252,   24636,   57404,   68620,  199692,  268300,  792588/
        DATA (ISTA(I),I= 71,140) /
     +    1079308, 2296844, 6690828, 9181196,23268364,      15,      14,
     +         12,       8,      24,      56,     120,     248,     504,
     +       3592,    3080,    2056,    6152,    8248,   24632,   57400,
     +      68616,  399368,  268296,  792584, 1079304, 2496520, 6690824,
     +    9181192,23468040,      31,      30,      28,      24,      16,
     +         48,     112,     240,     496,    3608,    3096,    2072,
     +      12336,    8240,   24624,   57392,   68632,  399384,  274480,
     +     798768, 1073200, 2496536,13381680, 9187376,30158896,      63,
     +         62,      60,      56,      48,      32,      96,     224,
     +        480,    3640,   15392,   14368,   12320,    8224,   24608/
        DATA (ISTA(I),I=141,210) /
     +      57376,   80928,  405536,  274464, 1597472, 1073184, 2502688,
     +   13381664, 9986080,30158880,     127,     126,     124,     120,
     +        112,      96,      64,     192,     448,    3704,   15456,
     +      14432,   12384,    8288,   49344,   32960,   80992,  405600,
     +     274528, 1597536, 1097920, 2502752,14180448, 9986144,30957664,
     +        255,     254,     252,     248,     240,     224,     192,
     +        128,     384,   16096,   15584,   14560,   61568,   57472,
     +      49280,   32896,  520320,  454784,  323712, 1622144, 1097856,
     +    4112512,14205056,10010752,30982272,     511,     510,     508,
     +        504,     496,     480,     448,     384,     256,    4088/
        DATA (ISTA(I),I=211,280) /
     +      15840,   14816,   61824,   57728,   49536,   33152,  520576,
     +     455040,  323968, 1622400, 1098112, 4112768,14205312,10011008,
     +   30982528,     515,     514,     518,     526,     542,    3640,
     +       3704,    3832,    4088,     512,    1536,    3584,    7680,
     +      15872,   32256,   65024,   67072,  198144,  269824,  794112,
     +    1842688, 2295296, 6489600, 9373184,23266816,    1539,    1538,
     +       1542,    3080,    3096,    3128,    3192,   15584,   15840,
     +       1536,    1024,    3072,    7168,   15360,   31744,   64512,
     +      66560,  197632,  269312,  793600, 1842176, 2294784, 6489088,
     +    9372672,23266304,    3587,    3586,    2060,    2056,    2072/
        DATA (ISTA(I),I=281,350) /
     +      14368,   14432,   14560,   14816,    3584,    3072,    2048,
     +       6144,   14336,   30720,   63488,   68608,  199680,  268288,
     +     792576, 1841152, 2296832, 6690816, 9181184,23468032,    7683,
     +       7682,    6156,    6152,    6168,   12320,   12384,   61568,
     +      61824,    7680,    7168,    6144,    4096,   12288,   28672,
     +      61440,  462848,  397312,  266240,  790528, 1839104, 2494464,
     +    6688768, 9179136,23465984,   14351,   14350,   14348,   14344,
     +       8240,    8224,    8288,   57472,   57728,   15872,   15360,
     +      14336,   12288,    8192,   24576,   57344,  471040,  405504,
     +     274432, 1597440, 1073152, 2502656,13381632, 9986048,30158848/
        DATA (ISTA(I),I=351,420) /
     +      30735,   30734,   30732,   30728,   24624,   24608,   49344,
     +      49280,   49536,   32256,   31744,   30720,   28672,   24576,
     +      16384,   49152,  487424, 1982464, 1851392, 1589248, 1064960,
     +    4079616,14172160, 9977856,30949376,   57407,   63502,   57404,
     +      57400,   57392,   57376,   32960,   32896,   33152,   65024,
     +      64512,   63488,   61440,   57344,   49152,   32768,  520192,
     +    2015232, 1884160, 1622016, 1097728, 4112384,14204928,10010624,
     +   30982144,   67075,   67074,   67078,   68616,   68632,   80928,
     +      80992,   81120,   81376,   67072,   66560,   68608,   72704,
     +      80896,  487424,  520192,   65536,  196608,  458752,  983040/
        DATA (ISTA(I),I=421,490) /
     +    2031616, 2293760, 6488064,14876672,23265280,  198147,  198146,
     +     199692,  199688,  399384,  405536,  405600,  454784,  455040,
     +     198144,  197632,  199680,  397312,  405504,  421888,  454656,
     +     196608,  131072,  393216,  917504, 1966080, 2228224, 6422528,
     +   14811136,23199744,  269827,  269826,  268300,  268296,  268312,
     +     274464,  274528,  323712,  323968,  460288,  459776,  268288,
     +     266240,  274432,  290816,  323584,  458752,  393216,  262144,
     +     786432, 1835008, 2490368, 6684672, 9175040,23461888,  794115,
     +     794114,  792588,  792584,  798768,  798752, 1597536, 1622144,
     +    1622400,  984576,  984064,  792576,  790528,  798720, 1589248/
        DATA (ISTA(I),I=491,560) /
     +    1622016,  983040,  917504,  786432,  524288, 1572864, 3014656,
     +   13107200, 8912896,29884416, 1842691, 1842690, 1079308, 1079304,
     +    1073200, 1073184, 1073248, 1097856, 1098112, 1842688, 1842176,
     +    1841152, 1839104, 1073152, 1064960, 1097728, 2031616, 1966080,
     +    1835008, 1572864, 1048576,16252928,14155776, 9961472,30932992,
     +    2295299, 2295298, 2296844, 2296840, 2496536, 2502688, 2502752,
     +    2551936, 4112768, 2295296, 2294784, 2296832, 2494464, 2502656,
     +    4079616, 4112384, 2293760, 2228224, 2490368, 3014656, 4063232,
     +    2097152, 6291456,14680064,23068672, 6489603, 6489602, 6491148,
     +    6690824, 6690840,13381664,13381728,14205056,14205312, 6489600/
        DATA (ISTA(I),I=561,625) /
     +    6489088, 6690816, 6688768,13381632,14172160,14204928, 6488064,
     +    6422528, 6684672,13107200,14155776, 6291456, 4194304,12582912,
     +   20971520, 9373187, 9373186, 9181196, 9181192, 9187376, 9187360,
     +    9986144,10010752,10011008, 9373184, 9372672, 9181184, 9179136,
     +    9187328, 9977856,10010624,14876672,14811136, 9175040, 8912896,
     +    9961472,14680064,12582912, 8388608,29360128,23266819,23266818,
     +   23268364,23468040,23468056,30158880,30957664,30982272,30982528,
     +   23266816,23266304,23468032,23465984,30158848,30949376,30982144,
     +   23265280,23199744,23461888,29884416,30932992,23068672,20971520,
     +   29360128,16777216/
C
C ISVT is the parameter 'SVT', which turns on the algorithm for
C thinning simple vectors and helps determine how it works.
C
        DATA ISVT / 5 /
C
C ITBM contains the parameters 'TBX' and 'TBA', which are used to mask
C triangle blocking flags.  It has the form 4096*ITBX+ITBA; both ITBX
C and ITBA are 12-bit masks.  If ITBF is the triangle blocking flag for
C some triangle of the triangular mesh, then, in general, the triangle
C will be blocked if and only if the value of AND(XOR(ITBF,ITBX),ITBA)
C is non-zero.  The default values are such as to block only triangles
C having the low-order blocking flag bit set (ITBX = 0, ITBA = 1).
C
        DATA ITBM / 1 /
C
C IWSO is the parameter 'WSO', which says what to do when workspace
C overflow occurs.
C
        DATA IWSO / 1 /
C
C IZFF is the parameter 'ZFF' (output only) which is non-zero if the
C flow field being dealt with is essentially zero.
C
        DATA IZFF / 0 /
C
C JODP, JOMA, and JOTZ are used to hold 0/1 flags extracted from the
C parameter 'NOF'.  Each is non-zero if and only if some extraneous
C portion of a numeric label may be omitted.
C
C LCTM is the length of the character string in CTMA.
C
        DATA LCTM / 1 /
C
C LEA1, LEA2, and LEA3 are the actual lengths of the three portions of
C the character string CHEX.
C
C LEE1, LEE2, and LEE3 are the effective lengths of the three portions
C of the character string CHEX.
C
C LIWB is the parameter 'IWB', which is the length of the integer
C workspace to be made available to the routine VTTDBF (called to
C set the blocking flags for triangles being mapped by TDPACK).
C
        DATA LIWB / 2500 /
C
C LIWK is the length of the user's integer workspace array, as declared
C in the last call to VTMESH.
C
C LIWS is described with IIWS, above.
C
C LNLG is the linear/log flag for the SET call defining the mapping
C from the current viewport to the window and vice-versa.
C
C LOEN, LOPN, and LOTN are the lengths of an edge node, a point node,
C and a triangle node, respectively, as set by the routine VTMESH.
C
C LRWK is the length of the user's real workspace array, as declared in
C the last call to VTMESH.
C
C LRWS is described with IRWS, above.
C
C LSDD is set by VTMESH to indicate the position of the leftmost
C significant digit in ABS(DMAX-DMIN).
C
C LSDL is used for the leftmost-significant-digit argument of VTNUMB,
C which is based on, but not identical with, the leftmost-significant-
C digit parameter 'NLS'.
C
C LSDM is set by VTMESH to indicate the position of the leftmost
C significant digit in MAX(ABS(DMIN),ABS(DMAX)).
C
C LTIL is the length of the informational label, before substitution.
C
        DATA LTIL / 21 /
C
C LTZF is the length of the zero-field label, before substitution.
C
        DATA LTZF / 10 /
C
C MIRO is a flag used to signal that the coordinate transformations in
C effect will cause mirror imaging.
C
        DATA MIRO / 0 /
C
C NCLR is the parameter 'NLV', which is the number of colors currently
C defined for use on streamlines.
C
        DATA NCLR / 0 /
C
C NDGL is used for the number-of-significant-digits argument of VTNUMB,
C which is based on, but not identical with, the number-of-significant-
C digits parameter 'NSD'.
C
C NEDG/LOEN is the number of edges in the triangular mesh (set by
C VTMESH).
C
C NEXL is the parameter 'NEL', which specifies the desired length of
C exponents in numeric labels.  A value which is zero or negative
C indicates that exponents should be written in the shortest possible
C form.  A positive value "n" indicates that a sign should be used (+
C or -) and that the length should be padded, if necessary, to n digits
C with leading zeroes.
C
        DATA NEXL / 0 /
C
C NEXT is the parameter 'NET', which is the numeric exponent type,
C specifying what characters are to be used between the mantissa of a
C numeric label and the exponent.  The value 0 implies the use of an
C E, as in FORTRAN "E format", the value 1 implies the use of function
C codes, as expected by the utility routine PLOTCHAR, to generate
C "x10n", where n is a superscript exponent, and the value 2 implies
C the use of "x10**".
C
        DATA NEXT / 1 /
C
C NEXU is the parameter 'NEU', the numeric exponent use flag.  A value
C less than or equal to zero forces the use of the exponential form in
C all numeric labels.  A positive value n indicates that the form
C without an exponent should be used as long as it requires no more
C than n characters; otherwise the form requiring the fewest characters
C should be used.
C
        DATA NEXU / 5 /
C
C NLBS specifies the current number of entries in the list of labels.
C
        DATA NLBS / 0 /
C
C NLSD is the parameter 'NLS', the leftmost-significant-digit flag.
C The value zero indicates that the leftmost non-zero digit of a
C number represented by a numeric label is to be considered its first
C significant digit.  A non-zero value indicates that the digit in the
C same digit position as the leftmost non-zero digit of the largest
C number (in absolute value) in the field is to be considered the
C leftmost significant digit.  This tends to make the numeric labels
C more consistent with one another.  Consider the following example,
C using three significant digits:
C
C    'NLS'=0:  .500  1.00  1.50  ...  9.50  10.5  ...
C    'NLS'=1:  .5    1.0   1.5   ...  9.5   10.5  ...
C
        DATA NLSD / 1 /
C
C NLZF is the parameter 'NLZ', which may be set non-zero to force a
C zero preceding the decimal point in no-exponent representations of
C numbers.
C
        DATA NLZF / 0 /
C
C NOMF is the parameter 'NOF', which specifies the numeric omission
C flags, which say what parts of a numeric label may be omitted.  The
C value 0 says that no part may be omitted.  Adding a 4 indicates that
C a leading "1" or "1." which is unnecessary (as in "1x10**13") may be
C omitted, adding a 2 indicates that a trailing decimal point (as in
C "13.") may be omitted, and adding a 1 indicates that trailing zeroes
C (as in "46.200") may be omitted.
C
        DATA NOMF / 6 /
C
C NPNT/LOPN is the number of points in the triangular mesh (set by
C VTMESH).
C
C NR04 is the current number of words of real work space devoted to the
C list of labels which are not line labels (the informational label and
C high/low labels).
C
C NSDL is the parameter 'NSD', which specifies the maximum number of
C significant digits to be used in numeric labels representing contour
C field values.  A negative value "-n" indicates that n significant
C digits should be used.  A positive value "n" indicates that m+n digits
C should be used, where m is the number of digits that are the same for
C all values in the field.  (For example, if the minimum value is 1163.6
C and the maximum value is 1165.9, then the value of m is 3.)
C
        DATA NSDL / 4 /
C
C NSDR is the number of significant digits in a real number, which is
C computed as required by VASPACKT itself.
C
C NTRI/LOTN is the number of triangles in the triangular mesh (set by
C VTMESH).
C
C OORV is the parameter 'ORV', an out-of-range value to be returned by
C VTMPXY for both coordinates of a point which is invisible.
C
        DATA OORV / 0. /
C
C (PCPX,PCPY,PCPZ) is a "projection center point" for the mesh, used in
C the process of projecting each velocity vector into the plane of its
C associated triangle.  The three coordinates are the parameters 'PCX',
C 'PCY', and 'PCZ'.
C
        DATA PCPX,PCPY,PCPZ / 0.,0.,0. /
C
C PITH is the parameter 'PIT', the "point interpolation threshold".  In
C routines that map polylines using VTMPXY, this value is used to check
C whether two points have mapped so far apart that some interpolated
C points should be inserted.  A value less than or equal to zero (like
C the default) says that no such checks are to be performed.  A value
C greater than zero represents a fraction of the height or width of the
C window in the user coordinate system.
C
        DATA PITH / 0. /
C
C SCFS is the parameter 'SFS', the scale factor selector.
C
        DATA SCFS / 1. /
C
C SCFU is the parameter 'SFU', the scale factor in use.
C
        DATA SCFU / 1. /
C
C SLLN is the parameter 'SLL', the maximum length of any streamline,
C while SLLR is a "realized" value of SLLN, computed as needed.
C
        DATA SLLN / 8. /
C
C SLPS is the parameter 'SLP', the desired distance between points used
C to draw the streamlines, while SLPR is a "realized" value of SLPS,
C computed as needed.
C
        DATA SLPS / .001 /
C
C SLSP is the parameter 'SLS', the desired spacing of the streamlines,
C while SLSR is a "realized" value of SLSP, computed as needed.
C
        DATA SLSP / .072 /
C
C SVSP is the parameter 'SVS', which is the desired spacing of simple
C vectors.  Its value is used by the algorithm that attempts to cull
C some of the simple vectors.  SVSR is a "realized" value of this
C parameter, computed from it as needed.
C
        DATA SVSP / 0. /
C
C TTLL is the parameter 'TTL', which is the length of each termination
C test line, expressed in the same coordinate system used for the
C triangular mesh, while TTLR is a "realized" value of TTLL, computed
C as required.
C
        DATA TTLL / .018 /
C
C TTSP is the parameter 'TTS', which says how far apart termination
C tests are to be spaced along streamlines, expressed in the same
C coordinate system used for the triangular mesh, while TTSR is a
C "realized" value of TTSP, computed as required.
C
        DATA TTSP / .036 /
C
C TVAL is the parameter array 'TVL', which is an array of threshold
C values for use in determining what color indices from 'CLR' are to
C be used to color streamlines.
C
        DATA TVAL / <$MCLR$+2>*0. /
C
C TXIL is the parameter 'ILT', the text of the informational label.
C
        DATA TXIL / 'SCALE FACTOR IS $SFU$' /
C
C TXZF is the parameter 'ZFT', the text of the zero-field label.
C
        DATA TXZF / 'ZERO FIELD' /
C
C UVPL, UVPR, UVPB, and UVPT are the parameters 'VPL', 'VPR', 'VPB',
C and 'VPT', specifying the edges of an area in which the viewport is
C to lie.  Each is expressed as a fraction of the distance from left to
C right, or from bottom to top, in the plotter frame.
C
        DATA UVPL,UVPR,UVPB,UVPT / .05,.95,.05,.95 /
C
C UVPS is the parameter 'VPS', specifying the desired shape of the
C viewport.
C
        DATA UVPS / .25 /
C
C UWDL, UWDR, UWDB, and UWDT are the parameters 'WDL', 'WDR', 'WDB',
C and 'WDT', specifying the user-coordinate-system values at the left,
C right, bottom, and top edges of the window.  These are used when
C VASPACKT is asked to do the call to SET; they become arguments 5
C through 8 in the call.
C
        DATA UWDL,UWDR,UWDB,UWDT / 0.,0.,0.,0. /
C
C VFRA is the parameter 'VFR', which is the minimum length of a simple
C vector or a curly vector as a fraction of 'VRL'.
C
        DATA VFRA / 0. /
C
C VRLN is the parameter 'VRL', which is the "vector reference length",
C given in the native coordinate system of the triangular mesh, which
C is the length to be used for a curly vector representing magnitude
C 'VRM'.  VRLR is a "vector reference length, realized", which is
C computed as needed, as implied by the value of VRLN.
C
        DATA VRLN / 0. /
C
C VRMG is the parameter 'VRM' - the "vector reference magnitude".  A
C simple vector or curly vector of this magnitude will be shown with
C length 'VRL'.  The value zero specifies the use of the actual maximum
C magnitude in the data field.  VRMR is a "vector reference magnitude,
C realized", which is computed as needed, as implied by the value of
C VRMG.
C
        DATA VRMG / 0. /
C
C VVMM is the parameter 'VVM', which is the velocity vector magnitude
C minimum, below which the velocity is considered to be zero.
C
        DATA VVMM / 0. /
C
C WCIL is the parameter 'ILS', which specifies the width of a character
C in the informational label, as a fraction of the viewport width.
C
        DATA WCIL / .012 /
C
C WCZF is the parameter 'ZFS', which specifies the width of a character
C in the zero-field label, as a fraction of the viewport width.
C
        DATA WCZF / .012 /
C
C WLIL is the parameter 'ILL', a line-width specifier for the box
C around an informational label.
C
        DATA WLIL / 0. /
C
C WLZF is the parameter 'ZFL', a line-width specifier for the box
C around a zero-field label.
C
        DATA WLZF / 0. /
C
C WWIL is the parameter 'ILW', which specifies the width of the white
C space around the informational label, as a fraction of the viewport
C width.
C
        DATA WWIL / .005 /
C
C WWZF is the parameter 'ZFW', which specifies the width of the white
C space around the zero-field label, as a fraction of the viewport
C width.
C
        DATA WWZF / .005 /
C
C XLBC is the parameter 'LBX', which may be retrieved in any of the
C change routines and specifies the X position of the label's center,
C in the current user coordinate system.
C
        DATA XLBC / 0. /
C
C XMAX and XMIN are the parameters 'XMX' and 'XMN', the maximum and
C minimum values among the user's X coordinate data.
C
        DATA XMAX,XMIN / 0.,0. /
C
C XVPL and XVPR specify the positions of the current viewport's left
C and right edges.  Both values are between 0. and 1.
C
C XWDL and XWDR are the values at the left and right edges of the
C current window in the user coordinate system.
C
C YLBC is the parameter 'LBY', which may be retrieved in any of the
C change routines and specifies the Y position of the label's center,
C in the current user coordinate system.
C
        DATA YLBC / 0. /
C
C YMAX and YMIN are the parameters 'YMX' and 'YMN', the maximum and
C minimum values among the user's Y coordinate data.
C
        DATA YMAX,YMIN / 0.,0. /
C
C YVPB and YVPT specify the positions of the current viewport's bottom
C and top edges.  Both values are between 0. and 1.
C
C YWDB and YWDT are the values at the bottom and top edges of the
C current window in the user coordinate system.
C
C ZMAX and ZMIN are the parameters 'ZMX' and 'ZMN', the maximum and
C minimum values among the user's Z coordinate data.
C
        DATA ZMAX,ZMIN / 0.,0. /
C
      END


I***********************************************************************
I  V A S P A C K T   -   U S E R - L E V E L   S U B R O U T I N E S
I***********************************************************************


      SUBROUTINE VTBACK (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTBACK - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C If initialization has not been done, log an error and quit.
C
        IF (INIT.EQ.0)
          CALL SETER ('VTBACK - INITIALIZATION CALL NOT DONE',2,1)
          RETURN
        END IF
C
C Do the proper SET call.
C
        CALL SET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
        IF (ICFELL('VTBACK',3).NE.0) RETURN
C
C Do a simple call to PERIM.
C
        CALL PERIM (1,1,1,1)
        IF (ICFELL('VTBACK',4).NE.0) RETURN
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTDRPL (XCS,YCS,NCS,IAI,IAG,NAI)
C
        DIMENSION XCS(*),YCS(*),IAI(*),IAG(*)
C
C This version of VTDRPL draws the polyline defined by the points
C ((XCS(I),YCS(I)),I=1,NCS) if and only if none of the area identifiers
C for the area containing the polyline are negative.  It calls CURVE
C to do the drawing.
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Turn on drawing.
C
        IDR=1
C
C If any area identifier is negative, turn off drawing.
C
        DO 101 I=1,NAI
          IF (IAI(I).LT.0) IDR=0
  101   CONTINUE
C
C If drawing is turned on, draw the polyline.
C
        IF (IDR.NE.0)
          CALL CURVE  (XCS,YCS,NCS)
          IF (ICFELL('VTDRPL',1).NE.0) RETURN
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTGETC (WHCH,CVAL)
C
        CHARACTER*(*) WHCH,CVAL
C
C This subroutine is called to retrieve the character value of a
C specified parameter.
C
C WHCH is the name of the parameter whose value is to be retrieved.
C
C CVAL is a character variable in which the desired value is to be
C returned by VTGETC.
C
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTGETC - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Check for a parameter name that is too short.
C
        IF (LEN(WHCH).LT.3)
          CTMB(1:36)='VTGETC - PARAMETER NAME TOO SHORT - '
          CTMB(37:36+LEN(WHCH))=WHCH
          CALL SETER (CTMB(1:36+LEN(WHCH)),2,1)
          RETURN
        END IF
C
C Get the appropriate parameter value.
C
        IF      (WHCH(1:3).EQ.'CTM'.OR.WHCH(1:3).EQ.'ctm')
          CVAL=CTMA(1:LCTM)
        ELSE IF (WHCH(1:3).EQ.'DVA'.OR.WHCH(1:3).EQ.'dva')
          CALL VTSBST ('$DVA$',CVAL,LCVL)
        ELSE IF (WHCH(1:3).EQ.'DVU'.OR.WHCH(1:3).EQ.'dvu')
          CALL VTSBST ('$DVAU$',CVAL,LCVL)
        ELSE IF (WHCH(1:3).EQ.'ILT'.OR.WHCH(1:3).EQ.'ilt')
          CVAL=TXIL(1:LTIL)
        ELSE IF (WHCH(1:3).EQ.'ZFT'.OR.WHCH(1:3).EQ.'zft')
          CVAL=TXZF(1:LTZF)
        ELSE
          CTMB(1:36)='VTGETC - PARAMETER NAME NOT KNOWN - '
          CTMB(37:39)=WHCH(1:3)
          CALL SETER (CTMB(1:39),3,1)
          RETURN
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTGETI (WHCH,IVAL)
C
        CHARACTER*(*) WHCH
C
C This subroutine is called to retrieve the integer value of a specified
C parameter.
C
C WHCH is the name of the parameter whose value is to be retrieved.
C
C IVAL is an integer variable in which the desired value is to be
C returned by VTGETI.
C
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTGETI - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Use VTGETR to retrieve the real value, fix it, and return it to the
C user.
C
        CALL VTGETR (WHCH,RVAL)
        IF (ICFELL('VTGETI',2).NE.0) RETURN
        IVAL=INT(RVAL)
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTGETR (WHCH,RVAL)
C
        CHARACTER*(*) WHCH
C
C This subroutine is called to retrieve the real value of a specified
C parameter.
C
C WHCH is the name of the parameter whose value is to be retrieved.
C
C RVAL is a real variable in which the desired value is to be returned
C by VTGETR.
C
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTGETR - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Check for a parameter name that is too short.
C
        IF (LEN(WHCH).LT.3)
          CTMB(1:36)='VTGETR - PARAMETER NAME TOO SHORT - '
          CTMB(37:36+LEN(WHCH))=WHCH
          CALL SETER (CTMB(1:36+LEN(WHCH)),2,1)
          RETURN
        END IF
C
C Check for incorrect use of the index parameter.
C
        IF (WHCH(1:3).EQ.'CLR'.OR.WHCH(1:3).EQ.'clr'.OR.
     +      WHCH(1:3).EQ.'TVL'.OR.WHCH(1:3).eq.'tvl')
          IF (IPAI.LT.1.OR.IPAI.GT.NCLR)
            INVOKE (PAI-INCORRECT,NR)
          END IF
        END IF
C
        BLOCK (PAI-INCORRECT,NR)
          CTMB(1:36)='VTGETR - GETTING XXX - PAI INCORRECT'
          CTMB(18:20)=WHCH(1:3)
          CALL SETER (CTMB(1:36),3,1)
          RETURN
        END BLOCK
C
C Get the appropriate parameter value.
C
        IF      (WHCH(1:3).EQ.'AEL'.OR.WHCH(1:3).EQ.'ael')
          RVAL=AVEL
        ELSE IF (WHCH(1:3).EQ.'AHA'.OR.WHCH(1:3).EQ.'aha')
          RVAL=AHAW
        ELSE IF (WHCH(1:3).EQ.'AHL'.OR.WHCH(1:3).EQ.'ahl')
          RVAL=AHLN
        ELSE IF (WHCH(1:3).EQ.'AHS'.OR.WHCH(1:3).EQ.'ahs')
          RVAL=AHSP
        ELSE IF (WHCH(1:3).EQ.'AM1'.OR.WHCH(1:3).EQ.'am1')
          RVAL=ANM1
        ELSE IF (WHCH(1:3).EQ.'AM2'.OR.WHCH(1:3).EQ.'am2')
          RVAL=ANM2
        ELSE IF (WHCH(1:3).EQ.'CLR'.OR.WHCH(1:3).EQ.'clr')
          RVAL=REAL(ICLR(IPAI))
        ELSE IF (WHCH(1:3).EQ.'CTV'.OR.WHCH(1:3).EQ.'ctv')
          RVAL=REAL(ICTV)
        ELSE IF (WHCH(1:3).EQ.'CWM'.OR.WHCH(1:3).EQ.'cwm')
          RVAL=CHWM
        ELSE IF (WHCH(1:3).EQ.'DBG'.OR.WHCH(1:3).EQ.'dbg')
          RVAL=REAL(IDBG)
        ELSE IF (WHCH(1:3).EQ.'DMN'.OR.WHCH(1:3).EQ.'dmn')
          RVAL=DMIN
        ELSE IF (WHCH(1:3).EQ.'DMX'.OR.WHCH(1:3).EQ.'dmx')
          RVAL=DMAX
        ELSE IF (WHCH(1:3).EQ.'DVA'.OR.WHCH(1:3).EQ.'dva')
          RVAL=DVAL
        ELSE IF (WHCH(1:3).EQ.'EOM'.OR.WHCH(1:3).EQ.'eom')
          RVAL=EMAX
        ELSE IF (WHCH(1:3).EQ.'ILA'.OR.WHCH(1:3).EQ.'ila')
          RVAL=ANIL
        ELSE IF (WHCH(1:3).EQ.'ILB'.OR.WHCH(1:3).EQ.'ilb')
          RVAL=REAL(IBIL)
        ELSE IF (WHCH(1:3).EQ.'ILC'.OR.WHCH(1:3).EQ.'ilc')
          RVAL=REAL(ICIL)
        ELSE IF (WHCH(1:3).EQ.'ILL'.OR.WHCH(1:3).EQ.'ill')
          RVAL=WLIL
        ELSE IF (WHCH(1:3).EQ.'ILP'.OR.WHCH(1:3).EQ.'ilp')
          RVAL=REAL(IPIL)
        ELSE IF (WHCH(1:3).EQ.'ILS'.OR.WHCH(1:3).EQ.'ils')
          RVAL=WCIL
        ELSE IF (WHCH(1:3).EQ.'ILW'.OR.WHCH(1:3).EQ.'ilw')
          RVAL=WWIL
        ELSE IF (WHCH(1:3).EQ.'ILX'.OR.WHCH(1:3).EQ.'ilx')
          RVAL=CXIL
        ELSE IF (WHCH(1:3).EQ.'ILY'.OR.WHCH(1:3).EQ.'ily')
          RVAL=CYIL
        ELSE IF (WHCH(1:3).EQ.'ISP'.OR.WHCH(1:3).EQ.'isp')
          RVAL=REAL(IISP)
        ELSE IF (WHCH(1:3).EQ.'IWB'.OR.WHCH(1:3).EQ.'iwb')
          RVAL=REAL(LIWB)
        ELSE IF (WHCH(1:3).EQ.'IWU'.OR.WHCH(1:3).EQ.'iwu')
          RVAL=REAL(IIWU)
        ELSE IF (WHCH(1:3).EQ.'LBC'.OR.WHCH(1:3).EQ.'lbc')
          RVAL=REAL(ILBC)
        ELSE IF (WHCH(1:3).EQ.'LBX'.OR.WHCH(1:3).EQ.'lbx')
          RVAL=XLBC
        ELSE IF (WHCH(1:3).EQ.'LBY'.OR.WHCH(1:3).EQ.'lby')
          RVAL=YLBC
        ELSE IF (WHCH(1:3).EQ.'MAP'.OR.WHCH(1:3).EQ.'map')
          RVAL=REAL(IMPF)
        ELSE
          GO TO 101
        END IF
C
C Done.
C
        RETURN
C
  101   IF      (WHCH(1:3).EQ.'NEL'.OR.WHCH(1:3).EQ.'nel')
          RVAL=REAL(NEXL)
        ELSE IF (WHCH(1:3).EQ.'NET'.OR.WHCH(1:3).EQ.'net')
          RVAL=REAL(NEXT)
        ELSE IF (WHCH(1:3).EQ.'NEU'.OR.WHCH(1:3).EQ.'neu')
          RVAL=REAL(NEXU)
        ELSE IF (WHCH(1:3).EQ.'NLS'.OR.WHCH(1:3).EQ.'nls')
          RVAL=REAL(NLSD)
        ELSE IF (WHCH(1:3).EQ.'NLV'.OR.WHCH(1:3).EQ.'nlv')
          RVAL=REAL(NCLR)
        ELSE IF (WHCH(1:3).EQ.'NLZ'.OR.WHCH(1:3).EQ.'nlz')
          RVAL=REAL(NLZF)
        ELSE IF (WHCH(1:3).EQ.'NOF'.OR.WHCH(1:3).EQ.'nof')
          RVAL=REAL(NOMF)
        ELSE IF (WHCH(1:3).EQ.'NSD'.OR.WHCH(1:3).EQ.'nsd')
          RVAL=REAL(NSDL)
        ELSE IF (WHCH(1:3).EQ.'ORV'.OR.WHCH(1:3).EQ.'orv')
          RVAL=OORV
        ELSE IF (WHCH(1:3).EQ.'PAI'.OR.WHCH(1:3).EQ.'pai')
          RVAL=REAL(IPAI)
        ELSE IF (WHCH(1:3).EQ.'PIS'.OR.WHCH(1:3).EQ.'pis')
          RVAL=REAL(IPIS)
        ELSE IF (WHCH(1:3).EQ.'PIT'.OR.WHCH(1:3).EQ.'pit')
          RVAL=PITH
        ELSE IF (WHCH(1:3).EQ.'PCX'.OR.WHCH(1:3).EQ.'pcx')
          RVAL=PCPX
        ELSE IF (WHCH(1:3).EQ.'PCY'.OR.WHCH(1:3).EQ.'pcy')
          RVAL=PCPY
        ELSE IF (WHCH(1:3).EQ.'PCZ'.OR.WHCH(1:3).EQ.'pcz')
          RVAL=PCPZ
        ELSE IF (WHCH(1:3).EQ.'RNG'.OR.WHCH(1:3).EQ.'rng')
          RVAL=REAL(IRNG)
        ELSE IF (WHCH(1:3).EQ.'RWU'.OR.WHCH(1:3).EQ.'rwu')
          RVAL=REAL(IRWU)
        ELSE IF (WHCH(1:3).EQ.'SET'.OR.WHCH(1:3).EQ.'set')
          RVAL=REAL(ISET)
        ELSE IF (WHCH(1:3).EQ.'SFS'.OR.WHCH(1:3).EQ.'sfs')
          RVAL=SCFS
        ELSE IF (WHCH(1:3).EQ.'SFU'.OR.WHCH(1:3).EQ.'sfu')
          RVAL=SCFU
        ELSE IF (WHCH(1:3).EQ.'SGC'.OR.WHCH(1:3).EQ.'sgc')
          RVAL=REAL(ICSG)
        ELSE IF (WHCH(1:3).EQ.'SLL'.OR.WHCH(1:3).EQ.'sll')
          RVAL=SLLN
        ELSE IF (WHCH(1:3).EQ.'SLP'.OR.WHCH(1:3).EQ.'slp')
          RVAL=SLPS
        ELSE IF (WHCH(1:3).EQ.'SLS'.OR.WHCH(1:3).EQ.'sls')
          RVAL=SLSP
        ELSE IF (WHCH(1:3).EQ.'STC'.OR.WHCH(1:3).EQ.'stc')
          RVAL=REAL(ICST)
        ELSE IF (WHCH(1:3).EQ.'SVS'.OR.WHCH(1:3).EQ.'svs')
          RVAL=SVSP
        ELSE IF (WHCH(1:3).EQ.'SVT'.OR.WHCH(1:3).EQ.'svt')
          RVAL=REAL(ISVT)
        ELSE IF (WHCH(1:3).EQ.'TBA'.OR.WHCH(1:3).EQ.'tba')
          RVAL=REAL(IAND(ITBM,4095))
        ELSE IF (WHCH(1:3).EQ.'TBX'.OR.WHCH(1:3).EQ.'tbx')
          RVAL=REAL(IAND(ISHIFT(ITBM,-12),4095))
        ELSE IF (WHCH(1:3).EQ.'TTC'.OR.WHCH(1:3).EQ.'ttc')
          RVAL=REAL(ICTT)
        ELSE IF (WHCH(1:3).EQ.'TTL'.OR.WHCH(1:3).EQ.'ttl')
          RVAL=TTLL
        ELSE IF (WHCH(1:3).EQ.'TTS'.OR.WHCH(1:3).EQ.'tts')
          RVAL=TTSP
        ELSE IF (WHCH(1:3).EQ.'TVL'.OR.WHCH(1:3).EQ.'tvl')
          RVAL=TVAL(IPAI)
        ELSE IF (WHCH(1:3).EQ.'VFR'.OR.WHCH(1:3).EQ.'vfr')
          RVAL=VFRA
        ELSE IF (WHCH(1:3).EQ.'VPB'.OR.WHCH(1:3).EQ.'vpb')
          RVAL=UVPB
        ELSE IF (WHCH(1:3).EQ.'VPL'.OR.WHCH(1:3).EQ.'vpl')
          RVAL=UVPL
        ELSE IF (WHCH(1:3).EQ.'VPR'.OR.WHCH(1:3).EQ.'vpr')
          RVAL=UVPR
        ELSE IF (WHCH(1:3).EQ.'VPS'.OR.WHCH(1:3).EQ.'vps')
          RVAL=UVPS
        ELSE IF (WHCH(1:3).EQ.'VPT'.OR.WHCH(1:3).EQ.'vpt')
          RVAL=UVPT
        ELSE IF (WHCH(1:3).EQ.'VRL'.OR.WHCH(1:3).EQ.'vrl')
          RVAL=VRLN
        ELSE IF (WHCH(1:3).EQ.'VRM'.OR.WHCH(1:3).EQ.'vrm')
          RVAL=VRMG
        ELSE IF (WHCH(1:3).EQ.'VVM'.OR.WHCH(1:3).EQ.'vvm')
          RVAL=VVMM
        ELSE IF (WHCH(1:3).EQ.'WDB'.OR.WHCH(1:3).EQ.'wdb')
          RVAL=UWDB
        ELSE IF (WHCH(1:3).EQ.'WDL'.OR.WHCH(1:3).EQ.'wdl')
          RVAL=UWDL
        ELSE IF (WHCH(1:3).EQ.'WDR'.OR.WHCH(1:3).EQ.'wdr')
          RVAL=UWDR
        ELSE IF (WHCH(1:3).EQ.'WDT'.OR.WHCH(1:3).EQ.'wdt')
          RVAL=UWDT
        ELSE IF (WHCH(1:3).EQ.'WSO'.OR.WHCH(1:3).EQ.'wso')
          RVAL=REAL(IWSO)
        ELSE IF (WHCH(1:3).EQ.'XMN'.OR.WHCH(1:3).EQ.'xmn')
          RVAL=XMIN
        ELSE IF (WHCH(1:3).EQ.'XMX'.OR.WHCH(1:3).EQ.'xmx')
          RVAL=XMAX
        ELSE IF (WHCH(1:3).EQ.'YMN'.OR.WHCH(1:3).EQ.'ymn')
          RVAL=YMIN
        ELSE IF (WHCH(1:3).EQ.'YMX'.OR.WHCH(1:3).EQ.'ymx')
          RVAL=YMAX
        ELSE IF (WHCH(1:3).EQ.'ZFA'.OR.WHCH(1:3).EQ.'zfa')
          RVAL=ANZF
        ELSE IF (WHCH(1:3).EQ.'ZFB'.OR.WHCH(1:3).EQ.'zfb')
          RVAL=REAL(IBZF)
        ELSE IF (WHCH(1:3).EQ.'ZFC'.OR.WHCH(1:3).EQ.'zfc')
          RVAL=REAL(ICZF)
        ELSE IF (WHCH(1:3).EQ.'ZFF'.OR.WHCH(1:3).EQ.'zff')
          RVAL=IZFF
        ELSE IF (WHCH(1:3).EQ.'ZFL'.OR.WHCH(1:3).EQ.'zfl')
          RVAL=WLZF
        ELSE IF (WHCH(1:3).EQ.'ZFP'.OR.WHCH(1:3).EQ.'zfp')
          RVAL=REAL(IPZF)
        ELSE IF (WHCH(1:3).EQ.'ZFS'.OR.WHCH(1:3).EQ.'zfs')
          RVAL=WCZF
        ELSE IF (WHCH(1:3).EQ.'ZFW'.OR.WHCH(1:3).EQ.'zfw')
          RVAL=WWZF
        ELSE IF (WHCH(1:3).EQ.'ZFX'.OR.WHCH(1:3).EQ.'zfx')
          RVAL=CXZF
        ELSE IF (WHCH(1:3).EQ.'ZFY'.OR.WHCH(1:3).EQ.'zfy')
          RVAL=CYZF
        ELSE IF (WHCH(1:3).EQ.'ZMN'.OR.WHCH(1:3).EQ.'zmn')
          RVAL=ZMIN
        ELSE IF (WHCH(1:3).EQ.'ZMX'.OR.WHCH(1:3).EQ.'zmx')
          RVAL=ZMAX
        ELSE
          CTMB(1:36)='VTGETR - PARAMETER NAME NOT KNOWN - '
          CTMB(37:39)=WHCH(1:3)
          CALL SETER (CTMB(1:39),4,1)
          RETURN
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTMESH (RPNT,KPNT,KOPN,
     +                   IEDG,KEDG,KOEN,
     +                   ITRI,KTRI,KOTN,
     +                   RWRK,KRWK,
     +                   IWRK,KIWK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C The routine VTMESH is called to start the process of drawing a
C streamline plot, given data on a triangular mesh.
C
C RPNT is a one-dimensional array containing information about the
C points of the triangular mesh.
C
C KPNT is the index of the last element of RPNT containing data.
C
C KOPN is the length of a point node in RPNT.
C
C IEDG is a one-dimensional array containing information about the
C edges of the triangular mesh.
C
C KEDG is the index of the last element of IEDG.
C
C KOEN is the length of an edge node in IEDG.
C
C ITRI is a one-dimensional array containing information about the
C triangles of the triangular mesh.
C
C KTRI is the index of the last element of ITRI.
C
C KOTN is the length of a triangle node in ITRI.
C
C RWRK is a singly-subscripted real work array of length KRWK.
C
C KRWK is the dimension of RWRK.
C
C IWRK is a singly-subscripted integer work array of length KIWK.
C
C KIWK is the dimension of IWRK.
C
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Define a variable which will hold a single character.
C
        CHARACTER*1 SCHR
C
C IXOR(IONE,ITWO) is the exclusive OR of the 12-bit masks IONE and ITWO.
C
        IXOR(IONE,ITWO)=IAND(IOR(IONE,ITWO),4095-IAND(IONE,ITWO))
C
C ITBF(IARG) is non-zero if and only if a triangle with blocking-flag
C element IARG is blocked by the user.
C
        ITBF(IARG)=IAND(IAND(IXOR(IARG,ITBX),ITBA),1)
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTMESH - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C If no VASPACKT routine has been called before, initialize required
C constants.
C
        IF (INIT.EQ.0)
          CALL VTINRC
          IF (ICFELL('VTMESH',2).NE.0) RETURN
        END IF
C
C Extract the values of ITBX and ITBA from ITBM.
C
        ITBX=IAND(ISHIFT(ITBM,-12),4095)
        ITBA=IAND(       ITBM     ,4095)
C
C Transfer the array dimensions and node lengths to variables in COMMON.
C
        NPNT=KPNT
        LOPN=KOPN
C
        NEDG=KEDG
        LOEN=KOEN
C
        NTRI=KTRI
        LOTN=KOTN
C
        LRWK=KRWK
C
        LIWK=KIWK
C
C Clear all the workspace block lengths.
C
        DO (I=1,$NBRW$)
          LRWS(I)=0
        END DO
C
        DO (I=1,$NBIW$)
          LIWS(I)=0
        END DO
C
C Zero the internal parameters which keep track of workspace usage.
C
        IIWU=0
        IRWU=0
C
C Compute the ranges of the X, Y, and Z coordinates, the flow field
C values, and the values of the 2D coordinates in the projection plane.
C
        ITM1=0
C
        XMIN=0.
        XMAX=0.
        YMIN=0.
        YMAX=0.
        ZMIN=0.
        ZMAX=0.
        DMIN=0.
        DMAX=0.
C
        ITM2=0
C
        UMIN=0.
        UMAX=0.
        VMIN=0.
        VMAX=0.
C
        DO (I=0,NTRI-LOTN,LOTN)
          IF (ITBF(ITRI(I+4)).EQ.0)
            DO (J=1,3)
              DO (K=1,2)
                L=IEDG(ITRI(I+J)+K)
                IF (ITM1.EQ.0)
                  ITM1=1
                  XMIN=RPNT(L+1)
                  XMAX=RPNT(L+1)
                  YMIN=RPNT(L+2)
                  YMAX=RPNT(L+2)
                  ZMIN=RPNT(L+3)
                  ZMAX=RPNT(L+3)
                  IF (ICTV.GE.4.AND.ICTV.LE.LOPN)
                    TMIN=RPNT(L+ICTV)
                    TMAX=RPNT(L+ICTV)
                  END IF
                  DMIN=SQRT(RPNT(L+4)**2+RPNT(L+5)**2+RPNT(L+6)**2)
                  DMAX=SQRT(RPNT(L+4)**2+RPNT(L+5)**2+RPNT(L+6)**2)
                ELSE
                  XMIN=MIN(XMIN,RPNT(L+1))
                  XMAX=MAX(XMAX,RPNT(L+1))
                  YMIN=MIN(YMIN,RPNT(L+2))
                  YMAX=MAX(YMAX,RPNT(L+2))
                  ZMIN=MIN(ZMIN,RPNT(L+3))
                  ZMAX=MAX(ZMAX,RPNT(L+3))
                  IF (ICTV.GE.4.AND.ICTV.LE.LOPN)
                    TMIN=MIN(TMIN,RPNT(L+ICTV))
                    TMAX=MAX(TMAX,RPNT(L+ICTV))
                  END IF
                  DMIN=MIN(DMIN,
     +                     SQRT(RPNT(L+4)**2+RPNT(L+5)**2+RPNT(L+6)**2))
                  DMAX=MAX(DMAX,
     +                     SQRT(RPNT(L+4)**2+RPNT(L+5)**2+RPNT(L+6)**2))
                END IF
                IF (IMPF.EQ.0)
                  UTMP=RPNT(L+1)
                  VTMP=RPNT(L+2)
                ELSE
                  CALL HLUVTMXYZ (IMPF,RPNT(L+1),RPNT(L+2),RPNT(L+3),
     +                                                     UTMP,VTMP)
                  IF (ICFELL('VTMESH',3).NE.0) RETURN
                  IF (OORV.NE.0..AND.(UTMP.EQ.OORV.OR.VTMP.EQ.OORV))
     +                                                         GO TO 101
                END IF
                IF (ITM2.EQ.0)
                  ITM2=1
                  UMIN=UTMP
                  UMAX=UTMP
                  VMIN=VTMP
                  VMAX=VTMP
                ELSE
                  UMIN=MIN(UMIN,UTMP)
                  UMAX=MAX(UMAX,UTMP)
                  VMIN=MIN(VMIN,VTMP)
                  VMAX=MAX(VMAX,VTMP)
                END IF
  101         END DO
            END DO
          END IF
        END DO
C
        EMAX=MAX(XMAX-XMIN,YMAX-YMIN,ZMAX-ZMIN)
C       
C Initialize coloring of the streamlines.
C
        IF (ICTV.GT.0.AND.NCLR.NE.0)
C
          IF (ICTV.EQ.1)
            TMIN=XMIN
            TMAX=XMAX
          ELSE IF (ICTV.EQ.2)
            TMIN=YMIN
            TMAX=YMAX
          ELSE IF (ICTV.EQ.3)
            TMIN=ZMIN
            TMAX=ZMAX
          ELSE IF (ICTV.GT.LOPN)
            TMIN=DMIN
            TMAX=DMAX
          END IF
C   
          DO (I=1,NCLR-1)
            TVAL(I)=TMIN+REAL(I)*(TMAX-TMIN)/REAL(NCLR)
          END DO
C
          TVAL(NCLR)=TMAX
C 
        END IF
C
C Compute an average edge length over the unblocked portion of the mesh.
C
        ITMP=0
        AVEL=0.
C
        DO (I=0,NEDG-LOEN,LOEN)
          IFLL=0
          IF (IEDG(I+3).GE.0)
            IF (ITBF(ITRI(LOTN*((IEDG(I+3)-1)/LOTN)+4)).EQ.0) IFLL=1
          END IF
          IFLR=0
          IF (IEDG(I+4).GE.0)
            IF (ITBF(ITRI(LOTN*((IEDG(I+4)-1)/LOTN)+4)).EQ.0) IFLR=1
          END IF
          IF (IFLL.NE.0.OR.IFLR.NE.0)
            ITMP=ITMP+1
            AVEL=AVEL+SQRT((RPNT(IEDG(I+1)+1)-RPNT(IEDG(I+2)+1))**2+
     +                     (RPNT(IEDG(I+1)+2)-RPNT(IEDG(I+2)+2))**2+
     +                     (RPNT(IEDG(I+1)+3)-RPNT(IEDG(I+2)+3))**2)
          END IF
        END DO
C
        IF (ITMP.NE.0) AVEL=AVEL/REAL(ITMP)
C
C If the user has done a SET call, retrieve the arguments; if he hasn't
C done a SET call, do it for him.
C
        IF (ISET.EQ.0)
C
          CALL GETSET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
          IF (ICFELL('VTMESH',4).NE.0) RETURN
C
        ELSE
C
          LNLG=1
C
          IF (UWDL.EQ.UWDR)
            XWDL=UMIN
            XWDR=UMAX
          ELSE
            XWDL=UWDL
            XWDR=UWDR
          END IF
C
          IF (UWDB.EQ.UWDT)
            YWDB=VMIN
            YWDT=VMAX
          ELSE
            YWDB=UWDB
            YWDT=UWDT
          END IF
C
          IF (UVPS.LT.0.)
            RWTH=ABS(UVPS)
          ELSE IF (UVPS.EQ.0.)
            RWTH=(UVPR-UVPL)/(UVPT-UVPB)
          ELSE IF (UVPS.LE.1.)
            RWTH=ABS((XWDR-XWDL)/(YWDT-YWDB))
            IF (MIN(RWTH,1./RWTH).LT.UVPS) RWTH=(UVPR-UVPL)/(UVPT-UVPB)
          ELSE
            RWTH=ABS((XWDR-XWDL)/(YWDT-YWDB))
            IF (MAX(RWTH,1./RWTH).GT.UVPS) RWTH=1.
          END IF
C
          IF (RWTH.LT.(UVPR-UVPL)/(UVPT-UVPB))
            XVPL=.5*(UVPL+UVPR)-.5*(UVPT-UVPB)*RWTH
            XVPR=.5*(UVPL+UVPR)+.5*(UVPT-UVPB)*RWTH
            YVPB=UVPB
            YVPT=UVPT
          ELSE
            XVPL=UVPL
            XVPR=UVPR
            YVPB=.5*(UVPB+UVPT)-.5*(UVPR-UVPL)/RWTH
            YVPT=.5*(UVPB+UVPT)+.5*(UVPR-UVPL)/RWTH
          END IF
C
          CALL SET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
          IF (ICFELL('VTMESH',5).NE.0) RETURN
C
        END IF
C
C Set the flag MIRO, which indicates whether or not the transformations
C in effect cause mirror imaging.  To do this, we look for an unblocked
C triangle in the mesh, all of whose vertices are visible under the
C current mapping, and check to see if its vertices, after mapping, are
C still in counterclockwise order (in which case we set MIRO=0) or not
C (in which case we set MIRO=1).  (However, when 'MAP' = 2, saying that
C TDPACK is being called to do the transformation, MIRO is forced to 0;
C in that case, the transformation cannot cause mirror imaging.)
C
        MIRO=0
C
        IF (IMPF.NE.0.AND.IMPF.NE.2)
C
          DO (I=0,NTRI-LOTN,LOTN)
C
C Use only triangles not blocked by the user.
C
            IF (ITBF(ITRI(I+4)).EQ.0)
C
C Find the base index of the point that edges 1 and 2 have in common.
C
              IF (IEDG(ITRI(I+1)+1).EQ.IEDG(ITRI(I+2)+1).OR.
     +            IEDG(ITRI(I+1)+1).EQ.IEDG(ITRI(I+2)+2))
                IPP1=IEDG(ITRI(I+1)+1)
              ELSE
                IPP1=IEDG(ITRI(I+1)+2)
              END IF
C
C Find the base index of the point that edges 2 and 3 have in common.
C
              IF (IEDG(ITRI(I+2)+1).EQ.IEDG(ITRI(I+3)+1).OR.
     +            IEDG(ITRI(I+2)+1).EQ.IEDG(ITRI(I+3)+2))
                IPP2=IEDG(ITRI(I+2)+1)
              ELSE
                IPP2=IEDG(ITRI(I+2)+2)
              END IF
C
C Find the base index of the point that edges 3 and 1 have in common.
C
              IF (IEDG(ITRI(I+3)+1).EQ.IEDG(ITRI(I+1)+1).OR.
     +            IEDG(ITRI(I+3)+1).EQ.IEDG(ITRI(I+1)+2))
                IPP3=IEDG(ITRI(I+3)+1)
              ELSE
                IPP3=IEDG(ITRI(I+3)+2)
              END IF
C
C Project point 1; if it's invisible, skip the triangle.
C
              CALL HLUVTMXYZ (IMPF,
     +                        RPNT(IPP1+1),RPNT(IPP1+2),RPNT(IPP1+3),
     +                                                        XCP1,YCP1)
              IF (ICFELL('VTMESH',6).NE.0) RETURN
              IF ((OORV.NE.0.).AND.(XCP1.EQ.OORV.OR.YCP1.EQ.OORV))
     +                                                         GO TO 102
C
C Project point 2; if it's invisible, skip the triangle.
C
              CALL HLUVTMXYZ (IMPF,
     +                        RPNT(IPP2+1),RPNT(IPP2+2),RPNT(IPP2+3),
     +                                                        XCP2,YCP2)
              IF (ICFELL('VTMESH',7).NE.0) RETURN
              IF ((OORV.NE.0.).AND.(XCP2.EQ.OORV.OR.YCP2.EQ.OORV))
     +                                                         GO TO 102
C
C Project point 3; if it's invisible, skip the triangle.
C
              CALL HLUVTMXYZ (IMPF,
     +                        RPNT(IPP3+1),RPNT(IPP3+2),RPNT(IPP3+3),
     +                                                        XCP3,YCP3)
              IF (ICFELL('VTMESH',8).NE.0) RETURN
              IF ((OORV.NE.0.).AND.(XCP3.EQ.OORV.OR.YCP3.EQ.OORV))
     +                                                         GO TO 102
C
C If two points of the triangle are too close to each other, skip it.
C
              IF (ABS(XCP1-XCP2).LT..0001*ABS(XWDR-XWDL).AND.
     +            ABS(YCP1-YCP2).LT..0001*ABS(YWDT-YWDB)) GO TO 102
              IF (ABS(XCP2-XCP3).LT..0001*ABS(XWDR-XWDL).AND.
     +            ABS(YCP2-YCP3).LT..0001*ABS(YWDT-YWDB)) GO TO 102
              IF (ABS(XCP3-XCP1).LT..0001*ABS(XWDR-XWDL).AND.
     +            ABS(YCP3-YCP1).LT..0001*ABS(YWDT-YWDB)) GO TO 102
C
C If two points of the triangle are too far apart, skip it.
C
              IF (ABS(XCP1-XCP2).GT..5*ABS(XWDR-XWDL).OR.
     +            ABS(YCP1-YCP2).GT..5*ABS(YWDT-YWDB)) GO TO 102
              IF (ABS(XCP2-XCP3).GT..5*ABS(XWDR-XWDL).OR.
     +            ABS(YCP2-YCP3).GT..5*ABS(YWDT-YWDB)) GO TO 102
              IF (ABS(XCP3-XCP1).GT..5*ABS(XWDR-XWDL).OR.
     +            ABS(YCP3-YCP1).GT..5*ABS(YWDT-YWDB)) GO TO 102
C
C Use this triangle to make the decision.  If point 1 is to the right
C of the vector from point 3 to point 2, then the mapping does not
C cause mirror imaging; otherwise, it does.
C
              IF (ABS(XCP2-XCP3).LT.ABS(YCP2-YCP3))
                IF (XCP1.LT.XCP3+((XCP2-XCP3)/(YCP2-YCP3))*(YCP1-YCP3))
                  IF (YCP3.LT.YCP2) MIRO=1
                  GO TO 103
                ELSE
                  IF (YCP3.GT.YCP2) MIRO=1
                  GO TO 103
                END IF
              ELSE
                IF (YCP1.LT.YCP3+((YCP2-YCP3)/(XCP2-XCP3))*(XCP1-XCP3))
                  IF (XCP3.GT.XCP2) MIRO=1
                  GO TO 103
                ELSE
                  IF (XCP3.LT.XCP2) MIRO=1
                  GO TO 103
                END IF
              END IF
C
            END IF
C
C End of loop through triangles.
C
  102     END DO
C
        END IF
C
C Zero the count of label positions selected, the count of words used
C in real workspace number 4 (for informational and high/low label
C data), and the indices which indicate where the different kinds of
C labels are stored.
C
  103   NLBS=0
        NR04=0
        INIL=0
C
C Initialize the value of the scale factor used.
C
        IF (SCFS.LE.0.)
          SCFU=1.
        ELSE
          SCFU=SCFS
        END IF
C
C If the flow field is (effectively) zero, set a flag to indicate that
C and force the scale factor back to 1.  Otherwise, clear the flag.
C
C Code here needs work ... ???
C
        IF (DMAX-DMIN.LE.10.*EPSI*ABS((DMIN+DMAX)/2.))
          IZFF=1
          SCFU=1.
        ELSE
          IZFF=0
        END IF
C
C Find the positions of the leftmost significant digits in the largest
C absolute value in the field and in the difference between the minimum
C and the maximum values in the field.  If the field is effectively
C zero, the latter value is set equal to the former.
C
        CALL VTNUMB (MAX(ABS(DMIN/SCFU),ABS(DMAX/SCFU)),1,-10000,-1,-1,
     +                      ' ',' ',' ',0,0,0,0,0,0,SCHR,NCHS,NDGS,IEVA)
        LSDM=IEVA-1
C
        IF (IZFF.EQ.0)
          CALL VTNUMB ((DMAX-DMIN)/SCFU,1,-10000,-1,-1,
     +                      ' ',' ',' ',0,0,0,0,0,0,SCHR,NCHS,NDGS,IEVA)
          LSDD=IEVA-1
        ELSE
          LSDD=LSDM
        END IF
C
C Retrieve the current PLOTCHAR function code signal character.
C
        CALL PCGETC ('FC',SCHR)
        IF (ICFELL('VTMESH',9).NE.0) RETURN
C
C Set up the parameters used in generating numeric labels.  Set the
C number of significant digits to be used ...
C
        IF (NSDL.LT.0)
          NDGL=ABS(NSDL)
        ELSE
          NDGL=MAX(0,LSDM-LSDD)+NSDL
        END IF
C
C ... the leftmost-significant digit flag ...
C
        IF (NLSD.EQ.0)
          LSDL=-10000
        ELSE
          LSDL=LSDM
        END IF
C
C ... the numeric exponent type ...
C
        IF (NEXT.LE.0)
          CHEX=' E '
          LEA1=1
          LEA2=1
          LEA3=1
          LEE1=0
          LEE2=1
          LEE3=0
        ELSE IF (NEXT.EQ.1)
          CHEX=':L1:410:S::N:'
          IF (SCHR.NE.':')
            CHEX( 1: 1)=SCHR
            CHEX( 4: 4)=SCHR
            CHEX( 8: 8)=SCHR
            CHEX(10:10)=SCHR
            CHEX(11:11)=SCHR
            CHEX(13:13)=SCHR
          END IF
          LEA1=5
          LEA2=5
          LEA3=3
          LEE1=1
          LEE2=2
          LEE3=0
        ELSE
          CHEX='x10** '
          LEA1=1
          LEA2=4
          LEA3=1
          LEE1=1
          LEE2=4
          LEE3=0
        END IF
C
C ... and the omission flags.
C
        JOMA=MOD(MAX(0,MIN(7,NOMF))/4,2)
        JODP=MOD(MAX(0,MIN(7,NOMF))/2,2)
        JOTZ=MOD(MAX(0,MIN(7,NOMF))  ,2)
C
C If the field is not zero and the scale factor is to be chosen
C here, do it now.  The parameter which specifies where the leftmost
C significant digit is assumed to be also must be updated.
C
        IF (IZFF.EQ.0.AND.SCFS.LE.0..AND.SCFS.GE.-3.)
          ITMP=0
          IF (SCFS.EQ.0..OR.(SCFS.EQ.-3..AND.LSDM.LT.-1)) ITMP=LSDM+1
          IF (SCFS.EQ.-1.) ITMP=LSDM
          IF (SCFS.EQ.-2..OR.(SCFS.EQ.-3..AND.LSDM-NDGL.GE.0))
     +                                                  ITMP=LSDM-NDGL+1
          SCFU=10.**ITMP
          IF (LSDL.NE.-10000) LSDL=LSDL-ITMP
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTMVIW (IWKO,IWKN,LWKN)
C
        DIMENSION IWKO(LIWK),IWKN(LWKN)
C
C This subroutine is called to move what VASPACKT has in the integer
C workspace array to a new array.  IWKO is the old array, IWKN the
C new one.  LWKN is the length of the new array.
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Declare local versions of the arrays used to keep track of workspace
C usage.
C
        DIMENSION LCLI($NBIW$),LCLL($NBIW$)
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTMVIW - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C First, zero the local pointers and lengths and, at the same time,
C compute the total space required in the new array.
C
        ITMP=0
C
        DO (I=1,$NBIW$)
          LCLI(I)=0
          LCLL(I)=0
          ITMP=ITMP+LIWS(I)
        END DO
C
C If there isn't enough space available in the new array, log an error
C and quit.
C
        IF (ITMP.GT.LWKN)
          CALL SETER ('VTMVIW - NEW WORKSPACE ARRAY IS TOO SMALL',2,1)
          RETURN
        END IF
C
C Zero an index into the new workspace array.
C
        IINW=0
C
C Now, the trick is to move the stuff without stepping on our own toes
C if the user gives us the same array as both the old and the new array.
C We move the blocks closer to the beginning of the array first.
C
        REPEAT

          ITM1=0
          ITM2=LIWK
C
          DO (I=1,$NBIW$)
            IF (LIWS(I).NE.0.AND.IIWS(I).LT.ITM2)
              ITM1=I
              ITM2=IIWS(I)
            END IF
          END DO
C
          IF (ITM1.NE.0)
            DO (J=1,LIWS(ITM1))
              IWKN(IINW+J)=IWKO(IIWS(ITM1)+J)
            END DO
            LCLI(ITM1)=IINW
            LCLL(ITM1)=LIWS(ITM1)
            IIWS(ITM1)=0
            LIWS(ITM1)=0
            IINW=IINW+LCLL(ITM1)
          END IF
C
        UNTIL (ITM1.EQ.0)
C
C Now, copy the local set of pointers and lengths to common.
C
        DO (I=1,$NBIW$)
          IIWS(I)=LCLI(I)
          LIWS(I)=LCLL(I)
        END DO
C
C Update the variable that says how much integer workspace we have.
C
        LIWK=LWKN
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTMVRW (RWKO,RWKN,LWKN)
C
        DIMENSION RWKO(LRWK),RWKN(LWKN)
C
C This subroutine is called to move what VASPACKT has in the real
C workspace array to a new array.  RWKO is the old array, RWKN the
C new one.  LWKN is the length of the new array.
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Declare local versions of the arrays used to keep track of workspace
C usage.
C
        DIMENSION LCLI($NBRW$),LCLL($NBRW$)
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTMVRW - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C First, zero the local pointers and lengths and, at the same time,
C compute the total space required in the new array.
C
        ITMP=0
C
        DO (I=1,$NBRW$)
          LCLI(I)=0
          LCLL(I)=0
          ITMP=ITMP+LRWS(I)
        END DO
C
C If there isn't enough space available in the new array, log an error
C and quit.
C
        IF (ITMP.GT.LWKN)
          CALL SETER ('VTMVRW - NEW WORKSPACE ARRAY IS TOO SMALL',2,1)
          RETURN
        END IF
C
C Zero an index into the new workspace array.
C
        IINW=0
C
C Now, the trick is to move the stuff without stepping on our own toes
C if the user gives us the same array as both the old and the new array.
C We move the blocks closer to the beginning of the array first.
C
        REPEAT

          ITM1=0
          ITM2=LRWK
C
          DO (I=1,$NBRW$)
            IF (LRWS(I).NE.0.AND.IRWS(I).LT.ITM2)
              ITM1=I
              ITM2=IRWS(I)
            END IF
          END DO
C
          IF (ITM1.NE.0)
            DO (J=1,LRWS(ITM1))
              RWKN(IINW+J)=RWKO(IRWS(ITM1)+J)
            END DO
            LCLI(ITM1)=IINW
            LCLL(ITM1)=LRWS(ITM1)
            IRWS(ITM1)=0
            LRWS(ITM1)=0
            IINW=IINW+LCLL(ITM1)
          END IF
C
        UNTIL (ITM1.EQ.0)
C
C Now, copy the local set of pointers and lengths to common.
C
        DO (I=1,$NBRW$)
          IRWS(I)=LCLI(I)
          LRWS(I)=LCLL(I)
        END DO
C
C Update the variable that says how much real workspace we have.
C
        LRWK=LWKN
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTRSET
C
C This subroutine may be called to reset all variables which have
C default values to those values.
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTRSET - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Reset individual parameters.
C
        AHAW=30.
        AHLN=.04
        AHSP=.16
        ANIL=0.
        ANZF=0.
        AVEL=0.
        CHWM=1.
        CTMA=' '
        CTMB=' '
        CXIL=.98
        CXZF=.50
        CYIL=-.02
        CYZF=.50
        DMAX=0.
        DMIN=0.
        DVAL=0.
        IBIL=0
        IBZF=0
        ICIL=-1
        ICSG=1
        ICST=1
        ICTT=1
        ICTV=0
        ICZF=-1
        IDBG=0
        IISP=0
        IIWU=0
        ILBC=0
        IMPF=0
        INIT=0
        IPAI=0
        IPIL=4
        IPIS=0
        IPZF=0
        IRNG=0
        IRWU=0
        ISET=1
        ISVT=5
        ITBM=1
        IWSO=1
        IZFF=0
        LCTM=1
        LIWB=2500
        LTZF=10
        LTIL=21
        MIRO=0
        NCLR=0
        NEXL=0
        NEXT=1
        NEXU=5
        NLBS=0
        NLSD=1
        NLZF=0
        NOMF=6
        NSDL=4
        OORV=0.
        PCPX=0.
        PCPY=0.
        PCPZ=0.
        PITH=0.
        SCFS=1.
        SCFU=1.
        SLLN=8.
        SLPS=.001
        SLSP=.072
        SVSP=0.
        TTLL=.018
        TTSP=.036
        TXIL='SCALE FACTOR IS $SFU$'
        TXZF='ZERO FIELD'
        UVPL=.05
        UVPR=.95
        UVPB=.05
        UVPT=.95
        UVPS=.25
        UWDL=0.
        UWDR=0.
        UWDB=0.
        UWDT=0.
        VFRA=0.
        VVMM=0.
        VRLN=0.
        VRMG=0.
        WCIL=.012
        WCZF=.012
        WLIL=0.
        WLZF=0.
        WWIL=.005
        WWZF=.005
        XLBC=0.
        XMAX=0.
        XMIN=0.
        YLBC=0.
        YMAX=0.
        YMIN=0.
        ZMAX=0.
        ZMIN=0.
C
C Reset parameter array elements.
C
        DO (I=1,$MCLR$)
          ICLR(I)=1
          TVAL(I)=0.
        END DO
        DO (I=1,$NBIW$)
          IIWS(I)=0
          LIWS(I)=0
        END DO
        DO (I=1,$NBRW$)
          IRWS(I)=0
          LRWS(I)=0
        END DO
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTSETC (WHCH,CVAL)
C
        CHARACTER*(*) WHCH,CVAL
C
C This subroutine is called to give a specified character value to a
C specified parameter.
C
C WHCH is the name of the parameter whose value is to be set.
C
C CVAL is a character variable containing the new value of the
C parameter.
C
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTSETC - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Check for a parameter name that is too short.
C
        IF (LEN(WHCH).LT.3)
          CTMB(1:36)='VTSETC - PARAMETER NAME TOO SHORT - '
          CTMB(37:36+LEN(WHCH))=WHCH
          CALL SETER (CTMB(1:36+LEN(WHCH)),2,1)
          RETURN
        END IF
C
C Compute the length of CVAL, excluding blanks.
C
        LCVL=1
C
        DO (I=1,MAX(1,LEN(CVAL)))
          IF (CVAL(I:I).NE.' ') LCVL=I
        END DO
C
C Set the proper parameter.
C
        IF      (WHCH(1:3).EQ.'CTM'.OR.WHCH(1:3).EQ.'ctm')
          CTMA=CVAL
          LCTM=MAX(1,MIN($LOCV$,LCVL))
        ELSE IF (WHCH(1:3).EQ.'ILT'.OR.WHCH(1:3).EQ.'ilt')
          TXIL=CVAL
          LTIL=MAX(1,MIN(100,LCVL))
        ELSE IF (WHCH(1:3).EQ.'ZFT'.OR.WHCH(1:3).EQ.'zft')
          TXZF=CVAL
          LTZF=MAX(1,MIN(40,LCVL))
        ELSE
          CTMB(1:36)='VTSETC - PARAMETER NAME NOT KNOWN - '
          CTMB(37:39)=WHCH(1:3)
          CALL SETER (CTMB(1:39),3,1)
          RETURN
        END IF
C
C Done.
C
  101   RETURN
C
      END


      SUBROUTINE VTSETI (WHCH,IVAL)
C
        CHARACTER*(*) WHCH
C
C This subroutine is called to give a specified integer value to a
C specified parameter.
C
C WHCH is the name of the parameter whose value is to be set.
C
C IVAL is an integer variable containing the new value of the parameter.
C
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
      INTEGER ISHIFT      
C
C RLB 3/2010: Previously the integer parameter was converted to a float
C   and the work was delegated off to VTSETR. This provided a sort
C   of "automatic type conversion", allowing the user to set a real
C   parameter using either vtseti() or vtsetr(), as in:
C        CALL VTSETI ('xxx',-9999)
C     or
C        CALL VTSETR ('xxx',-9999.0)
C
C   Color-indices are now either encoded RGBa values, or indices as
C   before. RGBa values are typically large integer values, beyond the
C   precision of floats, and thus this delegation scheme no longer
C   works correctly. The code has been refactored such that the integer
C   cases are now handled directly herein. If no action is found for
C   the WHCH, then we delegate over to VTSETR.
C --------------------------------------------------------------------
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTSETI - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Check for a parameter name that is too short.
C
        IF (LEN(WHCH).LT.3)
          CTMB(1:36)='VTSETI - PARAMETER NAME TOO SHORT - '
          CTMB(37:36+LEN(WHCH))=WHCH
          CALL SETER (CTMB(1:36+LEN(WHCH)),2,1)
          RETURN
        END IF
C
C Check for incorrect use of the index parameter.
C
        IF (WHCH(1:3).EQ.'CLR'.OR.WHCH(1:3).EQ.'clr')
          IF (IPAI.LT.1.OR.IPAI.GT.NCLR)
            INVOKE (PAI-INCORRECT,NR)
          END IF
        END IF
C
        BLOCK (PAI-INCORRECT,NR)
          CTMB(1:36)='VTSETI - SETTING XXX - PAI INCORRECT'
          CTMB(18:20)=WHCH(1:3)
          CALL SETER (CTMB(1:36),3,1)
          RETURN
        END BLOCK
C
C
C Set the appropriate parameter value.
C
        IF (WHCH(1:3).EQ.'CLR'.OR.WHCH(1:3).EQ.'clr')
          ICLR(IPAI)=IVAL
        ELSE IF (WHCH(1:3).EQ.'CTV'.OR.WHCH(1:3).EQ.'ctv')
          ICTV=IVAL
        ELSE IF (WHCH(1:3).EQ.'DBG'.OR.WHCH(1:3).EQ.'dbg')
          IDBG=IVAL
        ELSE IF (WHCH(1:3).EQ.'ILB'.OR.WHCH(1:3).EQ.'ilb')
          IBIL=MAX(0,MIN(3,IVAL))
        ELSE IF (WHCH(1:3).EQ.'ILC'.OR.WHCH(1:3).EQ.'ilc')
          ICIL=MAX(-1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'ILP'.OR.WHCH(1:3).EQ.'ilp')
          IPIL=MAX(-4,MIN(4,IVAL))
        ELSE IF (WHCH(1:3).EQ.'ISP'.OR.WHCH(1:3).EQ.'isp')
          IISP=MAX(0,MIN(1,IVAL))
        ELSE IF (WHCH(1:3).EQ.'IWB'.OR.WHCH(1:3).EQ.'iwb')
          LIWB=MAX(1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'LBC'.OR.WHCH(1:3).EQ.'lbc')
          ILBC=MAX(-1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'MAP'.OR.WHCH(1:3).EQ.'map')
          IMPF=MAX(0,IVAL)
        ELSE IF (WHCH(1:3).EQ.'NEL'.OR.WHCH(1:3).EQ.'nel')
          NEXL=IVAL
        ELSE IF (WHCH(1:3).EQ.'NET'.OR.WHCH(1:3).EQ.'net')
          NEXT=MAX(0,MIN(2,IVAL))
        ELSE IF (WHCH(1:3).EQ.'NEU'.OR.WHCH(1:3).EQ.'neu')
          NEXU=IVAL
        ELSE IF (WHCH(1:3).EQ.'NLS'.OR.WHCH(1:3).EQ.'nls')
          NLSD=MAX(0,MIN(1,IVAL))
        ELSE IF (WHCH(1:3).EQ.'NLV'.OR.WHCH(1:3).EQ.'nlv')
          NCLR=MAX(0,MIN($MCLR$,IVAL))
        ELSE IF (WHCH(1:3).EQ.'NLZ'.OR.WHCH(1:3).EQ.'nlz')
          NLZF=MAX(0,MIN(1,IVAL))
        ELSE IF (WHCH(1:3).EQ.'NOF'.OR.WHCH(1:3).EQ.'nof')
          NOMF=MAX(0,MIN(7,IVAL))
        ELSE IF (WHCH(1:3).EQ.'NSD'.OR.WHCH(1:3).EQ.'nsd')
          NSDL=IVAL
        ELSE IF (WHCH(1:3).EQ.'PAI'.OR.WHCH(1:3).EQ.'pai')
          IPAI=IVAL
        ELSE IF (WHCH(1:3).EQ.'PIS'.OR.WHCH(1:3).EQ.'pis')
          IPIS=IVAL
        ELSE IF (WHCH(1:3).EQ.'RNG'.OR.WHCH(1:3).EQ.'rng')
          IRNG=MAX(0,IVAL)
        ELSE IF (WHCH(1:3).EQ.'SET'.OR.WHCH(1:3).EQ.'set')
          ISET=MAX(0,MIN(1,IVAL))
        ELSE IF (WHCH(1:3).EQ.'SGC'.OR.WHCH(1:3).EQ.'sgc')
          ICSG=MAX(0,IVAL)
        ELSE IF (WHCH(1:3).EQ.'STC'.OR.WHCH(1:3).EQ.'stc')
          ICST=MAX(0,IVAL)
        ELSE IF (WHCH(1:3).EQ.'SVT'.OR.WHCH(1:3).EQ.'svt')
          ISVT=MAX(0,MIN(10,IVAL))
        ELSE IF (WHCH(1:3).EQ.'TBA'.OR.WHCH(1:3).EQ.'tba')
          ITBM=IOR(ISHIFT(ISHIFT(ITBM,-12),12),IAND(IVAL,4095))
        ELSE IF (WHCH(1:3).EQ.'TBX'.OR.WHCH(1:3).EQ.'tbx')
          ITBM=IOR(ISHIFT(IAND(IVAL,4095),12),IAND(ITBM,4095))
        ELSE IF (WHCH(1:3).EQ.'TTC'.OR.WHCH(1:3).EQ.'ttc')
          ICTT=MAX(0,IVAL)
        ELSE IF (WHCH(1:3).EQ.'WSO'.OR.WHCH(1:3).EQ.'wso')
          IWSO=MAX(0,MIN(3,IVAL))
        ELSE IF (WHCH(1:3).EQ.'ZFB'.OR.WHCH(1:3).EQ.'zfb')
          IBZF=MAX(0,MIN(3,IVAL))
        ELSE IF (WHCH(1:3).EQ.'ZFC'.OR.WHCH(1:3).EQ.'zfc')
          ICZF=MAX(-1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'ZFP'.OR.WHCH(1:3).EQ.'zfp')
          IPZF=MAX(-4,MIN(4,IVAL))
        ELSE
C         Float the integer value and pass it on to VTSETR.
          RVAL=REAL(IVAL)
          CALL VTSETR (WHCH,RVAL)
          IF (ICFELL('VTSETI',2).NE.0) RETURN
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTSETR (WHCH,RVAL)
C
        CHARACTER*(*) WHCH
C
C This subroutine is called to set the real value of a specified
C parameter.
C
C WHCH is the name of the parameter whose value is to be set.
C
C RVAL is a real variable containing the new value of the parameter.
C
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
       INTEGER ISHIFT
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTSETR - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Check for a parameter name that is too short.
C
        IF (LEN(WHCH).LT.3)
          CTMB(1:36)='VTSETR - PARAMETER NAME TOO SHORT - '
          CTMB(37:36+LEN(WHCH))=WHCH
          CALL SETER (CTMB(1:36+LEN(WHCH)),2,1)
          RETURN
        END IF
C
C Check for incorrect use of the index parameter.
C
        IF (WHCH(1:3).EQ.'CLR'.OR.WHCH(1:3).EQ.'clr'.OR.
     +      WHCH(1:3).EQ.'TVL'.OR.WHCH(1:3).EQ.'tvl')
          IF (IPAI.LT.1.OR.IPAI.GT.NCLR)
            INVOKE (PAI-INCORRECT,NR)
          END IF
        END IF
C
        BLOCK (PAI-INCORRECT,NR)
          CTMB(1:36)='VTSETR - SETTING XXX - PAI INCORRECT'
          CTMB(18:20)=WHCH(1:3)
          CALL SETER (CTMB(1:36),3,1)
          RETURN
        END BLOCK
C
C
C Set the appropriate parameter value.
C
        IF      (WHCH(1:3).EQ.'AHA'.OR.WHCH(1:3).EQ.'aha')
          AHAW=MAX(1.,MIN(90.,RVAL))
        ELSE IF (WHCH(1:3).EQ.'AHL'.OR.WHCH(1:3).EQ.'ahl')
          AHLN=RVAL
        ELSE IF (WHCH(1:3).EQ.'AHS'.OR.WHCH(1:3).EQ.'ahs')
          AHSP=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'AM1'.OR.WHCH(1:3).EQ.'am1')
          ANM1=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'AM2'.OR.WHCH(1:3).EQ.'am2')
          ANM2=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'CLR'.OR.WHCH(1:3).EQ.'clr')
          ICLR(IPAI)=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'CTV'.OR.WHCH(1:3).EQ.'ctv')
          ICTV=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'CWM'.OR.WHCH(1:3).EQ.'cwm')
          CHWM=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'DBG'.OR.WHCH(1:3).EQ.'dbg')
          IDBG=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'DVA'.OR.WHCH(1:3).EQ.'dva')
          DVAL=RVAL
        ELSE IF (WHCH(1:3).EQ.'ILA'.OR.WHCH(1:3).EQ.'ila')
          ANIL=RVAL
        ELSE IF (WHCH(1:3).EQ.'ILB'.OR.WHCH(1:3).EQ.'ilb')
          IBIL=MAX(0,MIN(3,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'ILC'.OR.WHCH(1:3).EQ.'ilc')
          ICIL=MAX(-1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'ILL'.OR.WHCH(1:3).EQ.'ill')
          WLIL=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'ILP'.OR.WHCH(1:3).EQ.'ilp')
          IPIL=MAX(-4,MIN(4,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'ILS'.OR.WHCH(1:3).EQ.'ils')
          WCIL=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'ILW'.OR.WHCH(1:3).EQ.'ilw')
          WWIL=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'ILX'.OR.WHCH(1:3).EQ.'ilx')
          CXIL=RVAL
        ELSE IF (WHCH(1:3).EQ.'ILY'.OR.WHCH(1:3).EQ.'ily')
          CYIL=RVAL
        ELSE IF (WHCH(1:3).EQ.'ISP'.OR.WHCH(1:3).EQ.'isp')
          IISP=MAX(0,MIN(1,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'IWB'.OR.WHCH(1:3).EQ.'iwb')
          LIWB=MAX(1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'LBC'.OR.WHCH(1:3).EQ.'lbc')
          ILBC=MAX(-1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'MAP'.OR.WHCH(1:3).EQ.'map')
          IMPF=MAX(0,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'NEL'.OR.WHCH(1:3).EQ.'nel')
          NEXL=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'NET'.OR.WHCH(1:3).EQ.'net')
          NEXT=MAX(0,MIN(2,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'NEU'.OR.WHCH(1:3).EQ.'neu')
          NEXU=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'NLS'.OR.WHCH(1:3).EQ.'nls')
          NLSD=MAX(0,MIN(1,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'NLV'.OR.WHCH(1:3).EQ.'nlv')
          NCLR=MAX(0,MIN($MCLR$,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'NLZ'.OR.WHCH(1:3).EQ.'nlz')
          NLZF=MAX(0,MIN(1,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'NOF'.OR.WHCH(1:3).EQ.'nof')
          NOMF=MAX(0,MIN(7,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'NSD'.OR.WHCH(1:3).EQ.'nsd')
          NSDL=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'ORV'.OR.WHCH(1:3).EQ.'orv')
          OORV=RVAL
        ELSE IF (WHCH(1:3).EQ.'PAI'.OR.WHCH(1:3).EQ.'pai')
          IPAI=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'PCX'.OR.WHCH(1:3).EQ.'pcx')
          PCPX=RVAL
        ELSE IF (WHCH(1:3).EQ.'PCY'.OR.WHCH(1:3).EQ.'pcy')
          PCPY=RVAL
        ELSE IF (WHCH(1:3).EQ.'PCZ'.OR.WHCH(1:3).EQ.'pcz')
          PCPZ=RVAL
        ELSE IF (WHCH(1:3).EQ.'PIS'.OR.WHCH(1:3).EQ.'pis')
          IPIS=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'PIT'.OR.WHCH(1:3).EQ.'pit')
          PITH=RVAL
        ELSE IF (WHCH(1:3).EQ.'RNG'.OR.WHCH(1:3).EQ.'rng')
          IRNG=MAX(0,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'SET'.OR.WHCH(1:3).EQ.'set')
          ISET=MAX(0,MIN(1,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'SFS'.OR.WHCH(1:3).EQ.'sfs'.OR.
     +           WHCH(1:3).EQ.'SFU'.OR.WHCH(1:3).EQ.'sfu')
          SCFS=RVAL
        ELSE IF (WHCH(1:3).EQ.'SGC'.OR.WHCH(1:3).EQ.'sgc')
          ICSG=MAX(0,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'SLL'.OR.WHCH(1:3).EQ.'sll')
          SLLN=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'SLP'.OR.WHCH(1:3).EQ.'slp')
          SLPS=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'SLS'.OR.WHCH(1:3).EQ.'sls')
          SLSP=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'SVS'.OR.WHCH(1:3).EQ.'svs')
          SVSP=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'STC'.OR.WHCH(1:3).EQ.'stc')
          ICST=MAX(0,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'SVT'.OR.WHCH(1:3).EQ.'svt')
          ISVT=MAX(0,MIN(10,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'TBA'.OR.WHCH(1:3).EQ.'tba')
          ITBM=IOR(ISHIFT(ISHIFT(ITBM,-12),12),IAND(INT(RVAL),4095))
        ELSE IF (WHCH(1:3).EQ.'TBX'.OR.WHCH(1:3).EQ.'tbx')
          ITBM=IOR(ISHIFT(IAND(INT(RVAL),4095),12),IAND(ITBM,4095))
        ELSE IF (WHCH(1:3).EQ.'TTC'.OR.WHCH(1:3).EQ.'ttc')
          ICTT=MAX(0,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'TTL'.OR.WHCH(1:3).EQ.'ttl')
          TTLL=RVAL
        ELSE IF (WHCH(1:3).EQ.'TTS'.OR.WHCH(1:3).EQ.'tts')
          TTSP=RVAL
        ELSE IF (WHCH(1:3).EQ.'TVL'.OR.WHCH(1:3).EQ.'tvl')
          TVAL(IPAI)=RVAL
        ELSE IF (WHCH(1:3).EQ.'VFR'.OR.WHCH(1:3).EQ.'vfr')
          VFRA=MAX(0.,MIN(1.,RVAL))
        ELSE IF (WHCH(1:3).EQ.'VPB'.OR.WHCH(1:3).EQ.'vpb')
          UVPB=MAX(0.,MIN(1.,RVAL))
        ELSE IF (WHCH(1:3).EQ.'VPL'.OR.WHCH(1:3).EQ.'vpl')
          UVPL=MAX(0.,MIN(1.,RVAL))
        ELSE IF (WHCH(1:3).EQ.'VPR'.OR.WHCH(1:3).EQ.'vpr')
          UVPR=MAX(0.,MIN(1.,RVAL))
        ELSE IF (WHCH(1:3).EQ.'VPS'.OR.WHCH(1:3).EQ.'vps')
          UVPS=RVAL
        ELSE IF (WHCH(1:3).EQ.'VPT'.OR.WHCH(1:3).EQ.'vpt')
          UVPT=MAX(0.,MIN(1.,RVAL))
        ELSE IF (WHCH(1:3).EQ.'VRL'.OR.WHCH(1:3).EQ.'vrl')
          VRLN=RVAL
        ELSE IF (WHCH(1:3).EQ.'VRM'.OR.WHCH(1:3).EQ.'vrm')
          VRMG=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'VVM'.OR.WHCH(1:3).EQ.'vvm')
          VVMM=RVAL
        ELSE IF (WHCH(1:3).EQ.'WDB'.OR.WHCH(1:3).EQ.'wdb')
          UWDB=RVAL
        ELSE IF (WHCH(1:3).EQ.'WDL'.OR.WHCH(1:3).EQ.'wdl')
          UWDL=RVAL
        ELSE IF (WHCH(1:3).EQ.'WDR'.OR.WHCH(1:3).EQ.'wdr')
          UWDR=RVAL
        ELSE IF (WHCH(1:3).EQ.'WDT'.OR.WHCH(1:3).EQ.'wdt')
          UWDT=RVAL
        ELSE IF (WHCH(1:3).EQ.'WSO'.OR.WHCH(1:3).EQ.'wso')
          IWSO=MAX(0,MIN(3,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'ZFA'.OR.WHCH(1:3).EQ.'zfa')
          ANZF=RVAL
        ELSE IF (WHCH(1:3).EQ.'ZFB'.OR.WHCH(1:3).EQ.'zfb')
          IBZF=MAX(0,MIN(3,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'ZFC'.OR.WHCH(1:3).EQ.'zfc')
          ICZF=MAX(-1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'ZFL'.OR.WHCH(1:3).EQ.'zfl')
          WLZF=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'ZFS'.OR.WHCH(1:3).EQ.'zfs')
          WCZF=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'ZFP'.OR.WHCH(1:3).EQ.'zfp')
          IPZF=MAX(-4,MIN(4,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'ZFW'.OR.WHCH(1:3).EQ.'zfw')
          WWZF=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'ZFX'.OR.WHCH(1:3).EQ.'zfx')
          CXZF=RVAL
        ELSE IF (WHCH(1:3).EQ.'ZFY'.OR.WHCH(1:3).EQ.'zfy')
          CYZF=RVAL
        ELSE
          CTMB(1:36)='VTSETR - PARAMETER NAME NOT KNOWN - '
          CTMB(37:39)=WHCH(1:3)
          CALL SETER (CTMB(1:39),4,1)
          RETURN
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTCVDM (RPNT,IEDG,ITRI,RWRK,IWRK,IAMA,RTPL)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*),IAMA(*)
C
        EXTERNAL RTPL
C
C This routine draws "curly vectors".
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C 
C The following common block allows us to initialize the "seed" for the
C random number generator VTRAND.  This makes it possible to generate
C the same set of curly vectors for a pair of stereo views of a field.
C 
        COMMON /VTSEED/ SEED
          DOUBLE PRECISION SEED
        SAVE   /VTSEED/
C
C Define a constant used to convert from degrees to radians.
C
        DATA DTOR / .017453292519943 /
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTCVDM - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Compute "realized" values of various vector parameters.
C
        CALL VTRVSP
C 
C Initialize the "seed" for the random number generator used.
C
        SEED=0.D0
C
        DO (I=1,IRNG)
          TEMP=VTRAND()
        END DO
C
C Get the required real and integer workspaces.
C
        CALL VTGRWS (RWRK,1,NTRI/LOTN,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('VTCVDM',2).NE.0) GO TO 104
C
        CALL VTGIWS (IWRK,1,NTRI/LOTN,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('VTCVDM',3).NE.0) GO TO 104
C
C Do an initialization loop through all of the triangle nodes.
C
        DO (I=0,NTRI-LOTN,LOTN)
C
C Zero the utility flags in the triangle node.  Bits B2-B0 of element
C 5 contain a count of the number of curly vectors that have passed
C through the triangle.  Bits B27-B3 record which of 25 sub-triangles
C have been previously crossed by a curly vector.
C
          ITRI(I+5)=0
C
C Find the indices of the nodes of the vertices of the triangle (in no
C particular order).
C
          IPP1=IEDG(ITRI(I+1)+1)
          IPP2=IEDG(ITRI(I+1)+2)
          IPP3=IEDG(ITRI(I+2)+1)
          IF (IPP3.EQ.IPP1.OR.IPP3.EQ.IPP2) IPP3=IEDG(ITRI(I+2)+2)
C
C Compute the squares of the cosines of the angles between the velocity
C vectors at pairs of vertices of the triangle.  (We use the squares in
C order to avoid taking square roots, and, actually, we compute "signed
C squares" such that, as the angles range from 0 degrees to 180 degrees,
C the values we get range from -1 to +1.)  We avoid starting a curly
C vector in any triangle where this measure is too large.
C
          RWRK(IR01+I/LOTN+1)=1.
C
          DNM1=(RPNT(IPP1+4)**2+RPNT(IPP1+5)**2+RPNT(IPP1+6)**2)*
     +         (RPNT(IPP2+4)**2+RPNT(IPP2+5)**2+RPNT(IPP2+6)**2)
          IF (DNM1.EQ.0.) GO TO 104
          CSA1=(RPNT(IPP1+4)*RPNT(IPP2+4)+
     +          RPNT(IPP1+5)*RPNT(IPP2+5)+
     +          RPNT(IPP1+6)*RPNT(IPP2+6))
          CSA1=CSA1*ABS(CSA1)/DNM1
C
          DNM2=(RPNT(IPP2+4)**2+RPNT(IPP2+5)**2+RPNT(IPP2+6)**2)*
     +         (RPNT(IPP3+4)**2+RPNT(IPP3+5)**2+RPNT(IPP3+6)**2)
          IF (DNM2.EQ.0.) GO TO 104
          CSA2=(RPNT(IPP2+4)*RPNT(IPP3+4)+
     +          RPNT(IPP2+5)*RPNT(IPP3+5)+
     +          RPNT(IPP2+6)*RPNT(IPP3+6))
          CSA2=CSA2*ABS(CSA2)/DNM2
C
          DNM3=(RPNT(IPP3+4)**2+RPNT(IPP3+5)**2+RPNT(IPP3+6)**2)*
     +         (RPNT(IPP1+4)**2+RPNT(IPP1+5)**2+RPNT(IPP1+6)**2)
          IF (DNM3.EQ.0.) GO TO 104
          CSA3=(RPNT(IPP3+4)*RPNT(IPP1+4)+
     +          RPNT(IPP3+5)*RPNT(IPP1+5)+
     +          RPNT(IPP3+6)*RPNT(IPP1+6))
          CSA3=CSA3*ABS(CSA3)/DNM3
C
          RWRK(IR01+I/LOTN+1)=-MIN(CSA1,CSA2,CSA3)
C
        END DO
C
C Compute an index array putting the triangles in random order.
C
        NIND=NTRI/LOTN
C
        DO (IIII=1,NIND)
          IWRK(II01+IIII)=IIII
        END DO
C
        DO (IIII=1,NIND-1)
          JJJJ=MAX(1,MIN(NIND,IIII+INT(REAL(NIND-IIII+1)*VTRAND())))
          IF (IIII.NE.JJJJ)
            ITMP=IWRK(II01+IIII)
            IWRK(II01+IIII)=IWRK(II01+JJJJ)
            IWRK(II01+JJJJ)=ITMP
          END IF
        END DO
C
C Compute a maximum acceptable value of the angular measures that were
C computed for the triangles above.
C
        TMAX=COS(DTOR*ANM1)
        TMAX=-TMAX*ABS(TMAX)
C
C Loop through the triangles in the specified random order.
C
        DO (IIII=1,NIND)
C
C Avoid using the triangle if the greatest angle between the velocity
C vectors at its vertices is too large.
C
          IF (RWRK(IR01+IWRK(II01+IIII)).GT.TMAX) GO TO 103
C
C Otherwise, compute the base index of the triangle.
C
          IBEG=(IWRK(II01+IIII)-1)*LOTN
C
C Avoid using the triangle if there are already curly vectors passing
C through it.
C
          IF (ITRI(IBEG+5).NE.0) GO TO 103
C
C Otherwise, use the center point of the triangle as the base point
C for a curly vector.
C
C Update the count of the number of curly vectors crossing the triangle.
C (This is a little premature, since we may not draw the vector, but it
C also prevents the triangle from being considered again.)
C 
          IF (IAND(ITRI(IBEG+5),7).NE.7) ITRI(IBEG+5)=ITRI(IBEG+5)+1
C
C The curly vector starts from the center of the triangle.
C
          RBEG=.333333333333333
          SBEG=.333333333333333
C
C Trace a line orthogonal to the velocity-vector field, first in one
C direction and then the other, for a specified distance.  If another
C curly vector is encountered, skip the current triangle.
C
          CALL VTTPOM (RPNT,IEDG,ITRI,IBEG,RBEG,SBEG,
     +                 0,ICSG,TTLR,ITER,SLGB,ISTB,RSTB,SSTB,IAMA,RTPL)
          IF (SLGB.LE..999*TTLR) GO TO 103
C
          CALL VTTPOM (RPNT,IEDG,ITRI,IBEG,RBEG,SBEG,
     +                 1,ICSG,TTLR,ITER,SLGE,ISTE,RSTE,SSTE,IAMA,RTPL)
          IF (SLGE.LE..999*TTLR) GO TO 103
C 
C Find the indices of the nodes of the vertices of the triangle (in no
C particular order).
C 
          IPP1=IEDG(ITRI(IBEG+1)+1)
          IPP2=IEDG(ITRI(IBEG+1)+2)
          IPP3=IEDG(ITRI(IBEG+2)+1)
          IF (IPP3.EQ.IPP1.OR.IPP3.EQ.IPP2) IPP3=IEDG(ITRI(IBEG+2)+2)
C
C Find the magnitude of the flow field at the center of the triangle
C and use that to compute a vector length to be used.
C
          VMAG=(SQRT(RPNT(IPP1+4)**2+RPNT(IPP1+5)**2+RPNT(IPP1+6)**2)+
     +          SQRT(RPNT(IPP2+4)**2+RPNT(IPP2+5)**2+RPNT(IPP2+6)**2)+
     +          SQRT(RPNT(IPP3+4)**2+RPNT(IPP3+5)**2+RPNT(IPP3+6)**2))
     +                                                               /3.
C
          VLEN=VFRA*VRLR+(1.-VFRA)*VRLR*(VMAG/VRMR)
C
          VLEN=VLEN/2.
C
          IF (VLEN.LE.SLPR) GO TO 103
C
C Trace the curly vector toward its beginning (in a direction opposite
C to the direction of the flow field), ...
C
          CALL VTTSOM (0,RPNT,IEDG,ITRI,IBEG,RBEG,SBEG,
     +                 0,VLEN,ITER,VRET,ISTD,RSTD,SSTD,IAMA,RTPL)
C
C ... skipping the triangle if the curly vector terminated early, ...
C
          IF (VRET.LT..999*VLEN) GO TO 103
C
C ... and then toward its end (in the direction of the flow field), ...
C
          CALL VTTSOM (0,RPNT,IEDG,ITRI,IBEG,RBEG,SBEG,
     +                 1,VLEN,ITER,VRET,ISTD,RSTD,SSTD,IAMA,RTPL)
C
C ... skipping the triangle if the curly vector terminated early.
C
          IF (VRET.LT..999*VLEN) GO TO 103
C
C Draw the curly vector toward its beginning (in a direction opposite
C to the direction of the flow field) ...
C
          CALL VTTSOM (1,RPNT,IEDG,ITRI,IBEG,RBEG,SBEG,
     +                 0,VLEN,ITER,VRET,ISTD,RSTD,SSTD,IAMA,RTPL)
C
C ... and then toward its end (in the direction of the flow field).
C
          CALL VTTSOM (2,RPNT,IEDG,ITRI,IBEG,RBEG,SBEG,
     +                 1,VLEN,ITER,VRET,ISTD,RSTD,SSTD,IAMA,RTPL)
C
  103   END DO
C
C Release the real and integer workspaces acquired above.
C
  104   LR01=0
        LI01=0
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTCVDR (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C This routine draws "curly vectors".
C
        DIMENSION IAMA(1)
C
        EXTERNAL VTDRPL
C
        DATA IAMA / 0 /
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTCVDR - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
        CALL VTCVDM (RPNT,IEDG,ITRI,RWRK,IWRK,IAMA,VTDRPL)
        IF (ICFELL('VTCVDR',2).NE.0) RETURN
C
        RETURN
C
      END


      SUBROUTINE VTSLDM (RPNT,IEDG,ITRI,RWRK,IWRK,IAMA,RTPL)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*),IAMA(*)
C
        EXTERNAL RTPL
C
C This routine draws streamlines.  It uses the capability of moving
C in a direction perpendicular to the velocity vectors to generate
C streamlines that are approximately the same distance apart and are
C such that the distance does not depend on the resolution of the mesh.
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C The following common block allows us to initialize the "seed" for the
C random number generator VTRAND that is used to offset the arrowheads.
C This makes it possible to generate the same set of arrowheads for a
C pair of stereo views of a streamline field.
C
        COMMON /VTSEED/ SEED
          DOUBLE PRECISION SEED
        SAVE   /VTSEED/
C
C Define a constant used to convert from degrees to radians.
C
        DATA DTOR / .017453292519943 /
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTSLDM - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Compute "realized" values of various vector parameters.
C
        CALL VTRVSP
C
C Initialize the "seed" for the random number generator used to offset
C the arrowheads.
C
        SEED=0.D0
C
        DO (I=1,IRNG)
          TEMP=VTRAND()
        END DO
C
C Get the required real and integer workspaces.
C
        CALL VTGRWS (RWRK,1,NTRI/LOTN,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('VTSLDM',2).NE.0) GO TO 104
C
        CALL VTGIWS (IWRK,1,NTRI/LOTN,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('VTSLDM',3).NE.0) GO TO 104
C
C Do an initialization loop through all of the triangle nodes.
C
        DO (I=0,NTRI-LOTN,LOTN)
C
C Zero the utility flags in the triangle node.  Bits B2-B0 of element 5
C contain a count of the number of streamlines that have passed through
C the triangle.  Bits B27-B3 record which of 25 sub-triangles have been
C previously crossed by a streamline.
C
          ITRI(I+5)=0
C
C Find the indices of the nodes of the vertices of the triangle (in no
C particular order).
C
          IPP1=IEDG(ITRI(I+1)+1)
          IPP2=IEDG(ITRI(I+1)+2)
          IPP3=IEDG(ITRI(I+2)+1)
          IF (IPP3.EQ.IPP1.OR.IPP3.EQ.IPP2) IPP3=IEDG(ITRI(I+2)+2)
C
C Compute the squares of the cosines of the angles between the velocity
C vectors at pairs of vertices of the triangle.  (We use the squares in
C order to avoid taking square roots, and, actually, we compute "signed
C squares" such that, as the angles range from 0 degrees to 180 degrees,
C the values we get range from -1 to +1.)  These values will be used to
C order the triangles from most desirable as the starting point of a
C streamline generator to least desirable.
C
          RWRK(IR01+I/LOTN+1)=1.
C
          DNM1=(RPNT(IPP1+4)**2+RPNT(IPP1+5)**2+RPNT(IPP1+6)**2)*
     +         (RPNT(IPP2+4)**2+RPNT(IPP2+5)**2+RPNT(IPP2+6)**2)
          IF (DNM1.EQ.0.) GO TO 104
          CSA1=(RPNT(IPP1+4)*RPNT(IPP2+4)+
     +          RPNT(IPP1+5)*RPNT(IPP2+5)+
     +          RPNT(IPP1+6)*RPNT(IPP2+6))
          CSA1=CSA1*ABS(CSA1)/DNM1
C
          DNM2=(RPNT(IPP2+4)**2+RPNT(IPP2+5)**2+RPNT(IPP2+6)**2)*
     +         (RPNT(IPP3+4)**2+RPNT(IPP3+5)**2+RPNT(IPP3+6)**2)
          IF (DNM2.EQ.0.) GO TO 104
          CSA2=(RPNT(IPP2+4)*RPNT(IPP3+4)+
     +          RPNT(IPP2+5)*RPNT(IPP3+5)+
     +          RPNT(IPP2+6)*RPNT(IPP3+6))
          CSA2=CSA2*ABS(CSA2)/DNM2
C
          DNM3=(RPNT(IPP3+4)**2+RPNT(IPP3+5)**2+RPNT(IPP3+6)**2)*
     +         (RPNT(IPP1+4)**2+RPNT(IPP1+5)**2+RPNT(IPP1+6)**2)
          IF (DNM3.EQ.0.) GO TO 104
          CSA3=(RPNT(IPP3+4)*RPNT(IPP1+4)+
     +          RPNT(IPP3+5)*RPNT(IPP1+5)+
     +          RPNT(IPP3+6)*RPNT(IPP1+6))
          CSA3=CSA3*ABS(CSA3)/DNM3
C
          RWRK(IR01+I/LOTN+1)=-MIN(CSA1,CSA2,CSA3)
C
        END DO
C
C Generate an index array for the values in RWRK.
C
        CALL VTSORT (RWRK(IR01+1),NTRI/LOTN,IWRK(II01+1))
C
C Compute a maximum acceptable value of the measure that we used to
C order the triangles.
C
        TMAX=COS(DTOR*ANM1)
        TMAX=-TMAX*ABS(TMAX)
C
C Loop through the triangles in order from most desirable to least
C desirable.
C
        DO (IIII=1,NTRI/LOTN)
C
C Avoid using the triangle (or any following it) if the greatest angle
C between the velocity vectors at its vertices is too large.
C
          IF (RWRK(IR01+IWRK(II01+IIII)).GT.TMAX) GO TO 104
C
C Otherwise, compute the base index of the triangle.
C
          IBEG=(IWRK(II01+IIII)-1)*LOTN
C
C Avoid using the triangle if there are already streamlines passing
C through it.
C
          IF (ITRI(IBEG+5).NE.0) GO TO 103
C
C Otherwise, use the center point of the triangle as a starting point
C to generate a batch of streamlines that are "parallel" to one another.
C (The streamlines' starting points are distributed at regular intervals
C along a "streamline generator", which is traced in such a way as to
C be everywhere perpendicular to the flow field.)
C
C Update the count of the number of streamlines crossing the triangle.
C (This is a little premature, since we may not draw the streamline,
C but it also prevents the triangle from being considered again.)
C 
          IF (IAND(ITRI(IBEG+5),7).NE.7) ITRI(IBEG+5)=ITRI(IBEG+5)+1
C
C Both the streamline generator and the first streamline start from the
C center of the triangle.
C
          RBEG=.333333333333333
          SBEG=.333333333333333
C
C Trace the streamline generator for a specified distance, first toward
C its beginning and then toward its end.  This does two things for us:
C 1) it tells us whether or not the first streamline is far enough away
C from previously-drawn streamlines and 2) it locates starting points
C for other streamlines to be drawn.
C
          CALL VTTPOM (RPNT,IEDG,ITRI,IBEG,RBEG,SBEG,
     +                 0,ICSG,SLSR,ITER,SLGB,ISTB,RSTB,SSTB,IAMA,RTPL)
          IF (SLGB.LE.TTLR) GO TO 103
C
          CALL VTTPOM (RPNT,IEDG,ITRI,IBEG,RBEG,SBEG,
     +                 1,ICSG,SLSR,ITER,SLGE,ISTE,RSTE,SSTE,IAMA,RTPL)
          IF (SLGE.LE.TTLR) GO TO 103
C
C Trace the first streamline toward its beginning (in a direction
C opposite to the direction of the flow field) ...
C
          CALL VTTSOM (0,RPNT,IEDG,ITRI,IBEG,RBEG,SBEG,
     +                 0,SLLR,ITER,SLTB,ISTD,RSTD,SSTD,IAMA,RTPL)
C
C ... and then toward its end (in the direction of the flow field).
C
          CALL VTTSOM (0,RPNT,IEDG,ITRI,IBEG,RBEG,SBEG,
     +                 1,SLLR,ITER,SLTE,ISTD,RSTD,SSTD,IAMA,RTPL)
C
C Draw the first streamline toward its beginning (in a direction
C opposite to the direction of the flow field) ...
C
          CALL VTTSOM (3,RPNT,IEDG,ITRI,IBEG,RBEG,SBEG,
     +                 0,SLTB,ITER,SLTD,ISTD,RSTD,SSTD,IAMA,RTPL)
C
C ... and then toward its end (in the direction of the flow field).
C
          CALL VTTSOM (3,RPNT,IEDG,ITRI,IBEG,RBEG,SBEG,
     +                 1,SLTE,ITER,SLTD,ISTD,RSTD,SSTD,IAMA,RTPL)
C
C Then, repositioning to the start of the next streamline toward the
C beginning of the streamline generator ...
C
  101     IF (SLGB.GT..999*SLSR)
C
            ISTR=ISTB
            RSTR=RSTB
            SSTR=SSTB
C
C ... trace the streamline generator further toward its beginning
C (taking steps of a specified size), ...
C
            CALL VTTPOM (RPNT,IEDG,ITRI,ISTR,RSTR,SSTR,
     +                   0,ICSG,SLSR,ITER,SLGB,ISTB,RSTB,SSTB,IAMA,RTPL)
C
C ... and then draw a streamline (in two parts).
C
            IF (SLGB.GT.TTLR)
              IF (IAND(ITRI(ISTR+5),7).NE.7) ITRI(ISTR+5)=ITRI(ISTR+5)+1
              CALL VTTSOM (0,RPNT,IEDG,ITRI,ISTR,RSTR,SSTR,
     +                     0,SLLR,ITER,SLTB,ISTD,RSTD,SSTD,IAMA,RTPL)
              CALL VTTSOM (0,RPNT,IEDG,ITRI,ISTR,RSTR,SSTR,
     +                     1,SLLR,ITER,SLTE,ISTD,RSTD,SSTD,IAMA,RTPL)
              CALL VTTSOM (3,RPNT,IEDG,ITRI,ISTR,RSTR,SSTR,
     +                     0,SLTB,ITER,SLTD,ISTD,RSTD,SSTD,IAMA,RTPL)
              CALL VTTSOM (3,RPNT,IEDG,ITRI,ISTR,RSTR,SSTR,
     +                     1,SLTE,ITER,SLTD,ISTD,RSTD,SSTD,IAMA,RTPL)
              GO TO 101
            END IF
C
          END IF
C
C Then, repositioning to the start of the next streamline toward the
C end of the streamline generator ...
C
  102     IF (SLGE.GT..999*SLSR)
C
            ISTR=ISTE
            RSTR=RSTE
            SSTR=SSTE
C
C ... trace the streamline generator further toward its end (taking
C steps of a specified size), ...
C
            CALL VTTPOM (RPNT,IEDG,ITRI,ISTR,RSTR,SSTR,
     +                   1,ICSG,SLSR,ITER,SLGE,ISTE,RSTE,SSTE,IAMA,RTPL)
C
C ... and draw a streamline (in two parts).
C
            IF (SLGE.GT.TTLR)
              IF (IAND(ITRI(ISTR+5),7).NE.7) ITRI(ISTR+5)=ITRI(ISTR+5)+1
              CALL VTTSOM (0,RPNT,IEDG,ITRI,ISTR,RSTR,SSTR,
     +                     0,SLLR,ITER,SLTB,IDUM,RDUM,SDUM,IAMA,RTPL)
              CALL VTTSOM (0,RPNT,IEDG,ITRI,ISTR,RSTR,SSTR,
     +                     1,SLLR,ITER,SLTE,IDUM,RDUM,SDUM,IAMA,RTPL)
              CALL VTTSOM (3,RPNT,IEDG,ITRI,ISTR,RSTR,SSTR,
     +                     0,SLTB,ITER,SLTD,IDUM,RDUM,SDUM,IAMA,RTPL)
              CALL VTTSOM (3,RPNT,IEDG,ITRI,ISTR,RSTR,SSTR,
     +                     1,SLTE,ITER,SLTD,IDUM,RDUM,SDUM,IAMA,RTPL)
              GO TO 102
            END IF
C
          END IF
C
  103   END DO
C
C Release the real and integer workspaces acquired above.
C
  104   LR01=0
        LI01=0
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTSLDR (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C This routine draws streamlines.
C
        DIMENSION IAMA(1)
C
        EXTERNAL VTDRPL
C
        DATA IAMA / 0 /
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTSLDR - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
        CALL VTSLDM (RPNT,IEDG,ITRI,RWRK,IWRK,IAMA,VTDRPL)
        IF (ICFELL('VTSLDR',2).NE.0) RETURN
C
        RETURN
C
      END


.OP   BI=66
      SUBROUTINE VTSVDM (RPNT,IEDG,ITRI,RWRK,IWRK,IAMA,RTPL)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*),IAMA(*)
C
        EXTERNAL RTPL
C
C This routine draws simple vectors.
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Declare arrays for use in calling VTCUDR.
C
        DIMENSION UCRV(2),VCRV(2),WCRV(2),CCRV(2)
C 
C The following common block allows us to initialize the "seed" for the
C random number generator VTRAND.  This makes it possible to generate
C the same set of vectors for a pair of stereo views of a field.
C 
        COMMON /VTSEED/ SEED
          DOUBLE PRECISION SEED
        SAVE   /VTSEED/
C
C Declare an array to be used in searching and marking all triangles
C within a specified radius of some particular triangle.
C
        DIMENSION ISTK(2,10)
C
C Define a constant used to convert from degrees to radians.
C
        DATA DTOR / .017453292519943 /
C
C IXOR(IONE,ITWO) is the exclusive OR of the 12-bit masks IONE and ITWO.
C
        IXOR(IONE,ITWO)=IAND(IOR(IONE,ITWO),4095-IAND(IONE,ITWO))
C
C ITBF(IARG) is non-zero if and only if a triangle with blocking-flag
C element IARG is blocked.
C
        ITBF(IARG)=IAND(IXOR(IARG,ITBX),ITBA)
C
C Extract the values of ITBX and ITBA from ITBM.
C
        ITBX=IAND(ISHIFT(ITBM,-12),4095)
        ITBA=IAND(       ITBM     ,4095)
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTSVDM - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Compute "realized" values of various vector parameters.
C
        CALL VTRVSP
C
C Set a flag that says whether or not vectors will be colored.
C
        IF (ICTV.EQ.0.OR.NCLR.EQ.0)
          ICOL=0
        ELSE
          ICOL=1
        END IF
C
C Decide whether to use a simple algorithm that draws a vector in each
C unblocked triangle or a more complicated algorithm that attempts to
C cull some of them.
C
        IF (ISVT.EQ.0)
C
C Simple algorithm - just loop through all of the triangle nodes and
C draw a vector at the center of each triangle.
C
          FOR (IIII = 0 TO NTRI-LOTN BY LOTN)
C
            INVOKE (DRAW-SIMPLE-VECTOR)
C
          END FOR
C
          GO TO 103
C
        ELSE
C 
C More complicated algorithm - first, initialize the "seed" for the
C random number generator used.
C
          SEED=0.D0
C
          DO (I=1,IRNG)
            TEMP=VTRAND()
          END DO
C
C Get the required integer workspace.
C
        CALL VTGIWS (IWRK,1,NTRI/LOTN,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('VTSVDM',2).NE.0) GO TO 102
C
C Zero the utility flags in all of the triangle nodes.
C
          DO (I=0,NTRI-LOTN,LOTN)
            ITRI(I+5)=0
          END DO
C
C Generate an index array putting the triangles in random order.
C
          NIND=NTRI/LOTN
C
          DO (I=1,NIND)
            IWRK(II01+I)=I
          END DO
C
          DO (I=1,NIND-1)
            J=MAX(I,MIN(NIND,I+INT(REAL(NIND-I+1)*VTRAND())))
            IF (I.NE.J)
              ITMP=IWRK(II01+I)
              IWRK(II01+I)=IWRK(II01+J)
              IWRK(II01+J)=ITMP
            END IF
          END DO
C
C Loop through the triangles in random order.
C
          FOR (I = 1 TO NIND)
C
            IIII=LOTN*(II01+IWRK(I)-1)
C
C Use the current triangle only if it has not been marked yet.
C
            IF (ITRI(IIII+5).EQ.0)
C
C Draw a vector at the center of the current triangle.
C
              INVOKE (DRAW-SIMPLE-VECTOR)
C
C Save the coordinates of the center of the triangle.
C
              UCCS=UCCT
              VCCS=VCCT
              WCCS=WCCT
C
C Mark all triangles within ISVT steps of this one (where a "step" is
C just from one triangle to an adjacent triangle) and having centers
C within SVSR units of the center of this one.  (If SVSR is zero, we
C don't bother with computing the distance - we just mark all triangles
C within ISVT steps.)  The algorithm used here may not be the most
C efficient one; it was used because it could be implemented without
C a lot of extra memory.
C
C Initialize the stack.
C
              ILEV=1
              ISTK(1,ILEV)=IIII
              ISTK(2,ILEV)=0
C
C Try the next path from the current triangle to another one.
C
  101         IF (ISTK(2,ILEV).LT.3)
                ISTK(2,ILEV)=ISTK(2,ILEV)+1
                ITMP=ITRI(ISTK(1,ILEV)+ISTK(2,ILEV))
                IF (IEDG(ITMP+3).LT.0.OR.IEDG(ITMP+4).LT.0) GO TO 101
                IF (LOTN*((IEDG(ITMP+3)-1)/LOTN).NE.ISTK(1,ILEV))
                  ITMP=LOTN*((IEDG(ITMP+3)-1)/LOTN)
                ELSE
                  ITMP=LOTN*((IEDG(ITMP+4)-1)/LOTN)
                END IF
                IF (ITRI(ITMP+5).EQ.0)
                  IF (SVSR.EQ.0.)
                    ITRI(ITMP+5)=1
                  ELSE
                    IPP1=IEDG(ITRI(ITMP+1)+1)
                    IPP2=IEDG(ITRI(ITMP+1)+2)
                    IPP3=IEDG(ITRI(ITMP+2)+1)
                    IF (IPP3.EQ.IPP1.OR.IPP3.EQ.IPP2)
     +                                         IPP3=IEDG(ITRI(ITMP+2)+2)
                    UCCT=(RPNT(IPP1+1)+RPNT(IPP2+1)+RPNT(IPP3+1))/3.
                    VCCT=(RPNT(IPP1+2)+RPNT(IPP2+2)+RPNT(IPP3+2))/3.
                    WCCT=(RPNT(IPP1+3)+RPNT(IPP2+3)+RPNT(IPP3+3))/3.
                    IF (SQRT((UCCT-UCCS)**2+
     +                       (VCCT-VCCS)**2+
     +                       (WCCT-WCCS)**2).LT.SVSR) ITRI(ITMP+5)=1
                  END IF
                END IF
                IF (ILEV.LT.ISVT)
                  ILEV=ILEV+1
                  ISTK(1,ILEV)=ITMP
                  ISTK(2,ILEV)=0
                END IF
                GO TO 101
              ELSE
                IF (ILEV.GT.1)
                  ILEV=ILEV-1
                  GO TO 101
                END IF
              END IF
C
            END IF
C
          END FOR
C
        END IF
C
C Release the integer workspace acquired above.
C
  102   LI01=0
C
C Done.
C
  103   RETURN
C
C The following internal procedure draws a simple vector centered on
C the triangle whose base address is IIII.
C
        BLOCK (DRAW-SIMPLE-VECTOR)
C
C Find the indices of the nodes of the vertices of the triangle (in no
C particular order).
C
          IPP1=IEDG(ITRI(IIII+1)+1)
          IPP2=IEDG(ITRI(IIII+1)+2)
          IPP3=IEDG(ITRI(IIII+2)+1)
          IF (IPP3.EQ.IPP1.OR.IPP3.EQ.IPP2) IPP3=IEDG(ITRI(IIII+2)+2)
C
C Extract the coordinates of the vertices of the triangle.
C
          UCP1=RPNT(IPP1+1)
          VCP1=RPNT(IPP1+2)
          WCP1=RPNT(IPP1+3)
          UCP2=RPNT(IPP2+1)
          VCP2=RPNT(IPP2+2)
          WCP2=RPNT(IPP2+3)
          UCP3=RPNT(IPP3+1)
          VCP3=RPNT(IPP3+2)
          WCP3=RPNT(IPP3+3)
C
C Compute the coordinates of the center of the triangle.
C
          UCCT=(UCP1+UCP2+UCP3)/3.
          VCCT=(VCP1+VCP2+VCP3)/3.
          WCCT=(WCP1+WCP2+WCP3)/3.
C
C Skip the triangle if it's blocked.
C
          IF (ITBF(ITRI(IIII+4)).NE.0) GO TO 104
C
C Compute the coefficients A, B, C, and D in the equation defining the
C plane of the triangle (Ax+By+Cz+D=0).
C
          A=(VCP2-VCP1)*(WCP3-WCP1)-(VCP3-VCP1)*(WCP2-WCP1)
          B=(WCP2-WCP1)*(UCP3-UCP1)-(WCP3-WCP1)*(UCP2-UCP1)
          C=(UCP2-UCP1)*(VCP3-VCP1)-(UCP3-UCP1)*(VCP2-VCP1)
          D=-(A*UCP1+B*VCP1+C*WCP1)
C
C Compute the direction cosines of the normal to the triangle.  If they
C are not well-defined, skip the triangle.
C
          DNOM=SQRT(A**2+B**2+C**2)
C
          IF (DNOM.EQ.0.) GO TO 104
C
          DCNU=A/DNOM
          DCNV=B/DNOM
          DCNW=C/DNOM
C
C Compute the components of the velocity vector at the center of the
C triangle and its magnitude.
C
          UCVV=(RPNT(IPP1+4)+RPNT(IPP2+4)+RPNT(IPP3+4))/3.
          VCVV=(RPNT(IPP1+5)+RPNT(IPP2+5)+RPNT(IPP3+5))/3.
          WCVV=(RPNT(IPP1+6)+RPNT(IPP2+6)+RPNT(IPP3+6))/3.
C
          VMAG=SQRT(UCVV**2+VCVV**2+WCVV**2)
C
          VLEN=VFRA*VRLR+(1.-VFRA)*VRLR*(VMAG/VRMR)
C
          VLEN=VLEN/2.
C
C Draw the simple vector.  WE MAY WANT TO HAVE OTHER CHOICES HERE.  FOR
C EXAMPLE, IT MAY BE DESIRABLE TO FIND THE ORIENTATION OF THE VECTOR BY
C PROJECTING THE END POINTS OF A TINY PORTION OF IT AND THEN USE THAT
C FOR A VECTOR OF A SPECIFIED SIZE IN THE PROJECTION SPACE.
C
          UCRV(1)=UCCT-VLEN*UCVV/VMAG
          VCRV(1)=VCCT-VLEN*VCVV/VMAG
          WCRV(1)=WCCT-VLEN*WCVV/VMAG
          CCRV(1)=VMAG
C
          UCRV(2)=UCCT+VLEN*UCVV/VMAG
          VCRV(2)=VCCT+VLEN*VCVV/VMAG
          WCRV(2)=WCCT+VLEN*WCVV/VMAG
          CCRV(2)=VMAG
C
          CALL VTCUDR (UCRV,VCRV,WCRV,CCRV,2,ICOL,1,IAMA,RTPL)
C
  104   END BLOCK
C
      END
.OP   BI=77


      SUBROUTINE VTSVDR (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C This routine draws simple vectors.
C
        DIMENSION IAMA(1)
C
        EXTERNAL VTDRPL
C
        DATA IAMA / 0 /
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTSVDR - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
        CALL VTSVDM (RPNT,IEDG,ITRI,RWRK,IWRK,IAMA,VTDRPL)
        IF (ICFELL('VTSVDR',2).NE.0) RETURN
C
        RETURN
C
      END


      SUBROUTINE VTTMRG (IDIM,JDIM,RLAT,RLON,RDAT,ISCR,SVAL,RTMI,
     +                   RPNT,MPNT,NPNT,LOPN,
     +                   IEDG,MEDG,NEDG,LOEN,
     +                   ITRI,MTRI,NTRI,LOTN)
C
        DIMENSION RLAT(IDIM,JDIM),RLON(IDIM,JDIM),RDAT(IDIM,JDIM)
        DIMENSION ISCR(IDIM,JDIM,4)
        DIMENSION RPNT(MPNT),IEDG(MEDG),ITRI(MTRI)
C
C Given arrays defining a rectangular mesh of data deformed to wrap
C around the globe, VTTMRG returns a triangular mesh representing the
C data.
C
C The arguments are as follows:
C
C IDIM - an input expression of type INTEGER - the first dimension of
C the rectangular mesh.
C
C JDIM - an input expression of type INTEGER - the second dimension of
C the rectangular mesh.
C
C RLAT - an input array of type REAL, dimensioned IDIM by JDIM - the
C values of latitude for the points of the rectangular mesh.
C
C RLON - an input array of type REAL, dimensioned IDIM by JDIM - the
C values of longitude for the points of the rectangular mesh.
C
C RDAT - an input array of type REAL, dimensioned IDIM by JDIM - the
C values of the data field for the points of the rectangular mesh.
C
C ISCR - a scratch array of type INTEGER, dimensioned IDIM*JDIM*4.
C
C SVAL - an input expression of type REAL - a value which, if used in
C the array RDAT, marks that datum as "special" or "missing".
C
C RTMI - the name of a routine to be called by VTTMRG to determine the
C mapping of the indices of the mesh.  It must be declared EXTERNAL in
C the routine that calls VTTMRG.  The routine must be callable using a
C FORTRAN statement like this:
C
C       CALL RTMI (IDIM,JDIM,IINI,JINI,IINO,JINO)
C
C The arguments IDIM and JDIM are as defined above.  The arguments IINI
C and JINI are input expressions of type INTEGER defining the indices of
C a particular point of the rectangular mesh (1.LE.IINI.LE.IDIM and
C 1.LE.JINI.LE.JDIM).  The arguments IINO and JINO are output variables
C of type INTEGER, that receive the values to be used for the specified
C point of the mesh instead of IINI and JINI.  For example, if the
C rectangular mesh wraps around the globe in such a way that the entire
C first and last rows of the mesh each map into a single point (perhaps
C the south pole and the north pole, respectively) and the left and
C right edges of the mesh are coincident on the globe, then one would
C define RTMI as follows:
C
C     SUBROUTINE RTMI (IDIM,JDIM,IINI,JINI,IINO,JINO)
C
C       IF (JINI.EQ.1) THEN          !  point in first row of mesh
C         IINO=1
C         JINO=1
C       ELSE IF (JINI.EQ.JDIM) THEN  !  point in last row of mesh
C         IINO=1
C         JINO=JDIM
C       ELSE IF (IINI.EQ.IDIM) THEN  !  point in last column of mesh
C         IINO=1
C         JINO=JINI
C       ELSE                         !  all other points of the mesh
C         IINO=IINI
C         JINO=JINI
C       END IF
C
C       RETURN
C
C     END
C
C RPNT is a one-dimensional output array of type REAL in which the list
C of the points of the triangular mesh is placed.
C
C MPNT is an input expression of type INTEGER specifying the length of
C RPNT.
C
C NPNT is an output variable whose value is the index of the last
C element of RPNT used for the list of points.
C
C LOPN is the length of a point node in RPNT.
C
C IEDG is a one-dimensional output array of type INTEGER in which the
C list of the edges of the triangular mesh is placed.
C
C MEDG is an input expression of type INTEGER specifying the length of
C IEDG.
C
C NEDG is an output variable whose value is the index of the last
C element of IEDG used for the list of edges.
C
C LOEN is the length of an edge node in IEDG.
C
C ITRI is a one-dimensional output array of type INTEGER in which the
C list of the triangles of the triangular mesh is placed.
C
C MTRI is an input expression of type INTEGER specifying the length of
C ITRI.
C
C NTRI is an output variable whose value is the index of the last
C element of ITRI used for the list of triangles.
C
C LOTN is the length of a triangle node in IEDG.
C
C Define a constant used to convert from degrees to radians.
C
        DATA DTOR / .017453292519943 /
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTTMRG - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Build structures forming the triangular mesh.  First, zero the count
C of points, edges, and triangles formed.
C
        NPNT=0
        NEDG=0
        NTRI=0
C
C Initialize the array that keeps track of where in the triangular mesh
C the points and edges of the original rectangular grid were put.
C
        DO (I=1,IDIM)
          DO (J=1,JDIM)
            DO (K=1,4)
              ISCR(I,J,K)=-1
            END DO
          END DO
        END DO
C
C Loop through the cells of the rectangular grid.
C
        DO (I=1,IDIM-1)
C
          DO (J=1,JDIM-1)
C
C Use only rectangular cells with data at each of their four corners.
C
            IF (RDAT(I  ,J  ).NE.SVAL.AND.RDAT(I+1,J  ).NE.SVAL.AND.
     +          RDAT(I  ,J+1).NE.SVAL.AND.RDAT(I+1,J+1).NE.SVAL)
C
C Within each rectangular cell, loop to produce the two triangles into
C which it will be divided.
C
              DO (K=0,1)
C
C The cell is split into triangles using one of the two diagonals.  The
C following code determines which diagonal to use; it creates a sort of
C checkerboard pattern, using the diagonal from lower left to upper
C right on cells of one "color" and that from upper left to lower right
C on cells of the other "color".  The logic can be changed to use other
C patterns, but it is important that the points of each triangle be
C specified in counterclockwise order.
C
                IF (MOD(I+J,2).EQ.0)
                  IF (K.EQ.0)
                    INI1=I
                    INJ1=J
                    INI2=I+1
                    INJ2=J
                    INI3=I
                    INJ3=J+1
                  ELSE
                    INI1=I
                    INJ1=J+1
                    INI2=I+1
                    INJ2=J
                    INI3=I+1
                    INJ3=J+1
                  END IF
                ELSE
                  IF (K.EQ.0)
                    INI1=I
                    INJ1=J
                    INI2=I+1
                    INJ2=J+1
                    INI3=I
                    INJ3=J+1
                  ELSE
                    INI1=I
                    INJ1=J
                    INI2=I+1
                    INJ2=J
                    INI3=I+1
                    INJ3=J+1
                  END IF
                END IF
C
C Find out from the user's index-mapping routine what indices to use for
C the three points.
C
                CALL RTMI (IDIM,JDIM,INI1,INJ1,IOI1,IOJ1)
                CALL RTMI (IDIM,JDIM,INI2,INJ2,IOI2,IOJ2)
                CALL RTMI (IDIM,JDIM,INI3,INJ3,IOI3,IOJ3)
C
C Skip the triangle if any two points of it are coincident (because then
C it's just a line).
C
                IF (IOI1.EQ.IOI2.AND.IOJ1.EQ.IOJ2) GO TO 107
                IF (IOI2.EQ.IOI3.AND.IOJ2.EQ.IOJ3) GO TO 107
                IF (IOI3.EQ.IOI1.AND.IOJ3.EQ.IOJ1) GO TO 107
C
C Skip the triangle if its points all lie too nearly on the same great
C circle.
C
                ANGL=VTABGC(RLAT(IOI1,IOJ1),RLON(IOI1,IOJ1),
     +                      RLAT(IOI2,IOJ2),RLON(IOI2,IOJ2),
     +                      RLAT(IOI3,IOJ3),RLON(IOI3,IOJ3))
C
                IF (ANGL.LT..1.OR.ANGL.GT.179.9) GO TO 107
C
C Deal with the first point of the triangle.  We are careful not to put
C the point into the structure more than once.  (That way, we can test
C to see if two edges contain the same point by looking at pointers; we
C don't have to look at coordinates.)
C
                IF (ISCR(IOI1,IOJ1,4).GE.0)
                  IPP1=ISCR(IOI1,IOJ1,4)
                ELSE IF (NPNT+LOPN.GT.MPNT)
                  CALL SETER ('VTTMRG - POINT ARRAY IS TOO SMALL',2,1)
                  RETURN
                ELSE
                  IPP1=NPNT
                  NPNT=NPNT+LOPN
                  ISCR(IOI1,IOJ1,4)=IPP1
                END IF
C
                RPNT(IPP1+1)=COS(DTOR*RLAT(IOI1,IOJ1))*
     +                       COS(DTOR*RLON(IOI1,IOJ1))
                RPNT(IPP1+2)=COS(DTOR*RLAT(IOI1,IOJ1))*
     +                       SIN(DTOR*RLON(IOI1,IOJ1))
                RPNT(IPP1+3)=SIN(DTOR*RLAT(IOI1,IOJ1))
                RPNT(IPP1+4)=         RDAT(IOI1,IOJ1)
C
C Deal with the second point of the triangle.
C
                IF (ISCR(IOI2,IOJ2,4).GE.0)
                  IPP2=ISCR(IOI2,IOJ2,4)
                ELSE IF (NPNT+LOPN.GT.MPNT)
                  CALL SETER ('VTTMRG - POINT ARRAY IS TOO SMALL',3,1)
                  RETURN
                ELSE
                  IPP2=NPNT
                  NPNT=NPNT+LOPN
                  ISCR(IOI2,IOJ2,4)=IPP2
                END IF
C
                RPNT(IPP2+1)=COS(DTOR*RLAT(IOI2,IOJ2))*
     +                       COS(DTOR*RLON(IOI2,IOJ2))
                RPNT(IPP2+2)=COS(DTOR*RLAT(IOI2,IOJ2))*
     +                       SIN(DTOR*RLON(IOI2,IOJ2))
                RPNT(IPP2+3)=SIN(DTOR*RLAT(IOI2,IOJ2))
                RPNT(IPP2+4)=         RDAT(IOI2,IOJ2)
C
C Deal with the third point of the triangle.
C
                IF (ISCR(IOI3,IOJ3,4).GE.0)
                  IPP3=ISCR(IOI3,IOJ3,4)
                ELSE IF (NPNT+LOPN.GT.MPNT)
                  CALL SETER ('VTTMRG - POINT ARRAY IS TOO SMALL',4,1)
                  RETURN
                ELSE
                  IPP3=NPNT
                  NPNT=NPNT+LOPN
                  ISCR(IOI3,IOJ3,4)=IPP3
                END IF
C
                RPNT(IPP3+1)=COS(DTOR*RLAT(IOI3,IOJ3))*
     +                       COS(DTOR*RLON(IOI3,IOJ3))
                RPNT(IPP3+2)=COS(DTOR*RLAT(IOI3,IOJ3))*
     +                       SIN(DTOR*RLON(IOI3,IOJ3))
                RPNT(IPP3+3)=SIN(DTOR*RLAT(IOI3,IOJ3))
                RPNT(IPP3+4)=         RDAT(IOI3,IOJ3)
C
C Deal with the first edge of the triangle (joining points 1 and 2).
C Again, we are careful not to put an edge into the structure more
C than once.  (That way, two triangles that share an edge contain
C pointers to the same edge.)  The logic here is a bit opaque; if
C the user routine RTMI maps the edge to some edge of the unmapped
C triangular mesh, we can keep track of its index using that element
C of ISCR reserved for that edge; otherwise, we just have to search
C the whole edge list to see if the edge is already there (which
C shouldn't happen too often).
C
                IF (ABS(IOI1-IOI2).LE.1.AND.ABS(IOJ1-IOJ2).LE.1)
                  IDIR=(IOI1-IOI2)*(IOJ1-IOJ2)
                  IVOK=MOD(MIN(IOI1,IOI2)+MIN(IOJ1,IOJ2),2)
                  IF ((IDIR.EQ.0              ).OR.
     +                (IDIR.LT.0.AND.IVOK.EQ.0).OR.
     +                (IDIR.GT.0.AND.IVOK.EQ.1))
                    IF (IOI1.EQ.IOI2)
                      ITYP=1
                    ELSE IF (IOJ1.EQ.IOJ2)
                      ITYP=2
                    ELSE
                      ITYP=3
                    END IF
                    IOIM=MIN(IOI1,IOI2)
                    IOJM=MIN(IOJ1,IOJ2)
                    IF (ISCR(IOIM,IOJM,ITYP).GE.0)
                      IPE1=ISCR(IOIM,IOJM,ITYP)
                      IEDG(IPE1+4)=NTRI+1
                      GO TO 102
                    END IF
                    ISCR(IOIM,IOJM,ITYP)=NEDG
                    GO TO 101
                  END IF
                END IF
                DO (IPTE=0,NEDG-LOEN,LOEN)
                  IF ((IEDG(IPTE+1).EQ.IPP2.AND.
     +                 IEDG(IPTE+2).EQ.IPP1))
                    IPE1=IPTE
                    IEDG(IPE1+4)=NTRI+1
                    GO TO 102
                  END IF
                END DO
  101           IF (NEDG+LOEN.GT.MEDG)
                  CALL SETER ('VTTMRG - EDGE ARRAY IS TOO SMALL',5,1)
                  RETURN
                ELSE
                  IPE1=NEDG
                  NEDG=NEDG+LOEN
                  IEDG(IPE1+1)=IPP1
                  IEDG(IPE1+2)=IPP2
                  IEDG(IPE1+3)=NTRI+1
                  IEDG(IPE1+4)=-1
                END IF
C
C Deal with the second edge of the triangle (joining points 2 and 3).
C
  102           IF (ABS(IOI2-IOI3).LE.1.AND.ABS(IOJ2-IOJ3).LE.1)
                  IDIR=(IOI2-IOI3)*(IOJ2-IOJ3)
                  IVOK=MOD(MIN(IOI2,IOI3)+MIN(IOJ2,IOJ3),2)
                  IF ((IDIR.EQ.0              ).OR.
     +                (IDIR.LT.0.AND.IVOK.EQ.0).OR.
     +                (IDIR.GT.0.AND.IVOK.EQ.1))
                    IF (IOI2.EQ.IOI3)
                      ITYP=1
                    ELSE IF (IOJ2.EQ.IOJ3)
                      ITYP=2
                    ELSE
                      ITYP=3
                    END IF
                    IOIM=MIN(IOI2,IOI3)
                    IOJM=MIN(IOJ2,IOJ3)
                    IF (ISCR(IOIM,IOJM,ITYP).GE.0)
                      IPE2=ISCR(IOIM,IOJM,ITYP)
                      IEDG(IPE2+4)=NTRI+2
                      GO TO 104
                    END IF
                    ISCR(IOIM,IOJM,ITYP)=NEDG
                    GO TO 103
                  END IF
                END IF
                DO (IPTE=0,NEDG-LOEN,LOEN)
                  IF ((IEDG(IPTE+1).EQ.IPP3.AND.
     +                 IEDG(IPTE+2).EQ.IPP2))
                    IPE2=IPTE
                    IEDG(IPE2+4)=NTRI+2
                    GO TO 104
                  END IF
                END DO
  103           IF (NEDG+LOEN.GT.MEDG)
                  CALL SETER ('VTTMRG - EDGE ARRAY IS TOO SMALL',6,1)
                  RETURN
                ELSE
                  IPE2=NEDG
                  NEDG=NEDG+LOEN
                  IEDG(IPE2+1)=IPP2
                  IEDG(IPE2+2)=IPP3
                  IEDG(IPE2+3)=NTRI+2
                  IEDG(IPE2+4)=-1
                END IF
C
C Deal with the third edge of the triangle (joining points 3 and 1).
C
  104           IF (ABS(IOI3-IOI1).LE.1.AND.ABS(IOJ3-IOJ1).LE.1)
                  IDIR=(IOI3-IOI1)*(IOJ3-IOJ1)
                  IVOK=MOD(MIN(IOI3,IOI1)+MIN(IOJ3,IOJ1),2)
                  IF ((IDIR.EQ.0              ).OR.
     +                (IDIR.LT.0.AND.IVOK.EQ.0).OR.
     +                (IDIR.GT.0.AND.IVOK.EQ.1))
                    IF (IOI3.EQ.IOI1)
                      ITYP=1
                    ELSE IF (IOJ3.EQ.IOJ1)
                      ITYP=2
                    ELSE
                      ITYP=3
                    END IF
                    IOIM=MIN(IOI3,IOI1)
                    IOJM=MIN(IOJ3,IOJ1)
                    IF (ISCR(IOIM,IOJM,ITYP).GE.0)
                      IPE3=ISCR(IOIM,IOJM,ITYP)
                      IEDG(IPE3+4)=NTRI+3
                      GO TO 106
                    END IF
                    ISCR(IOIM,IOJM,ITYP)=NEDG
                    GO TO 105
                  END IF
                END IF
                DO (IPTE=0,NEDG-LOEN,LOEN)
                  IF ((IEDG(IPTE+1).EQ.IPP1.AND.
     +                 IEDG(IPTE+2).EQ.IPP3))
                    IPE3=IPTE
                    IEDG(IPE3+4)=NTRI+3
                    GO TO 106
                  END IF
                END DO
  105           IF (NEDG+LOEN.GT.MEDG)
                  CALL SETER ('VTTMRG - EDGE ARRAY IS TOO SMALL',7,1)
                  RETURN
                ELSE
                  IPE3=NEDG
                  NEDG=NEDG+LOEN
                  IEDG(IPE3+1)=IPP3
                  IEDG(IPE3+2)=IPP1
                  IEDG(IPE3+3)=NTRI+3
                  IEDG(IPE3+4)=-1
                END IF
C
C Finally, add the triangle itself to the triangle list.
C
  106           IF (NTRI+LOTN.GT.MTRI)
                  CALL SETER ('VTTMRG - TRIANGLE ARRAY IS TOO SMALL',
     +                                                              8,1)
                  RETURN
                ELSE
                  IPTT=NTRI
                  NTRI=NTRI+LOTN
                  ITRI(IPTT+1)=IPE1
                  ITRI(IPTT+2)=IPE2
                  ITRI(IPTT+3)=IPE3
                  ITRI(IPTT+4)=0
                END IF
C
  107         END DO
C
            END IF
C
          END DO
C
        END DO
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTTMTL (NTTO,TBUF,MBUF,NBUF,
     +                   IPPP,MPPP,NPPP,
     +                   IPPE,MPPE,NPPE,
     +                   RPNT,MPNT,NPNT,LOPN,
     +                   IEDG,MEDG,NEDG,LOEN,
     +                   ITRI,MTRI,NTRI,LOTN)
C
        DIMENSION TBUF(18,MBUF)
        DIMENSION IPPP(2,MPPP),IPPE(2,MPPE)
        DIMENSION RPNT(MPNT),IEDG(MEDG),ITRI(MTRI)
C
C The routine VTTMTL is called to process NTTO randomly-selected
C triangles from among the NBUF stored in the array TBUF, leaving the
C remaining NBUF-NTTO triangles at the beginning of the array.  New
C points are added to the point list in the array RPNT, new edges are
C added to the edge list in the array IEDG, and new triangles are
C added to the triangle list in the array ITRI.  The arrays IPPP and
C IPPE are used to keep tree-sorted lists of the points and the edges,
C respectively, so that no duplicate points or edges will be created.
C
        DO 102 I=1,NTTO
C
C Pick a value of IBUF between 1 and NTTO, inclusive.  The buffered
C triangle with index IBUF will be processed.
C
          IBUF=1+MAX(0,MIN(NBUF-1,INT(REAL(NBUF)*VTFRAN())))
C
C Use the function ICAVPT to get indices for each of the three points
C of the triangle in the point list and form the base indices (IPP1,
C IPP2, and IPP3) of the three points in the point list.
C
          IPP1=(ICAVPT(TBUF( 1,IBUF),
     +                 TBUF( 2,IBUF),
     +                 TBUF( 3,IBUF),
     +                 TBUF( 4,IBUF),
     +                 TBUF( 5,IBUF),
     +                 TBUF( 6,IBUF),
     +                 RPNT,LOPN,IPPP,MPPP,NPPP)-1)*LOPN
C
          IF (ICFELL('VTTMTL',1).NE.0) RETURN
C
          IPP2=(ICAVPT(TBUF( 7,IBUF),
     +                 TBUF( 8,IBUF),
     +                 TBUF( 9,IBUF),
     +                 TBUF(10,IBUF),
     +                 TBUF(11,IBUF),
     +                 TBUF(12,IBUF),
     +                 RPNT,LOPN,IPPP,MPPP,NPPP)-1)*LOPN
C
          IF (ICFELL('VTTMTL',2).NE.0) RETURN
C
          IPP3=(ICAVPT(TBUF(13,IBUF),
     +                 TBUF(14,IBUF),
     +                 TBUF(15,IBUF),
     +                 TBUF(16,IBUF),
     +                 TBUF(17,IBUF),
     +                 TBUF(18,IBUF),
     +                 RPNT,LOPN,IPPP,MPPP,NPPP)-1)*LOPN
C
          IF (ICFELL('VTTMTL',3).NE.0) RETURN
C
C Use the function ICAEDG to get indices for each of the three edges of
C the triangle in the edge list and form the base indices (IPE1, IPE2,
C and IPE3) of the three edges in the edge list.  At the same time, set
C the pointer from each edge node into the new triangle we're about to
C create (to the left or to the right, as appropriate).
C
          IPE1=(ICAEDG(IPP1,IPP2,IEDG,LOEN,IPPE,MPPE,NPPE,RPNT)-1)*LOEN
C
          IF (ICFELL('VTTMTL',4).NE.0) RETURN
C
          IF (IEDG(IPE1+1).EQ.IPP1)
            IEDG(IPE1+3)=NTRI+1
          ELSE
            IEDG(IPE1+4)=NTRI+1
          END IF
C
          IPE2=(ICAEDG(IPP2,IPP3,IEDG,LOEN,IPPE,MPPE,NPPE,RPNT)-1)*LOEN
C
          IF (ICFELL('VTTMTL',5).NE.0) RETURN
C
          IF (IEDG(IPE2+1).EQ.IPP2)
            IEDG(IPE2+3)=NTRI+2
          ELSE
            IEDG(IPE2+4)=NTRI+2
          END IF
C
          IPE3=(ICAEDG(IPP3,IPP1,IEDG,LOEN,IPPE,MPPE,NPPE,RPNT)-1)*LOEN
C
          IF (ICFELL('VTTMTL',6).NE.0) RETURN
C
          IF (IEDG(IPE3+1).EQ.IPP3)
            IEDG(IPE3+3)=NTRI+3
          ELSE
            IEDG(IPE3+4)=NTRI+3
          END IF
C
C Add the new triangle to the triangle list.
C
          IF (NTRI+LOTN.GT.MTRI)
            CALL SETER ('VTTMTL - TRIANGLE ARRAY IS TOO SMALL',7,1)
            RETURN
          ELSE
            IPTT=NTRI
            NTRI=NTRI+LOTN
            ITRI(IPTT+1)=IPE1
            ITRI(IPTT+2)=IPE2
            ITRI(IPTT+3)=IPE3
            ITRI(IPTT+4)=0
          END IF
C
C Copy the last triangle in the triangle buffer to the vacated slot left
C by the one just processed.
C
          IF (IBUF.NE.NBUF)
            DO 101 J=1,12
              TBUF(J,IBUF)=TBUF(J,NBUF)
  101       CONTINUE
          END IF
C
C Reduce the count of the number of triangles in the buffer.
C
          NBUF=NBUF-1
C
C Continue looping until NTTO triangles have been processed.
C
  102   CONTINUE
C
C Set the pointers that tell the caller how many points and edges were
C created.
C
        NPNT=NPPP*LOPN
        NEDG=NPPE*LOEN
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTTMTX (NTTO,TBUF,MBUF,NBUF,
     +                   EPST,
     +                   IPPP,MPPP,NPPP,
     +                   IPPE,MPPE,NPPE,
     +                   RPNT,MPNT,NPNT,LOPN,
     +                   IEDG,MEDG,NEDG,LOEN,
     +                   ITRI,MTRI,NTRI,LOTN)
C
        DIMENSION TBUF(18,MBUF)
        DIMENSION IPPP(3,MPPP),IPPE(2,MPPE)
        DIMENSION RPNT(MPNT),IEDG(MEDG),ITRI(MTRI)
C
C The routine VTTMTX is called to process NTTO randomly-selected
C triangles from among the NBUF stored in the array TBUF, leaving the
C remaining NBUF-NTTO triangles at the beginning of the array.  New
C points are added to the point list in the array RPNT, new edges are
C added to the edge list in the array IEDG, and new triangles are
C added to the triangle list in the array ITRI.  The arrays IPPP and
C IPPE are used to keep tree-sorted lists of the points and the edges,
C respectively, so that no duplicate points or edges will be created.
C The argument EPST is an epsilon used in testing whether or not two
C coordinate values are the same or not.
C
        DO 102 I=1,NTTO
C
C Pick a value of IBUF between 1 and NTTO, inclusive.  The buffered
C triangle with index IBUF will be processed.
C
          IBUF=1+MAX(0,MIN(NBUF-1,INT(REAL(NBUF)*VTFRAN())))
C
C Use the function ICAVPX to get indices for each of the three points
C of the triangle in the point list and form the base indices (IPP1,
C IPP2, and IPP3) of the three points in the point list.
C
          IPP1=(ICAVPX(TBUF( 1,IBUF),
     +                 TBUF( 2,IBUF),
     +                 TBUF( 3,IBUF),
     +                 TBUF( 4,IBUF),
     +                 TBUF( 5,IBUF),
     +                 TBUF( 6,IBUF),
     +                 RPNT,LOPN,IPPP,MPPP,NPPP,EPST)-1)*LOPN
C
          IF (ICFELL('VTTMTX',1).NE.0) RETURN
C
          IPP2=(ICAVPX(TBUF( 7,IBUF),
     +                 TBUF( 8,IBUF),
     +                 TBUF( 9,IBUF),
     +                 TBUF(10,IBUF),
     +                 TBUF(11,IBUF),
     +                 TBUF(12,IBUF),
     +                 RPNT,LOPN,IPPP,MPPP,NPPP,EPST)-1)*LOPN
C
          IF (ICFELL('VTTMTX',2).NE.0) RETURN
C
          IPP3=(ICAVPX(TBUF(13,IBUF),
     +                 TBUF(14,IBUF),
     +                 TBUF(15,IBUF),
     +                 TBUF(16,IBUF),
     +                 TBUF(17,IBUF),
     +                 TBUF(18,IBUF),
     +                 RPNT,LOPN,IPPP,MPPP,NPPP,EPST)-1)*LOPN
C
          IF (ICFELL('VTTMTX',3).NE.0) RETURN
C
C Use the function ICAEDG to get indices for each of the three edges of
C the triangle in the edge list and form the base indices (IPE1, IPE2,
C and IPE3) of the three edges in the edge list.  At the same time, set
C the pointer from each edge node into the new triangle we're about to
C create (to the left or to the right, as appropriate).
C
          IPE1=(ICAEDG(IPP1,IPP2,IEDG,LOEN,IPPE,MPPE,NPPE,RPNT)-1)*LOEN
C
          IF (ICFELL('VTTMTX',4).NE.0) RETURN
C
          IF (IEDG(IPE1+1).EQ.IPP1)
            IEDG(IPE1+3)=NTRI+1
          ELSE
            IEDG(IPE1+4)=NTRI+1
          END IF
C
          IPE2=(ICAEDG(IPP2,IPP3,IEDG,LOEN,IPPE,MPPE,NPPE,RPNT)-1)*LOEN
C
          IF (ICFELL('VTTMTX',5).NE.0) RETURN
C
          IF (IEDG(IPE2+1).EQ.IPP2)
            IEDG(IPE2+3)=NTRI+2
          ELSE
            IEDG(IPE2+4)=NTRI+2
          END IF
C
          IPE3=(ICAEDG(IPP3,IPP1,IEDG,LOEN,IPPE,MPPE,NPPE,RPNT)-1)*LOEN
C
          IF (ICFELL('VTTMTX',6).NE.0) RETURN
C
          IF (IEDG(IPE3+1).EQ.IPP3)
            IEDG(IPE3+3)=NTRI+3
          ELSE
            IEDG(IPE3+4)=NTRI+3
          END IF
C
C Add the new triangle to the triangle list.
C
          IF (NTRI+LOTN.GT.MTRI)
            CALL SETER ('VTTMTX - TRIANGLE ARRAY IS TOO SMALL',7,1)
            RETURN
          ELSE
            IPTT=NTRI
            NTRI=NTRI+LOTN
            ITRI(IPTT+1)=IPE1
            ITRI(IPTT+2)=IPE2
            ITRI(IPTT+3)=IPE3
            ITRI(IPTT+4)=0
          END IF
C
C Copy the last triangle in the triangle buffer to the vacated slot left
C by the one just processed.
C
          IF (IBUF.NE.NBUF)
            DO 101 J=1,12
              TBUF(J,IBUF)=TBUF(J,NBUF)
  101       CONTINUE
          END IF
C
C Reduce the count of the number of triangles in the buffer.
C
          NBUF=NBUF-1
C
C Continue looping until NTTO triangles have been processed.
C
  102   CONTINUE
C
C Set the pointers that tell the caller how many points and edges were
C created.
C
        NPNT=NPPP*LOPN
        NEDG=NPPE*LOEN
C
C Done.
C
        RETURN
C
      END


I***********************************************************************
I  V A S P A C K T   -   U S E R - C A L L B A C K   R O U T I N E S
I***********************************************************************


      SUBROUTINE HLUVTCHIL (IFLG)
C
C This routine stands between VASPACKT and the user call-back routine
C VTCHIL.  When HLUs are not in use, this version of the routine gets
C loaded, so that VTCHIL is called.  When HLUs are in use, another
C version gets loaded; it either does the appropriate thing for the
C purposes of the HLUs or calls VTCHIL.
C
        CALL VTCHIL (IFLG)
C
        RETURN
C
      END


      SUBROUTINE VTCHIL (IFLG)
C
C This routine is a dummy.  It is called just before and just after
C each action involving the informational label.  A user version may
C take action to change the label.
C
C IFLG is positive if an action is about to be taken, negative if an
C action has just been completed.  The action in question is implied
C by the absolute value of IFLG, as follows:
C
C   1 - deciding whether to put the informational label at a given point
C   2 - filling the box around the informational label
C   3 - drawing the informational label
C   4 - outlining the box around the informational label
C
C VTCHIL may retrieve the values of the internal parameters 'LBX' and
C 'LBY', which are the coordinates of the center point of the label,
C in the current user coordinate system.
C
C When IFLG is 1 or 3, VTCHIL is permitted to change the value of the
C internal parameter 'CTM' (a character string); if IFLG is 1 and 'CTM'
C is made blank, the label is suppressed; otherwise, the new value of
C 'CTM' will replace whatever VASPACKT was about to use.  If this is
C done for either IFLG = 1 or IFLG = 3, it must be done for both, and
C the same replacement label must be supplied in both cases.
C
C When IFLG = 2, 3, or 4, VTCHIL may make GKS calls to change color
C or line width; during the following call with IFLG = -2, -3, or -4,
C such changes should be undone.
C
        RETURN
C
      END


      SUBROUTINE HLUVTCHZF (IFLG)
C
C This routine stands between VASPACKT and the user call-back routine
C VTCHZF.  When HLUs are not in use, this version of the routine gets
C loaded, so that VTCHZF is called.  When HLUs are in use, another
C version gets loaded; it either does the appropriate thing for the
C purposes of the HLUs or calls VTCHZF.
C
        CALL VTCHZF (IFLG)
C
        RETURN
C
      END


      SUBROUTINE VTCHZF (IFLG)
C
C This routine is a dummy.  It is called just before and just after
C each action involving a zero-field label.  A user version may
C take action to change the label.
C
C IFLG is positive if an action is about to be taken, negative if an
C action has just been completed.  The action in question is implied
C by the absolute value of IFLG, as follows:
C
C   1 - computing the size of the zero-field label
C   2 - filling the box around the zero-field label
C   3 - drawing the zero-field label
C   4 - outlining the box around the zero-field label
C
C When IFLG = 2, 3, or 4, VTCHZF may make GKS calls to change color
C or line width; during the following call with IFLG = -2, -3, or -4,
C such changes should be undone.
C
        RETURN
C
      END


      SUBROUTINE HLUVTMXYZ (IMAP,XINP,YINP,ZINP,XOTP,YOTP)
C
C This routine stands between VASPACKT and the user call-back routine
C VTMXYZ.  When HLUs are not in use, this version of the routine gets
C loaded, so that VTMXYZ is called.  When HLUs are in use, another
C version gets loaded; it either does the appropriate thing for the
C purposes of the HLUs or calls VTMXYZ.
C
        CALL VTMXYZ (IMAP,XINP,YINP,ZINP,XOTP,YOTP)
C
        RETURN
C
      END


      SUBROUTINE VTMXYZ (IMAP,XINP,YINP,ZINP,XOTP,YOTP)
C
C Define the constant required to convert an angle from radians to
C degrees.
C
        DATA RTOD / 57.2957795130823 /
C
C If IMAP = 1, treat XINP, YINP, and ZINP as the coordinates of a point
C on the unit sphere.  Compute the latitude and longitude of that point
C and then use EZMAP to find its projection on a map.
C
        IF (IMAP.EQ.1)
C
          RLAT=RTOD*ASIN(ZINP/SQRT(XINP*XINP+YINP*YINP+ZINP*ZINP))
C
          IF (XINP.EQ.0..AND.YINP.EQ.0.)
            RLON=0.
          ELSE
            RLON=RTOD*ATAN2(YINP,XINP)
          END IF
C
          CALL MAPTRA (RLAT,RLON,XOTP,YOTP)
C
C If IMAP = -1, use EZMAP to see if a point on a map is the projection
C of some point on the globe.  (If not, 1.E12s are returned in XOTP and
C YOTP.)
C
        ELSE IF (IMAP.EQ.-1)
C
          CALL MAPTRI (XINP,YINP,XOTP,YOTP)
C
C If IMAP = 2, call TDPACK to project the point (XINP,YINP,ZINP) into
C the projection plane.
C
        ELSE IF (IMAP.EQ.2)
C
          CALL TDPRPT (XINP,YINP,ZINP,XOTP,YOTP)
C
C In all other cases, just do the identity mapping.
C
        ELSE
C
          XOTP=XINP
          YOTP=YINP
C
        END IF
C
        RETURN
C
      END


I***********************************************************************
I  V A S P A C K T   -   T D P A C K - A W A R E   S U B R O U T I N E S
I***********************************************************************


      SUBROUTINE VTTDBF (RPNT,IEDG,ITRI,RWRK,IWRK,IFLG,ATOL)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C This routine assumes that TDPACK routines are being used to map the
C triangular mesh from 3-space into 2-space.  It sets blocking flags
C for the triangles in the triangle list so as to block those that are
C seen from the wrong side or too nearly edge on and/or those that are
C invisible because they are behind other triangles of the mesh.  The
C partially blocked mesh can then be used to draw streamlines; if the
C mesh is a fine one, this can do a fair job of solving the hidden-line
C problem.
C
C RPNT is an array of nodes defining vertices of triangles.
C
C IEDG is an array of nodes defining edges of triangles.
C
C ITRI is an array of nodes defining triangles.
C
C RWRK is the user's real workspace array.
C
C IWRK is the user's integer workspace array.
C
C IFLG is a flag set to 1 to block triangles that are seen from the
C wrong side or too nearly edge on, to 2 to block triangles that are
C invisible because they are hidden by other triangles, or to 3 to do
C both of the above.  One can also set IFLG to zero to simply clear
C the blocking flags that this routine is capable of setting.
C
C ATOL is a tolerance, in degrees, to be used in determining whether
C or not a triangle is nearly edge-on to the line of sight.  Use a
C value near zero.
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C
C The variables in the following common block define TDPACK's mapping
C from 3-space to 2-space.
C
        COMMON /TDCOM1/ IH,IT,XM,YM,ZM,XO,YO,ZO,XT,YT,ZT,OE,XE,YE,ZE
        COMMON /TDCOM1/ A1,B1,C1,D1,E1,A2,B2,C2,D2,E2,A3,B3,C3,D3,E3
        COMMON /TDCOM1/ IS,FV,VL,VR,VB,VT,WL,WR,WB,WT
        SAVE   /TDCOM1/
C
C Declare a radians-to-degrees conversion constant.
C
        DATA RTOD / 57.2957795130823 /
C
C SIDE(X1,Y1,X2,Y2,X3,Y3) is negative if the three vertices of a given
C triangle in the plane are in clockwise order, positive if they are in
C counterclockwise order.  A zero value means that the three points are
C collinear.
C
        SIDE(X1,Y1,X2,Y2,X3,Y3)=(X1-X3)*(Y2-Y3)-(Y1-Y3)*(X2-X3)
C
C IXOR(IONE,ITWO) is the exclusive OR of the 12-bit masks IONE and ITWO.
C
        IXOR(IONE,ITWO)=IAND(IOR(IONE,ITWO),4095-IAND(IONE,ITWO))
C
C ITBF(IARG) is non-zero if and only if a triangle with blocking-flag
C element IARG is blocked by the user.
C
        ITBF(IARG)=IAND(IAND(IXOR(IARG,ITBX),ITBA),1)
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTTDBF - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C If initialization has not been done, log an error and quit.
C
        IF (INIT.EQ.0)
          CALL SETER ('VTTDBF - INITIALIZATION CALL NOT DONE',2,1)
          RETURN
        END IF
C
C Extract the values of ITBX and ITBA from ITBM.
C
        ITBX=IAND(ISHIFT(ITBM,-12),4095)
        ITBA=IAND(       ITBM     ,4095)
C
C Determine which bits of the blocking flags are to be used and set
C IBIT accordingly.
C
        IF (OE.GE.0.)
          IBIT=2
        ELSE
          IBIT=16
        END IF
C
C Set a mask used to clear the bits that might be set.
C
        ICLB=127-7*IBIT
C
C Make a pass over the triangle list.  At the very least, this pass will
C clear the blocking bits for all triangles.  If IFLG is 1 or 3, it will
C also block triangles that are seen from the wrong side or are too
C nearly edge-on.  If IFLG is 2 or 3, it will also compute the bounding
C box for all triangles in the mesh that are not user-blocked and a
C largest extent in X and Y for any single such triangle.
C
        IF (IFLG.EQ.2.OR.IFLG.EQ.3)
C
          XMNM=XWDR
          XMXM=XWDL
          YMNM=YWDT
          YMXM=YWDB
C
          XEXT=0.
          YEXT=0.
C
        END IF
C
        DO 101 IPTT=0,NTRI-LOTN,LOTN
C
C Use only triangles not blocked by the user.
C
          IF (ITBF(ITRI(IPTT+4)).NE.0) GO TO 101
C
C Clear the bits that might be set by this call.
C
          ITRI(IPTT+4)=IAND(ITRI(IPTT+4),ICLB)
C
C Find the base index of point 1 (that edges 1 and 2 have in common).
C
          IF (IEDG(ITRI(IPTT+1)+1).EQ.IEDG(ITRI(IPTT+2)+1).OR.
     +        IEDG(ITRI(IPTT+1)+1).EQ.IEDG(ITRI(IPTT+2)+2))
            IPT1=IEDG(ITRI(IPTT+1)+1)
          ELSE
            IPT1=IEDG(ITRI(IPTT+1)+2)
          END IF
C
C Find the base index of point 2 (that edges 2 and 3 have in common).
C
          IF (IEDG(ITRI(IPTT+2)+1).EQ.IEDG(ITRI(IPTT+3)+1).OR.
     +        IEDG(ITRI(IPTT+2)+1).EQ.IEDG(ITRI(IPTT+3)+2))
            IPT2=IEDG(ITRI(IPTT+2)+1)
          ELSE
            IPT2=IEDG(ITRI(IPTT+2)+2)
          END IF
C
C Find the base index of point 3 (that edges 3 and 1 have in common).
C
          IF (IEDG(ITRI(IPTT+3)+1).EQ.IEDG(ITRI(IPTT+1)+1).OR.
     +        IEDG(ITRI(IPTT+3)+1).EQ.IEDG(ITRI(IPTT+1)+2))
            IPT3=IEDG(ITRI(IPTT+3)+1)
          ELSE
            IPT3=IEDG(ITRI(IPTT+3)+2)
          END IF
C
C Project all three points.
C
          CALL TDPRPT (RPNT(IPT1+1),RPNT(IPT1+2),RPNT(IPT1+3),XPT1,YPT1)
          CALL TDPRPT (RPNT(IPT2+1),RPNT(IPT2+2),RPNT(IPT2+3),XPT2,YPT2)
          CALL TDPRPT (RPNT(IPT3+1),RPNT(IPT3+2),RPNT(IPT3+3),XPT3,YPT3)
C
C If requested, check for triangles that are wrong-side on or edge-on.
C
          IF (IFLG.EQ.1.OR.IFLG.EQ.3)
C
C If the wrong side of the triangle faces the eye, set a bit.
C
            IF (SIDE(XPT1,YPT1,XPT2,YPT2,XPT3,YPT3).LE.0.)
C
              ITRI(IPTT+4)=IOR(ITRI(IPTT+4),IBIT)
C
            END IF
C
C If the triangle is nearly edge-on to the eye, set a different bit.
C
            IF (ATOL.GT.0.)
C
              XDN1=RPNT(IPT1+2)*(RPNT(IPT3+3)-RPNT(IPT2+3))+
     +             RPNT(IPT2+2)*(RPNT(IPT1+3)-RPNT(IPT3+3))+
     +             RPNT(IPT3+2)*(RPNT(IPT2+3)-RPNT(IPT1+3))
              YDN1=RPNT(IPT1+1)*(RPNT(IPT2+3)-RPNT(IPT3+3))+
     +             RPNT(IPT2+1)*(RPNT(IPT3+3)-RPNT(IPT1+3))+
     +             RPNT(IPT3+1)*(RPNT(IPT1+3)-RPNT(IPT2+3))
              ZDN1=RPNT(IPT1+1)*(RPNT(IPT3+2)-RPNT(IPT2+2))+
     +             RPNT(IPT2+1)*(RPNT(IPT1+2)-RPNT(IPT3+2))+
     +             RPNT(IPT3+1)*(RPNT(IPT2+2)-RPNT(IPT1+2))
C
              XDN2=XE-(RPNT(IPT1+1)+RPNT(IPT2+1)+RPNT(IPT3+1))/3.
              YDN2=YE-(RPNT(IPT1+2)+RPNT(IPT2+2)+RPNT(IPT3+2))/3.
              ZDN2=ZE-(RPNT(IPT1+3)+RPNT(IPT2+3)+RPNT(IPT3+3))/3.
C
              IF ((XDN1.NE.0..OR.YDN1.NE.0..OR.ZDN1.NE.0.).AND.
     +            (XDN2.NE.0..OR.YDN2.NE.0..OR.ZDN2.NE.0.))
                ANGD=RTOD*ABS(ACOS((XDN1*XDN2+YDN1*YDN2+ZDN1*ZDN2)/
     +                        SQRT((XDN1*XDN1+YDN1*YDN1+ZDN1*ZDN1)*
     +                             (XDN2*XDN2+YDN2*YDN2+ZDN2*ZDN2))))
              ELSE
                ANGD=90.
              END IF
C
              IF (ANGD.GT.90.-ATOL.AND.ANGD.LT.90.+ATOL)
                ITRI(IPTT+4)=IOR(ITRI(IPTT+4),2*IBIT)
              END IF
C
            END IF
C
          END IF
C
C Update info required for the second pass (if that pass is to be done).
C
          IF (IFLG.EQ.2.OR.IFLG.EQ.3)
C
            XMNM=MIN(XMNM,XPT1,XPT2,XPT3)
            XMXM=MAX(XMXM,XPT1,XPT2,XPT3)
            YMNM=MIN(YMNM,YPT1,YPT2,YPT3)
            YMXM=MAX(YMXM,YPT1,YPT2,YPT3)
C
            XEXT=MAX(XEXT,MAX(XPT1,XPT2,XPT3)-MIN(XPT1,XPT2,XPT3))
            YEXT=MAX(YEXT,MAX(YPT1,YPT2,YPT3)-MIN(YPT1,YPT2,YPT3))
C
          END IF
C
  101   CONTINUE
C
C We are done if the second pass is not to be done or if the bounding
C box was improperly computed for some reason.
C
        IF (IFLG.NE.2.AND.IFLG.NE.3) RETURN
C
        IF (XMNM.GE.XMXM.OR.YMNM.GE.YMXM) RETURN
C
C Grab a chunk of integer workspace to use.
C
        RWTH=(XMXM-XMNM)/(YMXM-YMNM)
        IBLM=MAX(10,INT(SQRT(RWTH*REAL(LIWB))))
        IBLN=MAX(10,LIWB/IBLM)
        CALL VTGIWS (IWRK,1,IBLM*IBLN,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('VTTDBF',3).NE.0) GO TO 105
C
C For pass two, we use the next higher bit in the blocking flag.
C
        IBIT=IBIT*4
C
C Sort the triangles into an IBLMxIBLN array of bins.  This should help
C to speed up our search for those that overlap each other.  First,
C initialize all the bin pointers to nulls.
C
        DO (I=1,IBLM*IBLN)
          IWRK(II01+I)=0
        END DO
C
C Put each triangle that isn't blocked by the user into one of the bins,
C based on the position of its center point in user space.
C
        DO 102 IPTT=0,NTRI-LOTN,LOTN
C
          IF (ITBF(ITRI(IPTT+4)).NE.0) GO TO 102
C
          IF (IEDG(ITRI(IPTT+1)+1).EQ.IEDG(ITRI(IPTT+2)+1).OR.
     +        IEDG(ITRI(IPTT+1)+1).EQ.IEDG(ITRI(IPTT+2)+2))
            IPT1=IEDG(ITRI(IPTT+1)+1)
          ELSE
            IPT1=IEDG(ITRI(IPTT+1)+2)
          END IF
C
          IF (IEDG(ITRI(IPTT+2)+1).EQ.IEDG(ITRI(IPTT+3)+1).OR.
     +        IEDG(ITRI(IPTT+2)+1).EQ.IEDG(ITRI(IPTT+3)+2))
            IPT2=IEDG(ITRI(IPTT+2)+1)
          ELSE
            IPT2=IEDG(ITRI(IPTT+2)+2)
          END IF
C
          IF (IEDG(ITRI(IPTT+3)+1).EQ.IEDG(ITRI(IPTT+1)+1).OR.
     +        IEDG(ITRI(IPTT+3)+1).EQ.IEDG(ITRI(IPTT+1)+2))
            IPT3=IEDG(ITRI(IPTT+3)+1)
          ELSE
            IPT3=IEDG(ITRI(IPTT+3)+2)
          END IF
C
          CALL TDPRPT (RPNT(IPT1+1),RPNT(IPT1+2),RPNT(IPT1+3),XPT1,YPT1)
          CALL TDPRPT (RPNT(IPT2+1),RPNT(IPT2+2),RPNT(IPT2+3),XPT2,YPT2)
          CALL TDPRPT (RPNT(IPT3+1),RPNT(IPT3+2),RPNT(IPT3+3),XPT3,YPT3)
C
          XMDT=(XPT1+XPT2+XPT3)/3.
          YMDT=(YPT1+YPT2+YPT3)/3.
C
          I=MAX(1,MIN(IBLM,1+INT(REAL(IBLM)*((XMDT-XMNM)/(XMXM-XMNM)))))
          J=MAX(1,MIN(IBLN,1+INT(REAL(IBLN)*((YMDT-YMNM)/(YMXM-YMNM)))))
C
          ITRI(IPTT+4)=IWRK(II01+(I-1)*IBLN+J)+IAND(ITRI(IPTT+4),127)
          IWRK(II01+(I-1)*IBLN+J)=128*(IPTT/LOTN+1)
C
  102   CONTINUE
C
C Set the blocking flag for each triangle not already blocked by the
C user as implied by what's between the triangle and the eye.
C
        DO 104 IPTA=0,NTRI-LOTN,LOTN
C
C Use only triangles not blocked by the user.
C
          IF (ITBF(ITRI(IPTA+4)).NE.0) GO TO 104
C
C Find the base index of point 1 (that edges 1 and 2 have in common).
C
          IF (IEDG(ITRI(IPTA+1)+1).EQ.IEDG(ITRI(IPTA+2)+1).OR.
     +        IEDG(ITRI(IPTA+1)+1).EQ.IEDG(ITRI(IPTA+2)+2))
            IPA1=IEDG(ITRI(IPTA+1)+1)
          ELSE
            IPA1=IEDG(ITRI(IPTA+1)+2)
          END IF
C
C Find the base index of point 2 (that edges 2 and 3 have in common).
C
          IF (IEDG(ITRI(IPTA+2)+1).EQ.IEDG(ITRI(IPTA+3)+1).OR.
     +        IEDG(ITRI(IPTA+2)+1).EQ.IEDG(ITRI(IPTA+3)+2))
            IPA2=IEDG(ITRI(IPTA+2)+1)
          ELSE
            IPA2=IEDG(ITRI(IPTA+2)+2)
          END IF
C
C Find the base index of point 3 (that edges 3 and 1 have in common).
C
          IF (IEDG(ITRI(IPTA+3)+1).EQ.IEDG(ITRI(IPTA+1)+1).OR.
     +        IEDG(ITRI(IPTA+3)+1).EQ.IEDG(ITRI(IPTA+1)+2))
            IPA3=IEDG(ITRI(IPTA+3)+1)
          ELSE
            IPA3=IEDG(ITRI(IPTA+3)+2)
          END IF
C
C Project all three points.
C
          CALL TDPRPT (RPNT(IPA1+1),RPNT(IPA1+2),RPNT(IPA1+3),XPA1,YPA1)
          CALL TDPRPT (RPNT(IPA2+1),RPNT(IPA2+2),RPNT(IPA2+3),XPA2,YPA2)
          CALL TDPRPT (RPNT(IPA3+1),RPNT(IPA3+2),RPNT(IPA3+3),XPA3,YPA3)
C
C Compute coefficients defining the plane of triangle A.
C
          ACTA=(RPNT(IPA1+2)-RPNT(IPA2+2))*
     +         (RPNT(IPA2+3)-RPNT(IPA3+3))-
     +         (RPNT(IPA2+2)-RPNT(IPA3+2))*
     +         (RPNT(IPA1+3)-RPNT(IPA2+3))
          BCTA=(RPNT(IPA1+3)-RPNT(IPA2+3))*
     +         (RPNT(IPA2+1)-RPNT(IPA3+1))-
     +         (RPNT(IPA2+3)-RPNT(IPA3+3))*
     +         (RPNT(IPA1+1)-RPNT(IPA2+1))
          CCTA=(RPNT(IPA1+1)-RPNT(IPA2+1))*
     +         (RPNT(IPA2+2)-RPNT(IPA3+2))-
     +         (RPNT(IPA2+1)-RPNT(IPA3+1))*
     +         (RPNT(IPA1+2)-RPNT(IPA2+2))
C
          DNOM=SQRT(ACTA*ACTA+BCTA*BCTA+CCTA*CCTA)
C
          ACTA=ACTA/DNOM
          BCTA=BCTA/DNOM
          CCTA=CCTA/DNOM
C
          DCTA=-ACTA*RPNT(IPA1+1)-BCTA*RPNT(IPA1+2)
     +                           -CCTA*RPNT(IPA1+3)
C
C Compute the minimum and maximum X and Y for a box around triangle A
C in which the center of an overlapping triangle might lie.
C
          XMNT=MIN(XPA1,XPA2,XPA3)-.5*XEXT
          XMXT=MAX(XPA1,XPA2,XPA3)+.5*XEXT
          YMNT=MIN(YPA1,YPA2,YPA3)-.5*YEXT
          YMXT=MAX(YPA1,YPA2,YPA3)+.5*YEXT
C
C See which bins we need to look at to be sure of finding any triangle
C that could overlap triangle A.
C
          IMIN=MAX(1,MIN(IBLM,1+INT(REAL(IBLM)*
     +                                      ((XMNT-XMNM)/(XMXM-XMNM)))))
          IMAX=MAX(1,MIN(IBLM,1+INT(REAL(IBLM)*
     +                                      ((XMXT-XMNM)/(XMXM-XMNM)))))
          JMIN=MAX(1,MIN(IBLN,1+INT(REAL(IBLN)*
     +                                      ((YMNT-YMNM)/(YMXM-YMNM)))))
          JMAX=MAX(1,MIN(IBLN,1+INT(REAL(IBLN)*
     +                                      ((YMXT-YMNM)/(YMXM-YMNM)))))
C
C Loop through all the bins.
C
          DO (I=IMIN,IMAX)
C
            DO (J=JMIN,JMAX)
C
C Test each triangle in the bin to see if it is between triangle A and
C the eye.
C
              IPTB=(IWRK(II01+(I-1)*IBLN+J)/128-1)*LOTN
C
              WHILE (IPTB.GE.0)
C
C Don't compare the triangle with itself.
C
                IF (IPTB.EQ.IPTA) GO TO 103
C
C Find the base index of point 1 (that edges 1 and 2 have in common).
C
                IF (IEDG(ITRI(IPTB+1)+1).EQ.IEDG(ITRI(IPTB+2)+1).OR.
     +              IEDG(ITRI(IPTB+1)+1).EQ.IEDG(ITRI(IPTB+2)+2))
                  IPB1=IEDG(ITRI(IPTB+1)+1)
                ELSE
                  IPB1=IEDG(ITRI(IPTB+1)+2)
                END IF
C
C Find the base index of point 2 (that edges 2 and 3 have in common).
C
                IF (IEDG(ITRI(IPTB+2)+1).EQ.IEDG(ITRI(IPTB+3)+1).OR.
     +              IEDG(ITRI(IPTB+2)+1).EQ.IEDG(ITRI(IPTB+3)+2))
                  IPB2=IEDG(ITRI(IPTB+2)+1)
                ELSE
                  IPB2=IEDG(ITRI(IPTB+2)+2)
                END IF
C
C Find the base index of point 3 (that edges 3 and 1 have in common).
C
                IF (IEDG(ITRI(IPTB+3)+1).EQ.IEDG(ITRI(IPTB+1)+1).OR.
     +              IEDG(ITRI(IPTB+3)+1).EQ.IEDG(ITRI(IPTB+1)+2))
                  IPB3=IEDG(ITRI(IPTB+3)+1)
                ELSE
                  IPB3=IEDG(ITRI(IPTB+3)+2)
                END IF
C
C Project all three points.
C
                CALL TDPRPT (RPNT(IPB1+1),RPNT(IPB1+2),RPNT(IPB1+3),
     +                                                    XPB1,YPB1)
                CALL TDPRPT (RPNT(IPB2+1),RPNT(IPB2+2),RPNT(IPB2+3),
     +                                                    XPB2,YPB2)
                CALL TDPRPT (RPNT(IPB3+1),RPNT(IPB3+2),RPNT(IPB3+3),
     +                                                    XPB3,YPB3)
C
C See if projected triangles overlap and, if so, get coordinates of a
C point they have in common.
C
                CALL VTPITT (XPA1,YPA1,XPA2,YPA2,XPA3,YPA3,
     +                       XPB1,YPB1,XPB2,YPB2,XPB3,YPB3,
     +                       XPI2,YPI2,INTF)
C
C If they do have a point in common ...
C
                IF (INTF.NE.0)
C
C ... compute 3-space coordinates of that point, ...
C
                  XPI3=XO+XPI2*A2+YPI2*A3
                  YPI3=YO+XPI2*B2+YPI2*B3
                  ZPI3=ZO+XPI2*C2+YPI2*C3
C
C ... compute coefficients defining the plane of the 2nd triangle, ...
C
                  ACTB=(RPNT(IPB1+2)-RPNT(IPB2+2))*
     +                 (RPNT(IPB2+3)-RPNT(IPB3+3))-
     +                 (RPNT(IPB2+2)-RPNT(IPB3+2))*
     +                 (RPNT(IPB1+3)-RPNT(IPB2+3))
                  BCTB=(RPNT(IPB1+3)-RPNT(IPB2+3))*
     +                 (RPNT(IPB2+1)-RPNT(IPB3+1))-
     +                 (RPNT(IPB2+3)-RPNT(IPB3+3))*
     +                 (RPNT(IPB1+1)-RPNT(IPB2+1))
                  CCTB=(RPNT(IPB1+1)-RPNT(IPB2+1))*
     +                 (RPNT(IPB2+2)-RPNT(IPB3+2))-
     +                 (RPNT(IPB2+1)-RPNT(IPB3+1))*
     +                 (RPNT(IPB1+2)-RPNT(IPB2+2))
C
                  DNOM=SQRT(ACTB*ACTB+BCTB*BCTB+CCTB*CCTB)
C
                  ACTB=ACTB/DNOM
                  BCTB=BCTB/DNOM
                  CCTB=CCTB/DNOM
C
                  DCTB=-ACTB*RPNT(IPB1+1)-BCTB*RPNT(IPB1+2)
     +                                   -CCTB*RPNT(IPB1+3)
C
C ... find out for what values of S the line from the eye to the point
C intersects the triangles, ...
C
                  SFTA=-(ACTA*XE+BCTA*YE+CCTA*ZE+DCTA)/
     +                  (ACTA*(XPI3-XE)+BCTA*(YPI3-YE)+CCTA*(ZPI3-ZE))
C
                  SFTB=-(ACTB*XE+BCTB*YE+CCTB*ZE+DCTB)/
     +                  (ACTB*(XPI3-XE)+BCTB*(YPI3-YE)+CCTB*(ZPI3-ZE))
C
C ... and, if the first triangle is further away from the eye than the
C second one, block it.
C
                  IF (SFTA.GT.1.0001*SFTB)
                    ITRI(IPTA+4)=IOR(ITRI(IPTA+4),IBIT)
                    GO TO 104
                  END IF
C
                END IF
C
  103           IPTB=(ITRI(IPTB+4)/128-1)*LOTN
C
              END WHILE
C
            END DO
C
          END DO
C
  104   CONTINUE
C
C Clear the upper bits in the blocking flags.
C
        DO (IPTT=0,NTRI-LOTN,LOTN)
          ITRI(IPTT+4)=IAND(ITRI(IPTT+4),127)
        END DO
C
C Release the integer workspace acquired above.
C
  105   LI01=0
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTTDBM (IHBX,IEBX,IWBX,IUBX,IHBA,IEBA,IWBA,IUBA)
C
C This routine assumes that TDPACK routines are being used to map the
C triangular mesh from 3-space into 2-space.  It sets the triangle
C blocking mask parameter ITBM as directed by the user.  All arguments
C have one of the two values 0 or 1 and are as follows:
C
C IHBX, IEBX, IWBX, and IUBX are set to zero to leave a particular bit
C of a blocking flag unchanged or to one to toggle that bit.  IHBX
C is associated with the bit that says a triangle is hidden by other
C triangles, IEBX with the bit that says a triangle is nearly edge-on
C to the line of sight, IWBX with the bit that says a triangle is on
C the "wrong" side of the mesh, and IUBX with the bit that says a
C triangle is blocked by the user.
C
C IHBA, IEBA, IWBA, and IUBA are set to zero to ignore a particular bit
C of a blocking flag unchanged or to one to examine that bit.  IHBA
C is associated with the bit that says a triangle is hidden by other
C triangles, IEBA with the bit that says a triangle is nearly edge-on
C to the line of sight, IWBA with the bit that says a triangle is on
C the "wrong" side of the mesh, and IUBA with the bit that says a
C triangle is blocked by the user.
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C
C The variables in the following common block define TDPACK's mapping
C from 3-space to 2-space.
C
        COMMON /TDCOM1/ IH,IT,XM,YM,ZM,XO,YO,ZO,XT,YT,ZT,OE,XE,YE,ZE
        COMMON /TDCOM1/ A1,B1,C1,D1,E1,A2,B2,C2,D2,E2,A3,B3,C3,D3,E3
        COMMON /TDCOM1/ IS,FV,VL,VR,VB,VT,WL,WR,WB,WT
        SAVE   /TDCOM1/
C
C Create the proper values of ITBX and ITBA, depending on which eye is
C in use.
C
        IF (OE.LT.0.)
          ITBX=64*IAND(IHBX,1)+
     +         32*IAND(IEBX,1)+
     +         16*IAND(IWBX,1)+
     +            IAND(IUBX,1)
          ITBA=64*IAND(IHBA,1)+
     +         32*IAND(IEBA,1)+
     +         16*IAND(IWBA,1)+
     +            IAND(IUBA,1)
        ELSE
          ITBX= 8*IAND(IHBX,1)+
     +          4*IAND(IEBX,1)+
     +          2*IAND(IWBX,1)+
     +            IAND(IUBX,1)
          ITBA= 8*IAND(IHBA,1)+
     +          4*IAND(IEBA,1)+
     +          2*IAND(IWBA,1)+
     +            IAND(IUBA,1)
        END IF
C
C Pack the parameter values into the variable that holds them.
C
        ITBM=IOR(ISHIFT(ITBX,12),ITBA)
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTTDDM (RPNT,IEDG,ITRI,RWRK,IWRK,IDIA)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C This routine assumes that TDPACK routines are being used to map the
C triangular mesh from 3-space into 2-space and calls the routine
C TDLINE to draw it.
C
C RPNT is an array of nodes defining vertices of triangles.
C
C IEDG is an array of nodes defining edges of triangles.
C
C ITRI is an array of nodes defining triangles.
C
C RWRK is the user's real workspace array.
C
C IWRK is the user's integer workspace array.
C
C IDIA is a flag that can be used to activate or deactivate the drawing
C of line segments.  If IDIA is non-zero, then element IDIA of each edge
C node must be a flag that says whether or not that edge is to be drawn
C (element value zero) or not (element value non-zero).
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C IXOR(IONE,ITWO) is the exclusive OR of the 12-bit masks IONE and ITWO.
C
        IXOR(IONE,ITWO)=IAND(IOR(IONE,ITWO),4095-IAND(IONE,ITWO))
C
C ITBF(IARG) is non-zero if and only if a triangle with blocking-flag
C element IARG is blocked.
C
        ITBF(IARG)=IAND(IXOR(IARG,ITBX),ITBA)
C
C Extract the values of ITBX and ITBA from ITBM.
C
        ITBX=IAND(ISHIFT(ITBM,-12),4095)
        ITBA=IAND(       ITBM     ,4095)
C
C Draw the mesh.
C
        DO 101 IPTE=0,NEDG-LOEN,LOEN
C
          IF (IDIA.NE.0.AND.IEDG(IPTE+IDIA).NE.0) GO TO 101
C
          IFLL=0
C
          IF (IEDG(IPTE+3).GE.0)
            IF (ITBF(ITRI(LOTN*((IEDG(IPTE+3)-1)/LOTN)+4)).EQ.0) IFLL=1
          END IF
C
          IFLR=0
C
          IF (IEDG(IPTE+4).GE.0)
            IF (ITBF(ITRI(LOTN*((IEDG(IPTE+4)-1)/LOTN)+4)).EQ.0) IFLR=1
          END IF
C
          IF (IFLL.NE.0.OR.IFLR.NE.0)
C
            CALL TDLINE (RPNT(IEDG(IPTE+1)+1),
     +                   RPNT(IEDG(IPTE+1)+2),
     +                   RPNT(IEDG(IPTE+1)+3),
     +                   RPNT(IEDG(IPTE+2)+1),
     +                   RPNT(IEDG(IPTE+2)+2),
     +                   RPNT(IEDG(IPTE+2)+3))
C
          END IF
C
  101   CONTINUE
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTTDFM (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C This routine assumes that TDPACK routines are being used to map the
C triangular mesh from 3-space into 2-space and arranges to color-fill
C all the visible triangles of it.
C
C RPNT is an array of nodes defining vertices of triangles.
C
C IEDG is an array of nodes defining edges of triangles.
C
C ITRI is an array of nodes defining triangles.
C
C RWRK is the user's real workspace array.
C
C IWRK is the user's integer workspace array.
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C
C Declare arrays to hold projected triangle coordinates for color fill.
C
        DIMENSION XFLL(3),YFLL(3)
C
C IXOR(IONE,ITWO) is the exclusive OR of the 12-bit masks IONE and ITWO.
C
        IXOR(IONE,ITWO)=IAND(IOR(IONE,ITWO),4095-IAND(IONE,ITWO))
C
C ITBF(IARG) is non-zero if and only if a triangle with blocking-flag
C element IARG is blocked.
C
        ITBF(IARG)=IAND(IXOR(IARG,ITBX),ITBA)
C
C Extract the values of ITBX and ITBA from ITBM.
C
        ITBX=IAND(ISHIFT(ITBM,-12),4095)
        ITBA=IAND(       ITBM     ,4095)
C
C Project and fill the unblocked triangles of the mesh.
C
        DO (I=0,NTRI-LOTN,LOTN)
C
          IF (ITBF(ITRI(I+4)).EQ.0)
C
            IF (IEDG(ITRI(I+2)+1).NE.IEDG(ITRI(I+3)+1).AND.
     +          IEDG(ITRI(I+2)+1).NE.IEDG(ITRI(I+3)+2))
              IPP1=IEDG(ITRI(I+2)+1)
              IPP2=IEDG(ITRI(I+2)+2)
            ELSE
              IPP1=IEDG(ITRI(I+2)+2)
              IPP2=IEDG(ITRI(I+2)+1)
            END IF
C
            IF (IEDG(ITRI(I+1)+1).NE.IPP1)
              IPP3=IEDG(ITRI(I+1)+1)
            ELSE
              IPP3=IEDG(ITRI(I+1)+2)
            END IF
C
            CALL TDPRPT (RPNT(IPP1+1),RPNT(IPP1+2),RPNT(IPP1+3),
     +                                                  XFLL(1),YFLL(1))
C
            CALL TDPRPT (RPNT(IPP2+1),RPNT(IPP2+2),RPNT(IPP2+3),
     +                                                  XFLL(2),YFLL(2))
C
            CALL TDPRPT (RPNT(IPP3+1),RPNT(IPP3+2),RPNT(IPP3+3),
     +                                                  XFLL(3),YFLL(3))
C
            CALL GFA (3,XFLL,YFLL)
C
          END IF
C
        END DO
C
C Done.
C
        RETURN
C
      END


I***********************************************************************
I  V A S P A C K T   -   I N T E R N A L   S U B R O U T I N E S
I***********************************************************************


      SUBROUTINE VTZFLB (IACT,RWRK,IAMA)
C
        DIMENSION RWRK(*),IAMA(*)
C
C VTZFLB generates the zero-field label.  If IACT = 1, the label is
C plotted.  If IACT = 2, the label box is added to the area map in IAMA.
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C
C Declare local arrays to hold coordinates for area fill of boxes.
C
        DIMENSION BFXC(4),BFYC(4)
C
C Define some local arrays in which to retrieve information from GKS.
C
        DIMENSION DUMI(4),VPRT(4),WIND(4)
C
C Define some arithmetic statement functions to get from the fractional
C system to the world system.
C
        CFWX(X)=WIND(1)+(WIND(2)-WIND(1))*(X-VPRT(1))/(VPRT(2)-VPRT(1))
        CFWY(Y)=WIND(3)+(WIND(4)-WIND(3))*(Y-VPRT(3))/(VPRT(4)-VPRT(3))
C
C Retrieve the definitions of the current GKS window and viewport.
C
        CALL GQCNTN (IGER,NCNT)
C
        IF (IGER.NE.0)
          CALL SETER ('VTZFLB - ERROR EXIT FROM GQCNTN',1,1)
          RETURN
        END IF
C
        CALL GQNT (NCNT,IGER,WIND,VPRT)
C
        IF (IGER.NE.0)
          CALL SETER ('VTZFLB - ERROR EXIT FROM GQNT',2,1)
          RETURN
        END IF
C
C If the text string for the zero-field label is blank, do nothing.
C
        IF (TXZF(1:LTZF).EQ.' ') RETURN
C
C Otherwise, form the zero-field label ...
C
        DVAL=DMIN
        CALL VTSBST (TXZF(1:LTZF),CTMA,LCTM)
C
C ... get sizing information for the label ...
C
        XPFS=XVPL+CXZF*(XVPR-XVPL)
        YPFS=YVPB+CYZF*(YVPT-YVPB)
        XLBC=CFUX(XPFS)
        IF (ICFELL('VTZFLB',3).NE.0) RETURN
        YLBC=CFUY(YPFS)
        IF (ICFELL('VTZFLB',4).NE.0) RETURN
        WCFS=CHWM*WCZF*(XVPR-XVPL)
        WWFS=CHWM*WWZF*(XVPR-XVPL)
C
        CALL PCGETI ('TE',ISTE)
        IF (ICFELL('VTZFLB',5).NE.0) RETURN
        CALL PCSETI ('TE',1)
        IF (ICFELL('VTZFLB',6).NE.0) RETURN
        CALL HLUVTCHZF (+1)
        IF (ICFELL('VTZFLB',7).NE.0) RETURN
        CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,360.,0.)
        IF (ICFELL('VTZFLB',8).NE.0) RETURN
        CALL HLUVTCHZF (-1)
        IF (ICFELL('VTZFLB',9).NE.0) RETURN
        CALL PCGETR ('DL',DSTL)
        IF (ICFELL('VTZFLB',10).NE.0) RETURN
        CALL PCGETR ('DR',DSTR)
        IF (ICFELL('VTZFLB',11).NE.0) RETURN
        CALL PCGETR ('DB',DSTB)
        IF (ICFELL('VTZFLB',12).NE.0) RETURN
        CALL PCGETR ('DT',DSTT)
        IF (ICFELL('VTZFLB',13).NE.0) RETURN
        CALL PCSETI ('TE',ISTE)
        IF (ICFELL('VTZFLB',14).NE.0) RETURN
        DSTL=DSTL+WWFS
        DSTR=DSTR+WWFS
        DSTB=DSTB+WWFS
        DSTT=DSTT+WWFS
C
C ... and then take the desired action, either plotting the label or
C putting a box around it into the area map.
C
        SINA=SIN(.017453292519943*ANZF)
        COSA=COS(.017453292519943*ANZF)
C
        IXPO=MOD(IPZF+4,3)-1
C
        IF (IXPO.LT.0)
          XPFS=XPFS+DSTL*COSA
          YPFS=YPFS+DSTL*SINA
        ELSE IF (IXPO.GT.0)
          XPFS=XPFS-DSTR*COSA
          YPFS=YPFS-DSTR*SINA
        END IF
C
        IYPO=(IPZF+4)/3-1
C
        IF (IYPO.LT.0)
          XPFS=XPFS-DSTB*SINA
          YPFS=YPFS+DSTB*COSA
        ELSE IF (IYPO.GT.0)
          XPFS=XPFS+DSTT*SINA
          YPFS=YPFS-DSTT*COSA
        END IF
C
        XLBC=CFUX(XPFS)
        IF (ICFELL('VTZFLB',15).NE.0) RETURN
        YLBC=CFUY(YPFS)
        IF (ICFELL('VTZFLB',16).NE.0) RETURN
C
        IF (IACT.EQ.1)
          IF (MOD(IBZF/2,2).NE.0)
            JLBC=ILBC
            IF (JLBC.GE.0)
              CALL GQFACI (IGER,ISFC)
              IF (IGER.NE.0)
                CALL SETER ('VTZFLB - ERROR EXIT FROM GQFACI',17,1)
                RETURN
              END IF
              IF (ISFC.NE.JLBC) CALL GSFACI (JLBC)
            END IF
            CALL HLUVTCHZF (+2)
            IF (ICFELL('VTZFLB',18).NE.0) RETURN
            BFXC(1)=CFWX(XPFS-DSTL*COSA+DSTB*SINA)
            IF (ICFELL('VTZFLB',19).NE.0) RETURN
            BFYC(1)=CFWY(YPFS-DSTL*SINA-DSTB*COSA)
            IF (ICFELL('VTZFLB',20).NE.0) RETURN
            BFXC(2)=CFWX(XPFS+DSTR*COSA+DSTB*SINA)
            IF (ICFELL('VTZFLB',21).NE.0) RETURN
            BFYC(2)=CFWY(YPFS+DSTR*SINA-DSTB*COSA)
            IF (ICFELL('VTZFLB',22).NE.0) RETURN
            BFXC(3)=CFWX(XPFS+DSTR*COSA-DSTT*SINA)
            IF (ICFELL('VTZFLB',23).NE.0) RETURN
            BFYC(3)=CFWY(YPFS+DSTR*SINA+DSTT*COSA)
            IF (ICFELL('VTZFLB',24).NE.0) RETURN
            BFXC(4)=CFWX(XPFS-DSTL*COSA-DSTT*SINA)
            IF (ICFELL('VTZFLB',25).NE.0) RETURN
            BFYC(4)=CFWY(YPFS-DSTL*SINA+DSTT*COSA)
            IF (ICFELL('VTZFLB',26).NE.0) RETURN
            CALL GFA (4,BFXC,BFYC)
            CALL HLUVTCHZF (-2)
            IF (ICFELL('VTZFLB',27).NE.0) RETURN
            IF (JLBC.GE.0)
              IF (ISFC.NE.JLBC) CALL GSFACI (ISFC)
            END IF
          END IF
          CALL GQPLCI (IGER,ISLC)
          IF (IGER.NE.0)
            CALL SETER ('VTZFLB - ERROR EXIT FROM GQPLCI',28,1)
            RETURN
          END IF
          CALL GQTXCI (IGER,ISTC)
          IF (IGER.NE.0)
            CALL SETER ('VTZFLB - ERROR EXIT FROM GQTXCI',29,1)
            RETURN
          END IF
          IF (ICZF.GE.0)
            JCZF=ICZF
          ELSE
            JCZF=ISTC
          END IF
          JSLC=ISLC
          JSTC=ISTC
          IF (JSLC.NE.JCZF)
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('VTZFLB',30).NE.0) RETURN
            CALL GSPLCI (JCZF)
            JSLC=JCZF
          END IF
          IF (JSTC.NE.JCZF)
            CALL GSTXCI (JCZF)
            JSTC=JCZF
          END IF
          CALL GQCLIP (IGER,IGCF,DUMI)
          IF (IGER.NE.0)
            CALL SETER ('VTZFLB - ERROR EXIT FROM GQCLIP',31,1)
            RETURN
          END IF
          IF (IGCF.NE.0)
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('VTZFLB',32).NE.0) RETURN
            CALL GSCLIP (0)
          END IF
          CALL HLUVTCHZF (+3)
          IF (ICFELL('VTZFLB',33).NE.0) RETURN
          CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,ANZF,0.)
          IF (ICFELL('VTZFLB',34).NE.0) RETURN
          CALL HLUVTCHZF (-3)
          IF (ICFELL('VTZFLB',35).NE.0) RETURN
          IF (IGCF.NE.0)
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('VTZFLB',36).NE.0) RETURN
            CALL GSCLIP (IGCF)
          END IF
          IF (MOD(IBZF,2).NE.0)
            WDTH=WLZF
            IF (WDTH.GT.0.)
              CALL GQLWSC (IGER,SFLW)
              IF (IGER.NE.0)
                CALL SETER ('VTZFLB - ERROR EXIT FROM GQLWSC',37,1)
                RETURN
              END IF
              CALL PLOTIF (0.,0.,2)
              IF (ICFELL('VTZFLB',38).NE.0) RETURN
              CALL GSLWSC (WDTH)
            END IF
            CALL HLUVTCHZF (+4)
            IF (ICFELL('VTZFLB',39).NE.0) RETURN
            CALL PLOTIF (XPFS-DSTL*COSA+DSTB*SINA,
     +                   YPFS-DSTL*SINA-DSTB*COSA,0)
            IF (ICFELL('VTZFLB',40).NE.0) RETURN
            CALL PLOTIF (XPFS+DSTR*COSA+DSTB*SINA,
     +                   YPFS+DSTR*SINA-DSTB*COSA,1)
            IF (ICFELL('VTZFLB',41).NE.0) RETURN
            CALL PLOTIF (XPFS+DSTR*COSA-DSTT*SINA,
     +                   YPFS+DSTR*SINA+DSTT*COSA,1)
            IF (ICFELL('VTZFLB',42).NE.0) RETURN
            CALL PLOTIF (XPFS-DSTL*COSA-DSTT*SINA,
     +                   YPFS-DSTL*SINA+DSTT*COSA,1)
            IF (ICFELL('VTZFLB',43).NE.0) RETURN
            CALL PLOTIF (XPFS-DSTL*COSA+DSTB*SINA,
     +                   YPFS-DSTL*SINA-DSTB*COSA,1)
            IF (ICFELL('VTZFLB',44).NE.0) RETURN
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('VTZFLB',45).NE.0) RETURN
            CALL HLUVTCHZF (-4)
            IF (ICFELL('VTZFLB',46).NE.0) RETURN
            IF (WDTH.GT.0.)
              CALL PLOTIF (0.,0.,2)
              IF (ICFELL('VTZFLB',47).NE.0) RETURN
              CALL GSLWSC (SFLW)
            END IF
          END IF
          IF (ISLC.NE.JSLC)
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('VTZFLB',48).NE.0) RETURN
            CALL GSPLCI (ISLC)
          END IF
          IF (ISTC.NE.JSTC) CALL GSTXCI (ISTC)
        ELSE
          CALL VTGRWS (RWRK,1,10,IWSE)
          IF (IWSE.NE.0.OR.ICFELL('VTZFLB',49).NE.0) RETURN
          ANLB=.017453292519943*ANZF
          SALB=SIN(ANLB)
          CALB=COS(ANLB)
          RWRK(IR01+ 1)=CFUX(XPFS-DSTL*CALB+DSTB*SALB)
          IF (ICFELL('VTZFLB',50).NE.0) RETURN
          RWRK(IR01+ 2)=CFUX(XPFS+DSTR*CALB+DSTB*SALB)
          IF (ICFELL('VTZFLB',51).NE.0) RETURN
          RWRK(IR01+ 3)=CFUX(XPFS+DSTR*CALB-DSTT*SALB)
          IF (ICFELL('VTZFLB',52).NE.0) RETURN
          RWRK(IR01+ 4)=CFUX(XPFS-DSTL*CALB-DSTT*SALB)
          IF (ICFELL('VTZFLB',53).NE.0) RETURN
          RWRK(IR01+ 5)=RWRK(IR01+1)
          RWRK(IR01+ 6)=CFUY(YPFS-DSTL*SALB-DSTB*CALB)
          IF (ICFELL('VTZFLB',54).NE.0) RETURN
          RWRK(IR01+ 7)=CFUY(YPFS+DSTR*SALB-DSTB*CALB)
          IF (ICFELL('VTZFLB',55).NE.0) RETURN
          RWRK(IR01+ 8)=CFUY(YPFS+DSTR*SALB+DSTT*CALB)
          IF (ICFELL('VTZFLB',56).NE.0) RETURN
          RWRK(IR01+ 9)=CFUY(YPFS-DSTL*SALB+DSTT*CALB)
          IF (ICFELL('VTZFLB',57).NE.0) RETURN
          RWRK(IR01+10)=RWRK(IR01+6)
          IF ((XWDL.LT.XWDR.AND.YWDB.LT.YWDT).OR.
     +        (XWDL.GT.XWDR.AND.YWDB.GT.YWDT))
            CALL AREDAM (IAMA,RWRK(IR01+1),RWRK(IR01+6),5,IGLB,-1,0)
            IF (ICFELL('VTZFLB',58).NE.0) RETURN
          ELSE
            CALL AREDAM (IAMA,RWRK(IR01+1),RWRK(IR01+6),5,IGLB,0,-1)
            IF (ICFELL('VTZFLB',59).NE.0) RETURN
          END IF
          LR01=0
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTRVSP
C
C Compute "realized" values of all size parameters.
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Compute a "realized" value for the spacing of simple vectors.
C
        IF (IISP.EQ.0)
          SVSR=SVSP
        ELSE
          SVSR=SVSP*EMAX
        END IF
C
C Compute a "realized" value of the vector reference length.
C
        IF (VRLN.LT.0.)
          VRLR=ABS(VRLN)*AVEL
        ELSE IF (VRLN.GT.0.)
          IF (IISP.EQ.0)
            VRLR=VRLN
          ELSE
            VRLR=VRLN*EMAX
          END IF
        ELSE
          IF (ISVT.EQ.0.OR.SVSR.EQ.0.)
            VRLR=AVEL*REAL(1+ISVT)
          ELSE
            VRLR=AVEL+2.*SVSR
          END IF
        END IF
C
C Compute a "realized" value of the vector reference magnitude.
C
        IF (VRMG.EQ.0.)
          VRMR=DMAX
        ELSE
          VRMR=VRMG
        END IF
C
C Compute "realized" values of the arrowhead length and spacing.
C
        IF (AHLN.LE.0.)
          AHLR=ABS(AHLN)*VRLR
        ELSE
          IF (IISP.EQ.0)
            AHLR=AHLN
          ELSE
            AHLR=AHLN*EMAX
          END IF
        END IF
C
        IF (IISP.EQ.0)
          AHSR=AHSP
        ELSE
          AHSR=AHSP*EMAX
        END IF
C
C Compute "realized" values of the streamline length, point spacing,
C streamline spacing, termination test length, and termination test
C spacing parameters.
C
        IF (IISP.EQ.0)
          SLLR=SLLN
          SLPR=SLPS
          SLSR=SLSP
          TTLR=TTLL
          TTSR=TTSP
        ELSE
          SLLR=SLLN*EMAX
          SLPR=SLPS*EMAX
          SLSR=SLSP*EMAX
          TTLR=TTLL*EMAX
          TTSR=TTSP*EMAX
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTVRLL (RADI,RLAT,RLON,NVEC,VMIN,VMAX,ICOL,CMIN,CMAX,
     +                   IAMA,RTPL)
C
        DIMENSION IAMA(*)
C
        EXTERNAL RTPL
C
C Draw a "vector rose" on a globe - centered at (0,0,0) and having a
C radius RADI - at a position specified by the latitude RLAT and the
C longitude RLON.  The zero line is assumed to point north.
C
C NVEC is the number of vectors to draw.
C
C VMIN and VMAX are minimum and maximum lengths of vectors to be drawn
C in each of the NVEC directions; if VMIN = VMAX, only one set of
C vectors will be drawn, except when both are zero, when the lengths
C used will be computed from the current value of the VASPACKT
C parameter 'VRL'.
C
C If ICOL is zero, the vectors are drawn in the color implied by the
C current value of the polyline color index, but, if ICOL is non-zero,
C the values in CMIN and CMAX are used to determine their colors; in
C either case, CMIN and CMAX must contain valid real values that will
C not cause arithmetic problems.
C
C IAMA is an array containing an area map against which the rose is to
C be masked.  If masking is not desired, set IAMA(1) = 0.
C
C RTPL is a routine to be called to draw the rose (when it is masked).
C
C Define a vector pointing at latitude 0, longitude 0.
C
        DCLU=1.
        DCLV=0.
        DCLW=0.
C
C Define a vector pointing north.
C
        DCZU=0.
        DCZV=0.
        DCZW=1.
C
C Rotate both the point and the vector to the desired position.
C
        CALL NGRITD (2,-RLAT,DCLU,DCLV,DCLW)
        CALL NGRITD (3,+RLON,DCLU,DCLV,DCLW)
C
        CALL NGRITD (2,-RLAT,DCZU,DCZV,DCZW)
        CALL NGRITD (3,+RLON,DCZU,DCZV,DCZW)
C
C Call VTVRAP to draw the vector rose.
C
        CALL VTVRAP (RADI*DCLU,RADI*DCLV,RADI*DCLW,DCLU,DCLV,DCLW,
     +               DCZU,DCZV,DCZW,NVEC,VMIN,VMAX,ICOL,CMIN,CMAX,
     +               IAMA,RTPL)
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTVRAP (UCEN,VCEN,WCEN,DCLU,DCLV,DCLW,DCZU,DCZV,DCZW,
     +                   NVEC,VMIN,VMAX,ICOL,CMIN,CMAX,IAMA,RTPL)
C
        DIMENSION IAMA(*)
C
        EXTERNAL RTPL
C
C Draw a "vector rose" at an arbitrary position in 3-space - centered
C at (UCEN,VCEN,WCEN), perpendicular to a line with direction cosines
C (DCNU,DCNV,DCNW), and having a zero line with direction cosines
C (DCZU,DCZV,DCZW).
C
C NVEC specifies the number of vectors to draw.
C
C VMIN and VMAX are minimum and maximum lengths of vectors to be
C drawn in each of the NVEC directions; if VMIN = VMAX, only one set
C of vectors will be drawn, except when both are zero, when the lengths
C used will be computed from the current value of the VASPACKT
C parameter 'VRL'.
C
C If ICOL is zero, the vectors drawn in each of the NVEC directions; if
C VMIN = VMAX, only one set of vectors will be drawn.  If ICOL is zero,
C the vectors are drawn in the color implied by the current value of
C the polyline color index, but, if ICOL is non-zero, the values in
C CMIN and CMAX are used to determine their colors; in either case,
C CMIN and CMAX must contain valid real values that will not cause
C arithmetic problems.
C
C IAMA is an array containing an area map against which the rose is to
C be masked.  If masking is not desired, set IAMA(1) = 0.
C
C RTPL is a routine to be called to draw the rose (when it is masked).
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Declare arrays for use in calling VTCUDR.
C
        DIMENSION UCRV(2),VCRV(2),WCRV(2),CCRV(2)
C
C Define a constant used to convert from degrees to radians.
C
        DATA DTOR / .017453292519943 /
C
C Compute "realized" values of various vector parameters.
C
        CALL VTRVSP
C
C Transfer the direction cosines of the normal to COMMON for use by
C TDCURV.
C
        DCNU=DCLU
        DCNV=DCLV
        DCNW=DCLW
C
C Compute the direction cosines of a vector perpendicular to both the
C normal and the zero line of the wind rose.
C
        DCPU=DCZV*DCLW-DCZW*DCLV
        DCPV=DCZW*DCLU-DCZU*DCLW
        DCPW=DCZU*DCLV-DCZV*DCLU
C
C The first point for each vector drawn is the same and the colors to
C be used are the same.
C
        UCRV(1)=UCEN
        VCRV(1)=VCEN
        WCRV(1)=WCEN
        CCRV(1)=CMAX
        CCRV(2)=CMAX
C
C Determine "realized" values of VMIN and VMAX.
C
        IF (VMIN.EQ.0..AND.VMAX.EQ.0.)
          RMIN=VFRA*VRLR
          RMAX=VRLR
        ELSE
          RMIN=VMIN
          RMAX=VMAX
        END IF
C
C Loop to draw the NVEC vectors of maximum length.
C
        DO 101 I=1,NVEC
          ANGD=(REAL(I-1)/REAL(NVEC))*360.
          ANGR=DTOR*ANGD
          SINA=SIN(ANGR)
          COSA=COS(ANGR)
          UCRV(2)=UCEN+RMAX*(SINA*DCPU+COSA*DCZU)
          VCRV(2)=VCEN+RMAX*(SINA*DCPV+COSA*DCZV)
          WCRV(2)=WCEN+RMAX*(SINA*DCPW+COSA*DCZW)
          CALL VTCUDR (UCRV,VCRV,WCRV,CCRV,2,ICOL,1,IAMA,RTPL)
  101   CONTINUE
C
C If requested, loop to draw the NVEC vectors of minimum length.
C
        IF (RMIN.NE.RMAX)
C
          CCRV(1)=CMIN
          CCRV(2)=CMIN
C
          DO 102 I=1,NVEC
            ANGD=(REAL(I-1)/REAL(NVEC))*360.
            ANGR=DTOR*ANGD
            SINA=SIN(ANGR)
            COSA=COS(ANGR)
            UCRV(2)=UCEN+RMIN*(SINA*DCPU+COSA*DCZU)
            VCRV(2)=VCEN+RMIN*(SINA*DCPV+COSA*DCZV)
            WCRV(2)=WCEN+RMIN*(SINA*DCPW+COSA*DCZW)
            CALL VTCUDR (UCRV,VCRV,WCRV,CCRV,2,ICOL,1,IAMA,RTPL)
  102     CONTINUE
C
        END IF
C
C Done.
C
        RETURN
C
      END


.OP   BI=66
      SUBROUTINE VTCUDR (UCRV,VCRV,WCRV,CCRV,NCRV,ICOL,IARH,IAMA,RTPL)
C
        DIMENSION UCRV(NCRV),VCRV(NCRV),WCRV(NCRV),CCRV(NCRV),IAMA(*)
C
        EXTERNAL RTPL
C
C Draw the projection of a curve in 3-space, as defined by the points
C (UCRV(I),VCRV(I),WCRV(I)), for I from 1 to NCRV.  For each I from 1
C to NCRV, CCRV(I) is the value of some real quantity associated with
C point I of the curve.
C
C If ICOL is zero, the entire curve is drawn in the color implied by
C the current value of the polyline color index, but, if ICOL is
C non-zero, the values in CCRV are used to determine its color; in
C either case, CCRV must contain valid real values that will not cause
C arithmetic problems.
C
C If IARH is non-zero, VTCUDR will draw the projection of an arrowhead
C at one end of the curve (at the beginning of it if IARH is negative,
C or at the end of it if IARH is positive).  What is used is a simple
C arrowhead, of length AHLR and half-width AHHR (both of which are
C computed from AHLN and AHAW, in COMMON), lying in a plane
C perpendicular to both the unit vector having components DCNU, DCNV,
C and DCNW, and to the terminal segment of the curve.
C
C IAMA is an array containing an area map against which the curve is to
C be masked.  If masking is not desired, set IAMA(1) = 0.
C
C RTPL is a routine to be called to draw the curve (when it is masked).
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Declare local arrays for user-system polyline coordinates.
C
        PARAMETER (MCPL=100)
        DIMENSION XCPL(MCPL),YCPL(MCPL)
C
C Declare local arrays to use in drawing masked polylines.
C
        PARAMETER (MCPF=MCPL,MNOG=64)
        DIMENSION XCPF(MCPF),YCPF(MCPF),IAAI(MNOG),IAGI(MNOG)
C
C Check for an uncleared prior error.
C
        IF (ICFELL('VTCUDR - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Compute the value of AHHR.
C
        AHHR=AHLR*TAN(.017453292519943*AHAW/2.)
C
C If the curve is to be colored according to the values in CCRV, save
C the current polyline color.
C
        IF (ICOL.NE.0.AND.ICTV.NE.0.AND.NCLR.NE.0)
          CALL GQPLCI (IGER,IPCS)
          IF (IGER.NE.0)
            CALL SETER ('VTCUDR - ERROR EXIT FROM GQPLCI',2,1)
            RETURN
          END IF
          IPCC=IPCS
          ICVL=(NCLR+1)/2
        ELSE
          IPCS=-1
          IPCC=-1
          IPCD=-1
        END IF
C
C Set some tolerances.
C
        EPSX=ABS(XWDR-XWDL)*EPSI
        EPSY=ABS(YWDT-YWDB)*EPSI
C
        SMLX=.01*ABS(XWDR-XWDL)
        SMLY=.01*ABS(YWDT-YWDB)
C
        PITX=PITH*ABS(XWDR-XWDL)
        PITY=PITH*ABS(YWDT-YWDB)
C
C Extract the data coordinates of the first point on the curve.
C
        UCND=UCRV(1)
        VCND=VCRV(1)
        WCND=WCRV(1)
        CCND=CCRV(1)
C
C Map the point (UCND,VCND,WCND) to the position (XCNU,YCNU).
C
        INVOKE (COMPUTE-USER-COORDINATES)
C
C Zero the number of points in the coordinate arrays and zero the
C variable that keeps track of the ratio of segment length in the user
C coordinate system to segment length in the data coordinate system.
C
        NCPL=0
        RUDN=0.
C
C Process the rest of the points on the curve.
C
        FOR (IPNT = 2 TO NCRV)
C
C Save the coordinates of the previous point on the curve and compute
C coordinates of a new one.
C
          UCOD=UCND
          VCOD=VCND
          WCOD=WCND
          CCOD=CCND
C
          XCOU=XCNU
          YCOU=YCNU
C
          IVOU=IVNU
C
          UCND=UCRV(IPNT)
          VCND=VCRV(IPNT)
          WCND=WCRV(IPNT)
          CCND=CCRV(IPNT)
C
C Map the point (UCND,VCND,WCND) to the position (XCNU,YCNU).
C
          INVOKE (COMPUTE-USER-COORDINATES)
C
C Deal with the line segment from the previous point to the new one.
C
          INVOKE (INTERPOLATE-POINTS-ALONG-SEGMENT)
C
C Loop back to find the next point on the curve.
C
        END FOR
C
C Process any remaining portion of the curve.
C
        INVOKE (CLEAR-POLYLINE-BUFFER)
C
C If an arrowhead is to be drawn at one end of the curve, do that.
C
        IF (NCRV.GE.2.AND.IARH.NE.0)
          IF (IARH.LT.0)
            UEND=UCRV(1)
            VEND=VCRV(1)
            WEND=WCRV(1)
            UBEG=UCRV(2)
            VBEG=VCRV(2)
            WBEG=WCRV(2)
            CCOD=CCRV(1)
            CCND=CCRV(1)
          ELSE
            UEND=UCRV(NCRV)
            VEND=VCRV(NCRV)
            WEND=WCRV(NCRV)
            UBEG=UCRV(NCRV-1)
            VBEG=VCRV(NCRV-1)
            WBEG=WCRV(NCRV-1)
            CCOD=CCRV(NCRV)
            CCND=CCRV(NCRV)
          END IF
          DNOM=SQRT((UEND-UBEG)**2+(VEND-VBEG)**2+(WEND-WBEG)**2)
          IF (DNOM.NE.0.)
            UDCC=(UEND-UBEG)/DNOM
            VDCC=(VEND-VBEG)/DNOM
            WDCC=(WEND-WBEG)/DNOM
            UDCP=VDCC*DCNW-WDCC*DCNV
            VDCP=WDCC*DCNU-UDCC*DCNW
            WDCP=UDCC*DCNV-VDCC*DCNU
            UACC=UEND-AHLR*UDCC
            VACC=VEND-AHLR*VDCC
            WACC=WEND-AHLR*WDCC
            UCND=UACC-AHHR*UDCP
            VCND=VACC-AHHR*VDCP
            WCND=WACC-AHHR*WDCP
            INVOKE (COMPUTE-USER-COORDINATES)
            UCOD=UCND
            VCOD=VCND
            WCOD=WCND
            XCOU=XCNU
            YCOU=YCNU
            IVOU=IVNU
            UCND=UEND
            VCND=VEND
            WCND=WEND
            INVOKE (COMPUTE-USER-COORDINATES)
            INVOKE (INTERPOLATE-POINTS-ALONG-SEGMENT)
            UCOD=UCND
            VCOD=VCND
            WCOD=WCND
            XCOU=XCNU
            YCOU=YCNU
            IVOU=IVNU
            UCND=UACC+AHHR*UDCP
            VCND=VACC+AHHR*VDCP
            WCND=WACC+AHHR*WDCP
            INVOKE (COMPUTE-USER-COORDINATES)
            INVOKE (INTERPOLATE-POINTS-ALONG-SEGMENT)
          END IF
          INVOKE (CLEAR-POLYLINE-BUFFER)
        END IF
C
C If the curve was colored according to the values in CCRV, restore the
C saved polyline color.
C
  101   IF (IPCS.GE.0) CALL GSPLCI (IPCS)
C
C Done.
C
        RETURN
C
C The following internal procedure, given a line segment, adds visible
C portions of it to the coordinate arrays.
C
        BLOCK (INTERPOLATE-POINTS-ALONG-SEGMENT)
C
C If point interpolation is turned on, do the first IPIS segments.
C
          IF (IPIS.NE.0)
            USOD=UCOD
            VSOD=VCOD
            WSOD=WCOD
            CSOD=CCOD
            USND=UCND
            VSND=VCND
            WSND=WCND
            CSND=CCND
            XSNU=XCNU
            YSNU=YCNU
            ISNU=IVNU
            FOR (INTP = 1 TO ABS(IPIS))
              UCND=USOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(USND-USOD)
              VCND=VSOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(VSND-VSOD)
              WCND=WSOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(WSND-WSOD)
              CCND=CSOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(CSND-CSOD)
              INVOKE (COMPUTE-USER-COORDINATES)
              IF (IPIS.GT.0.OR.IVNU.NE.IVOU)
                INVOKE (ADD-POINTS-TO-POLYLINE)
                UCOD=UCND
                VCOD=VCND
                WCOD=WCND
                CCOD=CCND
                XCOU=XCNU
                YCOU=YCNU
                IVOU=IVNU
              END IF
            END FOR
            UCND=USND
            VCND=VSND
            WCND=WSND
            CCND=CSND
            XCNU=XSNU
            YCNU=YSNU
            IVNU=ISNU
          END IF
C
C Finish off the job.
C
          INVOKE (ADD-POINTS-TO-POLYLINE)
C
        END BLOCK
C
C The following internal procedure examines the points (UCOD,VCOD,WCOD),
C which projects into (XCOU,YCOU), and (UCND,VCND,WCND), which projects
C into (XCNU,YCNU), either of which may be visible or invisible in the
C projection space, and adds visible portions of the line segment
C between them to the polyline being built.
C
        BLOCK (ADD-POINTS-TO-POLYLINE)
C
          IF (UCND.NE.UCOD.OR.VCND.NE.VCOD.OR.WCND.NE.WCOD)
C
            IF (NCPL.EQ.0)
              IF (IVOU.NE.0)
                IF (IMPF.NE.0.AND.PITH.GT.0.)
                  UCLD=UCOD
                  VCLD=VCOD
                  WCLD=WCOD
                  CCLD=CCOD
                  XCLU=XCOU
                  YCLU=YCOU
                END IF
                NCPL=1
                XCPL(1)=XCOU
                YCPL(1)=YCOU
                IF (IPCS.GE.0)
                  CVAL=CCOD
                  INVOKE (COMPUTE-COLOR-INDEX)
                  IPCD=IPCI
                END IF
              ELSE IF (IVNU.NE.0)
                UCID=UCOD
                VCID=VCOD
                WCID=WCOD
                CCID=CCOD
                UCVD=UCND
                VCVD=VCND
                WCVD=WCND
                CCVD=CCND
                XCVU=XCNU
                YCVU=YCNU
                INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
                INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
                UCOD=UCVD
                VCOD=VCVD
                WCOD=WCVD
                CCOD=CCVD
                XCOU=XCVU
                YCOU=YCVU
                IVOU=1
              END IF
            ELSE IF (NCPL.EQ.MCPL)
              INVOKE (FLUSH-POLYLINE-BUFFER)
            END IF
C
            IF (IVNU.NE.0)
              INVOKE (OUTPUT-NEXT-POINT)
            ELSE IF (IVOU.NE.0)
              UCVD=UCOD
              VCVD=VCOD
              WCVD=WCOD
              CCVD=CCOD
              XCVU=XCOU
              YCVU=YCOU
              UCID=UCND
              VCID=VCND
              WCID=WCND
              CCID=CCND
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              UKND=UCND
              VKND=VCND
              WKND=WCND
              CKND=CCND
              XKNU=XCNU
              YKNU=YCNU
              UCND=UCVD
              VCND=VCVD
              WCND=WCVD
              CCND=CCVD
              XCNU=XCVU
              YCNU=YCVU
              INVOKE (OUTPUT-NEXT-POINT)
              UCND=UKND
              VCND=VKND
              WCND=WKND
              CCND=CKND
              XCNU=XKNU
              YCNU=YKNU
              INVOKE (CLEAR-POLYLINE-BUFFER)
            END IF
C
          END IF
C
        END BLOCK
C
C The following internal procedure outputs the next point; if mapping
C is being done and there is a sufficiently large jump in the mapped
C position of the point, we check for a discontinuity in the mapping.
C Similarly, if mapping is being done and point interpolation is
C activated, we check for a large enough jump in the mapped position
C to justify interpolating points.
C
        BLOCK (OUTPUT-NEXT-POINT)
          IF (IMPF.NE.0.AND.
     +                   (UCND.NE.UCOD.OR.VCND.NE.VCOD.OR.WCND.NE.WCOD))
            RUDO=RUDN
            RUDN=(ABS(XCNU-XCOU)+ABS(YCNU-YCOU))/
     +           (ABS(UCND-UCOD)+ABS(VCND-VCOD)+ABS(WCND-WCOD))
            IF (RUDN.GT.2.*RUDO)
              INVOKE (CHECK-FOR-POSSIBLE-DISCONTINUITY)
            END IF
            IF (PITH.GT.0.)
              UCTD=UCND
              VCTD=VCND
              WCTD=WCND
              CCTD=CCND
              XCTU=XCNU
              YCTU=YCNU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
          END IF
          NCPL=NCPL+1
          XCPL(NCPL)=XCNU
          YCPL(NCPL)=YCNU
          IF (IPCS.GE.0)
            CVAL=CCND
            INVOKE (COMPUTE-COLOR-INDEX)
            IF (IPCI.NE.IPCD)
              INVOKE (FLUSH-POLYLINE-BUFFER)
              IPCD=IPCI
            END IF
          END IF
        END BLOCK
C
C The following internal procedure is invoked when an unusually large
C jump in the position of mapped points on the curve is seen.  It
C checks for a possible discontinuity in the mapping function (as
C can happen, for example, when a cylindrical equidistant projection
C is being used); if there is such a discontinuity, we must generate
C a final point on one side of it, dump the polyline, and then start
C a new polyline on the other side.
C
        BLOCK (CHECK-FOR-POSSIBLE-DISCONTINUITY)
          UC1D=UCOD
          VC1D=VCOD
          WC1D=WCOD
          CC1D=CCOD
          XC1U=XCOU
          YC1U=YCOU
          UC2D=UCND
          VC2D=VCND
          WC2D=WCND
          CC2D=CCND
          XC2U=XCNU
          YC2U=YCNU
          ITMP=0
          LOOP
            DSTO=ABS(XC2U-XC1U)+ABS(YC2U-YC1U)
            UC3D=(UC1D+UC2D)/2.
            VC3D=(VC1D+VC2D)/2.
            WC3D=(WC1D+WC2D)/2.
            CC3D=(CC1D+CC2D)/2.
            CALL HLUCTMXYZ (IMPF,UC3D,VC3D,WC3D,XC3U,YC3U)
            IF (ICFELL('VTCUDR',3).NE.0) GO TO 101
            IF (OORV.EQ.0..OR.(XC3U.NE.OORV.AND.YC3U.NE.OORV))
              DST1=ABS(XC3U-XC1U)+ABS(YC3U-YC1U)
              DST2=ABS(XC3U-XC2U)+ABS(YC3U-YC2U)
              IF (MIN(DST1,DST2).GT.DSTO)
                ITMP=1000
                EXIT
              ELSE IF (DST1.LT.DST2)
                EXIT IF (UC3D.EQ.UC1D.AND.VC3D.EQ.VC1D.AND.WC3D.EQ.WC1D)
                UC1D=UC3D
                VC1D=VC3D
                WC1D=WC3D
                CC1D=CC3D
                XC1U=XC3U
                YC1U=YC3U
              ELSE
                EXIT IF (UC3D.EQ.UC2D.AND.VC3D.EQ.VC2D.AND.WC3D.EQ.WC2D)
                UC2D=UC3D
                VC2D=VC3D
                WC2D=WC3D
                CC2D=CC3D
                XC2U=XC3U
                YC2U=YC3U
              END IF
              ITMP=ITMP+1
              EXIT IF (ITMP.EQ.64)
            ELSE
              UCVD=UCOD
              VCVD=VCOD
              WCVD=WCOD
              CCVD=CCOD
              XCVU=XCOU
              YCVU=YCOU
              UCID=UC3D
              VCID=VC3D
              WCID=WC3D
              CCID=CC3D
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              INVOKE (CLEAR-POLYLINE-BUFFER)
              UCID=UC3D
              VCID=VC3D
              WCID=WC3D
              CCID=CC3D
              UCVD=UCND
              VCVD=VCND
              WCVD=WCND
              CCVD=CCND
              XCVU=XCNU
              YCVU=YCNU
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              ITMP=1000
              EXIT
            END IF
          END LOOP
          IF (ITMP.NE.1000.AND.
     +               (ABS(XC1U-XC2U).GT.SMLX.OR.ABS(YC1U-YC2U).GT.SMLY))
            IF (IMPF.NE.0.AND.PITH.GT.0.)
              UCTD=UC1D
              VCTD=VC1D
              WCTD=WC1D
              CCTD=CC1D
              XCTU=XC1U
              YCTU=YC1U
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
            NCPL=NCPL+1
            XCPL(NCPL)=XC1U
            YCPL(NCPL)=YC1U
            INVOKE (CLEAR-POLYLINE-BUFFER)
            IF (IMPF.NE.0.AND.PITH.GT.0.)
              UCLD=UC2D
              VCLD=VC2D
              WCLD=WC2D
              CCLD=CC2D
              XCLU=XC2U
              YCLU=YC2U
            END IF
            NCPL=1
            XCPL(1)=XC2U
            YCPL(1)=YC2U
            IF (IPCS.GE.0)
              CVAL=CC2D
              INVOKE (COMPUTE-COLOR-INDEX)
              IPCD=IPCI
            END IF
          END IF
        END BLOCK
C
C Given two points in the data-array-index coordinate system, one of
C which maps to a visible point and the other of which maps to an
C invisible point, this internal routine searches the line between
C them for a point near the edge of visibility.
C
        BLOCK (INTERPOLATE-TO-VISIBLE-EDGE)
          ITMP=0
          LOOP
            UCHD=(UCVD+UCID)/2.
            VCHD=(VCVD+VCID)/2.
            WCHD=(WCVD+WCID)/2.
            CCHD=(CCVD+CCID)/2.
            CALL HLUCTMXYZ (IMPF,UCHD,VCHD,WCHD,XCHU,YCHU)
            IF (ICFELL('VTCUDR',4).NE.0) GO TO 101
            IF (XCHU.NE.OORV.AND.YCHU.NE.OORV)
              EXIT IF (UCHD.EQ.UCVD.AND.VCHD.EQ.VCVD.AND.WCHD.EQ.WCVD)
              UCVD=UCHD
              VCVD=VCHD
              WCVD=WCHD
              CCVD=CCHD
              XCVU=XCHU
              YCVU=YCHU
            ELSE
              EXIT IF (UCHD.EQ.UCID.AND.VCHD.EQ.VCID.AND.WCHD.EQ.WCID)
              UCID=UCHD
              VCID=VCHD
              WCID=WCHD
              CCID=CCHD
            END IF
            ITMP=ITMP+1
            EXIT IF (ITMP.EQ.64)
          END LOOP
        END BLOCK
C
C The following internal procedure outputs a visible edge point found
C by the previous internal procedure.
C
        BLOCK (OUTPUT-VISIBLE-EDGE-POINT)
          IF (PITH.GT.0.)
            IF (NCPL.EQ.0)
              UCLD=UCVD
              VCLD=VCVD
              WCLD=WCVD
              CCLD=CCVD
              XCLU=XCVU
              YCLU=YCVU
            ELSE
              UCTD=UCVD
              VCTD=VCVD
              WCTD=WCVD
              CCTD=CCVD
              XCTU=XCVU
              YCTU=YCVU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
          END IF
          NCPL=NCPL+1
          XCPL(NCPL)=XCVU
          YCPL(NCPL)=YCVU
          IF (IPCS.GE.0)
            CVAL=CCVD
            INVOKE (COMPUTE-COLOR-INDEX)
            IF (IPCI.NE.IPCD)
              INVOKE (FLUSH-POLYLINE-BUFFER)
              IPCD=IPCI
            END IF
          END IF
        END BLOCK
C
C The following internal procedure is invoked when mapping is being
C done and a new point is about to be added to the polyline buffer.
C It checks for a jump (using a user-defined threshold value) in
C the mapped coordinates of the point and, if such a jump is found,
C interpolates some points in between.  The assumption is made that
C all points in between are visible; if that is found not to be the
C case, no attempt is made to rectify the situation: the user probably
C screwed up the definition of the mapping function.
C
        BLOCK (CHECK-FOR-JUMP-IN-MAPPING)
          WHILE (ABS(XCTU-XCLU).GT.PITX.OR.ABS(YCTU-YCLU).GT.PITY)
            IFND=0
            UCQD=0.
            VCQD=0.
            WCQD=0.
            CCQD=0.
            RDST=.50
            RSTP=.25
            LOOP
              UCPD=UCLD+RDST*(UCTD-UCLD)
              VCPD=VCLD+RDST*(VCTD-VCLD)
              WCPD=WCLD+RDST*(WCTD-WCLD)
              CCPD=CCLD+RDST*(CCTD-CCLD)
              CALL HLUCTMXYZ (IMPF,UCPD,VCPD,WCPD,XCPU,YCPU)
              IF (ICFELL('VTCUDR',5).NE.0) GO TO 101
              EXIT IF (OORV.NE.0..AND.(XCPU.EQ.OORV.OR.YCPU.EQ.OORV))
              IF (ABS(XCPU-XCLU).LT.PITX.AND.ABS(YCPU-YCLU).LT.PITY)
                IFND=1
                UCQD=UCPD
                VCQD=VCPD
                WCQD=WCPD
                CCQD=CCPD
                XCQU=XCPU
                YCQU=YCPU
                EXIT IF (ABS(XCQU-XCLU).GT..5*PITX.OR.
     +                   ABS(YCQU-YCLU).GT..5*PITY)
                RDST=RDST+RSTP
              ELSE
                RDST=RDST-RSTP
              END IF
              RSTP=RSTP/2.
              EXIT IF (RSTP.LT..0001)
            END LOOP
            IF (IFND.NE.0.AND.(UCQD.NE.UCLD.OR.VCQD.NE.VCLD.OR.
     +                                         WCQD.NE.WCLD))
              NCPL=NCPL+1
              XCPL(NCPL)=XCQU
              YCPL(NCPL)=YCQU
              IF (IPCS.GE.0)
                CVAL=CCQD
                INVOKE (COMPUTE-COLOR-INDEX)
                IF (IPCI.NE.IPCD)
                  INVOKE (FLUSH-POLYLINE-BUFFER)
                  IPCD=IPCI
                END IF
              END IF
              IF (NCPL.EQ.MCPL)
                INVOKE (FLUSH-POLYLINE-BUFFER)
              END IF
              UCLD=UCQD
              VCLD=VCQD
              WCLD=WCQD
              CCLD=CCQD
              XCLU=XCQU
              YCLU=YCQU
            ELSE
              UCLD=UCTD
              VCLD=VCTD
              WCLD=WCTD
              CCLD=CCTD
              XCLU=XCTU
              YCLU=YCTU
            END IF
          END WHILE
          UCLD=UCTD
          VCLD=VCTD
          WCLD=WCTD
          CCLD=CCTD
          XCLU=XCTU
          YCLU=YCTU
        END BLOCK
C
C The following internal procedure is given the data-system coordinates
C of a point (UCND,VCND,WCND) and computes the user-system coordinates
C of the point's projection (XCNU,YCNU).  It also sets a flag indicating
C whether the projection point is visible or not.
C
        BLOCK (COMPUTE-USER-COORDINATES)
C
          IF (IMPF.EQ.0)
            XCNU=UCND
            YCNU=VCND
            IVNU=1
          ELSE
            CALL HLUCTMXYZ (IMPF,UCND,VCND,WCND,XCNU,YCNU)
            IF (ICFELL('VTCUDR',6).NE.0) GO TO 101
            IF ((OORV.NE.0.).AND.(XCNU.EQ.OORV.OR.YCNU.EQ.OORV))
              IVNU=0
            ELSE
              IVNU=1
            END IF
          END IF
C
        END BLOCK
C
C The following internal procedure, given a value (CVAL), computes a
C polyline color index (IPCI) to be used to get a desired color for a
C streamline being drawn.
C
        BLOCK (COMPUTE-COLOR-INDEX)
          WHILE (ICVL.GT.1.AND.CVAL.LT.TVAL(ICVL))
            ICVL=ICVL-1
          END WHILE
          WHILE (ICVL.LT.NCLR.AND.CVAL.GE.TVAL(ICVL+1))
            ICVL=ICVL+1
          END WHILE
          IPCI=ICLR(ICVL)
        END BLOCK
C
C The following internal procedure draws the part of the curve defined
C by the contents of the polyline buffer and then removes all but the
C last point from the buffer.  IPCC is the polyline color currently
C in use and IPCD the polyline color desired for the curve.
C
        BLOCK (FLUSH-POLYLINE-BUFFER)
C
          I=1
C
          LOOP
            I=I+1
            EXIT IF (I.GT.NCPL)
            IF (ABS(XCPL(I)-XCPL(I-1)).LT.EPSX.AND.
     +          ABS(YCPL(I)-YCPL(I-1)).LT.EPSY)
              IF (I.NE.NCPL)
                DO (J=I+1,NCPL)
                  XCPL(J-1)=XCPL(J)
                  YCPL(J-1)=YCPL(J)
                END DO
              ELSE
                XCPL(NCPL-1)=XCPL(NCPL)
                YCPL(NCPL-1)=YCPL(NCPL)
              END IF
              I=I-1
              NCPL=NCPL-1
            END IF
          END LOOP
C
          IF (NCPL.GT.1)
            IF (IPCC.NE.IPCD)
              CALL GSPLCI (IPCD)
              IPCC=IPCD
            END IF
            IF (IAMA(1).EQ.0)
              CALL CURVE (XCPL,YCPL,NCPL)
            ELSE
              CALL ARDRLN (IAMA,XCPL,YCPL,NCPL,
     +                          XCPF,YCPF,MCPF,
     +                          IAAI,IAGI,MNOG,RTPL)
            END IF
          END IF
C
          XCPL(1)=XCPL(NCPL)
          YCPL(1)=YCPL(NCPL)
          NCPL=1
C
        END BLOCK
C
C The following internal procedure draws the part of the curve defined
C by the contents of the polyline buffer and then clears the buffer.
C IPCC is the polyline color currently in use and IPCD the polyline
C color desired for the curve.
C
        BLOCK (CLEAR-POLYLINE-BUFFER)
C
          I=1
C
          LOOP
            I=I+1
            EXIT IF (I.GT.NCPL)
            IF (ABS(XCPL(I)-XCPL(I-1)).LT.EPSX.AND.
     +          ABS(YCPL(I)-YCPL(I-1)).LT.EPSY)
              IF (I.NE.NCPL)
                DO (J=I+1,NCPL)
                  XCPL(J-1)=XCPL(J)
                  YCPL(J-1)=YCPL(J)
                END DO
              ELSE
                XCPL(NCPL-1)=XCPL(NCPL)
                YCPL(NCPL-1)=YCPL(NCPL)
              END IF
              I=I-1
              NCPL=NCPL-1
            END IF
          END LOOP
C
          IF (NCPL.GT.1)
            IF (IPCC.NE.IPCD)
              CALL GSPLCI (IPCD)
              IPCC=IPCD
            END IF
            IF (IAMA(1).EQ.0)
              CALL CURVE (XCPL,YCPL,NCPL)
            ELSE
              CALL ARDRLN (IAMA,XCPL,YCPL,NCPL,
     +                          XCPF,YCPF,MCPF,
     +                          IAAI,IAGI,MNOG,RTPL)
            END IF
          END IF
C
          NCPL=0
          RUDN=0.
C
        END BLOCK
C
      END
.OP   BI=77


      SUBROUTINE VTGIWS (IWRK,IOWS,LOWS,IERR)
C
        DIMENSION IWRK(*)
C
C This subroutine is called to get a block of space, of a specified
C size, in the user's integer workspace array.  The block may or may
C not have been used before.
C
C IOWS is the index (into the arrays IIWS and LIWS) of the values
C saying where the block starts and how long it is.
C
C LOWS is the desired length.  The value 0 indicates that the maximum
C amount is desired; it will be replaced by the actual amount assigned.
C
C IERR is a returned error flag.  It will be 0 if no workspace overflow
C occurred, 1 if an overflow did occur.
C
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Check for argument error.
C
        IF (IOWS.LT.1.OR.IOWS.GT.$NBIW$.OR.LOWS.LT.0)
          CALL SETER ('VTGIWS - ARGUMENT ERROR - SEE SPECIALIST',1,1)
          RETURN
        END IF
C
C Clear error flag.
C
        IERR=0
C
C See if the desired amount of space is available.
C
        NLFT=LIWK
C
        DO (I=1,$NBIW$)
          IF (I.NE.IOWS.AND.LIWS(I).GT.0) NLFT=NLFT-LIWS(I)
        END DO
C
C If caller wants it all, arrange for that.
C
        IF (LOWS.LE.0) LOWS=NLFT
C
C Update the integer-workspace-used parameter.
C
        IIWU=MAX(IIWU,LIWK-NLFT+LOWS)
C
C If too little space is available, take whatever action the user has
C specified.
C
        IF (NLFT.LT.LOWS)
          IF (IWSO.LE.1)
     +      WRITE (I1MACH(4),'('' VTGIWS'',
     +                         I8,'' WORDS REQUESTED'',
     +                         I8,'' WORDS AVAILABLE'')') LOWS,NLFT
          IF (IWSO.LE.0)
            CALL SETER ('VTGIWS - INTEGER WORKSPACE OVERFLOW',2,2)
            STOP
          ELSE IF (IWSO.GE.3)
            CALL SETER ('VTGIWS - INTEGER WORKSPACE OVERFLOW',3,1)
          ELSE
            IERR=1
          END IF
          RETURN
        END IF
C
C It may be that a reduction in size has been requested.  That's easy.
C
        IF (LOWS.LE.LIWS(IOWS))
          LIWS(IOWS)=LOWS
          RETURN
        END IF
C
C Otherwise, what we do depends on whether the workspace associated
C with this index exists already.
C
        IF (LIWS(IOWS).LE.0)
C
C It does not exist.  Find (or create) an area large enough.  First,
C check for an open space large enough.
C
          JIWS=0
          REPEAT
            KIWS=LIWK
            IMIN=0
            DO (I=1,$NBIW$)
              IF (IIWS(I).GE.JIWS.AND.IIWS(I).LT.KIWS.AND.LIWS(I).GT.0)
                KIWS=IIWS(I)
                IMIN=I
              END IF
            END DO
            IF (KIWS-JIWS.GE.LOWS)
              IIWS(IOWS)=JIWS
              LIWS(IOWS)=LOWS
              RETURN
            END IF
            IF (IMIN.NE.0)
              JIWS=IIWS(IMIN)+LIWS(IMIN)
            END IF
          UNTIL (IMIN.EQ.0)
C
C If no space large enough was found, pack all the existing blocks
C into the beginning of the array, which will leave enough space at
C the end of it.
C
          JIWS=0
          REPEAT
            KIWS=LIWK
            IMIN=0
            DO (I=1,$NBIW$)
              IF (IIWS(I).GE.JIWS.AND.IIWS(I).LT.KIWS.AND.LIWS(I).GT.0)
                KIWS=IIWS(I)
                IMIN=I
              END IF
            END DO
            IF (IMIN.NE.0)
              IF (IIWS(IMIN).NE.JIWS)
                DO (I=1,LIWS(IMIN))
                  IWRK(JIWS+I)=IWRK(IIWS(IMIN)+I)
                END DO
                IIWS(IMIN)=JIWS
              END IF
              JIWS=JIWS+LIWS(IMIN)
            END IF
          UNTIL (IMIN.EQ.0)
C
          IIWS(IOWS)=JIWS
          LIWS(IOWS)=LOWS
          RETURN
C
        ELSE
C
C It exists.  Extend its length.  First, see if that can be done
C without moving anything around.
C
          JIWS=IIWS(IOWS)+LIWS(IOWS)
          KIWS=LIWK
          DO (I=1,$NBIW$)
            IF (IIWS(I).GE.JIWS.AND.IIWS(I).LT.KIWS.AND.LIWS(I).GT.0)
              KIWS=IIWS(I)
            END IF
          END DO
          IF (KIWS-JIWS.GE.LOWS)
            LIWS(IOWS)=LOWS
            RETURN
          END IF
C
C Blocks have to be moved.  Move those that precede the one to be
C lengthened and that one itself toward the beginning of the workspace.
C
          JIWS=0
          REPEAT
            KIWS=LIWK
            IMIN=0
            DO (I=1,$NBIW$)
              IF (IIWS(I).GE.JIWS.AND.IIWS(I).LT.KIWS.AND.LIWS(I).GT.0)
                KIWS=IIWS(I)
                IMIN=I
              END IF
            END DO
            IF (IMIN.NE.0)
              IF (IIWS(IMIN).NE.JIWS)
                DO (I=1,LIWS(IMIN))
                  IWRK(JIWS+I)=IWRK(IIWS(IMIN)+I)
                END DO
                IIWS(IMIN)=JIWS
              END IF
              JIWS=JIWS+LIWS(IMIN)
            END IF
          UNTIL (IMIN.EQ.0.OR.IMIN.EQ.IOWS)
C
C Move blocks that follow the one to be lengthened toward the end of
C the workspace.
C
          KIWS=LIWK
          REPEAT
            JIWS=IIWS(IOWS)+LIWS(IOWS)
            IMAX=0
            DO (I=1,$NBIW$)
              IF (IIWS(I).GE.JIWS.AND.IIWS(I).LT.KIWS.AND.LIWS(I).GT.0)
                JIWS=IIWS(I)+LIWS(I)
                IMAX=I
              END IF
            END DO
            IF (IMAX.NE.0)
              IF (JIWS.NE.KIWS)
                DO (I=LIWS(IMAX),1,-1)
                  IWRK(KIWS-LIWS(IMAX)+I)=IWRK(JIWS-LIWS(IMAX)+I)
                END DO
                IIWS(IMAX)=KIWS-LIWS(IMAX)
              END IF
              KIWS=IIWS(IMAX)
            END IF
          UNTIL (IMAX.EQ.0)
C
C There should now be room, so just update the length of the block.
C
          LIWS(IOWS)=LOWS
          RETURN
C
        END IF
C
      END


      SUBROUTINE VTGRWS (RWRK,IOWS,LOWS,IERR)
C
        DIMENSION RWRK(*)
C
C This subroutine is called to get a block of space, of a specified
C size, in the user's real workspace array.  The block may or may not
C have been used before.
C
C IOWS is the index (into the arrays IRWS and LRWS) of the values
C saying where the block starts and how long it is.
C
C LOWS is the desired length.  The value 0 indicates that the maximum
C amount is desired; it will be replaced by the actual amount assigned.
C
C IERR is a returned error flag.  It will be 0 if no workspace overflow
C occurred, 1 if an overflow did occur.
C
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Check for argument error.
C
        IF (IOWS.LT.1.OR.IOWS.GT.$NBRW$.OR.LOWS.LT.0)
          CALL SETER ('VTGRWS - ARGUMENT ERROR - SEE SPECIALIST',1,1)
          RETURN
        END IF
C
C Clear error flag.
C
        IERR=0
C
C See if the desired amount of space is available.
C
        NLFT=LRWK
C
        DO (I=1,$NBRW$)
          IF (I.NE.IOWS.AND.LRWS(I).GT.0) NLFT=NLFT-LRWS(I)
        END DO
C
C If caller wants it all, arrange for that.
C
        IF (LOWS.LE.0) LOWS=NLFT
C
C Update the real-workspace-used parameter.
C
        IRWU=MAX(IRWU,LRWK-NLFT+LOWS)
C
C If too little space is available, take whatever action the user has
C specified.
C
        IF (NLFT.LT.LOWS)
          IF (IWSO.LE.1)
     +      WRITE (I1MACH(4),'('' VTGRWS'',
     +                         I8,'' WORDS REQUESTED'',
     +                         I8,'' WORDS AVAILABLE'')') LOWS,NLFT
          IF (IWSO.LE.0)
            CALL SETER ('VTGRWS - REAL WORKSPACE OVERFLOW',2,2)
            STOP
          ELSE IF (IWSO.GE.3)
            CALL SETER ('VTGRWS - REAL WORKSPACE OVERFLOW',3,1)
          ELSE
            IERR=1
          END IF
          RETURN
        END IF
C
C It may be that a reduction in size has been requested.  That's easy.
C
        IF (LOWS.LE.LRWS(IOWS))
          LRWS(IOWS)=LOWS
          RETURN
        END IF
C
C Otherwise, what we do depends on whether the workspace associated
C with this index exists already.
C
        IF (LRWS(IOWS).LE.0)
C
C It does not exist.  Find (or create) an area large enough.  First,
C check for an open space large enough.
C
          JRWS=0
          REPEAT
            KRWS=LRWK
            IMIN=0
            DO (I=1,$NBRW$)
              IF (IRWS(I).GE.JRWS.AND.IRWS(I).LT.KRWS.AND.LRWS(I).GT.0)
                KRWS=IRWS(I)
                IMIN=I
              END IF
            END DO
            IF (KRWS-JRWS.GE.LOWS)
              IRWS(IOWS)=JRWS
              LRWS(IOWS)=LOWS
              RETURN
            END IF
            IF (IMIN.NE.0)
              JRWS=IRWS(IMIN)+LRWS(IMIN)
            END IF
          UNTIL (IMIN.EQ.0)
C
C If no space large enough was found, pack all the existing blocks
C into the beginning of the array, which will leave enough space at
C the end of it.
C
          JRWS=0
          REPEAT
            KRWS=LRWK
            IMIN=0
            DO (I=1,$NBRW$)
              IF (IRWS(I).GE.JRWS.AND.IRWS(I).LT.KRWS.AND.LRWS(I).GT.0)
                KRWS=IRWS(I)
                IMIN=I
              END IF
            END DO
            IF (IMIN.NE.0)
              IF (IRWS(IMIN).NE.JRWS)
                DO (I=1,LRWS(IMIN))
                  RWRK(JRWS+I)=RWRK(IRWS(IMIN)+I)
                END DO
                IRWS(IMIN)=JRWS
              END IF
              JRWS=JRWS+LRWS(IMIN)
            END IF
          UNTIL (IMIN.EQ.0)
C
          IRWS(IOWS)=JRWS
          LRWS(IOWS)=LOWS
          RETURN
C
        ELSE
C
C It exists.  Extend its length.  First, see if that can be done
C without moving anything around.
C
          JRWS=IRWS(IOWS)+LRWS(IOWS)
          KRWS=LRWK
          DO (I=1,$NBRW$)
            IF (IRWS(I).GE.JRWS.AND.IRWS(I).LT.KRWS.AND.LRWS(I).GT.0)
              KRWS=IRWS(I)
            END IF
          END DO
          IF (KRWS-JRWS.GE.LOWS)
            LRWS(IOWS)=LOWS
            RETURN
          END IF
C
C Blocks have to be moved.  Move those that precede the one to be
C lengthened and that one itself toward the beginning of the workspace.
C
          JRWS=0
          REPEAT
            KRWS=LRWK
            IMIN=0
            DO (I=1,$NBRW$)
              IF (IRWS(I).GE.JRWS.AND.IRWS(I).LT.KRWS.AND.LRWS(I).GT.0)
                KRWS=IRWS(I)
                IMIN=I
              END IF
            END DO
            IF (IMIN.NE.0)
              IF (IRWS(IMIN).NE.JRWS)
                DO (I=1,LRWS(IMIN))
                  RWRK(JRWS+I)=RWRK(IRWS(IMIN)+I)
                END DO
                IRWS(IMIN)=JRWS
              END IF
              JRWS=JRWS+LRWS(IMIN)
            END IF
          UNTIL (IMIN.EQ.0.OR.IMIN.EQ.IOWS)
C
C Move blocks that follow the one to be lengthened toward the end of
C the workspace.
C
          KRWS=LRWK
          REPEAT
            JRWS=IRWS(IOWS)+LRWS(IOWS)
            IMAX=0
            DO (I=1,$NBRW$)
              IF (IRWS(I).GE.JRWS.AND.IRWS(I).LT.KRWS.AND.LRWS(I).GT.0)
                JRWS=IRWS(I)+LRWS(I)
                IMAX=I
              END IF
            END DO
            IF (IMAX.NE.0)
              IF (JRWS.NE.KRWS)
                DO (I=LRWS(IMAX),1,-1)
                  RWRK(KRWS-LRWS(IMAX)+I)=RWRK(JRWS-LRWS(IMAX)+I)
                END DO
                IRWS(IMAX)=KRWS-LRWS(IMAX)
              END IF
              KRWS=IRWS(IMAX)
            END IF
          UNTIL (IMAX.EQ.0)
C
C There should now be room, so just update the length of the block.
C
          LRWS(IOWS)=LOWS
          RETURN
C
        END IF
C
      END


      SUBROUTINE VTINLB (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C VTINLB generates the informational label; the quantities defining the
C label are added to the lists in real workspaces 3 and 4.
C
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C If the text string for the informational label is blank, do nothing.
C
        IF (TXIL(1:LTIL).EQ.' ') RETURN
C
C Otherwise, form the informational label ...
C
        CALL VTSBST (TXIL(1:LTIL),CTMA,LCTM)
C
C ... get sizing information for the label ...
C
        XPFS=XVPL+CXIL*(XVPR-XVPL)
        YPFS=YVPB+CYIL*(YVPT-YVPB)
        XLBC=CFUX(XPFS)
        IF (ICFELL('VTINLB',1).NE.0) RETURN
        YLBC=CFUY(YPFS)
        IF (ICFELL('VTINLB',2).NE.0) RETURN
        WCFS=CHWM*WCIL*(XVPR-XVPL)
        WWFS=CHWM*WWIL*(XVPR-XVPL)
C
        CALL PCGETI ('TE',ISTE)
        IF (ICFELL('VTINLB',3).NE.0) RETURN
        CALL PCSETI ('TE',1)
        IF (ICFELL('VTINLB',4).NE.0) RETURN
        CALL HLUVTCHIL (+1)
        IF (ICFELL('VTINLB',5).NE.0) RETURN
        IF (CTMA(1:LCTM).EQ.' ') GO TO 101
        CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,360.,0.)
        IF (ICFELL('VTINLB',6).NE.0) RETURN
        CALL HLUVTCHIL (-1)
        IF (ICFELL('VTINLB',7).NE.0) RETURN
        CALL PCGETR ('DL',DSTL)
        IF (ICFELL('VTINLB',8).NE.0) RETURN
        CALL PCGETR ('DR',DSTR)
        IF (ICFELL('VTINLB',9).NE.0) RETURN
        CALL PCGETR ('DB',DSTB)
        IF (ICFELL('VTINLB',10).NE.0) RETURN
        CALL PCGETR ('DT',DSTT)
        IF (ICFELL('VTINLB',11).NE.0) RETURN
        CALL PCSETI ('TE',ISTE)
        IF (ICFELL('VTINLB',12).NE.0) RETURN
        DSTL=DSTL+WWFS
        DSTR=DSTR+WWFS
        DSTB=DSTB+WWFS
        DSTT=DSTT+WWFS
C
C ... and then put information about the label into the lists.
C
        SINA=SIN(.017453292519943*ANIL)
        COSA=COS(.017453292519943*ANIL)
C
        IXPO=MOD(IPIL+4,3)-1
C
        IF (IXPO.LT.0)
          XPFS=XPFS+DSTL*COSA
          YPFS=YPFS+DSTL*SINA
        ELSE IF (IXPO.GT.0)
          XPFS=XPFS-DSTR*COSA
          YPFS=YPFS-DSTR*SINA
        END IF
C
        IYPO=(IPIL+4)/3-1
C
        IF (IYPO.LT.0)
          XPFS=XPFS-DSTB*SINA
          YPFS=YPFS+DSTB*COSA
        ELSE IF (IYPO.GT.0)
          XPFS=XPFS+DSTT*SINA
          YPFS=YPFS-DSTT*COSA
        END IF
C
        XLBC=CFUX(XPFS)
        IF (ICFELL('VTINLB',13).NE.0) RETURN
        YLBC=CFUY(YPFS)
        IF (ICFELL('VTINLB',14).NE.0) RETURN
C
        NLBS=NLBS+1
        IF (4*NLBS.GT.LR03)
          CALL VTGRWS (RWRK,3,MAX(4*NLBS,LR03+100),IWSE)
          IF (IWSE.NE.0.OR.ICFELL('VTINLB',15).NE.0)
            NLBS=NLBS-1
            RETURN
          END IF
        END IF
        RWRK(IR03+4*(NLBS-1)+1)=XPFS
        RWRK(IR03+4*(NLBS-1)+2)=YPFS
        RWRK(IR03+4*(NLBS-1)+3)=.017453292519943*ANIL
        RWRK(IR03+4*(NLBS-1)+4)=-NR04
        NR04=NR04+6
        IF (NR04.GT.LR04)
          CALL VTGRWS (RWRK,4,MAX(NR04,LR04+100),IWSE)
          IF (IWSE.NE.0.OR.ICFELL('VTINLB',16).NE.0)
            NLBS=NLBS-1
            RETURN
          END IF
        END IF
        RWRK(IR04+NR04-5)=0.
        RWRK(IR04+NR04-4)=0.
        RWRK(IR04+NR04-3)=DSTL
        RWRK(IR04+NR04-2)=DSTR
        RWRK(IR04+NR04-1)=DSTB
        RWRK(IR04+NR04  )=DSTT
C
C Done.
C
  101   RETURN
C
      END


      SUBROUTINE VTINRC
C
C VTINRC sets constants that are required by VASPACKT and that cannot be
C defined in a DATA statement because determining their values requires
C that code be executed.
C
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Do a call forcing a BLOCKDATA to be loaded from a binary library.
C
        CALL VTBLDA
C
C Find out how many significant digits a real can represent and use it
C to compute machine constants "epsilon" and "1+epsilon" and to set up
C the format to be used by VTNUMB.
C
        NSDR=0
C
        REPEAT
          NSDR=NSDR+1
          CALL VTINRK (NSDR,TMP1,TMP2,TMP3)
        UNTIL (TMP2.EQ.1..OR.TMP3.EQ.TMP2.OR.NSDR.GE.100)
C
        EPSI=10.**(1-NSDR)
C
        FRMT(1:2)='(E'
        IF (NSDR+8.LE.9)
          FRMT(3:3)=CHAR(ICHAR('0')+NSDR+8)
          ITMP=4
        ELSE
          FRMT(3:3)=CHAR(ICHAR('0')+(NSDR+8)/10)
          FRMT(4:4)=CHAR(ICHAR('0')+MOD(NSDR+8,10))
          ITMP=5
        END IF
        FRMT(ITMP:ITMP)='.'
        IF (NSDR.LE.9)
          FRMT(ITMP+1:ITMP+1)=CHAR(ICHAR('0')+NSDR)
          ITMP=ITMP+2
        ELSE
          FRMT(ITMP+1:ITMP+1)=CHAR(ICHAR('0')+(NSDR)/10)
          FRMT(ITMP+2:ITMP+2)=CHAR(ICHAR('0')+MOD(NSDR,10))
          ITMP=ITMP+3
        END IF
        FRMT(ITMP:ITMP)=')'
C
C Set the flag to indicate that these constants have been initialized.
C
        INIT=1
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTINRK (NSDR,TMP1,TMP2,TMP3)
C
C This routine computes some quantities needed by VTINRC; the code is
C here so as to ensure that, on machines on which arithmetic is done
C in double-precision registers, these quantities will be truncated to
C real precision before being used in tests.
C
        TMP1=10.**(-NSDR)
        TMP2=  1.+TMP1
        TMP3=TMP2+TMP1
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTNUMB (VALU,NDGD,LMSD,IEXP,LEXP,CEX1,CEX2,CEX3,LEX1,
     +                   LEX2,LEX3,IOMA,IODP,IOTZ,CBUF,NBUF,NDGS,IEVA)
C
        CHARACTER*(*) CEX1,CEX2,CEX3,CBUF
C
C This subroutine expresses the value of a real number in a character
C form.  Depending on the values of the arguments, an exponential form
C (for example, "1.36E-2") or a no-exponent form (for example, ".0136")
C may be used.  The arguments are as follows:
C
C VALU is the real number whose value is to be expressed.
C
C NDGD is the desired number of significant digits to be used in the
C character expression of the number.
C
C LMSD is a flag indicating how the leftmost significant digit of VALU
C is to be determined.  VALU may be written in the form
C
C   ... D(3) D(2) D(1) D(0) . D(-1) D(-2) D(-3) D(-4) ...
C
C where, for all integer values of I, D(I) is an integer between 0 and
C 9, inclusive.  There exists an integer ILFT such that D(ILFT) is non-
C zero and, for all I greater than ILFT, D(I) is zero.  The leftmost
C significant digit of VALU is considered to occur in the position
C MAX(ILFT,LMSD).
C
C LMSD may be used to achieve consistency in expressing the values of a
C group of numbers.  For example, suppose that, with NDGD = 3 and LMSD
C = -10000, we get the numbers
C
C   5.00, 10.0, 15.0, ..., 95.0, 100., 105.              (no exponents)
C   5.00E0, 1.00E1, 1.50E1, ..., 9.50E1, 1.00E2, 1.05E2  (exponents)
C
C By resetting LMSD to 2 (which is the position of the leftmost non-zero
C digit in the whole group), we can get instead
C
C   5., 10., 15., ..., 95., 100., 105.                   (no exponents)
C   0.05E2, 0.10E2, 0.15E2, ..., 0.95E2, 1.00E2, 1.05E2  (exponents)
C
C Whether one prefers to see numbers like those in the first set or the
C second set is to some extent a matter of preference.  The second set
C includes fewer extraneous zeroes and allows the values with exponents
C to be compared with each other more easily.  Note that, in the case of
C the exponential form, LMSD may be viewed as specifying the minimum
C exponent value to be used.  Use LMSD = -10000 to indicate that no
C attempt should be made to force consistency.
C
C IEXP specifies how it is to be decided whether to use the exponential
C form or not, as follows:  If IEXP is less than or equal to zero, the
C exponential form is used, no matter what.  If IEXP is greater than
C zero, the no-exponent form is used if the length of the resulting
C string is less than or equal to IEXP; otherwise, the form resulting
C in the shorter string is used.
C
C LEXP is set less than or equal to zero if exponents are to be written
C in their shortest possible form (plus signs are omitted and the fewest
C digits required to express the value of the exponent are used).  LEXP
C is set greater than zero if exponents are to be written in a manner
C more nearly consistent with one another (the exponent is written with
C either a plus sign or a minus sign and the value of LEXP is the
C desired minimum number of digits to be used, leading zeroes being
C supplied to pad the exponent to the desired length).
C
C CEX1 and CEX2 are character strings to be used in the exponential form
C between the mantissa and the exponent.  If IOMA is non-zero, and, as
C a result, a mantissa exactly equal to one is omitted, CEX1 is omitted
C as well.  Blanks are treated as null strings.  Some possibilities are
C 1) CEX1='E' and CEX2=' ' (or vice-versa), which gives a sort of E
C format (in which case IOMA should not be set non-zero), 2) CEX1='x'
C and CEX2='10**', which gives numbers like "1.36453x10**13", and 3)
C CEX1=':L1:4' and CEX2='10:S:', which generates the function codes
C necessary to make the utility PLCHHQ write the number in exponential
C form.
C
C CEX3 is a character string to be used in the exponential form after
C the exponent.  This will usually be a blank, which is treated as a
C null string; an exception is when function codes for PLCHHQ are being
C generated, in which case it is desirable to use ':N:', in order to
C return to normal level.
C
C LEX1, LEX2, and LEX3 are the lengths to be assumed for the character
C strings CEX1, CEX2, and CEX3 in making decisions about the length of
C the exponential form and the no-exponent form.  (Note that these are
C not the actual lengths of the strings CEX1, CEX2, and CEX3.  If, for
C example, CEX1, CEX2 and CEX3 contain the function codes for PLCHHQ
C mentioned above, use LEX1=1, LEX2=2, and LEX3=0.)
C
C IOMA specifies whether or not it is permissible to omit, from the
C exponential form, mantissas of the form "1" or "1." which are not
C necessary to express the value (as, for example, in "1.x10**2").  If
C IOMA is non-zero, such mantissas are omitted; the part of the exponent
C given by CEX1 (probably the "x" above) is also omitted (thus changing
C "1.x10**2" into "10**2").  Such omission takes place even if IODP
C (which see, below) is zero.
C
C IODP specifies whether or not it is allowed to omit a decimal point
C which is unnecessary (as for example, in "23487.").  If IODP is
C non-zero, such decimal points are omitted.
C
C IOTZ specifies whether or not it is allowed to omit trailing zeroes.
C If IOTZ is non-zero, trailing zeroes are omitted.
C
C CBUF is a character buffer in which the character string is returned.
C If this buffer is not long enough to hold all the characters, no error
C results; the extra characters are simply lost.  This is potentially
C useful, since the object of the call may be simply to obtain the
C number of significant digits and the exponent value.
C
C NBUF is an output parameter; it says how many characters have been
C put into the character buffer CBUF.
C
C NDGS is an output parameter; it contains the number of significant
C digits which were used to express the value of VALU.
C
C IEVA is another output parameter; it is the power to which 10 must be
C raised to obtain a scale factor which will reduce VALU to the range
C from .1 to 1.  That is, the expression "VALU/10.**IEVA" is guaranteed
C (subject to round-off problems) to be greater than or equal to .1 and
C less than 1.  Another way of interpreting IEVA is that it specifies
C the position preceding the leftmost significant digit of VALU (where
C the one's position is numbered 0, the ten's position 1, the hundred's
C position 2, the tenth's position -1, etc.  Thus, the significant
C digits occur in positions IEVA-1 (the leftmost) through IEVA-NDGS
C (the rightmost).
C
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Declare a variable to hold single characters for testing purposes.
C
        CHARACTER*1 SCHR
C
C Find the real lengths of the three parts of the exponent-creating
C string.
C
        LCX1=LEN(CEX1)
        IF (CEX1.EQ.' ') LCX1=0
        LCX2=LEN(CEX2)
        IF (CEX2.EQ.' ') LCX2=0
        LCX3=LEN(CEX3)
        IF (CEX3.EQ.' ') LCX3=0
C
C Find the length of the character buffer and initialize it to blanks.
C
        LBUF=LEN(CBUF)
        CBUF=' '
C
C Use the local I/O routines to generate an E-format representation of
C the number.
C
        WRITE (CTMB(1:NSDR+8),FRMT) VALU
C
C We're about to scan the E-format representation.  Initialize NBUF,
C which is the number of characters put into CBUF, NDGS, which is the
C number of significant digits found in CTMB, IDPT, which is the number
C of the significant digit after which the decimal point was found,
C IEXF, which is a flag indicating whether or not the exponent has been
C found yet, and IRND, which is a rounding flag.
C
        NBUF=0
        NDGS=0
        IDPT=0
        IEXF=0
        IRND=0
C
C Scan the E-format representation.
C
        DO (I=1,NSDR+8)
C
C If a minus sign is found, and it's not part of the exponent, put it
C into the user's character buffer.  If it is a part of the exponent,
C set the exponent sign.  On the Cray, large exponents will cause the
C 'E' to be omitted, in which case the sign introduces the exponent.
C
          IF (CTMB(I:I).EQ.'-')
            IF (IEXF.EQ.0)
              IF (NDGS.EQ.0)
                NBUF=NBUF+1
                IF (NBUF.LE.LBUF) CBUF(NBUF:NBUF)='-'
              ELSE
                IEXF=1
                IESI=-1
                IEVA=0
              END IF
            ELSE
              IESI=-1
            END IF
C
C If a plus sign is found, it can usually just be skipped.  On the Cray,
C large exponents will cause the 'E' to be omitted, in which case the
C sign introduces the exponent.
C
          ELSE IF (CTMB(I:I).EQ.'+')
            IF (IEXF.EQ.0.AND.NDGS.NE.0)
              IEXF=1
              IESI=1
              IEVA=0
            END IF
C
C If a digit is found, and it's not a part of the exponent, copy it to
C the beginning of the temporary buffer; save at most NDGD such digits.
C If a digit is found, and it's part of the exponent, update the value
C of the exponent.
C
          ELSE IF (ICHAR(CTMB(I:I)).GE.ICHAR('0').AND.
     +             ICHAR(CTMB(I:I)).LE.ICHAR('9'))
            IF (IEXF.EQ.0)
              IF (NDGS.EQ.0)
                IF (CTMB(I:I).NE.'0')
                  NDGS=1
                  SCHR=CTMB(I:I)
                  CTMB(1:1)=SCHR
                  NZRS=0
                  IF (SCHR.EQ.'9')
                    NNNS=1
                  ELSE
                    NNNS=0
                  END IF
                ELSE
                  IDPT=IDPT-1
                END IF
              ELSE IF (NDGS.LT.NDGD)
                NDGS=NDGS+1
                SCHR=CTMB(I:I)
                CTMB(NDGS:NDGS)=SCHR
                IF (SCHR.EQ.'0')
                  NZRS=NZRS+1
                  NNNS=0
                ELSE
                  NZRS=0
                  IF (SCHR.EQ.'9')
                    NNNS=NNNS+1
                  ELSE
                    NNNS=0
                  END IF
                END IF
              ELSE IF (IRND.EQ.0)
                IRND=1+(ICHAR(CTMB(I:I))-ICHAR('0'))/5
              END IF
            ELSE
              IEVA=10*IEVA+ICHAR(CTMB(I:I))-ICHAR('0')
            END IF
C
C If a decimal point is found, record the index of the digit which it
C followed.
C
          ELSE IF (CTMB(I:I).EQ.'.')
            IDPT=NDGS
C
C If an "E" or an "e" is found, reset the flags to start processing of
C the exponent.
C
          ELSE IF (CTMB(I:I).EQ.'E'.OR.CTMB(I:I).EQ.'e')
            IEXF=1
            IESI=1
            IEVA=0
          END IF
C
        END DO
C
C If no significant digits were found, or if no exponent was found,
C assume that the number was exactly zero and return a character string
C reflecting that (unless the use of consistent exponents is forced,
C which requires special action).
C
        IF (NDGS.EQ.0.OR.IEXF.EQ.0)
          IF (IEXP.GT.0.OR.LMSD.EQ.-10000)
            CBUF='0'
            NBUF=1
            NDGS=1
            IEVA=0
            RETURN
          ELSE
            NBUF=0
            INVOKE (GENERATE-MULTI-DIGIT-ZERO,NR)
          END IF
        END IF
C
C Round the number, take care of trailing zeroes and nines, and compute
C the final number of significant digits.
C
        IF (IRND.LT.2)
          IF (NZRS.NE.0) NDGS=NDGS-NZRS
        ELSE
          IF (NNNS.NE.0) NDGS=NDGS-NNNS
          IF (NDGS.EQ.0)
            IDPT=IDPT+1
            CTMB(1:1)='1'
            NDGS=1
          ELSE
            SCHR=CHAR(ICHAR(CTMB(NDGS:NDGS))+1)
            CTMB(NDGS:NDGS)=SCHR
          END IF
        END IF
C
C Compute the final value of the exponent which would be required if
C the decimal point preceded the first significant digit in CTMB.
C
        IEVA=IESI*IEVA+IDPT
C
C If the leftmost significant digit is to the right of the one the user
C wants, supply some leading zeroes and adjust the parameters giving the
C number of digits in CTMB and the exponent value.  We must provide for
C the possibility that this will reduce the number to zero.
C
        IF (IEVA-1.LT.LMSD)
          NLZS=LMSD-(IEVA-1)
          IF (NLZS.LT.NDGD)
            NDGT=MIN(NDGS+NLZS,NDGD)
            DO (I=NDGT,NLZS+1,-1)
              SCHR=CTMB(I-NLZS:I-NLZS)
              CTMB(I:I)=SCHR
            END DO
            DO (I=1,NLZS)
              CTMB(I:I)='0'
            END DO
            NDGS=NDGT
            IEVA=LMSD+1
          ELSE
            INVOKE (GENERATE-MULTI-DIGIT-ZERO,NR)
          END IF
        ELSE
          NLZS=0
        END IF
C
C Control arrives at this block to generate a multi-digit zero.
C
        BLOCK (GENERATE-MULTI-DIGIT-ZERO,NR)
          CTMB(1:1)='0'
          NDGS=1
          NLZS=0
          IEVA=LMSD+1
        END BLOCK
C
C Decide how many digits to output.  This depends on whether the user
C wants to omit trailing zeroes or not.
C
        IF (IOTZ.EQ.0)
          NDTO=NDGD
        ELSE
          NDTO=NDGS
        END IF
C
C Compute the lengths of the character strings required for the form
C without an exponent (LWOE) and for the form with an exponent (LWIE).
C In certain cases, the values given are dummies, intended to force the
C use of one form or the other.  Note that leading zeroes are included
C in computing LWOE, even though they may be omitted from the output,
C in order to achieve consistency of sets of labels.
C
        IF (IEXP.GT.0)
          LWOE=NBUF+MAX(NDTO,IEVA)-MIN(IEVA,0)
          IF (IEVA.LE.NLZS.AND.NLZF.NE.0) LWOE=LWOE+1
          IF (IEVA.GE.NDTO.AND.IODP.EQ.0) LWOE=LWOE+1
          IF (LWOE.LE.IEXP)
            LWOE=0
            LWIE=0
          ELSE
            LWIE=NBUF+NDTO+2+LEX1+LEX2+LEX3
            IF (NDTO.EQ.1)
              IF (IOMA.NE.0.AND.CTMB(1:1).EQ.'1')
                LWIE=LWIE-2-LEX1
              ELSE IF (IODP.NE.0)
                LWIE=LWIE-1
              END IF
            END IF
            IF (IEVA-1.LT.0.OR.LEXP.GT.0) LWIE=LWIE+1
            IF (ABS(IEVA-1).GT.9.OR.LEXP.GE.2) LWIE=LWIE+1
            IF (ABS(IEVA-1).GT.99.OR.LEXP.GE.3) LWIE=LWIE+1
            IF (ABS(IEVA-1).GT.999.OR.LEXP.GE.4) LWIE=LWIE+1
          END IF
        ELSE
          LWOE=1
          LWIE=0
        END IF
C
C Depending on the lengths, generate a string without an exponent ...
C
        IF (LWOE.LE.LWIE)
C
          DO (I=MIN(IEVA+1,NLZS+1),MAX(NDTO,IEVA))
            IF (I.EQ.IEVA+1)
              IF (I.LE.NLZS+1.AND.NLZF.NE.0)
                NBUF=NBUF+1
                IF (NBUF.LE.LBUF) CBUF(NBUF:NBUF)='0'
              END IF
              NBUF=NBUF+1
              IF (NBUF.LE.LBUF) CBUF(NBUF:NBUF)='.'
            END IF
            NBUF=NBUF+1
            IF (NBUF.LE.LBUF)
              IF (I.GE.1.AND.I.LE.NDGS)
                CBUF(NBUF:NBUF)=CTMB(I:I)
              ELSE
                CBUF(NBUF:NBUF)='0'
              END IF
            END IF
          END DO
C
          IF (IEVA.GE.NDTO.AND.IODP.EQ.0)
            NBUF=NBUF+1
            IF (NBUF.LE.LBUF) CBUF(NBUF:NBUF)='.'
          END IF
C
C ... or a string with an exponent.
C
        ELSE
C
          IF (NDTO.NE.1.OR.
     +        CTMB(1:1).NE.'1'.OR.IOMA.EQ.0)
            NBUF=NBUF+1
            IF (NBUF.LE.LBUF) CBUF(NBUF:NBUF)=CTMB(1:1)
          END IF
C
          IF (NDTO.NE.1.OR.
     +        ((CTMB(1:1).NE.'1'.OR.IOMA.EQ.0).AND.IODP.EQ.0))
            NBUF=NBUF+1
            IF (NBUF.LE.LBUF) CBUF(NBUF:NBUF)='.'
          END IF
C
          DO (I=2,NDTO)
            NBUF=NBUF+1
            IF (NBUF.LE.LBUF)
              IF (I.LE.NDGS)
                CBUF(NBUF:NBUF)=CTMB(I:I)
              ELSE
                CBUF(NBUF:NBUF)='0'
              END IF
            END IF
          END DO
C
          IF (LCX1.NE.0.AND.(NDTO.NE.1.OR.
     +                       CTMB(1:1).NE.'1'.OR.IOMA.EQ.0))
            IF (NBUF.LT.LBUF) CBUF(NBUF+1:MIN(NBUF+LCX1,LBUF))=CEX1
            NBUF=NBUF+LCX1
          END IF
C
          IF (LCX2.NE.0)
            IF (NBUF.LT.LBUF) CBUF(NBUF+1:MIN(NBUF+LCX2,LBUF))=CEX2
            NBUF=NBUF+LCX2
          END IF
C
          ITMP=IEVA-1
C
          IF (ITMP.LT.0.OR.LEXP.GT.0)
            NBUF=NBUF+1
            IF (NBUF.LE.LBUF)
              IF (ITMP.LT.0)
                CBUF(NBUF:NBUF)='-'
              ELSE
                CBUF(NBUF:NBUF)='+'
              END IF
            END IF
          END IF
C
          ITMP=MIN(ABS(ITMP),9999)
C
          IF (ITMP.GT.999)
            NTTL=4
            IDIV=1000
          ELSE IF (ITMP.GT.99)
            NTTL=3
            IDIV=100
          ELSE IF (ITMP.GT.9)
            NTTL=2
            IDIV=10
          ELSE
            NTTL=1
            IDIV=1
          END IF
C
          IF (LEXP.GT.0)
            DO (I=1,LEXP-NTTL)
              NBUF=NBUF+1
              IF (NBUF.LE.LBUF) CBUF(NBUF:NBUF)='0'
            END DO
          END IF
C
          DO (I=1,NTTL)
            NBUF=NBUF+1
            IF (NBUF.LE.LBUF) CBUF(NBUF:NBUF)=CHAR(ICHAR('0')+ITMP/IDIV)
            ITMP=MOD(ITMP,IDIV)
            IDIV=IDIV/10
          END DO
C
          IF (LCX3.NE.0)
            IF (NBUF.LT.LBUF) CBUF(NBUF+1:MIN(NBUF+LCX3,LBUF))=CEX3
            NBUF=NBUF+LCX3
          END IF
C
        END IF
C
C Limit the value of NBUF to the length of the character buffer CBUF.
C
        IF (NBUF.GT.LBUF) NBUF=LBUF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTPISB (XCPA,YCPA,XCPB,YCPB,XCPC,YCPC,XCPD,YCPD,
     +                                            XCOP,YCOP,IFLG)
C
C This function checks for overlap of the 2D line segments AB and CD;
C if they overlap, it adds the X and Y coordinates of the point of
C overlap to XCOP and YCOP and bumps the value of the counter IFLG.
C
C Compute a denominator needed below.  (Its value is zero if and only
C if the line segments are parallel.)
C
        DNOM=(XCPB-XCPA)*(YCPD-YCPC)-(XCPD-XCPC)*(YCPB-YCPA)
C
C If the line segments are parallel, they don't intersect.
C
        IF (DNOM.EQ.0.) RETURN
C
C Otherwise, find the values of S and T, in the parametric equations
C for line segments AB and CD, for which intersection occurs.
C
        S=((XCPC-XCPA)*(YCPD-YCPC)-(XCPD-XCPC)*(YCPC-YCPA))/DNOM
        T=((XCPC-XCPA)*(YCPB-YCPA)-(XCPB-XCPA)*(YCPC-YCPA))/DNOM
C
C If both S and T are between 0 and 1, the line segments intersect;
C otherwise, they don't.
C
        IF (S.GE.0..AND.S.LE.1..AND.T.GE.0..AND.T.LE.1.)
          XCOP=XCOP+(XCPA+S*(XCPB-XCPA))
          YCOP=YCOP+(YCPA+S*(YCPB-YCPA))
          IFLG=IFLG+1
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTPITT (XCA1,YCA1,XCA2,YCA2,XCA3,YCA3,
     +                   XCB1,YCB1,XCB2,YCB2,XCB3,YCB3,
     +                   XCOP,YCOP,IFLG)
C
C Given the coordinates of the corner points of two triangles in the
C plane, this routine computes and returns the coordinates of a point
C in both triangles, if such a point exists.  If no such point exists,
C IFLG is returned equal to zero; otherwise, it is a count of the
C number of points used to compute the common point.
C
C Declare an arithmetic statement function that has one sign if point
C 3 is to the left of the line from point 1 to point 2 and a different
C sign if point 3 is to the right of that line.
C
        SIDE(X1,Y1,X2,Y2,X3,Y3)=(X1-X3)*(Y2-Y3)-(Y1-Y3)*(X2-X3)
C
C Initialize the quantities to be returned.
C
        XCOP=0.
        YCOP=0.
        IFLG=0
C
C Use any point of A that is inside B.
C
        TMP1=SIDE(XCB1,YCB1,XCB2,YCB2,XCA1,YCA1)
        TMP2=SIDE(XCB2,YCB2,XCB3,YCB3,XCA1,YCA1)
        TMP3=SIDE(XCB3,YCB3,XCB1,YCB1,XCA1,YCA1)
C
        IF ((TMP1.LT.0..AND.TMP2.LT.0..AND.TMP3.LT.0.).OR.
     +      (TMP1.GT.0..AND.TMP2.GT.0..AND.TMP3.GT.0.))
          XCOP=XCOP+XCA1
          YCOP=YCOP+YCA1
          IFLG=IFLG+1
        END IF
C
        TMP1=SIDE(XCB1,YCB1,XCB2,YCB2,XCA2,YCA2)
        TMP2=SIDE(XCB2,YCB2,XCB3,YCB3,XCA2,YCA2)
        TMP3=SIDE(XCB3,YCB3,XCB1,YCB1,XCA2,YCA2)
C
        IF ((TMP1.LT.0..AND.TMP2.LT.0..AND.TMP3.LT.0.).OR.
     +      (TMP1.GT.0..AND.TMP2.GT.0..AND.TMP3.GT.0.))
          XCOP=XCOP+XCA2
          YCOP=YCOP+YCA2
          IFLG=IFLG+1
        END IF
C
        TMP1=SIDE(XCB1,YCB1,XCB2,YCB2,XCA3,YCA3)
        TMP2=SIDE(XCB2,YCB2,XCB3,YCB3,XCA3,YCA3)
        TMP3=SIDE(XCB3,YCB3,XCB1,YCB1,XCA3,YCA3)
C
        IF ((TMP1.LT.0..AND.TMP2.LT.0..AND.TMP3.LT.0.).OR.
     +      (TMP1.GT.0..AND.TMP2.GT.0..AND.TMP3.GT.0.))
          XCOP=XCOP+XCA3
          YCOP=YCOP+YCA3
          IFLG=IFLG+1
        END IF
C
C Use any point of B that is inside A.
C
        TMP1=SIDE(XCA1,YCA1,XCA2,YCA2,XCB1,YCB1)
        TMP2=SIDE(XCA2,YCA2,XCA3,YCA3,XCB1,YCB1)
        TMP3=SIDE(XCA3,YCA3,XCA1,YCA1,XCB1,YCB1)
C
        IF ((TMP1.LT.0..AND.TMP2.LT.0..AND.TMP3.LT.0.).OR.
     +      (TMP1.GT.0..AND.TMP2.GT.0..AND.TMP3.GT.0.))
          XCOP=XCOP+XCB1
          YCOP=YCOP+YCB1
          IFLG=IFLG+1
        END IF
C
        TMP1=SIDE(XCA1,YCA1,XCA2,YCA2,XCB2,YCB2)
        TMP2=SIDE(XCA2,YCA2,XCA3,YCA3,XCB2,YCB2)
        TMP3=SIDE(XCA3,YCA3,XCA1,YCA1,XCB2,YCB2)
C
        IF ((TMP1.LT.0..AND.TMP2.LT.0..AND.TMP3.LT.0.).OR.
     +      (TMP1.GT.0..AND.TMP2.GT.0..AND.TMP3.GT.0.))
          XCOP=XCOP+XCB2
          YCOP=YCOP+YCB2
          IFLG=IFLG+1
        END IF
C
        TMP1=SIDE(XCA1,YCA1,XCA2,YCA2,XCB3,YCB3)
        TMP2=SIDE(XCA2,YCA2,XCA3,YCA3,XCB3,YCB3)
        TMP3=SIDE(XCA3,YCA3,XCA1,YCA1,XCB3,YCB3)
C
        IF ((TMP1.LT.0..AND.TMP2.LT.0..AND.TMP3.LT.0.).OR.
     +      (TMP1.GT.0..AND.TMP2.GT.0..AND.TMP3.GT.0.))
          XCOP=XCOP+XCB3
          YCOP=YCOP+YCB3
          IFLG=IFLG+1
        END IF
C
C Use all points of intersection of the edges.
C
         CALL VTPISB (XCA1,YCA1,XCA2,YCA2,XCB1,YCB1,XCB2,YCB2,
     +                                         XCOP,YCOP,IFLG)
         CALL VTPISB (XCA1,YCA1,XCA2,YCA2,XCB2,YCB2,XCB3,YCB3,
     +                                         XCOP,YCOP,IFLG)
         CALL VTPISB (XCA1,YCA1,XCA2,YCA2,XCB3,YCB3,XCB1,YCB1,
     +                                         XCOP,YCOP,IFLG)
         CALL VTPISB (XCA2,YCA2,XCA3,YCA3,XCB1,YCB1,XCB2,YCB2,
     +                                         XCOP,YCOP,IFLG)
         CALL VTPISB (XCA2,YCA2,XCA3,YCA3,XCB2,YCB2,XCB3,YCB3,
     +                                         XCOP,YCOP,IFLG)
         CALL VTPISB (XCA2,YCA2,XCA3,YCA3,XCB3,YCB3,XCB1,YCB1,
     +                                         XCOP,YCOP,IFLG)
         CALL VTPISB (XCA3,YCA3,XCA1,YCA1,XCB1,YCB1,XCB2,YCB2,
     +                                         XCOP,YCOP,IFLG)
         CALL VTPISB (XCA3,YCA3,XCA1,YCA1,XCB2,YCB2,XCB3,YCB3,
     +                                         XCOP,YCOP,IFLG)
         CALL VTPISB (XCA3,YCA3,XCA1,YCA1,XCB3,YCB3,XCB1,YCB1,
     +                                         XCOP,YCOP,IFLG)
C
C Average over all points found; return average X and average Y.
C
        IF (IFLG.NE.0)
          XCOP=XCOP/REAL(IFLG)
          YCOP=YCOP/REAL(IFLG)
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE VTSBST (CHSI,CHSO,NCHO)
C
        CHARACTER*(*) CHSI,CHSO
C
C The routine VTSBST is called to perform substitution of numeric values
C for parameter names.  The contents of the string CHSI are copied to
C the string CHSO.  Certain substrings of the form '$xxx$' are replaced
C by strings representing numeric values; in particular, '$DVA$' is
C replaced by a string representing the numeric value of DVAL.  The
C length of the resulting string is returned as the value of NCHO.
C
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Find the length of the input character string.
C
        NCHI=LEN(CHSI)
C
C Find the length of the output character-string variable, blank-fill
C it, and initialize the count of characters put into it.
C
        MCHO=LEN(CHSO)
        CHSO=' '
        NCHO=0
C
C Do the copy.  Each time a dollar sign is encountered, see if it
C introduces one of the parameter names to be replaced and, if so,
C do the replacement.
C
.OP     BI=66
        KCHI=0
        WHILE (KCHI.LT.NCHI)
          KCHI=KCHI+1
          IF (NCHO.LT.MCHO)
            NCHO=NCHO+1
            CHSO(NCHO:NCHO)=CHSI(KCHI:KCHI)
            IF (CHSI(KCHI:KCHI).EQ.'$'.AND.KCHI+4.LE.NCHI)
              IF (CHSI(KCHI+1:KCHI+3).EQ.'DVA')
                VALU=DVAL
                INVOKE (TRANSLATE-UNROUNDED-NUMBER)
              ELSE IF (CHSI(KCHI+1:KCHI+3).EQ.'DMN')
                VALU=DMIN
                INVOKE (TRANSLATE-UNROUNDED-NUMBER)
              ELSE IF (CHSI(KCHI+1:KCHI+3).EQ.'DMX')
                VALU=DMAX
                INVOKE (TRANSLATE-UNROUNDED-NUMBER)
              ELSE IF (CHSI(KCHI+1:KCHI+3).EQ.'SFU')
                VALU=SCFU
                LMSD=-10000
                IEXP=1
                LEXP=0
                IOMA=1
                IODP=1
                IOTZ=1
                INVOKE (GENERATE-NUMERIC-VALUE)
              END IF
            END IF
          END IF
        END WHILE
.OP     BI=77
C
C Done.
C
        RETURN
C
C The following internal procedure is used to handle numbers known not
C to have been rounded to nice values.
C
        BLOCK (TRANSLATE-UNROUNDED-NUMBER)
          IF (CHSI(KCHI+4:KCHI+4).NE.'U') VALU=VALU/SCFU
          LMSD=LSDL
          IEXP=NEXU
          LEXP=NEXL
          IOMA=JOMA
          IODP=JODP
          IOTZ=JOTZ
          INVOKE (GENERATE-NUMERIC-VALUE)
        END BLOCK
C
C The following internal procedure generates, in the output string, the
C representation of a numeric value.  It then updates the pointers into
C the input and output character strings.
C
        BLOCK (GENERATE-NUMERIC-VALUE)
          CALL VTNUMB (VALU,NDGL,LMSD,IEXP,LEXP,CHEX(1:LEA1),
     +                 CHEX(LEA1+1:LEA1+LEA2),
     +                 CHEX(LEA1+LEA2+1:LEA1+LEA2+LEA3),
     +                 LEE1,LEE2,LEE3,IOMA,IODP,IOTZ,
     +                 CHSO(NCHO:MCHO),NCHS,NDGS,IEVA)
          NCHO=NCHO+NCHS-1
          KCHI=KCHI+4
          IF (CHSI(KCHI:KCHI).NE.'$') KCHI=KCHI+1
        END BLOCK
C
      END


      FUNCTION VTFRAN ()
C
C Pseudo-random-number generator.
C
        DOUBLE PRECISION X
        SAVE X
C
        DATA X / 2.718281828459045D0 /
C
        X=MOD(9821.D0*X+.211327D0,1.D0)
        VTFRAN=REAL(X)
C
        RETURN
C
      END


      FUNCTION VTABGC (ALAT,ALON,BLAT,BLON,CLAT,CLON)
C
C (VTABGC = VaspackT, Angle Between Great Circles)
C
C This function, given the latitudes and longitudes of points A, B, and
C C on the globe, returns the absolute value of the angle, in degrees,
C between the great circle from A to B and the great circle from A to C.
C
        DATA DTOR / .017453292519943 /
        DATA RTOD / 57.2957795130823 /
C
C Get XYZ coordinates for B and C.
C
        BVOX=COS(DTOR*BLAT)*COS(DTOR*BLON)
        BVOY=COS(DTOR*BLAT)*SIN(DTOR*BLON)
        BVOZ=SIN(DTOR*BLAT)
C
        CVOX=COS(DTOR*CLAT)*COS(DTOR*CLON)
        CVOY=COS(DTOR*CLAT)*SIN(DTOR*CLON)
        CVOZ=SIN(DTOR*CLAT)
C
C Rotate about the Z axis so as to put A on the prime meridian.
C
        CALL NGRITD (3,-ALON,BVOX,BVOY,BVOZ)
        CALL NGRITD (3,-ALON,CVOX,CVOY,CVOZ)
C
C Rotate about the Y axis so as to put A on the equator.
C
        CALL NGRITD (2,ALAT,BVOX,BVOY,BVOZ)
        CALL NGRITD (2,ALAT,CVOX,CVOY,CVOZ)
C
C Rotate about the X axis so as to put B on the equator.
C
        IF (BVOZ.NE.0..OR.BVOY.NE.0.)
          ANGL=-RTOD*ATAN2(BVOZ,BVOY)
        ELSE
          ANGL=0.
        END IF
C
        CALL NGRITD (1,ANGL,CVOX,CVOY,CVOZ)
C
C Set the value of the function accordingly.
C
        IF (CVOZ.NE.0..OR.CVOY.NE.0.)
          VTABGC=ABS(RTOD*ATAN2(CVOZ,CVOY))
        ELSE
          VTABGC=0.
        END IF
C
C Done.
C
        RETURN
C
      END


      FUNCTION VTRAND ()
C
C This function generates repeatable sequences of pseudo-random
C numbers.  Initially, the calling routine zeroes the seed value X in
C the labelled common block VTSEED, calls VTRAND N times (where N is
C zero or greater), and then saves the resulting value of X.  When it
C is desired to repeat the sequence, the value of X is restored.  It
C is probably not a good idea to use an arbitrary seed value for X, as
C the algorithm seems to depend on starting with X = e.
C
        COMMON /VTSEED/ X
          DOUBLE PRECISION X
        SAVE   /VTSEED/
C
        IF (X.EQ.0.) X=2.718281828459045D0
C
        X=MOD(9821.D0*X+.211327D0,1.D0)
        VTRAND=REAL(X)
C
        RETURN  
C
      END


      SUBROUTINE VTSORT (RVAL,NVAL,IPER)
C
        DIMENSION RVAL(NVAL),IPER(NVAL)
C
C Given an array of NVAL reals in an array RVAL, this routine returns a
C permutation vector IPER such that, given I and J, 1.LE.I.LE.J.LE.NVAL,
C RVAL(IPER(I)).LE.RVAL(IPER(J)).
C
C A Shell sort is used.  Details of the algorithm may be found in the
C book "Algorithms" by Robert Sedgewick.
C        
C Note:  Fred Clare wrote the original version of this routine.  I have  
C adapted it for use in CONPACK; among other things, the error checking
C has been been removed because the calling routine does it.  (DJK)
C        
        DO (I=1,NVAL)
          IPER(I)=I
        END DO  
C        
        K=0     
C
        WHILE (3*K+1.LT.NVAL)
          K=3*K+1 
        END WHILE
C        
        WHILE (K.GT.0)
C
          DO (I=1,NVAL-K)
C
            J=I     
C
            LOOP    
              EXIT IF (RVAL(IPER(J)).LE.RVAL(IPER(J+K)))
              ITMP=IPER(J)
              IPER(J)=IPER(J+K)
              IPER(J+K)=ITMP
              J=J-K   
              EXIT IF (J.LT.1)
            END LOOP
C
          END DO  
C        
          K=(K-1)/3
C
        END WHILE
C
C Done.
C
        RETURN  
C
      END


.OP   BI=66
      SUBROUTINE VTTLOM (RPNT,IEDG,ITRI,ISTR,RSTR,SSTR,ANGD,SLMX,
     +                   ITER,SLTR,IAMA,RTPL)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),IAMA(*)
C
        EXTERNAL RTPL
C
C This routine, given arrays defining a triangular mesh, at each point
C of which a velocity vector is given, and the location of a particular
C starting point on a particular triangle of that mesh, draws a line
C that everywhere makes a specified angle with the velocity vectors,
C continuing until one of a set of termination conditions is satisfied.
C
C RPNT is an array of nodes defining vertices of triangles of the mesh.
C
C IEDG is an array of nodes defining edges (pairs of vertices) of the
C triangles of the mesh.
C
C ITRI is an array of nodes defining triangles (triplets of edges) of
C the mesh.
C
C ISTR is the base index, in ITRI, of the triangle node of the triangle
C containing the starting point, and RSTR and SSTR are coordinates of
C the starting point within that triangle (fractional multipliers of
C its first and second sides, respectively).
C
C ANGD is the angle, in degrees, that the line drawn is to make with
C the velocity vectors.
C
C SLMX is the maximum length of streamline to be traced.
C
C ITER is a flag that is returned to say how the line terminated:
C
C   ITER=1 => exterior edge of mesh encountered.
C   ITER=4 => line traced for specified distance.
C   ITER=5 => velocity along line dropped below VVMM.
C   ITER=7 => other (e. g., a degenerate triangle).
C
C SLTR is returned and is the length of streamline traced before a
C termination condition was encountered.
C
C IAMA is an array containing an area map against which the line is to
C be masked.  If masking is not desired, set IAMA(1) = 0.
C
C RTPL is a routine to be called to draw the line (when it is masked).
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Declare local arrays for user-system polyline coordinates.
C
        PARAMETER (MCPL=100)
C
        DIMENSION XCPL(MCPL),YCPL(MCPL)
C
C Declare local arrays to use in drawing masked polylines.
C
        PARAMETER (MCPF=MCPL,MNOG=64)
        DIMENSION XCPF(MCPF),YCPF(MCPF),IAAI(MNOG),IAGI(MNOG)
C
C DTOR is a multiplicative constant to convert from degrees to radians.
C
        DATA DTOR / .017453292519943 /
C
C IXOR(IONE,ITWO) is the exclusive OR of the 12-bit masks IONE and ITWO.
C
        IXOR(IONE,ITWO)=IAND(IOR(IONE,ITWO),4095-IAND(IONE,ITWO))
C
C ITBF(IARG) is non-zero if and only if a triangle with blocking-flag
C element IARG is blocked.
C
        ITBF(IARG)=IAND(IXOR(IARG,ITBX),ITBA)
C
C Extract the values of ITBX and ITBA from ITBM.
C
        ITBX=IAND(ISHIFT(ITBM,-12),4095)
        ITBA=IAND(       ITBM     ,4095)
C
C If the line is to be colored, save the initial polyline color and
C initialize the variables that keep track of coloring.
C
        IF (ICTV.NE.0.AND.NCLR.NE.0)
          CALL GQPLCI (IGER,IPCS)
          IF (IGER.NE.0)
            CALL SETER ('VTTLOM - ERROR EXIT FROM GQPLCI',1,1)
            RETURN
          END IF
          IPCC=IPCS
          ICVL=(NCLR+1)/2
        ELSE
          IPCS=-1
          IPCC=-1
          IPCD=-1
        END IF
C
C Set some tolerances for the drawing code.
C
        EPSX=ABS(XWDR-XWDL)*EPSI
        EPSY=ABS(YWDT-YWDB)*EPSI
C
        SMLX=.01*ABS(XWDR-XWDL)
        SMLY=.01*ABS(YWDT-YWDB)
C
        PITX=PITH*ABS(XWDR-XWDL)
        PITY=PITH*ABS(YWDT-YWDB)
C
C Initialize the pointer to the current triangle and find the base
C indices of the nodes defining its vertices.
C
        IIII=ISTR
C
C Find the base indices of point 1 (that edges 1 and 2 have in common),
C point 2 (that edges 2 and 3 have in common), and point 3 (that edges
C 3 and 1 have in common).
C
        IF (IEDG(ITRI(IIII+2)+1).NE.IEDG(ITRI(IIII+3)+1).AND.
     +      IEDG(ITRI(IIII+2)+1).NE.IEDG(ITRI(IIII+3)+2))
          IPP1=IEDG(ITRI(IIII+2)+1)
          IPP2=IEDG(ITRI(IIII+2)+2)
        ELSE
          IPP1=IEDG(ITRI(IIII+2)+2)
          IPP2=IEDG(ITRI(IIII+2)+1)
        END IF
C
        IF (IEDG(ITRI(IIII+1)+1).NE.IPP1)
          IPP3=IEDG(ITRI(IIII+1)+1)
        ELSE
          IPP3=IEDG(ITRI(IIII+1)+2)
        END IF
C
C Initialize the starting point values.
C
        RVAL=RSTR
        SVAL=SSTR
C
C SLTR keeps track of the length of line traced already.
C
        SLTR=0.
C
C NCPL keeps track of the number of points in the coordinate arrays.
C
        NCPL=0
C
C RUDN keeps track of the ratio of segment length in the user coordinate
C system to segment length in the data coordinate system.
C
        RUDN=0.
C
C ICTB is non-zero if and only if the current triangle is blocked and
C ILTB is non-zero if and only if the last triangle was blocked.
C
        ICTB=1
C
C START TRACING LINE INSIDE TRIANGLE ----------------------------------
C
C Initializing - move ICTB to ILTB and recompute the correct value for
C the new triangle.
C
  101   ILTB=ICTB
        ICTB=ITBF(ITRI(IIII+4))
C
C Extract values from the point arrays describing the current triangle,
C including the coordinates of its vertices, the components of the
C velocity vectors at its vertices, and the values of the quantities
C to be used to determine the color of the line drawn.
C
        UCP1=RPNT(IPP1+1)
        VCP1=RPNT(IPP1+2)
        WCP1=RPNT(IPP1+3)
        UCP2=RPNT(IPP2+1)
        VCP2=RPNT(IPP2+2)
        WCP2=RPNT(IPP2+3)
        UCP3=RPNT(IPP3+1)
        VCP3=RPNT(IPP3+2)
        WCP3=RPNT(IPP3+3)
C
        IF (IDIR.EQ.0)
          UVP1=-RPNT(IPP1+4)
          VVP1=-RPNT(IPP1+5)
          WVP1=-RPNT(IPP1+6)
          UVP2=-RPNT(IPP2+4)
          VVP2=-RPNT(IPP2+5)
          WVP2=-RPNT(IPP2+6)
          UVP3=-RPNT(IPP3+4)
          VVP3=-RPNT(IPP3+5)
          WVP3=-RPNT(IPP3+6)
        ELSE
          UVP1=+RPNT(IPP1+4)
          VVP1=+RPNT(IPP1+5)
          WVP1=+RPNT(IPP1+6)
          UVP2=+RPNT(IPP2+4)
          VVP2=+RPNT(IPP2+5)
          WVP2=+RPNT(IPP2+6)
          UVP3=+RPNT(IPP3+4)
          VVP3=+RPNT(IPP3+5)
          WVP3=+RPNT(IPP3+6)
        END IF
C
        VMG1=SQRT(UVP1**2+VVP1**2+WVP1**2)
C
        IF (VMG1.NE.0.)
          UVP1=.001*EMAX*UVP1/VMG1
          VVP1=.001*EMAX*VVP1/VMG1
          WVP1=.001*EMAX*WVP1/VMG1
        END IF
C
        VMG2=SQRT(UVP2**2+VVP2**2+WVP2**2)
C
        IF (VMG2.NE.0.)
          UVP2=.001*EMAX*UVP2/VMG2
          VVP2=.001*EMAX*VVP2/VMG2
          WVP2=.001*EMAX*WVP2/VMG2
        END IF
C
        VMG3=SQRT(UVP3**2+VVP3**2+WVP3**2)
C
        IF (VMG3.NE.0.)
          UVP3=.001*EMAX*UVP3/VMG3
          VVP3=.001*EMAX*VVP3/VMG3
          WVP3=.001*EMAX*WVP3/VMG3
        END IF
C
        IF (ICTV.EQ.0)
          CVP1=0.
          CVP2=0.
          CVP3=0.
        ELSE IF (ABS(ICTV).LE.LOPN)
          CVP1=RPNT(IPP1+ABS(ICTV))
          CVP2=RPNT(IPP2+ABS(ICTV))
          CVP3=RPNT(IPP3+ABS(ICTV))
        ELSE
          CVP1=SQRT(RPNT(IPP1+4)**2+RPNT(IPP1+5)**2+RPNT(IPP1+6)**2)
          CVP2=SQRT(RPNT(IPP2+4)**2+RPNT(IPP2+5)**2+RPNT(IPP2+6)**2)
          CVP3=SQRT(RPNT(IPP3+4)**2+RPNT(IPP3+5)**2+RPNT(IPP3+6)**2)
        END IF
C
C Compute the coefficients A, B, C, and D in the equation defining the
C plane of the triangle (Ax+By+Cz+D=0).
C
        A=(VCP2-VCP1)*(WCP3-WCP1)-(VCP3-VCP1)*(WCP2-WCP1)
        B=(WCP2-WCP1)*(UCP3-UCP1)-(WCP3-WCP1)*(UCP2-UCP1)
        C=(UCP2-UCP1)*(VCP3-VCP1)-(UCP3-UCP1)*(VCP2-VCP1)
        D=-(A*UCP1+B*VCP1+C*WCP1)
C
C Compute the direction cosines of the normal to the triangle.  If they
C are not well-defined, take an error exit.
C
        DNOM=SQRT(A**2+B**2+C**2)
C
        IF (DNOM.NE.0.)

          DCNU=A/DNOM
          DCNV=B/DNOM
          DCNW=C/DNOM
C
        ELSE
C
          ITER=7
          GO TO 104
C
        END IF
C
C (09/29/2005) The following code resulted in discontinuities in the
C definitions of the velocity vectors along the edges of the triangles
C of the mesh.  I found a formulation that didn't have this problem,
C but I'm leaving the original code here, commented out, for possible
C future reference.
C
C For each velocity vector, use the parametric equations for a line that
C passes through the end of it and is perpendicular to the plane of the
C triangle to find the coordinates of the point where it intersects the
C triangle; use that to compute the components of the projection of the
C velocity vector into the plane of the triangle.
C
C       T=-(A*(UCP1+UVP1)+B*(VCP1+VVP1)+C*(WCP1+WVP1)+D)/
C    +                                                  (A**2+B**2+C**2)
C       UPP1=UVP1+A*T
C       VPP1=VVP1+B*T
C       WPP1=WVP1+C*T
C
C       T=-(A*(UCP2+UVP2)+B*(VCP2+VVP2)+C*(WCP2+WVP2)+D)/
C    +                                                  (A**2+B**2+C**2)
C       UPP2=UVP2+A*T
C       VPP2=VVP2+B*T
C       WPP2=WVP2+C*T
C
C       T=-(A*(UCP3+UVP3)+B*(VCP3+VVP3)+C*(WCP3+WVP3)+D)/
C    +                                                  (A**2+B**2+C**2)
C       UPP3=UVP3+A*T
C       VPP3=VVP3+B*T
C       WPP3=WVP3+C*T
C
C (09/29/2005) This is the alternate formulation.  Instead of a line
C perpendicular to the plane of the triangle, we use one that passes
C through a user-specified center point.  This ought to work okay for
C triangular meshes that are meant to represent the surface of a globe
C (using the center of the globe as the center point), which is the
C case of most interest to us, but it will not work for an arbitrary
C triangular mesh.  This is a problem I'll have to look into later.
C
        T=-((UCP1+UVP1)*A+(VCP1+VVP1)*B+(WCP1+WVP1)*C+D)/
     +     ((UCP1+UVP1-PCPX)*A+(VCP1+VVP1-PCPY)*B+(WCP1+WVP1-PCPZ)*C)
C
        UPP1=UVP1+(UCP1+UVP1-PCPX)*T
        VPP1=VVP1+(VCP1+VVP1-PCPY)*T
        WPP1=WVP1+(WCP1+WVP1-PCPZ)*T
C
        T=-((UCP2+UVP2)*A+(VCP2+VVP2)*B+(WCP2+WVP2)*C+D)/
     +     ((UCP2+UVP2-PCPX)*A+(VCP2+VVP2-PCPY)*B+(WCP2+WVP2-PCPZ)*C)
C
        UPP2=UVP2+(UCP2+UVP2-PCPX)*T
        VPP2=VVP2+(VCP2+VVP2-PCPY)*T
        WPP2=WVP2+(WCP2+WVP2-PCPZ)*T
C
        T=-((UCP3+UVP3)*A+(VCP3+VVP3)*B+(WCP3+WVP3)*C+D)/
     +     ((UCP3+UVP3-PCPX)*A+(VCP3+VVP3-PCPY)*B+(WCP3+WVP3-PCPZ)*C)
C
        UPP3=UVP3+(UCP3+UVP3-PCPX)*T
        VPP3=VVP3+(VCP3+VVP3-PCPY)*T
        WPP3=WVP3+(WCP3+WVP3-PCPZ)*T
C
C Use cross products with the normal to the triangle to generate
C vectors perpendicular to the velocity vectors.
C
        UQP1=DCNV*WPP1-DCNW*VPP1
        VQP1=DCNW*UPP1-DCNU*WPP1
        WQP1=DCNU*VPP1-DCNV*UPP1
C
        UQP2=DCNV*WPP2-DCNW*VPP2
        VQP2=DCNW*UPP2-DCNU*WPP2
        WQP2=DCNU*VPP2-DCNV*UPP2
C
        UQP3=DCNV*WPP3-DCNW*VPP3
        VQP3=DCNW*UPP3-DCNU*WPP3
        WQP3=DCNU*VPP3-DCNV*UPP3
C
C Now generate vectors at the specified angle to the velocity vectors.
C
        UPP1=UPP1*COS(DTOR*ANGD)+UQP1*SIN(DTOR*ANGD)
        VPP1=VPP1*COS(DTOR*ANGD)+VQP1*SIN(DTOR*ANGD)
        WPP1=WPP1*COS(DTOR*ANGD)+WQP1*SIN(DTOR*ANGD)
C
        UPP2=UPP2*COS(DTOR*ANGD)+UQP2*SIN(DTOR*ANGD)
        VPP2=VPP2*COS(DTOR*ANGD)+VQP2*SIN(DTOR*ANGD)
        WPP2=WPP2*COS(DTOR*ANGD)+WQP2*SIN(DTOR*ANGD)
C
        UPP3=UPP3*COS(DTOR*ANGD)+UQP3*SIN(DTOR*ANGD)
        VPP3=VPP3*COS(DTOR*ANGD)+VQP3*SIN(DTOR*ANGD)
        WPP3=WPP3*COS(DTOR*ANGD)+WQP3*SIN(DTOR*ANGD)
C
C For each of the projected velocity vectors at the three vertices of
C the triangle, find R and S such that the vector may be expressed as R
C times the vector from V1 to V2 plus S times the vector from V1 to V3.
C There are three possible ways to compute these; we use the one that
C minimizes the probability of dividing zero by zero.
C
        DNUV=((UCP2-UCP1)*(VCP3-VCP1)-(VCP2-VCP1)*(UCP3-UCP1))
        DNVW=((VCP2-VCP1)*(WCP3-WCP1)-(WCP2-WCP1)*(VCP3-VCP1))
        DNWU=((WCP2-WCP1)*(UCP3-UCP1)-(UCP2-UCP1)*(WCP3-WCP1))
C
        IF (ABS(DNUV).GT.ABS(DNVW).AND.ABS(DNUV).GT.ABS(DNWU))
          RVV1=(      UPP1 *(VCP3-VCP1)-      VPP1 *(UCP3-UCP1))/DNUV
          SVV1=((UCP2-UCP1)*      VPP1 -(VCP2-VCP1)*      UPP1 )/DNUV
          RVV2=(      UPP2 *(VCP3-VCP1)-      VPP2 *(UCP3-UCP1))/DNUV
          SVV2=((UCP2-UCP1)*      VPP2 -(VCP2-VCP1)*      UPP2 )/DNUV
          RVV3=(      UPP3 *(VCP3-VCP1)-      VPP3 *(UCP3-UCP1))/DNUV
          SVV3=((UCP2-UCP1)*      VPP3 -(VCP2-VCP1)*      UPP3 )/DNUV
        ELSE IF(ABS(DNVW).GT.ABS(DNWU).AND.ABS(DNVW).GT.ABS(DNUV))
          RVV1=(      VPP1 *(WCP3-WCP1)-      WPP1 *(VCP3-VCP1))/DNVW
          SVV1=((VCP2-VCP1)*      WPP1 -(WCP2-WCP1)*      VPP1 )/DNVW
          RVV2=(      VPP2 *(WCP3-WCP1)-      WPP2 *(VCP3-VCP1))/DNVW
          SVV2=((VCP2-VCP1)*      WPP2 -(WCP2-WCP1)*      VPP2 )/DNVW
          RVV3=(      VPP3 *(WCP3-WCP1)-      WPP3 *(VCP3-VCP1))/DNVW
          SVV3=((VCP2-VCP1)*      WPP3 -(WCP2-WCP1)*      VPP3 )/DNVW
        ELSE
          RVV1=(      WPP1 *(UCP3-UCP1)-      UPP1 *(WCP3-WCP1))/DNWU
          SVV1=((WCP2-WCP1)*      UPP1 -(UCP2-UCP1)*      WPP1 )/DNWU
          RVV2=(      WPP2 *(UCP3-UCP1)-      UPP2 *(WCP3-WCP1))/DNWU
          SVV2=((WCP2-WCP1)*      UPP2 -(UCP2-UCP1)*      WPP2 )/DNWU
          RVV3=(      WPP3 *(UCP3-UCP1)-      UPP3 *(WCP3-WCP1))/DNWU
          SVV3=((WCP2-WCP1)*      UPP3 -(UCP2-UCP1)*      WPP3 )/DNWU
        END IF
C
C If the last triangle was blocked (or non-existent) and this one is
C not blocked, compute values associated with the first point of a new
C segment of streamline.
C
        IF (ILTB.NE.0.AND.ICTB.EQ.0)
          UCND=UCP1+RVAL*(UCP2-UCP1)+SVAL*(UCP3-UCP1)
          VCND=VCP1+RVAL*(VCP2-VCP1)+SVAL*(VCP3-VCP1)
          WCND=WCP1+RVAL*(WCP2-WCP1)+SVAL*(WCP3-WCP1)
          CCND=CVP1+RVAL*(CVP2-CVP1)+SVAL*(CVP3-CVP1)
          INVOKE (COMPUTE-USER-COORDINATES)
        END IF
C
C If the new triangle is blocked and there's something in the polyline
C buffer, clear the buffer.
C
        IF (ICTB.NE.0.AND.NCPL.NE.0)
          INVOKE (CLEAR-POLYLINE-BUFFER)
        END IF
C
C Initialize a flag which keeps track of whether the line has terminated
C inside the triangle, and, if so, how.
C
        JUMP=0
C
C CONTINUE TRACING LINE INSIDE TRIANGLE -------------------------------
C
C Trace the line in the requested direction.  SLNE is the length of
C line to be traced before the next event, and SLNS is a saved copy
C of SLNE.
C
  102   SLNE=SLMX-SLTR
        SLNS=SLNE
C
C Take a step along the line and check for termination.  Helpful
C comments about some of the tests below are to be found in the
C file called "VectorMath".
C
  103   RVVN=RVV1+RVAL*(RVV2-RVV1)+SVAL*(RVV3-RVV1)
        SVVN=SVV1+RVAL*(SVV2-SVV1)+SVAL*(SVV3-SVV1)
C
        UPPN=RVVN*(UCP2-UCP1)+SVVN*(UCP3-UCP1)
        VPPN=RVVN*(VCP2-VCP1)+SVVN*(VCP3-VCP1)
        WPPN=RVVN*(WCP2-WCP1)+SVVN*(WCP3-WCP1)
C
        VMAG=SQRT(UPPN**2+VPPN**2+WPPN**2)
C
        IF (VMAG.GT.VVMM)
C
          TEMP=MIN(SLNE,SLPR)/VMAG
C
C Check for exit through the side joining V1 and V3.
C
          IF (RVAL+TEMP*RVVN.LT.0..AND.(RVAL.GT..001.OR.
     +        ABS(RVVN).GT..001*ABS(RVVN+2.*SVVN)))
            JUMP=1
            TEMP=-RVAL/RVVN
          END IF
C
C Check for exit through the side joining V1 and V2.
C
          IF (SVAL+TEMP*SVVN.LT.0..AND.(SVAL.GT..001.OR.
     +        ABS(SVVN).GT..001*ABS(2.*RVVN+SVVN)))
            JUMP=2
            TEMP=-SVAL/SVVN
          END IF
C
C Check for exit through the side joining V2 and V3.
C
          IF (1.-RVAL-SVAL-TEMP*(RVVN+SVVN).LT.0..AND.
     +       (1.-RVAL-SVAL.GT..001.OR.
     +        ABS(RVVN+SVVN).GT..001*ABS(RVVN-SVVN)))
            JUMP=3
            TEMP=(1.-RVAL-SVAL)/(RVVN+SVVN)
          END IF
C
          RVAL=MAX(0.,MIN(1.,RVAL+TEMP*RVVN))
          SVAL=MAX(0.,MIN(1.,SVAL+TEMP*SVVN))
C
C If the current triangle is not blocked, save information about the
C previous point, generate values for the new point, and process the
C line segment joining them.
C
          IF (ICTB.EQ.0)
            UCOD=UCND
            VCOD=VCND
            WCOD=WCND
            CCOD=CCND
            XCOU=XCNU
            YCOU=YCNU
            IVOU=IVNU
            UCND=UCP1+RVAL*(UCP2-UCP1)+SVAL*(UCP3-UCP1)
            VCND=VCP1+RVAL*(VCP2-VCP1)+SVAL*(VCP3-VCP1)
            WCND=WCP1+RVAL*(WCP2-WCP1)+SVAL*(WCP3-WCP1)
            CCND=CVP1+RVAL*(CVP2-CVP1)+SVAL*(CVP3-CVP1)
            INVOKE (COMPUTE-USER-COORDINATES)
            INVOKE (INTERPOLATE-POINTS-ALONG-SEGMENT)
          END IF
C
C Reduce the streamline length to be traced before the next event.
C
          SLNE=SLNE-VMAG*TEMP
C
C If the line is now of the desired length at the next event, terminate
C it.
C
          IF (SLNE.LT..01*SLPR)
            SLNE=0.
            JUMP=4
          END IF
C
        ELSE
C
C The velocity is too low.
C
          JUMP=5
C
        END IF
C
        IF (JUMP.EQ.0) GO TO 103
C
        IF (JUMP.EQ.4) JUMP=0
C
C Update various line-length quantities (line length in buffer and line
C length traced already).
C
        SLIB=SLNS-SLNE
        SLTR=SLTR+SLIB
C
C If the length of the line has hit the maximum, terminate it.
C
        IF (SLTR.GE.SLMX)
          ITER=4
          GO TO 104
        END IF
C
C If there is more of the line to be traced in the current triangle,
C jump back to continue tracing it.
C
        IF (JUMP.EQ.0) GO TO 102
C
C Otherwise, the line terminated inside the triangle.  If that happened
C because RVAL became zero, move to the triangle, if any, that lies on
C the other side of edge 1 (joining vertices 3 and 1 of the triangle).
C
        IF (JUMP.EQ.1)
C
          IF      (IEDG(ITRI(IIII+1)+1).EQ.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+2).EQ.IPP3)
            INEW=IEDG(ITRI(IIII+1)+3)
          ELSE IF (IEDG(ITRI(IIII+1)+1).EQ.IPP3.AND.
     +             IEDG(ITRI(IIII+1)+2).EQ.IPP1)
            INEW=IEDG(ITRI(IIII+1)+4)
          ELSE
            INEW=-1
          END IF
          IF (INEW.LT.0)
            ITER=1
            GO TO 104
          END IF
          IIII=LOTN*((INEW-1)/LOTN)
          IPP2=IPP3
          IF      (IEDG(ITRI(IIII+1)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+1).NE.IPP2)
            IPP3=IEDG(ITRI(IIII+1)+1)
          ELSE IF (IEDG(ITRI(IIII+1)+2).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+2).NE.IPP2)
            IPP3=IEDG(ITRI(IIII+1)+2)
          ELSE IF (IEDG(ITRI(IIII+2)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+2)+1).NE.IPP2)
            IPP3=IEDG(ITRI(IIII+2)+1)
          ELSE
            IPP3=IEDG(ITRI(IIII+2)+2)
          END IF
          RVAL=SVAL
          SVAL=0.
C
C If the line terminated because SVAL became zero, move to the triangle,
C if any, that lies on the other side of edge 2 (joining vertices 1 and
C 2 of the triangle).
C
        ELSE IF (JUMP.EQ.2)
C
          IF      (IEDG(ITRI(IIII+2)+1).EQ.IPP1.AND.
     +             IEDG(ITRI(IIII+2)+2).EQ.IPP2)
            INEW=IEDG(ITRI(IIII+2)+4)
          ELSE IF (IEDG(ITRI(IIII+2)+1).EQ.IPP2.AND.
     +             IEDG(ITRI(IIII+2)+2).EQ.IPP1)
            INEW=IEDG(ITRI(IIII+2)+3)
          ELSE
            INEW=-1
          END IF
          IF (INEW.LT.0)
            ITER=1
            GO TO 104
          END IF
          IIII=LOTN*((INEW-1)/LOTN)
          IPP3=IPP2
          IF      (IEDG(ITRI(IIII+1)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+1).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+1)+1)
          ELSE IF (IEDG(ITRI(IIII+1)+2).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+2).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+1)+2)
          ELSE IF (IEDG(ITRI(IIII+2)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+2)+1).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+2)+1)
          ELSE
            IPP2=IEDG(ITRI(IIII+2)+2)
          END IF
          SVAL=RVAL
          RVAL=0.
C
C If the line terminated because RVAL+SVAL became equal to one, move to
C the triangle, if any, that lies on the other side of edge 3 (joining
C vertices 2 and 3 of the triangle).
C
        ELSE IF (JUMP.EQ.3)
C
          IF      (IEDG(ITRI(IIII+3)+1).EQ.IPP2.AND.
     +             IEDG(ITRI(IIII+3)+2).EQ.IPP3)
            INEW=IEDG(ITRI(IIII+3)+4)
          ELSE IF (IEDG(ITRI(IIII+3)+1).EQ.IPP3.AND.
     +             IEDG(ITRI(IIII+3)+2).EQ.IPP2)
            INEW=IEDG(ITRI(IIII+3)+3)
          ELSE
            INEW=-1
          END IF
          IF (INEW.LT.0)
            ITER=1
            GO TO 104
          END IF
          IIII=LOTN*((INEW-1)/LOTN)
          IPP1=IPP2
          IF      (IEDG(ITRI(IIII+1)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+1).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+1)+1)
          ELSE IF (IEDG(ITRI(IIII+1)+2).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+2).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+1)+2)
          ELSE IF (IEDG(ITRI(IIII+2)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+2)+1).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+2)+1)
          ELSE
            IPP2=IEDG(ITRI(IIII+2)+2)
          END IF
          SVAL=1.-RVAL
          RVAL=0.
C
        END IF
C
C If we just moved into a new triangle, we may need to recompute the
C values of the pointers to its vertices and of the coordinates of the
C point in the triangle.
C
        IF (JUMP.LT.4)
C
C Get a pointer to what should be point 1 of the triangle.  It will
C match one of the pointers we already have.
C
          IF (IEDG(ITRI(IIII+1)+1).EQ.IEDG(ITRI(IIII+2)+1).OR.
     +        IEDG(ITRI(IIII+1)+1).EQ.IEDG(ITRI(IIII+2)+2))
            IPPT=IEDG(ITRI(IIII+1)+1)
          ELSE
            IPPT=IEDG(ITRI(IIII+1)+2)
          END IF
C
C Adjust the pointers and the values of RVAL and SVAL appropriately.
C
          IF (IPPT.NE.IPP1)
            RTMP=RVAL
            STMP=SVAL
            IF (IPPT.EQ.IPP2)
              IPP2=IPP3
              IPP3=IPP1
              IPP1=IPPT
              RVAL=STMP
              SVAL=1.-RTMP-STMP
            ELSE
              IPP3=IPP2
              IPP2=IPP1
              IPP1=IPPT
              RVAL=1.-RTMP-STMP
              SVAL=RTMP
            END IF
          END IF
C
C Jump back to continue tracing the line in the new triangle.
C
          GO TO 101
C
C Otherwise, ...
C
        ELSE
C
C ... transfer the termination condition flag within the triangle to
C the appropriate return variable and drop through to the return from
C this routine.
C
          ITER=JUMP
C
        END IF
C
C Common exit point.  Process any remaining portion of the curve.
C
  104   IF (NCPL.NE.0)
          INVOKE (CLEAR-POLYLINE-BUFFER)
        END IF
C
C If the curve was colored, restore the saved polyline color.
C
        IF (IPCS.GE.0) CALL GSPLCI (IPCS)
C
C Done.
C
        RETURN
C
C The following internal procedure, given a line segment, adds visible
C portions of it to the coordinate arrays.
C
        BLOCK (INTERPOLATE-POINTS-ALONG-SEGMENT)
C
C If point interpolation is turned on, do the first IPIS segments.
C
          IF (IPIS.NE.0)
            USOD=UCOD
            VSOD=VCOD
            WSOD=WCOD
            CSOD=CCOD
            USND=UCND
            VSND=VCND
            WSND=WCND
            CSND=CCND
            XSNU=XCNU
            YSNU=YCNU
            ISNU=IVNU
            FOR (INTP = 1 TO ABS(IPIS))
              UCND=USOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(USND-USOD)
              VCND=VSOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(VSND-VSOD)
              WCND=WSOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(WSND-WSOD)
              CCND=CSOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(CSND-CSOD)
              INVOKE (COMPUTE-USER-COORDINATES)
              IF (IPIS.GT.0.OR.IVNU.NE.IVOU)
                INVOKE (ADD-POINTS-TO-POLYLINE)
                UCOD=UCND
                VCOD=VCND
                WCOD=WCND
                CCOD=CCND
                XCOU=XCNU
                YCOU=YCNU
                IVOU=IVNU
              END IF
            END FOR
            UCND=USND
            VCND=VSND
            WCND=WSND
            CCND=CSND
            XCNU=XSNU
            YCNU=YSNU
            IVNU=ISNU
          END IF
C
C Finish off the job.
C
          INVOKE (ADD-POINTS-TO-POLYLINE)
C
        END BLOCK
C
C The following internal procedure examines the points (UCOD,VCOD,WCOD),
C which projects into (XCOU,YCOU), and (UCND,VCND,WCND), which projects
C into (XCNU,YCNU), either of which may be visible or invisible in the
C projection space, and adds visible portions of the line segment
C between them to the polyline being built.
C
        BLOCK (ADD-POINTS-TO-POLYLINE)
C
          IF (UCND.NE.UCOD.OR.VCND.NE.VCOD.OR.WCND.NE.WCOD)
C
            IF (NCPL.EQ.0)
              IF (IVOU.NE.0)
                IF (IMPF.NE.0.AND.PITH.GT.0.)
                  UCLD=UCOD
                  VCLD=VCOD
                  WCLD=WCOD
                  CCLD=CCOD
                  XCLU=XCOU
                  YCLU=YCOU
                END IF
                NCPL=1
                XCPL(1)=XCOU
                YCPL(1)=YCOU
                IF (IPCS.GE.0)
                  CVAL=CCOD
                  INVOKE (COMPUTE-COLOR-INDEX)
                  IPCD=IPCI
                END IF
              ELSE IF (IVNU.NE.0)
                UCID=UCOD
                VCID=VCOD
                WCID=WCOD
                CCID=CCOD
                UCVD=UCND
                VCVD=VCND
                WCVD=WCND
                CCVD=CCND
                XCVU=XCNU
                YCVU=YCNU
                INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
                INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
                UCOD=UCVD
                VCOD=VCVD
                WCOD=WCVD
                CCOD=CCVD
                XCOU=XCVU
                YCOU=YCVU
                IVOU=1
              END IF
            ELSE IF (NCPL.EQ.MCPL)
              INVOKE (FLUSH-POLYLINE-BUFFER)
            END IF
C
            IF (IVNU.NE.0)
              INVOKE (OUTPUT-NEXT-POINT)
            ELSE IF (IVOU.NE.0)
              UCVD=UCOD
              VCVD=VCOD
              WCVD=WCOD
              CCVD=CCOD
              XCVU=XCOU
              YCVU=YCOU
              UCID=UCND
              VCID=VCND
              WCID=WCND
              CCID=CCND
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              UKND=UCND
              VKND=VCND
              WKND=WCND
              CKND=CCND
              XKNU=XCNU
              YKNU=YCNU
              UCND=UCVD
              VCND=VCVD
              WCND=WCVD
              CCND=CCVD
              XCNU=XCVU
              YCNU=YCVU
              INVOKE (OUTPUT-NEXT-POINT)
              UCND=UKND
              VCND=VKND
              WCND=WKND
              CCND=CKND
              XCNU=XKNU
              YCNU=YKNU
              INVOKE (CLEAR-POLYLINE-BUFFER)
            END IF
C
          END IF
C
        END BLOCK
C
C The following internal procedure outputs the next point; if mapping
C is being done and there is a sufficiently large jump in the mapped
C position of the point, we check for a discontinuity in the mapping.
C Similarly, if mapping is being done and point interpolation is
C activated, we check for a large enough jump in the mapped position
C to justify interpolating points.
C
        BLOCK (OUTPUT-NEXT-POINT)
          IF (IMPF.NE.0.AND.
     +                   (UCND.NE.UCOD.OR.VCND.NE.VCOD.OR.WCND.NE.WCOD))
            RUDO=RUDN
            RUDN=(ABS(XCNU-XCOU)+ABS(YCNU-YCOU))/
     +           (ABS(UCND-UCOD)+ABS(VCND-VCOD)+ABS(WCND-WCOD))
            IF (RUDN.GT.2.*RUDO)
              INVOKE (CHECK-FOR-POSSIBLE-DISCONTINUITY)
            END IF
            IF (PITH.GT.0.)
              UCTD=UCND
              VCTD=VCND
              WCTD=WCND
              CCTD=CCND
              XCTU=XCNU
              YCTU=YCNU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
          END IF
          NCPL=NCPL+1
          XCPL(NCPL)=XCNU
          YCPL(NCPL)=YCNU
          IF (IPCS.GE.0)
            CVAL=CCND
            INVOKE (COMPUTE-COLOR-INDEX)
            IF (IPCI.NE.IPCD)
              INVOKE (FLUSH-POLYLINE-BUFFER)
              IPCD=IPCI
            END IF
          END IF
        END BLOCK
C
C The following internal procedure is invoked when an unusually large
C jump in the position of mapped points on the curve is seen.  It
C checks for a possible discontinuity in the mapping function (as
C can happen, for example, when a cylindrical equidistant projection
C is being used); if there is such a discontinuity, we must generate
C a final point on one side of it, dump the polyline, and then start
C a new polyline on the other side.
C
        BLOCK (CHECK-FOR-POSSIBLE-DISCONTINUITY)
          UC1D=UCOD
          VC1D=VCOD
          WC1D=WCOD
          CC1D=CCOD
          XC1U=XCOU
          YC1U=YCOU
          UC2D=UCND
          VC2D=VCND
          WC2D=WCND
          CC2D=CCND
          XC2U=XCNU
          YC2U=YCNU
          ITMP=0
          LOOP
            DSTO=ABS(XC2U-XC1U)+ABS(YC2U-YC1U)
            UC3D=(UC1D+UC2D)/2.
            VC3D=(VC1D+VC2D)/2.
            WC3D=(WC1D+WC2D)/2.
            CC3D=(CC1D+CC2D)/2.
            CALL HLUCTMXYZ (IMPF,UC3D,VC3D,WC3D,XC3U,YC3U)
            IF (ICFELL('VTTLOM',2).NE.0) GO TO 104
            IF (OORV.EQ.0..OR.(XC3U.NE.OORV.AND.YC3U.NE.OORV))
              DST1=ABS(XC3U-XC1U)+ABS(YC3U-YC1U)
              DST2=ABS(XC3U-XC2U)+ABS(YC3U-YC2U)
              IF (MIN(DST1,DST2).GT.DSTO)
                ITMP=1000
                EXIT
              ELSE IF (DST1.LT.DST2)
                EXIT IF (UC3D.EQ.UC1D.AND.VC3D.EQ.VC1D.AND.WC3D.EQ.WC1D)
                UC1D=UC3D
                VC1D=VC3D
                WC1D=WC3D
                CC1D=CC3D
                XC1U=XC3U
                YC1U=YC3U
              ELSE
                EXIT IF (UC3D.EQ.UC2D.AND.VC3D.EQ.VC2D.AND.WC3D.EQ.WC2D)
                UC2D=UC3D
                VC2D=VC3D
                WC2D=WC3D
                CC2D=CC3D
                XC2U=XC3U
                YC2U=YC3U
              END IF
              ITMP=ITMP+1
              EXIT IF (ITMP.EQ.64)
            ELSE
              UCVD=UCOD
              VCVD=VCOD
              WCVD=WCOD
              CCVD=CCOD
              XCVU=XCOU
              YCVU=YCOU
              UCID=UC3D
              VCID=VC3D
              WCID=WC3D
              CCID=CC3D
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              INVOKE (CLEAR-POLYLINE-BUFFER)
              UCID=UC3D
              VCID=VC3D
              WCID=WC3D
              CCID=CC3D
              UCVD=UCND
              VCVD=VCND
              WCVD=WCND
              CCVD=CCND
              XCVU=XCNU
              YCVU=YCNU
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              ITMP=1000
              EXIT
            END IF
          END LOOP
          IF (ITMP.NE.1000.AND.
     +               (ABS(XC1U-XC2U).GT.SMLX.OR.ABS(YC1U-YC2U).GT.SMLY))
            IF (IMPF.NE.0.AND.PITH.GT.0.)
              UCTD=UC1D
              VCTD=VC1D
              WCTD=WC1D
              CCTD=CC1D
              XCTU=XC1U
              YCTU=YC1U
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
            NCPL=NCPL+1
            XCPL(NCPL)=XC1U
            YCPL(NCPL)=YC1U
            INVOKE (CLEAR-POLYLINE-BUFFER)
            IF (IMPF.NE.0.AND.PITH.GT.0.)
              UCLD=UC2D
              VCLD=VC2D
              WCLD=WC2D
              CCLD=CC2D
              XCLU=XC2U
              YCLU=YC2U
            END IF
            NCPL=1
            XCPL(1)=XC2U
            YCPL(1)=YC2U
            IF (IPCS.GE.0)
              CVAL=CC2D
              INVOKE (COMPUTE-COLOR-INDEX)
              IPCD=IPCI
            END IF
          END IF
        END BLOCK
C
C Given two points in the data-array-index coordinate system, one of
C which maps to a visible point and the other of which maps to an
C invisible point, this internal routine searches the line between
C them for a point near the edge of visibility.
C
        BLOCK (INTERPOLATE-TO-VISIBLE-EDGE)
          ITMP=0
          LOOP
            UCHD=(UCVD+UCID)/2.
            VCHD=(VCVD+VCID)/2.
            WCHD=(WCVD+WCID)/2.
            CCHD=(CCVD+CCID)/2.
            CALL HLUCTMXYZ (IMPF,UCHD,VCHD,WCHD,XCHU,YCHU)
            IF (ICFELL('VTTLOM',3).NE.0) GO TO 104
            IF (XCHU.NE.OORV.AND.YCHU.NE.OORV)
              EXIT IF (UCHD.EQ.UCVD.AND.VCHD.EQ.VCVD.AND.WCHD.EQ.WCVD)
              UCVD=UCHD
              VCVD=VCHD
              WCVD=WCHD
              CCVD=CCHD
              XCVU=XCHU
              YCVU=YCHU
            ELSE
              EXIT IF (UCHD.EQ.UCID.AND.VCHD.EQ.VCID.AND.WCHD.EQ.WCID)
              UCID=UCHD
              VCID=VCHD
              WCID=WCHD
              CCID=CCHD
            END IF
            ITMP=ITMP+1
            EXIT IF (ITMP.EQ.64)
          END LOOP
        END BLOCK
C
C The following internal procedure outputs a visible edge point found
C by the previous internal procedure.
C
        BLOCK (OUTPUT-VISIBLE-EDGE-POINT)
          IF (PITH.GT.0.)
            IF (NCPL.EQ.0)
              UCLD=UCVD
              VCLD=VCVD
              WCLD=WCVD
              CCLD=CCVD
              XCLU=XCVU
              YCLU=YCVU
            ELSE
              UCTD=UCVD
              VCTD=VCVD
              WCTD=WCVD
              CCTD=CCVD
              XCTU=XCVU
              YCTU=YCVU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
          END IF
          NCPL=NCPL+1
          XCPL(NCPL)=XCVU
          YCPL(NCPL)=YCVU
          IF (IPCS.GE.0)
            CVAL=CCVD
            INVOKE (COMPUTE-COLOR-INDEX)
            IF (IPCI.NE.IPCD)
              INVOKE (FLUSH-POLYLINE-BUFFER)
              IPCD=IPCI
            END IF
          END IF
        END BLOCK
C
C The following internal procedure is invoked when mapping is being
C done and a new point is about to be added to the polyline buffer.
C It checks for a jump (using a user-defined threshold value) in
C the mapped coordinates of the point and, if such a jump is found,
C interpolates some points in between.  The assumption is made that
C all points in between are visible; if that is found not to be the
C case, no attempt is made to rectify the situation: the user probably
C screwed up the definition of the mapping function.
C
        BLOCK (CHECK-FOR-JUMP-IN-MAPPING)
          WHILE (ABS(XCTU-XCLU).GT.PITX.OR.ABS(YCTU-YCLU).GT.PITY)
            IFND=0
            UCQD=0.
            VCQD=0.
            WCQD=0.
            CCQD=0.
            RDST=.50
            RSTP=.25
            LOOP
              UCPD=UCLD+RDST*(UCTD-UCLD)
              VCPD=VCLD+RDST*(VCTD-VCLD)
              WCPD=WCLD+RDST*(WCTD-WCLD)
              CCPD=CCLD+RDST*(CCTD-CCLD)
              CALL HLUCTMXYZ (IMPF,UCPD,VCPD,WCPD,XCPU,YCPU)
              IF (ICFELL('VTTLOM',4).NE.0) GO TO 104
              EXIT IF (OORV.NE.0..AND.(XCPU.EQ.OORV.OR.YCPU.EQ.OORV))
              IF (ABS(XCPU-XCLU).LT.PITX.AND.ABS(YCPU-YCLU).LT.PITY)
                IFND=1
                UCQD=UCPD
                VCQD=VCPD
                WCQD=WCPD
                CCQD=CCPD
                XCQU=XCPU
                YCQU=YCPU
                EXIT IF (ABS(XCQU-XCLU).GT..5*PITX.OR.
     +                   ABS(YCQU-YCLU).GT..5*PITY)
                RDST=RDST+RSTP
              ELSE
                RDST=RDST-RSTP
              END IF
              RSTP=RSTP/2.
              EXIT IF (RSTP.LT..0001)
            END LOOP
            IF (IFND.NE.0.AND.(UCQD.NE.UCLD.OR.VCQD.NE.VCLD.OR.
     +                                         WCQD.NE.WCLD))
              NCPL=NCPL+1
              XCPL(NCPL)=XCQU
              YCPL(NCPL)=YCQU
              IF (IPCS.GE.0)
                CVAL=CCQD
                INVOKE (COMPUTE-COLOR-INDEX)
                IF (IPCI.NE.IPCD)
                  INVOKE (FLUSH-POLYLINE-BUFFER)
                  IPCD=IPCI
                END IF
              END IF
              IF (NCPL.EQ.MCPL)
                INVOKE (FLUSH-POLYLINE-BUFFER)
              END IF
              UCLD=UCQD
              VCLD=VCQD
              WCLD=WCQD
              CCLD=CCQD
              XCLU=XCQU
              YCLU=YCQU
            ELSE
              UCLD=UCTD
              VCLD=VCTD
              WCLD=WCTD
              CCLD=CCTD
              XCLU=XCTU
              YCLU=YCTU
            END IF
          END WHILE
          UCLD=UCTD
          VCLD=VCTD
          WCLD=WCTD
          CCLD=CCTD
          XCLU=XCTU
          YCLU=YCTU
        END BLOCK
C
C The following internal procedure is given the data-system coordinates
C of a point (UCND,VCND,WCND) and computes the user-system coordinates
C of the point's projection (XCNU,YCNU).  It also sets a flag indicating
C whether the projection point is visible or not.
C
        BLOCK (COMPUTE-USER-COORDINATES)
C
          IF (IMPF.EQ.0)
            XCNU=UCND
            YCNU=VCND
            IVNU=1
          ELSE
            CALL HLUCTMXYZ (IMPF,UCND,VCND,WCND,XCNU,YCNU)
            IF (ICFELL('VTTLOM',5).NE.0) GO TO 104
            IF ((OORV.NE.0.).AND.(XCNU.EQ.OORV.OR.YCNU.EQ.OORV))
              IVNU=0
            ELSE
              IVNU=1
            END IF
          END IF
C
        END BLOCK
C
C The following internal procedure, given a value (CVAL), computes a
C polyline color index (IPCI) to be used to get a desired color for a
C streamline being drawn.
C
        BLOCK (COMPUTE-COLOR-INDEX)
          WHILE (ICVL.GT.1.AND.CVAL.LT.TVAL(ICVL))
            ICVL=ICVL-1
          END WHILE
          WHILE (ICVL.LT.NCLR.AND.CVAL.GE.TVAL(ICVL+1))
            ICVL=ICVL+1
          END WHILE
          IPCI=ICLR(ICVL)
        END BLOCK
C
C The following internal procedure draws the part of the curve defined
C by the contents of the polyline buffer and then removes all but the
C last point from the buffer.  IPCC is the polyline color currently
C in use and IPCD the polyline color desired for the curve.
C
        BLOCK (FLUSH-POLYLINE-BUFFER)
C
          I=1
C
          LOOP
            I=I+1
            EXIT IF (I.GT.NCPL)
            IF (ABS(XCPL(I)-XCPL(I-1)).LT.EPSX.AND.
     +          ABS(YCPL(I)-YCPL(I-1)).LT.EPSY)
              IF (I.NE.NCPL)
                DO (J=I+1,NCPL)
                  XCPL(J-1)=XCPL(J)
                  YCPL(J-1)=YCPL(J)
                END DO
              ELSE
                XCPL(NCPL-1)=XCPL(NCPL)
                YCPL(NCPL-1)=YCPL(NCPL)
              END IF
              I=I-1
              NCPL=NCPL-1
            END IF
          END LOOP
C
          IF (NCPL.GT.1)
            IF (IPCC.NE.IPCD)
              CALL GSPLCI (IPCD)
              IPCC=IPCD
            END IF
            IF (IAMA(1).EQ.0)
              CALL CURVE (XCPL,YCPL,NCPL)
            ELSE
              CALL ARDRLN (IAMA,XCPL,YCPL,NCPL,
     +                          XCPF,YCPF,MCPF,
     +                          IAAI,IAGI,MNOG,RTPL)
            END IF
          END IF
C
          XCPL(1)=XCPL(NCPL)
          YCPL(1)=YCPL(NCPL)
          NCPL=1
C
        END BLOCK
C
C The following internal procedure draws the part of the curve defined
C by the contents of the polyline buffer and then clears the buffer.
C IPCC is the polyline color currently in use and IPCD the polyline
C color desired for the curve.
C
        BLOCK (CLEAR-POLYLINE-BUFFER)
C
          I=1
C
          LOOP
            I=I+1
            EXIT IF (I.GT.NCPL)
            IF (ABS(XCPL(I)-XCPL(I-1)).LT.EPSX.AND.
     +          ABS(YCPL(I)-YCPL(I-1)).LT.EPSY)
              IF (I.NE.NCPL)
                DO (J=I+1,NCPL)
                  XCPL(J-1)=XCPL(J)
                  YCPL(J-1)=YCPL(J)
                END DO
              ELSE
                XCPL(NCPL-1)=XCPL(NCPL)
                YCPL(NCPL-1)=YCPL(NCPL)
              END IF
              I=I-1
              NCPL=NCPL-1
            END IF
          END LOOP
C
          IF (NCPL.GT.1)
            IF (IPCC.NE.IPCD)
              CALL GSPLCI (IPCD)
              IPCC=IPCD
            END IF
            IF (IAMA(1).EQ.0)
              CALL CURVE (XCPL,YCPL,NCPL)
            ELSE
              CALL ARDRLN (IAMA,XCPL,YCPL,NCPL,
     +                          XCPF,YCPF,MCPF,
     +                          IAAI,IAGI,MNOG,RTPL)
            END IF
          END IF
C
          NCPL=0
          RUDN=0.
C
        END BLOCK
C
      END
.OP   BI=77


.OP   BI=66
      SUBROUTINE VTTPOM (RPNT,IEDG,ITRI,ISTR,RSTR,SSTR,IDIR,IDBC,
     +                   SLMX,ITER,SLTR,IEND,REND,SEND,IAMA,RTPL)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),IAMA(*)
C
        EXTERNAL RTPL
C
C This routine is a copy of VTTSOM that has been modified to allow for
C tracing a line perpendicular to the direction of the flow field.  It
C is used for two purposes: 1) to trace a streamline generator; and 2)
C to trace a short line, perpendicular to a streamline, to see whether
C the streamline is within a specified distance of previously-drawn
C streamlines (referred to as "proximity testing").
C
C This routine, given arrays defining a triangular mesh, at each point
C of which a velocity vector is given, and the location of a particular
C point on a particular triangle of that mesh, traces a line that is
C perpendicular to the velocity vectors, following it until one of a
C set of termination conditions is satisfied.
C
C RPNT is an array of nodes defining vertices of triangles of the mesh.
C
C IEDG is an array of nodes defining edges (pairs of vertices) of the
C triangles of the mesh.
C
C ITRI is an array of nodes defining triangles (triplets of edges) of
C the mesh.
C
C ISTR is the base index, in ITRI, of the triangle node of the triangle
C containing the starting point, and RSTR and SSTR are coordinates of
C the starting point within that triangle (fractional multipliers of
C its first and second sides, respectively).
C
C IDIR is a flag that says in which direction the line is to be traced:
C 0 => toward its beginning; 1 => toward its end.
C
C IDBC is the color index for a color to be used to draw debug stuff.
C
C SLMX is the maximum length of line to be traced.
C
C ITER is a flag that is returned to say how the line terminated:
C
C   ITER=1 => exterior edge of mesh encountered.
C   ITER=3 => angle between velocity vectors exceeded maximum.
C   ITER=4 => line traced for specified distance.
C   ITER=5 => velocity along line dropped below VVMM.
C   ITER=6 => line entered a subtriangle occupied by a streamline.
C   ITER=7 => other (e. g., a degenerate triangle).
C
C SLTR is returned and is the length of line traced before a termination
C condition was encountered.
C
C IEND, REND, and SEND are returned; IEND is the base index, in ITRI,
C of the triangle node of the triangle containing the end point of the
C line and REND and SEND are the coordinates of the end point within
C that triangle.
C
C IAMA is an array containing an area map against which the line is to
C be masked.  If masking is not desired, set IAMA(1) = 0.
C
C RTPL is a routine to be called to draw the line (when it is masked).
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Declare local arrays for user-system polyline coordinates.
C
        PARAMETER (MCPL=100)
C
        DIMENSION XCPL(MCPL),YCPL(MCPL)
C
C Declare local arrays to use in drawing masked polylines.
C
        PARAMETER (MCPF=MCPL,MNOG=64)
        DIMENSION XCPF(MCPF),YCPF(MCPF),IAAI(MNOG),IAGI(MNOG)
C
C Declare a character variable to hold the digits from 0 to 9.
C
        CHARACTER*10 IDIG
C
C Put the digits from 0 to 9 in a single character variable.
C
        DATA IDIG / '0123456789' /
C
C DTOR is a multiplicative constant to convert from degrees to radians.
C
        DATA DTOR / .017453292519943 /
C
C IXOR(IONE,ITWO) is the exclusive OR of the 12-bit masks IONE and ITWO.
C
        IXOR(IONE,ITWO)=IAND(IOR(IONE,ITWO),4095-IAND(IONE,ITWO))
C
C ITBF(IARG) is non-zero if and only if a triangle with blocking-flag
C element IARG is blocked.
C
        ITBF(IARG)=IAND(IXOR(IARG,ITBX),ITBA)
C
C Extract the values of ITBX and ITBA from ITBM.
C
        ITBX=IAND(ISHIFT(ITBM,-12),4095)
        ITBA=IAND(       ITBM     ,4095)
C
C If debugging is turned on, save the initial polyline color and reset
C it to a specified color.
C
        IF (IDBG.NE.0)
          CALL GQPLCI (IGER,IPCS)
          IF (IGER.NE.0)
            CALL SETER ('VTTPOM - ERROR EXIT FROM GQPLCI',2,1)
            RETURN
          END IF
          CALL PLOTIT (0,0,2)
          CALL GSPLCI (IDBC)
        ELSE
          IPCS=-1
        END IF
C
C Compute a test value, based on the maximum allowable angle, to be
C used below.
C
        IF (ANM2.NE.0.)
          CSMN=COS(DTOR*ANM2)
          CSMN=CSMN*ABS(CSMN)
        END IF
C
C Set some tolerances for the drawing code.
C
        EPSX=ABS(XWDR-XWDL)*EPSI
        EPSY=ABS(YWDT-YWDB)*EPSI
C
        SMLX=.01*ABS(XWDR-XWDL)
        SMLY=.01*ABS(YWDT-YWDB)
C
        PITX=PITH*ABS(XWDR-XWDL)
        PITY=PITH*ABS(YWDT-YWDB)
C
C Initialize the pointer to the current triangle and find the base
C indices of the nodes defining its points.
C
        IIII=ISTR
C
C Find the base indices of point 1 (that edges 1 and 2 have in common),
C point 2 (that edges 2 and 3 have in common), and point 3 (that edges
C 3 and 1 have in common).
C
        IF (IEDG(ITRI(IIII+2)+1).NE.IEDG(ITRI(IIII+3)+1).AND.
     +      IEDG(ITRI(IIII+2)+1).NE.IEDG(ITRI(IIII+3)+2))
          IPP1=IEDG(ITRI(IIII+2)+1)
          IPP2=IEDG(ITRI(IIII+2)+2)
        ELSE
          IPP1=IEDG(ITRI(IIII+2)+2)
          IPP2=IEDG(ITRI(IIII+2)+1)
        END IF
C
        IF (IEDG(ITRI(IIII+1)+1).NE.IPP1)
          IPP3=IEDG(ITRI(IIII+1)+1)
        ELSE
          IPP3=IEDG(ITRI(IIII+1)+2)
        END IF
C
C Initialize the starting point values.
C
        RVAL=RSTR
        SVAL=SSTR
C
C If debugging is turned on, mark the starting point of the line in a
C specified color.
C
        IF (IDBG.NE.0.AND.ITBF(ITRI(IIII+4)).EQ.0)
          CALL HLUVTMXYZ (IMPF,
     +                    RPNT(IPP1+1)+RVAL*(RPNT(IPP2+1)-RPNT(IPP1+1))+
     +                                 SVAL*(RPNT(IPP3+1)-RPNT(IPP1+1)),
     +                    RPNT(IPP1+2)+RVAL*(RPNT(IPP2+2)-RPNT(IPP1+2))+
     +                                 SVAL*(RPNT(IPP3+2)-RPNT(IPP1+2)),
     +                    RPNT(IPP1+3)+RVAL*(RPNT(IPP2+3)-RPNT(IPP1+3))+
     +                                 SVAL*(RPNT(IPP3+3)-RPNT(IPP1+3)),
     +                    XPOS,YPOS)
          IF (XPOS.NE.OORV)
            CALL GQFACI (IGER,ISFC)
            CALL GSFACI (IDBC)
            CALL VTDREL (CUFX(XPOS),CUFY(YPOS),.0004,.0004,0.,10.,1)
            CALL GSFACI (ISFC)
          END IF
        END IF
C
C SLTR keeps track of the length of line traced already.
C
          SLTR=0.
C
C IPRJ is non-zero if and only if the streamline is to be projected
C from the triangular mesh to the image plane, either because the line
C is to be drawn there or because testing needs to be done there.
C
        IF (IDBG.EQ.0)
          IPRJ=0
        ELSE
          IPRJ=1
        END IF
C
C NCPL keeps track of the number of points in the coordinate arrays.
C
        NCPL=0
C
C RUDN keeps track of the ratio of segment length in the user coordinate
C system to segment length in the data coordinate system.
C
        RUDN=0.
C
C ICTB is non-zero if and only if the current triangle is blocked and
C ILTB is non-zero if and only if the last triangle was blocked.
C
        ICTB=1
C
C START TRACING LINE INSIDE TRIANGLE ----------------------------------
C
C Initializing - move ICTB to ILTB and recompute the correct value for
C the new triangle.
C
  101   ILTB=ICTB
        ICTB=ITBF(ITRI(IIII+4))
C
C Extract values from the point arrays describing the current triangle,
C including the coordinates of its vertices, the components of the
C velocity vectors at its vertices, and the values of the quantities
C to be used to determine the color of the line drawn.
C
        UCP1=RPNT(IPP1+1)
        VCP1=RPNT(IPP1+2)
        WCP1=RPNT(IPP1+3)
        UCP2=RPNT(IPP2+1)
        VCP2=RPNT(IPP2+2)
        WCP2=RPNT(IPP2+3)
        UCP3=RPNT(IPP3+1)
        VCP3=RPNT(IPP3+2)
        WCP3=RPNT(IPP3+3)
C
        IF (IDIR.EQ.0)
          UVP1=-RPNT(IPP1+4)
          VVP1=-RPNT(IPP1+5)
          WVP1=-RPNT(IPP1+6)
          UVP2=-RPNT(IPP2+4)
          VVP2=-RPNT(IPP2+5)
          WVP2=-RPNT(IPP2+6)
          UVP3=-RPNT(IPP3+4)
          VVP3=-RPNT(IPP3+5)
          WVP3=-RPNT(IPP3+6)
        ELSE
          UVP1=+RPNT(IPP1+4)
          VVP1=+RPNT(IPP1+5)
          WVP1=+RPNT(IPP1+6)
          UVP2=+RPNT(IPP2+4)
          VVP2=+RPNT(IPP2+5)
          WVP2=+RPNT(IPP2+6)
          UVP3=+RPNT(IPP3+4)
          VVP3=+RPNT(IPP3+5)
          WVP3=+RPNT(IPP3+6)
        END IF
C
        VMG1=SQRT(UVP1**2+VVP1**2+WVP1**2)
C
        IF (VMG1.NE.0.)
          UVP1=.001*EMAX*UVP1/VMG1
          VVP1=.001*EMAX*VVP1/VMG1
          WVP1=.001*EMAX*WVP1/VMG1
        END IF
C
        VMG2=SQRT(UVP2**2+VVP2**2+WVP2**2)
C
        IF (VMG2.NE.0.)
          UVP2=.001*EMAX*UVP2/VMG2
          VVP2=.001*EMAX*VVP2/VMG2
          WVP2=.001*EMAX*WVP2/VMG2
        END IF
C
        VMG3=SQRT(UVP3**2+VVP3**2+WVP3**2)
C
        IF (VMG3.NE.0.)
          UVP3=.001*EMAX*UVP3/VMG3
          VVP3=.001*EMAX*VVP3/VMG3
          WVP3=.001*EMAX*WVP3/VMG3
        END IF
C
C Compute the coefficients A, B, C, and D in the equation defining the
C plane of the triangle (Ax+By+Cz+D=0).
C
        A=(VCP2-VCP1)*(WCP3-WCP1)-(VCP3-VCP1)*(WCP2-WCP1)
        B=(WCP2-WCP1)*(UCP3-UCP1)-(WCP3-WCP1)*(UCP2-UCP1)
        C=(UCP2-UCP1)*(VCP3-VCP1)-(UCP3-UCP1)*(VCP2-VCP1)
        D=-(A*UCP1+B*VCP1+C*WCP1)
C
C Compute the direction cosines of the normal to the triangle.  If they
C are not well-defined, take an error exit.
C
        DNOM=SQRT(A**2+B**2+C**2)
C
        IF (DNOM.NE.0.)

          DCNU=A/DNOM
          DCNV=B/DNOM
          DCNW=C/DNOM
C
        ELSE
C
          ITER=7
          GO TO 104
C
        END IF
C
C (09/29/2005) The following code resulted in discontinuities in the
C definitions of the velocity vectors along the edges of the triangles
C of the mesh.  I found a formulation that didn't have this problem,
C but I'm leaving the original code here, commented out, for possible
C future reference.
C
C For each velocity vector, use the parametric equations for a line that
C passes through the end of it and is perpendicular to the plane of the
C triangle to find the coordinates of the point where it intersects the
C triangle; use that to compute the components of the projection of the
C velocity vector into the plane of the triangle.
C
C       T=-(A*(UCP1+UVP1)+B*(VCP1+VVP1)+C*(WCP1+WVP1)+D)/
C    +                                                  (A**2+B**2+C**2)
C       UPP1=UVP1+A*T
C       VPP1=VVP1+B*T
C       WPP1=WVP1+C*T
C
C       T=-(A*(UCP2+UVP2)+B*(VCP2+VVP2)+C*(WCP2+WVP2)+D)/
C    +                                                  (A**2+B**2+C**2)
C       UPP2=UVP2+A*T
C       VPP2=VVP2+B*T
C       WPP2=WVP2+C*T
C
C       T=-(A*(UCP3+UVP3)+B*(VCP3+VVP3)+C*(WCP3+WVP3)+D)/
C    +                                                  (A**2+B**2+C**2)
C       UPP3=UVP3+A*T
C       VPP3=VVP3+B*T
C       WPP3=WVP3+C*T
C
C (09/29/2005) This is the alternate formulation.  Instead of a line
C perpendicular to the plane of the triangle, we use one that passes
C through a user-specified center point.  This ought to work okay for
C triangular meshes that are meant to represent the surface of a globe
C (using the center of the globe as the center point), which is the
C case of most interest to us, but it will not work for an arbitrary
C triangular mesh.  This is a problem I'll have to look into later.
C
        T=-((UCP1+UVP1)*A+(VCP1+VVP1)*B+(WCP1+WVP1)*C+D)/
     +     ((UCP1+UVP1-PCPX)*A+(VCP1+VVP1-PCPY)*B+(WCP1+WVP1-PCPZ)*C)
C
        UPP1=UVP1+(UCP1+UVP1-PCPX)*T
        VPP1=VVP1+(VCP1+VVP1-PCPY)*T
        WPP1=WVP1+(WCP1+WVP1-PCPZ)*T
C
        T=-((UCP2+UVP2)*A+(VCP2+VVP2)*B+(WCP2+WVP2)*C+D)/
     +     ((UCP2+UVP2-PCPX)*A+(VCP2+VVP2-PCPY)*B+(WCP2+WVP2-PCPZ)*C)
C
        UPP2=UVP2+(UCP2+UVP2-PCPX)*T
        VPP2=VVP2+(VCP2+VVP2-PCPY)*T
        WPP2=WVP2+(WCP2+WVP2-PCPZ)*T
C
        T=-((UCP3+UVP3)*A+(VCP3+VVP3)*B+(WCP3+WVP3)*C+D)/
     +     ((UCP3+UVP3-PCPX)*A+(VCP3+VVP3-PCPY)*B+(WCP3+WVP3-PCPZ)*C)
C
        UPP3=UVP3+(UCP3+UVP3-PCPX)*T
        VPP3=VVP3+(VCP3+VVP3-PCPY)*T
        WPP3=WVP3+(WCP3+WVP3-PCPZ)*T
C
C Modify these values, using cross products with the normal to the
C triangle to generate vectors perpendicular to the velocity vectors.
C
        UPPT=DCNV*WPP1-DCNW*VPP1
        VPPT=DCNW*UPP1-DCNU*WPP1
        WPPT=DCNU*VPP1-DCNV*UPP1
C
        UPP1=UPPT
        VPP1=VPPT
        WPP1=WPPT
C
        UPPT=DCNV*WPP2-DCNW*VPP2
        VPPT=DCNW*UPP2-DCNU*WPP2
        WPPT=DCNU*VPP2-DCNV*UPP2
C
        UPP2=UPPT
        VPP2=VPPT
        WPP2=WPPT
C
        UPPT=DCNV*WPP3-DCNW*VPP3
        VPPT=DCNW*UPP3-DCNU*WPP3
        WPPT=DCNU*VPP3-DCNV*UPP3
C
        UPP3=UPPT
        VPP3=VPPT
        WPP3=WPPT
C
C For each of the projected velocity vectors at the three vertices of
C the triangle, find R and S such that the vector may be expressed as R
C times the vector from V1 to V2 plus S times the vector from V1 to V3.
C There are three possible ways to compute these; we use the one that
C minimizes the probability of dividing zero by zero.
C
        DNUV=((UCP2-UCP1)*(VCP3-VCP1)-(VCP2-VCP1)*(UCP3-UCP1))
        DNVW=((VCP2-VCP1)*(WCP3-WCP1)-(WCP2-WCP1)*(VCP3-VCP1))
        DNWU=((WCP2-WCP1)*(UCP3-UCP1)-(UCP2-UCP1)*(WCP3-WCP1))
C
        IF (ABS(DNUV).GT.ABS(DNVW).AND.ABS(DNUV).GT.ABS(DNWU))
          RVV1=(      UPP1 *(VCP3-VCP1)-      VPP1 *(UCP3-UCP1))/DNUV
          SVV1=((UCP2-UCP1)*      VPP1 -(VCP2-VCP1)*      UPP1 )/DNUV
          RVV2=(      UPP2 *(VCP3-VCP1)-      VPP2 *(UCP3-UCP1))/DNUV
          SVV2=((UCP2-UCP1)*      VPP2 -(VCP2-VCP1)*      UPP2 )/DNUV
          RVV3=(      UPP3 *(VCP3-VCP1)-      VPP3 *(UCP3-UCP1))/DNUV
          SVV3=((UCP2-UCP1)*      VPP3 -(VCP2-VCP1)*      UPP3 )/DNUV
        ELSE IF(ABS(DNVW).GT.ABS(DNWU).AND.ABS(DNVW).GT.ABS(DNUV))
          RVV1=(      VPP1 *(WCP3-WCP1)-      WPP1 *(VCP3-VCP1))/DNVW
          SVV1=((VCP2-VCP1)*      WPP1 -(WCP2-WCP1)*      VPP1 )/DNVW
          RVV2=(      VPP2 *(WCP3-WCP1)-      WPP2 *(VCP3-VCP1))/DNVW
          SVV2=((VCP2-VCP1)*      WPP2 -(WCP2-WCP1)*      VPP2 )/DNVW
          RVV3=(      VPP3 *(WCP3-WCP1)-      WPP3 *(VCP3-VCP1))/DNVW
          SVV3=((VCP2-VCP1)*      WPP3 -(WCP2-WCP1)*      VPP3 )/DNVW
        ELSE
          RVV1=(      WPP1 *(UCP3-UCP1)-      UPP1 *(WCP3-WCP1))/DNWU
          SVV1=((WCP2-WCP1)*      UPP1 -(UCP2-UCP1)*      WPP1 )/DNWU
          RVV2=(      WPP2 *(UCP3-UCP1)-      UPP2 *(WCP3-WCP1))/DNWU
          SVV2=((WCP2-WCP1)*      UPP2 -(UCP2-UCP1)*      WPP2 )/DNWU
          RVV3=(      WPP3 *(UCP3-UCP1)-      UPP3 *(WCP3-WCP1))/DNWU
          SVV3=((WCP2-WCP1)*      UPP3 -(UCP2-UCP1)*      WPP3 )/DNWU
        END IF
C
C See which subtriangle the line starts in and check the subtriangle
C mask to see if a streamline has passed through it already.  If so,
C terminate the line.
C
        INDR=MAX(0,MIN(4,INT(5.*RVAL)))
        INDS=MAX(0,MIN(4,INT(5.*SVAL)))
        INDT=MAX(0,MIN(4,INT(5.*(RVAL+SVAL))))
        IOSB=2*(5*INDR+INDS)-INDR*INDR+MOD(INDR+INDS+INDT,2)
        IF (IAND(ITRI(IIII+5),ISHIFT(1,3+IOSB)).NE.0)
          ITER=6
          GO TO 104
        END IF
C
C If the streamline is being projected ...
C
        IF (IPRJ.NE.0)
C
C ... and the last triangle was blocked (or non-existent) and this one
C is not blocked, compute values associated with the first point of a
C new segment of streamline.  (If both triangles are unblocked, values
C computed would be identical to what we already had, but for round-off
C differences that could cause problems.)
C
          IF (ILTB.NE.0.AND.ICTB.EQ.0)
            UCND=UCP1+RVAL*(UCP2-UCP1)+SVAL*(UCP3-UCP1)
            VCND=VCP1+RVAL*(VCP2-VCP1)+SVAL*(VCP3-VCP1)
            WCND=WCP1+RVAL*(WCP2-WCP1)+SVAL*(WCP3-WCP1)
            INVOKE (COMPUTE-USER-COORDINATES)
          END IF
C
C ... and, if the new triangle is blocked and there's something in the
C polyline buffer, clear the buffer.
C
          IF (ICTB.NE.0.AND.NCPL.NE.0)
            INVOKE (CLEAR-POLYLINE-BUFFER)
          END IF
C
        END IF
C
C Initialize a flag which keeps track of whether the line has terminated
C inside the triangle, and, if so, how.
C
        JUMP=0
C
C CONTINUE TRACING LINE INSIDE TRIANGLE -------------------------------
C
C Trace the line in the requested direction.  SLNE is the length of
C line to be traced before the next event, and SLNS is a saved copy
C of SLNE.
C
  102   SLNE=SLMX-SLTR
        SLNS=SLNE
C
C Take a step along the line and check for termination.  Helpful
C comments about some of the tests below are to be found in the
C file called "VectorMath".
C
  103   RVVN=RVV1+RVAL*(RVV2-RVV1)+SVAL*(RVV3-RVV1)
        SVVN=SVV1+RVAL*(SVV2-SVV1)+SVAL*(SVV3-SVV1)
C
        UPPN=RVVN*(UCP2-UCP1)+SVVN*(UCP3-UCP1)
        VPPN=RVVN*(VCP2-VCP1)+SVVN*(VCP3-VCP1)
        WPPN=RVVN*(WCP2-WCP1)+SVVN*(WCP3-WCP1)
C
        VMAG=SQRT(UPPN**2+VPPN**2+WPPN**2)
C
        IF (VMAG.GT.VVMM)
C
          TEMP=MIN(SLNE,SLPR)/VMAG
C
C Check for exit through the side joining V1 and V3.
C
          IF (RVAL+TEMP*RVVN.LT.0..AND.(RVAL.GT..001.OR.
     +        ABS(RVVN).GT..001*ABS(RVVN+2.*SVVN)))
            JUMP=1
            TEMP=-RVAL/RVVN
          END IF
C
C Check for exit through the side joining V1 and V2.
C
          IF (SVAL+TEMP*SVVN.LT.0..AND.(SVAL.GT..001.OR.
     +        ABS(SVVN).GT..001*ABS(2.*RVVN+SVVN)))
            JUMP=2
            TEMP=-SVAL/SVVN
          END IF
C
C Check for exit through the side joining V2 and V3.
C
          IF (1.-RVAL-SVAL-TEMP*(RVVN+SVVN).LT.0..AND.
     +       (1.-RVAL-SVAL.GT..001.OR.
     +        ABS(RVVN+SVVN).GT..001*ABS(RVVN-SVVN)))
            JUMP=3
            TEMP=(1.-RVAL-SVAL)/(RVVN+SVVN)
          END IF
C
          RVAL=MAX(0.,MIN(1.,RVAL+TEMP*RVVN))
          SVAL=MAX(0.,MIN(1.,SVAL+TEMP*SVVN))
C
C If the streamline is being projected and the current triangle is not
C blocked, save information about the previous point, generate values
C for the new point, and process the line segment joining them.
C
          IF (IPRJ.NE.0.AND.ICTB.EQ.0)
            UCOD=UCND
            VCOD=VCND
            WCOD=WCND
            XCOU=XCNU
            YCOU=YCNU
            IVOU=IVNU
            UCND=UCP1+RVAL*(UCP2-UCP1)+SVAL*(UCP3-UCP1)
            VCND=VCP1+RVAL*(VCP2-VCP1)+SVAL*(VCP3-VCP1)
            WCND=WCP1+RVAL*(WCP2-WCP1)+SVAL*(WCP3-WCP1)
            INVOKE (COMPUTE-USER-COORDINATES)
            INVOKE (INTERPOLATE-POINTS-ALONG-SEGMENT)
          END IF
C
C Reduce the streamline length to be traced before the next event.
C
          SLNE=SLNE-VMAG*TEMP
C
C If the line is now of the desired length at the next event, terminate
C it.
C
          IF (SLNE.LT..01*SLPR)
            SLNE=0.
            JUMP=4
          END IF
C
C See which subtriangle the line is entering and check the subtriangle
C mask to see if a streamline has passed through it already.  If so,
C terminate the line.
C
          IOSL=IOSB
          INDR=MAX(0,MIN(4,INT(5.*RVAL)))
          INDS=MAX(0,MIN(4,INT(5.*SVAL)))
          INDT=MAX(0,MIN(4,INT(5.*(RVAL+SVAL))))
          IOSB=2*(5*INDR+INDS)-INDR*INDR+MOD(INDR+INDS+INDT,2)
          IF (IAND(ITRI(IIII+5),ISHIFT(ISTA(25*IOSL+IOSB+1),3)).NE.0)
            JUMP=6
          END IF
C
        ELSE
C
C The velocity is too low.
C
          JUMP=5
C
        END IF
C
        IF (JUMP.EQ.0) GO TO 103
C
        IF (JUMP.EQ.4) JUMP=0
C
C Update various line-length quantities (line length in buffer and line
C length traced already).
C
        SLIB=SLNS-SLNE
        SLTR=SLTR+SLIB
C
C If the length of the line has hit the maximum, terminate it.
C
        IF (SLTR.GE.SLMX)
          ITER=4
          GO TO 104
        END IF
C
C If there is more of the line to be traced in the current triangle,
C jump back to continue tracing it.
C
        IF (JUMP.EQ.0) GO TO 102
C
C Otherwise, the line terminated inside the triangle.  If that happened
C because RVAL became zero, move to the triangle, if any, that lies on 
C the other side of edge 1 (joining vertices 3 and 1 of the triangle).
C
        IF (JUMP.EQ.1)
C
          IF      (IEDG(ITRI(IIII+1)+1).EQ.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+2).EQ.IPP3)
            INEW=IEDG(ITRI(IIII+1)+3)
          ELSE IF (IEDG(ITRI(IIII+1)+1).EQ.IPP3.AND.
     +             IEDG(ITRI(IIII+1)+2).EQ.IPP1)
            INEW=IEDG(ITRI(IIII+1)+4)
          ELSE
            INEW=-1
          END IF
          IF (INEW.LT.0)
            ITER=1
            GO TO 104
          END IF
          IIII=LOTN*((INEW-1)/LOTN)
          IPP2=IPP3
          IF      (IEDG(ITRI(IIII+1)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+1).NE.IPP2)
            IPP3=IEDG(ITRI(IIII+1)+1)
          ELSE IF (IEDG(ITRI(IIII+1)+2).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+2).NE.IPP2)
            IPP3=IEDG(ITRI(IIII+1)+2)
          ELSE IF (IEDG(ITRI(IIII+2)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+2)+1).NE.IPP2)
            IPP3=IEDG(ITRI(IIII+2)+1)
          ELSE
            IPP3=IEDG(ITRI(IIII+2)+2)
          END IF
          RVAL=SVAL
          SVAL=0.
C
C If the line terminated because SVAL became zero, move to the triangle,
C if any, that lies on the other side of edge 2 (joining vertices 1 and
C 2 of the triangle).
C
        ELSE IF (JUMP.EQ.2)
C
          IF      (IEDG(ITRI(IIII+2)+1).EQ.IPP1.AND.
     +             IEDG(ITRI(IIII+2)+2).EQ.IPP2)
            INEW=IEDG(ITRI(IIII+2)+4)
          ELSE IF (IEDG(ITRI(IIII+2)+1).EQ.IPP2.AND.
     +             IEDG(ITRI(IIII+2)+2).EQ.IPP1)
            INEW=IEDG(ITRI(IIII+2)+3)
          ELSE
            INEW=-1
          END IF
          IF (INEW.LT.0)
            ITER=1
            GO TO 104
          END IF
          IIII=LOTN*((INEW-1)/LOTN)
          IPP3=IPP2
          IF      (IEDG(ITRI(IIII+1)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+1).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+1)+1)
          ELSE IF (IEDG(ITRI(IIII+1)+2).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+2).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+1)+2)
          ELSE IF (IEDG(ITRI(IIII+2)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+2)+1).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+2)+1)
          ELSE
            IPP2=IEDG(ITRI(IIII+2)+2)
          END IF
          SVAL=RVAL
          RVAL=0.
C
C If the line terminated because RVAL+SVAL became equal to one, move to
C the triangle, if any, that lies on the other side of edge 3 (joining
C vertices 2 and 3 of the triangle).
C
        ELSE IF (JUMP.EQ.3)
C
          IF      (IEDG(ITRI(IIII+3)+1).EQ.IPP2.AND.
     +             IEDG(ITRI(IIII+3)+2).EQ.IPP3)
            INEW=IEDG(ITRI(IIII+3)+4)
          ELSE IF (IEDG(ITRI(IIII+3)+1).EQ.IPP3.AND.
     +             IEDG(ITRI(IIII+3)+2).EQ.IPP2)
            INEW=IEDG(ITRI(IIII+3)+3)
          ELSE
            INEW=-1
          END IF
          IF (INEW.LT.0)
            ITER=1
            GO TO 104
          END IF
          IIII=LOTN*((INEW-1)/LOTN)
          IPP1=IPP2
          IF      (IEDG(ITRI(IIII+1)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+1).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+1)+1)
          ELSE IF (IEDG(ITRI(IIII+1)+2).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+2).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+1)+2)
          ELSE IF (IEDG(ITRI(IIII+2)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+2)+1).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+2)+1)
          ELSE
            IPP2=IEDG(ITRI(IIII+2)+2)
          END IF
          SVAL=1.-RVAL
          RVAL=0.
C
        END IF
C
C If we just moved into a new triangle, we may need to recompute the
C values of the pointers to its vertices and of the coordinates of the
C point in the triangle.
C
        IF (JUMP.LT.4)
C
C Get a pointer to what should be point 1 of the triangle.  It will
C match one of the pointers we already have.
C
          IF (IEDG(ITRI(IIII+1)+1).EQ.IEDG(ITRI(IIII+2)+1).OR.
     +        IEDG(ITRI(IIII+1)+1).EQ.IEDG(ITRI(IIII+2)+2))
            IPPT=IEDG(ITRI(IIII+1)+1)
          ELSE
            IPPT=IEDG(ITRI(IIII+1)+2)
          END IF
C
C Adjust the pointers and the values of RVAL and SVAL appropriately.
C
          IF (IPPT.NE.IPP1)
            RTMP=RVAL
            STMP=SVAL
            IF (IPPT.EQ.IPP2)
              IPP2=IPP3
              IPP3=IPP1
              IPP1=IPPT
              RVAL=STMP
              SVAL=1.-RTMP-STMP
            ELSE
              IPP3=IPP2
              IPP2=IPP1
              IPP1=IPPT
              RVAL=1.-RTMP-STMP
              SVAL=RTMP
            END IF
          END IF
C
C Also, if we have been directed to examine the angles between the
C velocity vectors at its vertices, do that.
C
          IF (ANM2.NE.0.)
C
C Compute the squares of the cosines of the angles between the velocity
C vectors at pairs of vertices of the triangle.
C
            DNM1=(RPNT(IPP1+4)**2+RPNT(IPP1+5)**2+RPNT(IPP1+6)**2)*
     +           (RPNT(IPP2+4)**2+RPNT(IPP2+5)**2+RPNT(IPP2+6)**2)
            IF (DNM1.EQ.0.)
              ITER=7
              GO TO 104
            END IF
            CSA1=(RPNT(IPP1+4)*RPNT(IPP2+4)+
     +            RPNT(IPP1+5)*RPNT(IPP2+5)+
     +            RPNT(IPP1+6)*RPNT(IPP2+6))
            CSA1=CSA1*ABS(CSA1)/DNM1
C
            DNM2=(RPNT(IPP2+4)**2+RPNT(IPP2+5)**2+RPNT(IPP2+6)**2)*
     +           (RPNT(IPP3+4)**2+RPNT(IPP3+5)**2+RPNT(IPP3+6)**2)
            IF (DNM2.EQ.0.)
              ITER=7
              GO TO 104
            END IF
            CSA2=(RPNT(IPP2+4)*RPNT(IPP3+4)+
     +            RPNT(IPP2+5)*RPNT(IPP3+5)+
     +            RPNT(IPP2+6)*RPNT(IPP3+6))
            CSA2=CSA2*ABS(CSA2)/DNM2
C
            DNM3=(RPNT(IPP3+4)**2+RPNT(IPP3+5)**2+RPNT(IPP3+6)**2)*
     +           (RPNT(IPP1+4)**2+RPNT(IPP1+5)**2+RPNT(IPP1+6)**2)
            IF (DNM3.EQ.0.)
              ITER=7
              GO TO 104
            END IF
            CSA3=(RPNT(IPP3+4)*RPNT(IPP1+4)+
     +            RPNT(IPP3+5)*RPNT(IPP1+5)+
     +            RPNT(IPP3+6)*RPNT(IPP1+6))
            CSA3=CSA3*ABS(CSA3)/DNM3
C
            IF (MIN(CSA1,CSA2,CSA3).LE.CSMN)
              ITER=3
              GO TO 104
            END IF
C
          END IF
C
C Jump back to continue tracing the streamline in the new triangle.
C
          GO TO 101
C
C Otherwise, ...
C
        ELSE
C
C ... transfer the termination condition flag within the triangle to
C the appropriate return variable and drop through to the return from
C this routine.
C
          ITER=JUMP
C
        END IF
C
C Common exit point.  Process any remaining portion of the curve.
C
  104   IF (NCPL.NE.0)
          INVOKE (CLEAR-POLYLINE-BUFFER)
        END IF
C
C If the polyline color index was changed above, restore it.
C
        IF (IPCS.GE.0) CALL GSPLCI (IPCS)
C
C Return the final trace position to the caller.
C
        IEND=IIII
        REND=RVAL
        SEND=SVAL
C
C If debugging is turned on and the line is being drawn, mark the
C termination point.
C
        IF (IDBG.NE.0.AND.ICTB.EQ.0)
          CALL HLUVTMXYZ (IMPF,UCND,VCND,WCND,XPOS,YPOS)
          IF (XPOS.NE.OORV)
            CALL GQFACI (IGER,ISFC)
            CALL GSFACI (IDBC)
            CALL VTDREL (CUFX(XPOS),CUFY(YPOS),.0004,.0004,0.,10.,1)
            CALL GSFACI (ISFC)
            CALL PLCHHQ (XPOS,YPOS,IDIG(ITER+1:ITER+1),.0004,0.,0.)
          END IF
        END IF
C
C Done.
C
        RETURN
C
C The following internal procedure, given a line segment, adds visible
C portions of it to the coordinate arrays.
C
        BLOCK (INTERPOLATE-POINTS-ALONG-SEGMENT)
C
C If point interpolation is turned on, do the first IPIS segments.
C
          IF (IPIS.NE.0)
            USOD=UCOD
            VSOD=VCOD
            WSOD=WCOD
            USND=UCND
            VSND=VCND
            WSND=WCND
            XSNU=XCNU
            YSNU=YCNU
            ISNU=IVNU
            FOR (INTP = 1 TO ABS(IPIS))
              UCND=USOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(USND-USOD)
              VCND=VSOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(VSND-VSOD)
              WCND=WSOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(WSND-WSOD)
              INVOKE (COMPUTE-USER-COORDINATES)
              IF (IPIS.GT.0.OR.IVNU.NE.IVOU)
                INVOKE (ADD-POINTS-TO-POLYLINE)
                UCOD=UCND
                VCOD=VCND
                WCOD=WCND
                XCOU=XCNU
                YCOU=YCNU
                IVOU=IVNU
              END IF
            END FOR
            UCND=USND
            VCND=VSND
            WCND=WSND
            XCNU=XSNU
            YCNU=YSNU
            IVNU=ISNU
          END IF
C
C Finish off the job.
C
          INVOKE (ADD-POINTS-TO-POLYLINE)
C
        END BLOCK
C
C The following internal procedure examines the points (UCOD,VCOD,WCOD),
C which projects into (XCOU,YCOU), and (UCND,VCND,WCND), which projects
C into (XCNU,YCNU), either of which may be visible or invisible in the
C projection space, and adds visible portions of the line segment
C between them to the polyline being built.
C
        BLOCK (ADD-POINTS-TO-POLYLINE)
C
          IF (UCND.NE.UCOD.OR.VCND.NE.VCOD.OR.WCND.NE.WCOD)
C
            IF (NCPL.EQ.0)
              IF (IVOU.NE.0)
                IF (IMPF.NE.0.AND.PITH.GT.0.)
                  UCLD=UCOD
                  VCLD=VCOD
                  WCLD=WCOD
                  XCLU=XCOU
                  YCLU=YCOU
                END IF
                NCPL=1
                XCPL(1)=XCOU
                YCPL(1)=YCOU
              ELSE IF (IVNU.NE.0)
                UCID=UCOD
                VCID=VCOD
                WCID=WCOD
                UCVD=UCND
                VCVD=VCND
                WCVD=WCND
                XCVU=XCNU
                YCVU=YCNU
                INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
                INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
                UCOD=UCVD
                VCOD=VCVD
                WCOD=WCVD
                XCOU=XCVU
                YCOU=YCVU
                IVOU=1
              END IF
            ELSE IF (NCPL.EQ.MCPL)
              INVOKE (FLUSH-POLYLINE-BUFFER)
            END IF
C
            IF (IVNU.NE.0)
              INVOKE (OUTPUT-NEXT-POINT)
            ELSE IF (IVOU.NE.0)
              UCVD=UCOD
              VCVD=VCOD
              WCVD=WCOD
              XCVU=XCOU
              YCVU=YCOU
              UCID=UCND
              VCID=VCND
              WCID=WCND
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              UKND=UCND
              VKND=VCND
              WKND=WCND
              XKNU=XCNU
              YKNU=YCNU
              UCND=UCVD
              VCND=VCVD
              WCND=WCVD
              XCNU=XCVU
              YCNU=YCVU
              INVOKE (OUTPUT-NEXT-POINT)
              UCND=UKND
              VCND=VKND
              WCND=WKND
              XCNU=XKNU
              YCNU=YKNU
              INVOKE (CLEAR-POLYLINE-BUFFER)
            END IF
C
          END IF
C
        END BLOCK
C
C The following internal procedure outputs the next point; if mapping
C is being done and there is a sufficiently large jump in the mapped
C position of the point, we check for a discontinuity in the mapping.
C Similarly, if mapping is being done and point interpolation is
C activated, we check for a large enough jump in the mapped position
C to justify interpolating points.
C
        BLOCK (OUTPUT-NEXT-POINT)
          IF (IMPF.NE.0.AND.
     +                   (UCND.NE.UCOD.OR.VCND.NE.VCOD.OR.WCND.NE.WCOD))
            RUDO=RUDN
            RUDN=(ABS(XCNU-XCOU)+ABS(YCNU-YCOU))/
     +           (ABS(UCND-UCOD)+ABS(VCND-VCOD)+ABS(WCND-WCOD))
            IF (RUDN.GT.2.*RUDO)
              INVOKE (CHECK-FOR-POSSIBLE-DISCONTINUITY)
            END IF
            IF (PITH.GT.0.)
              UCTD=UCND
              VCTD=VCND
              WCTD=WCND
              XCTU=XCNU
              YCTU=YCNU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
          END IF
          NCPL=NCPL+1
          XCPL(NCPL)=XCNU
          YCPL(NCPL)=YCNU
        END BLOCK
C
C The following internal procedure is invoked when an unusually large
C jump in the position of mapped points on the curve is seen.  It
C checks for a possible discontinuity in the mapping function (as
C can happen, for example, when a cylindrical equidistant projection
C is being used); if there is such a discontinuity, we must generate
C a final point on one side of it, dump the polyline, and then start
C a new polyline on the other side.
C
        BLOCK (CHECK-FOR-POSSIBLE-DISCONTINUITY)
          UC1D=UCOD
          VC1D=VCOD
          WC1D=WCOD
          XC1U=XCOU
          YC1U=YCOU
          UC2D=UCND
          VC2D=VCND
          WC2D=WCND
          XC2U=XCNU
          YC2U=YCNU
          ITMP=0
          LOOP
            DSTO=ABS(XC2U-XC1U)+ABS(YC2U-YC1U)
            UC3D=(UC1D+UC2D)/2.
            VC3D=(VC1D+VC2D)/2.
            WC3D=(WC1D+WC2D)/2.
            CALL HLUCTMXYZ (IMPF,UC3D,VC3D,WC3D,XC3U,YC3U)
            IF (ICFELL('VTTPOM',2).NE.0) GO TO 104
            IF (OORV.EQ.0..OR.(XC3U.NE.OORV.AND.YC3U.NE.OORV))
              DST1=ABS(XC3U-XC1U)+ABS(YC3U-YC1U)
              DST2=ABS(XC3U-XC2U)+ABS(YC3U-YC2U)
              IF (MIN(DST1,DST2).GT.DSTO)
                ITMP=1000
                EXIT
              ELSE IF (DST1.LT.DST2)
                EXIT IF (UC3D.EQ.UC1D.AND.VC3D.EQ.VC1D.AND.WC3D.EQ.WC1D)
                UC1D=UC3D
                VC1D=VC3D
                WC1D=WC3D
                XC1U=XC3U
                YC1U=YC3U
              ELSE
                EXIT IF (UC3D.EQ.UC2D.AND.VC3D.EQ.VC2D.AND.WC3D.EQ.WC2D)
                UC2D=UC3D
                VC2D=VC3D
                WC2D=WC3D
                XC2U=XC3U
                YC2U=YC3U
              END IF
              ITMP=ITMP+1
              EXIT IF (ITMP.EQ.64)
            ELSE
              UCVD=UCOD
              VCVD=VCOD
              WCVD=WCOD
              XCVU=XCOU
              YCVU=YCOU
              UCID=UC3D
              VCID=VC3D
              WCID=WC3D
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              INVOKE (CLEAR-POLYLINE-BUFFER)
              UCID=UC3D
              VCID=VC3D
              WCID=WC3D
              UCVD=UCND
              VCVD=VCND
              WCVD=WCND
              XCVU=XCNU
              YCVU=YCNU
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              ITMP=1000
              EXIT
            END IF
          END LOOP
          IF (ITMP.NE.1000.AND.
     +               (ABS(XC1U-XC2U).GT.SMLX.OR.ABS(YC1U-YC2U).GT.SMLY))
            IF (IMPF.NE.0.AND.PITH.GT.0.)
              UCTD=UC1D
              VCTD=VC1D
              WCTD=WC1D
              XCTU=XC1U
              YCTU=YC1U
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
            NCPL=NCPL+1
            XCPL(NCPL)=XC1U
            YCPL(NCPL)=YC1U
            INVOKE (CLEAR-POLYLINE-BUFFER)
            IF (IMPF.NE.0.AND.PITH.GT.0.)
              UCLD=UC2D
              VCLD=VC2D
              WCLD=WC2D
              XCLU=XC2U
              YCLU=YC2U
            END IF
            NCPL=1
            XCPL(1)=XC2U
            YCPL(1)=YC2U
          END IF
        END BLOCK
C
C Given two points in the data-array-index coordinate system, one of
C which maps to a visible point and the other of which maps to an
C invisible point, this internal routine searches the line between
C them for a point near the edge of visibility.
C
        BLOCK (INTERPOLATE-TO-VISIBLE-EDGE)
          ITMP=0
          LOOP
            UCHD=(UCVD+UCID)/2.
            VCHD=(VCVD+VCID)/2.
            WCHD=(WCVD+WCID)/2.
            CALL HLUCTMXYZ (IMPF,UCHD,VCHD,WCHD,XCHU,YCHU)
            IF (ICFELL('VTTPOM',3).NE.0) GO TO 104
            IF (XCHU.NE.OORV.AND.YCHU.NE.OORV)
              EXIT IF (UCHD.EQ.UCVD.AND.VCHD.EQ.VCVD.AND.WCHD.EQ.WCVD)
              UCVD=UCHD
              VCVD=VCHD
              WCVD=WCHD
              XCVU=XCHU
              YCVU=YCHU
            ELSE
              EXIT IF (UCHD.EQ.UCID.AND.VCHD.EQ.VCID.AND.WCHD.EQ.WCID)
              UCID=UCHD
              VCID=VCHD
              WCID=WCHD
            END IF
            ITMP=ITMP+1
            EXIT IF (ITMP.EQ.64)
          END LOOP
        END BLOCK
C
C The following internal procedure outputs a visible edge point found
C by the previous internal procedure.
C
        BLOCK (OUTPUT-VISIBLE-EDGE-POINT)
          IF (PITH.GT.0.)
            IF (NCPL.EQ.0)
              UCLD=UCVD
              VCLD=VCVD
              WCLD=WCVD
              XCLU=XCVU
              YCLU=YCVU
            ELSE
              UCTD=UCVD
              VCTD=VCVD
              WCTD=WCVD
              XCTU=XCVU
              YCTU=YCVU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
          END IF
          NCPL=NCPL+1
          XCPL(NCPL)=XCVU
          YCPL(NCPL)=YCVU
        END BLOCK
C
C The following internal procedure is invoked when mapping is being
C done and a new point is about to be added to the polyline buffer.
C It checks for a jump (using a user-defined threshold value) in
C the mapped coordinates of the point and, if such a jump is found,
C interpolates some points in between.  The assumption is made that
C all points in between are visible; if that is found not to be the
C case, no attempt is made to rectify the situation: the user probably
C screwed up the definition of the mapping function.
C
        BLOCK (CHECK-FOR-JUMP-IN-MAPPING)
          WHILE (ABS(XCTU-XCLU).GT.PITX.OR.ABS(YCTU-YCLU).GT.PITY)
            IFND=0
            UCQD=0.
            VCQD=0.
            WCQD=0.
            RDST=.50
            RSTP=.25
            LOOP
              UCPD=UCLD+RDST*(UCTD-UCLD)
              VCPD=VCLD+RDST*(VCTD-VCLD)
              WCPD=WCLD+RDST*(WCTD-WCLD)
              CALL HLUCTMXYZ (IMPF,UCPD,VCPD,WCPD,XCPU,YCPU)
              IF (ICFELL('VTTPOM',4).NE.0) GO TO 104
              EXIT IF (OORV.NE.0..AND.(XCPU.EQ.OORV.OR.YCPU.EQ.OORV))
              IF (ABS(XCPU-XCLU).LT.PITX.AND.ABS(YCPU-YCLU).LT.PITY)
                IFND=1
                UCQD=UCPD
                VCQD=VCPD
                WCQD=WCPD
                XCQU=XCPU
                YCQU=YCPU
                EXIT IF (ABS(XCQU-XCLU).GT..5*PITX.OR.
     +                   ABS(YCQU-YCLU).GT..5*PITY)
                RDST=RDST+RSTP
              ELSE
                RDST=RDST-RSTP
              END IF
              RSTP=RSTP/2.
              EXIT IF (RSTP.LT..0001)
            END LOOP
            IF (IFND.NE.0.AND.(UCQD.NE.UCLD.OR.VCQD.NE.VCLD.OR.
     +                                         WCQD.NE.WCLD))
              NCPL=NCPL+1
              XCPL(NCPL)=XCQU
              YCPL(NCPL)=YCQU
              IF (NCPL.EQ.MCPL)
                INVOKE (FLUSH-POLYLINE-BUFFER)
              END IF
              UCLD=UCQD
              VCLD=VCQD
              WCLD=WCQD
              XCLU=XCQU
              YCLU=YCQU
            ELSE
              UCLD=UCTD
              VCLD=VCTD
              WCLD=WCTD
              XCLU=XCTU
              YCLU=YCTU
            END IF
          END WHILE
          UCLD=UCTD
          VCLD=VCTD
          WCLD=WCTD
          XCLU=XCTU
          YCLU=YCTU
        END BLOCK
C
C The following internal procedure is given the data-system coordinates
C of a point (UCND,VCND,WCND) and computes the user-system coordinates
C of the point's projection (XCNU,YCNU).  It also sets a flag indicating
C whether the projection point is visible or not.
C
        BLOCK (COMPUTE-USER-COORDINATES)
C
          IF (IMPF.EQ.0)
            XCNU=UCND
            YCNU=VCND
            IVNU=1
          ELSE
            CALL HLUCTMXYZ (IMPF,UCND,VCND,WCND,XCNU,YCNU)
            IF (ICFELL('VTTPOM',5).NE.0) GO TO 104
            IF ((OORV.NE.0.).AND.(XCNU.EQ.OORV.OR.YCNU.EQ.OORV))
              IVNU=0
            ELSE
              IVNU=1
            END IF
          END IF
C
        END BLOCK
C
C The following internal procedure draws the part of the curve defined
C by the contents of the polyline buffer and then removes all but the
C last point from the buffer.
C
        BLOCK (FLUSH-POLYLINE-BUFFER)
C
          I=1
C
          LOOP
            I=I+1
            EXIT IF (I.GT.NCPL)
            IF (ABS(XCPL(I)-XCPL(I-1)).LT.EPSX.AND.
     +          ABS(YCPL(I)-YCPL(I-1)).LT.EPSY)
              IF (I.NE.NCPL)
                DO (J=I+1,NCPL)
                  XCPL(J-1)=XCPL(J)
                  YCPL(J-1)=YCPL(J)
                END DO
              ELSE
                XCPL(NCPL-1)=XCPL(NCPL)
                YCPL(NCPL-1)=YCPL(NCPL)
              END IF
              I=I-1
              NCPL=NCPL-1
            END IF
          END LOOP
C
          IF (NCPL.GT.1)
            IF (IAMA(1).EQ.0)
              CALL CURVE (XCPL,YCPL,NCPL)
            ELSE
              CALL ARDRLN (IAMA,XCPL,YCPL,NCPL,
     +                          XCPF,YCPF,MCPF,
     +                          IAAI,IAGI,MNOG,RTPL)
            END IF
          END IF
C
          XCPL(1)=XCPL(NCPL)
          YCPL(1)=YCPL(NCPL)
          NCPL=1
C
        END BLOCK
C
C The following internal procedure draws the part of the curve defined
C by the contents of the polyline buffer and then clears the buffer.
C
        BLOCK (CLEAR-POLYLINE-BUFFER)
C
          I=1
C
          LOOP
            I=I+1
            EXIT IF (I.GT.NCPL)
            IF (ABS(XCPL(I)-XCPL(I-1)).LT.EPSX.AND.
     +          ABS(YCPL(I)-YCPL(I-1)).LT.EPSY)
              IF (I.NE.NCPL)
                DO (J=I+1,NCPL)
                  XCPL(J-1)=XCPL(J)
                  YCPL(J-1)=YCPL(J)
                END DO
              ELSE
                XCPL(NCPL-1)=XCPL(NCPL)
                YCPL(NCPL-1)=YCPL(NCPL)
              END IF
              I=I-1
              NCPL=NCPL-1
            END IF
          END LOOP
C
          IF (NCPL.GT.1)
            IF (IAMA(1).EQ.0)
              CALL CURVE (XCPL,YCPL,NCPL)
            ELSE
              CALL ARDRLN (IAMA,XCPL,YCPL,NCPL,
     +                          XCPF,YCPF,MCPF,
     +                          IAAI,IAGI,MNOG,RTPL)
            END IF
          END IF
C
          NCPL=0
          RUDN=0.
C
        END BLOCK
C
      END
.OP   BI=77


.OP   BI=66
      SUBROUTINE VTTSOM (IDRW,RPNT,IEDG,ITRI,ISTR,RSTR,SSTR,IDIR,
     +                   SLMX,ITER,SLTR,IEND,REND,SEND,IAMA,RTPL)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),IAMA(*)
C
        EXTERNAL RTPL
C
C This routine, given arrays defining a triangular mesh, at each point
C of which a velocity vector is given, and the location of a particular
C starting point on a particular triangle of that mesh, traces and/or
C draws a streamline (a line that is everywhere parallel to the velocity
C vectors), continuing until one of a set of termination conditions is
C satisfied, and then returns the location of the final point of the
C line to the caller.
C
C IDRW determines the mode in which VTTSOM is to operate: If IDRW = 0,
C the streamline is traced and proximity termination tests are done,
C but the line is not actually drawn.  If IDRW is not 0, the line is
C traced and drawn; no proximity termination tests are done.  If IDRW
C = 1, no arrowheads are drawn; if IDRW = 2, only one arrowhead is
C drawn, at the end of the streamline; if IDRW = 3, arrowheads are
C drawn at positions along the streamline which are AHSR units apart.
C
C RPNT is an array of nodes defining vertices of triangles of the mesh.
C
C IEDG is an array of nodes defining edges (pairs of vertices) of the
C triangles of the mesh.
C
C ITRI is an array of nodes defining triangles (triplets of edges) of
C the mesh.
C
C ISTR is the base index, in ITRI, of the triangle node of the triangle
C containing the starting point, and RSTR and SSTR are coordinates of
C the starting point within that triangle (fractional multipliers of
C its first and second sides, respectively).
C
C IDIR is a flag that says in which direction the line is to be traced:
C 0 => toward its beginning; 1 => toward its end.
C
C SLMX is the maximum length of streamline to be traced.
C
C ITER is a flag that is returned to say how the line terminated:
C
C   ITER=1 => exterior edge of mesh encountered.
C   ITER=2 => triangle crossed by seven or more streamlines entered.
C   ITER=3 => angle between velocity vectors exceeded maximum.
C   ITER=4 => line traced for specified distance.
C   ITER=5 => velocity along line dropped below VVMM.
C   ITER=6 => proximity termination test failure.
C   ITER=7 => other (e. g., a degenerate triangle).
C
C SLTR is returned and is the length of streamline traced before a
C termination condition was encountered.
C
C IEND, REND, and SEND are returned; IEND is the base index, in ITRI,
C of the triangle node of the triangle containing the end point of the
C line and REND and SEND are the coordinates of the end point within
C that triangle.
C
C IAMA is an array containing an area map against which the streamline
C is to be masked.  If masking is not desired, set IAMA(1) = 0.
C
C RTPL is a routine to be called to draw the streamline (when it is
C masked).
C
C Declare all of the VASPACKT common blocks.
C
.CALL VTCOMN,/$SAVE-COMMON$/1/
C
C Declare local arrays for user-system polyline coordinates.
C
        PARAMETER (MCPL=100)
C
        DIMENSION XCPL(MCPL),YCPL(MCPL)
C
C Declare local arrays to use in drawing masked polylines.
C
        PARAMETER (MCPF=MCPL,MNOG=64)
        DIMENSION XCPF(MCPF),YCPF(MCPF),IAAI(MNOG),IAGI(MNOG)
C
C Declare variables to hold coordinates of subtriangle vertices.
C
        DIMENSION UTRI(4),VTRI(4),WTRI(4)
C
C Declare a variable to be used to somewhat randomize the positions of
C arrowheads on the streamline.  Its value is computed during one call
C for use during that call and the next.
C
        SAVE AHPR
C
C Declare a character variable to hold the digits from 0 to 9.
C
        CHARACTER*10 IDIG
C
C Put the digits from 0 to 9 in a character variable.
C
        DATA IDIG / '0123456789' /
C
C DTOR is a multiplicative constant to convert from degrees to radians.
C
        DATA DTOR / .017453292519943 /
C
C IXOR(IONE,ITWO) is the exclusive OR of the 12-bit masks IONE and ITWO.
C
        IXOR(IONE,ITWO)=IAND(IOR(IONE,ITWO),4095-IAND(IONE,ITWO))
C
C ITBF(IARG) is non-zero if and only if a triangle with blocking-flag
C element IARG is blocked.
C
        ITBF(IARG)=IAND(IXOR(IARG,ITBX),ITBA)
C
C Extract the values of ITBX and ITBA from ITBM.
C
        ITBX=IAND(ISHIFT(ITBM,-12),4095)
        ITBA=IAND(       ITBM     ,4095)
C
C If a streamline is to be drawn, compute a quantity AHPR between 0 and
C 1 to be used to somewhat randomize the positions of arrowheads on it.
C Note that this code assumes pairs of calls, one to draw the part of
C the streamline toward its beginning and another to draw the part of
C the streamline toward its end.
C
        IF (IDRW.NE.0)
          IF (IDIR.EQ.0)
            AHPR=VTRAND()
          ELSE
            AHPR=1.-AHPR
          END IF
        END IF
C
C If a streamline is to be drawn and either debugging output is turned
C on or the streamline is to be colored, save the initial polyline
C color and initialize variables that keep track of the current
C polyline color setting.
C
        IF (IDRW.NE.0.AND.(IDBG.NE.0.OR.(ICTV.NE.0.AND.NCLR.NE.0)))
          CALL GQPLCI (IGER,IPCS)
          IF (IGER.NE.0)
            CALL SETER ('VTTSOM - ERROR EXIT FROM GQPLCI',1,1)
            RETURN
          END IF
          IPCC=IPCS
          IF (ICTV.NE.0.AND.NCLR.NE.0)
            IPCV=1
            ICVL=(NCLR+1)/2
          ELSE
            IPCV=0
          END IF
        ELSE
          IPCS=-1
          IPCV=0
        END IF
C
C Compute a test value, based on the maximum allowable angle, to be
C used below.
C
        IF (ANM2.NE.0.)
          CSMN=COS(DTOR*ANM2)
          CSMN=CSMN*ABS(CSMN)
        END IF
C
C Set some tolerances for the drawing code.
C
        EPSX=ABS(XWDR-XWDL)*EPSI
        EPSY=ABS(YWDT-YWDB)*EPSI
C
        SMLX=.01*ABS(XWDR-XWDL)
        SMLY=.01*ABS(YWDT-YWDB)
C
        PITX=PITH*ABS(XWDR-XWDL)
        PITY=PITH*ABS(YWDT-YWDB)
C
C Initialize the pointer to the current triangle and find the base
C indices of the nodes defining its vertices.
C
        IIII=ISTR
C
C Find the base indices of point 1 (that edges 1 and 2 have in common),
C point 2 (that edges 2 and 3 have in common), and point 3 (that edges
C 3 and 1 have in common).
C
        IF (IEDG(ITRI(IIII+2)+1).NE.IEDG(ITRI(IIII+3)+1).AND.
     +      IEDG(ITRI(IIII+2)+1).NE.IEDG(ITRI(IIII+3)+2))
          IPP1=IEDG(ITRI(IIII+2)+1)
          IPP2=IEDG(ITRI(IIII+2)+2)
        ELSE
          IPP1=IEDG(ITRI(IIII+2)+2)
          IPP2=IEDG(ITRI(IIII+2)+1)
        END IF
C
        IF (IEDG(ITRI(IIII+1)+1).NE.IPP1)
          IPP3=IEDG(ITRI(IIII+1)+1)
        ELSE
          IPP3=IEDG(ITRI(IIII+1)+2)
        END IF
C
C Initialize the starting point values.
C
        RVAL=RSTR
        SVAL=SSTR
C
C SLTR keeps track of the length of line traced already, SLAR the length
C of line to be drawn before adding the next arrowhead, and SLTT the
C length of line to be drawn before performing the next proximity tests
C for termination of the streamline.
C
        SLTR=0.
C
        IF (IDRW.EQ.0)
          SLAR=2.*SLMX
          SLTT=TTSR
        ELSE IF (IDRW.EQ.1)
          SLAR=2.*SLMX
          SLTT=2.*SLMX
        ELSE IF (IDRW.EQ.2)
          IF (IDIR.EQ.0)
            SLAR=0.
          ELSE
            SLAR=SLMX
          END IF
          SLTT=2.*SLMX
        ELSE
          SLAR=AHSR*AHPR
          SLTT=2.*SLMX
        END IF
C
C IPRJ is non-zero if and only if the streamline is to be projected
C from the triangular mesh to the image plane, either because the line
C is to be drawn there or because testing needs to be done there.
C
        IF (IDRW.EQ.0)
          IPRJ=0
        ELSE
          IPRJ=1
        END IF
C
C NCPL keeps track of the number of points in the coordinate arrays.
C
        NCPL=0
C
C RUDN keeps track of the ratio of segment length in the user coordinate
C system to segment length in the data coordinate system.
C
        RUDN=0.
C
C ICTB is non-zero if and only if the current triangle is blocked and
C ILTB is non-zero if and only if the last triangle was blocked.
C
        ICTB=1
C
C START TRACING LINE INSIDE TRIANGLE ----------------------------------
C
C Initializing - move ICTB to ILTB and recompute the correct value for
C the new triangle.
C
  101   ILTB=ICTB
        ICTB=ITBF(ITRI(IIII+4))
C
C IDST is non-zero if and only if subtriangles are to be drawn for
C debugging purposes and the triangle is not blocked.
C
        IF (IDRW.EQ.0.OR.IDBG.EQ.0.OR.ICTB.NE.0)
          IDST=0
        ELSE
          IDST=1
        END IF
C
C Extract values from the point arrays describing the current triangle,
C including the coordinates of its vertices, the components of the
C velocity vectors at its vertices, and the values of the quantities
C to be used to determine the color of the line drawn.
C
        UCP1=RPNT(IPP1+1)
        VCP1=RPNT(IPP1+2)
        WCP1=RPNT(IPP1+3)
        UCP2=RPNT(IPP2+1)
        VCP2=RPNT(IPP2+2)
        WCP2=RPNT(IPP2+3)
        UCP3=RPNT(IPP3+1)
        VCP3=RPNT(IPP3+2)
        WCP3=RPNT(IPP3+3)
C
        IF (IDIR.EQ.0)
          UVP1=-RPNT(IPP1+4)
          VVP1=-RPNT(IPP1+5)
          WVP1=-RPNT(IPP1+6)
          UVP2=-RPNT(IPP2+4)
          VVP2=-RPNT(IPP2+5)
          WVP2=-RPNT(IPP2+6)
          UVP3=-RPNT(IPP3+4)
          VVP3=-RPNT(IPP3+5)
          WVP3=-RPNT(IPP3+6)
        ELSE
          UVP1=+RPNT(IPP1+4)
          VVP1=+RPNT(IPP1+5)
          WVP1=+RPNT(IPP1+6)
          UVP2=+RPNT(IPP2+4)
          VVP2=+RPNT(IPP2+5)
          WVP2=+RPNT(IPP2+6)
          UVP3=+RPNT(IPP3+4)
          VVP3=+RPNT(IPP3+5)
          WVP3=+RPNT(IPP3+6)
        END IF
C
        VMG1=SQRT(UVP1**2+VVP1**2+WVP1**2)
C
        IF (VMG1.NE.0.)
          UVP1=.001*EMAX*UVP1/VMG1
          VVP1=.001*EMAX*VVP1/VMG1
          WVP1=.001*EMAX*WVP1/VMG1
        END IF
C
        VMG2=SQRT(UVP2**2+VVP2**2+WVP2**2)
C
        IF (VMG2.NE.0.)
          UVP2=.001*EMAX*UVP2/VMG2
          VVP2=.001*EMAX*VVP2/VMG2
          WVP2=.001*EMAX*WVP2/VMG2
        END IF
C
        VMG3=SQRT(UVP3**2+VVP3**2+WVP3**2)
C
        IF (VMG3.NE.0.)
          UVP3=.001*EMAX*UVP3/VMG3
          VVP3=.001*EMAX*VVP3/VMG3
          WVP3=.001*EMAX*WVP3/VMG3
        END IF
C
        IF (ICTV.EQ.0)
          CVP1=0.
          CVP2=0.
          CVP3=0.
        ELSE IF (ABS(ICTV).LE.LOPN)
          CVP1=RPNT(IPP1+ABS(ICTV))
          CVP2=RPNT(IPP2+ABS(ICTV))
          CVP3=RPNT(IPP3+ABS(ICTV))
        ELSE
          CVP1=SQRT(RPNT(IPP1+4)**2+RPNT(IPP1+5)**2+RPNT(IPP1+6)**2)
          CVP2=SQRT(RPNT(IPP2+4)**2+RPNT(IPP2+5)**2+RPNT(IPP2+6)**2)
          CVP3=SQRT(RPNT(IPP3+4)**2+RPNT(IPP3+5)**2+RPNT(IPP3+6)**2)
        END IF
C
C Compute the coefficients A, B, C, and D in the equation defining the
C plane of the triangle (Ax+By+Cz+D=0).
C
        A=(VCP2-VCP1)*(WCP3-WCP1)-(VCP3-VCP1)*(WCP2-WCP1)
        B=(WCP2-WCP1)*(UCP3-UCP1)-(WCP3-WCP1)*(UCP2-UCP1)
        C=(UCP2-UCP1)*(VCP3-VCP1)-(UCP3-UCP1)*(VCP2-VCP1)
        D=-(A*UCP1+B*VCP1+C*WCP1)
C
C Compute the direction cosines of the normal to the triangle.  If they
C are not well-defined, take an error exit.
C
        DNOM=SQRT(A**2+B**2+C**2)
C
        IF (DNOM.NE.0.)

          DCNU=A/DNOM
          DCNV=B/DNOM
          DCNW=C/DNOM
C
        ELSE
C
          ITER=7
          GO TO 106
C
        END IF
C
C (09/29/2005) The following code resulted in discontinuities in the
C definitions of the velocity vectors along the edges of the triangles
C of the mesh.  I found a formulation that didn't have this problem,
C but I'm leaving the original code here, commented out, for possible
C future reference.
C
C For each velocity vector, use the parametric equations for a line that
C passes through the end of it and is perpendicular to the plane of the
C triangle to find the coordinates of the point where it intersects the
C triangle; use that to compute the components of the projection of the
C velocity vector into the plane of the triangle.
C
C       T=-(A*(UCP1+UVP1)+B*(VCP1+VVP1)+C*(WCP1+WVP1)+D)/
C    +                                                  (A**2+B**2+C**2)
C       UPP1=UVP1+A*T
C       VPP1=VVP1+B*T
C       WPP1=WVP1+C*T
C
C       T=-(A*(UCP2+UVP2)+B*(VCP2+VVP2)+C*(WCP2+WVP2)+D)/
C    +                                                  (A**2+B**2+C**2)
C       UPP2=UVP2+A*T
C       VPP2=VVP2+B*T
C       WPP2=WVP2+C*T
C
C       T=-(A*(UCP3+UVP3)+B*(VCP3+VVP3)+C*(WCP3+WVP3)+D)/
C    +                                                  (A**2+B**2+C**2)
C       UPP3=UVP3+A*T
C       VPP3=VVP3+B*T
C       WPP3=WVP3+C*T
C
C (09/29/2005) This is the alternate formulation.  Instead of a line
C perpendicular to the plane of the triangle, we use one that passes
C through a user-specified center point.  This ought to work okay for
C triangular meshes that are meant to represent the surface of a globe
C (using the center of the globe as the center point), which is the
C case of most interest to us, but it will not work for an arbitrary
C triangular mesh.  This is a problem I'll have to look into later.
C
        T=-((UCP1+UVP1)*A+(VCP1+VVP1)*B+(WCP1+WVP1)*C+D)/
     +     ((UCP1+UVP1-PCPX)*A+(VCP1+VVP1-PCPY)*B+(WCP1+WVP1-PCPZ)*C)
C
        UPP1=UVP1+(UCP1+UVP1-PCPX)*T
        VPP1=VVP1+(VCP1+VVP1-PCPY)*T
        WPP1=WVP1+(WCP1+WVP1-PCPZ)*T
C
        T=-((UCP2+UVP2)*A+(VCP2+VVP2)*B+(WCP2+WVP2)*C+D)/
     +     ((UCP2+UVP2-PCPX)*A+(VCP2+VVP2-PCPY)*B+(WCP2+WVP2-PCPZ)*C)
C
        UPP2=UVP2+(UCP2+UVP2-PCPX)*T
        VPP2=VVP2+(VCP2+VVP2-PCPY)*T
        WPP2=WVP2+(WCP2+WVP2-PCPZ)*T
C
        T=-((UCP3+UVP3)*A+(VCP3+VVP3)*B+(WCP3+WVP3)*C+D)/
     +     ((UCP3+UVP3-PCPX)*A+(VCP3+VVP3-PCPY)*B+(WCP3+WVP3-PCPZ)*C)
C
        UPP3=UVP3+(UCP3+UVP3-PCPX)*T
        VPP3=VVP3+(VCP3+VVP3-PCPY)*T
        WPP3=WVP3+(WCP3+WVP3-PCPZ)*T
C
C For each of the projected velocity vectors at the three vertices of
C the triangle, find R and S such that the vector may be expressed as R
C times the vector from V1 to V2 plus S times the vector from V1 to V3.
C There are three possible ways to compute these; we use the one that
C minimizes the probability of dividing zero by zero.
C
        DNUV=((UCP2-UCP1)*(VCP3-VCP1)-(VCP2-VCP1)*(UCP3-UCP1))
        DNVW=((VCP2-VCP1)*(WCP3-WCP1)-(WCP2-WCP1)*(VCP3-VCP1))
        DNWU=((WCP2-WCP1)*(UCP3-UCP1)-(UCP2-UCP1)*(WCP3-WCP1))
C
        IF (ABS(DNUV).GT.ABS(DNVW).AND.ABS(DNUV).GT.ABS(DNWU))
          RVV1=(      UPP1 *(VCP3-VCP1)-      VPP1 *(UCP3-UCP1))/DNUV
          SVV1=((UCP2-UCP1)*      VPP1 -(VCP2-VCP1)*      UPP1 )/DNUV
          RVV2=(      UPP2 *(VCP3-VCP1)-      VPP2 *(UCP3-UCP1))/DNUV
          SVV2=((UCP2-UCP1)*      VPP2 -(VCP2-VCP1)*      UPP2 )/DNUV
          RVV3=(      UPP3 *(VCP3-VCP1)-      VPP3 *(UCP3-UCP1))/DNUV
          SVV3=((UCP2-UCP1)*      VPP3 -(VCP2-VCP1)*      UPP3 )/DNUV
        ELSE IF(ABS(DNVW).GT.ABS(DNWU).AND.ABS(DNVW).GT.ABS(DNUV))
          RVV1=(      VPP1 *(WCP3-WCP1)-      WPP1 *(VCP3-VCP1))/DNVW
          SVV1=((VCP2-VCP1)*      WPP1 -(WCP2-WCP1)*      VPP1 )/DNVW
          RVV2=(      VPP2 *(WCP3-WCP1)-      WPP2 *(VCP3-VCP1))/DNVW
          SVV2=((VCP2-VCP1)*      WPP2 -(WCP2-WCP1)*      VPP2 )/DNVW
          RVV3=(      VPP3 *(WCP3-WCP1)-      WPP3 *(VCP3-VCP1))/DNVW
          SVV3=((VCP2-VCP1)*      WPP3 -(WCP2-WCP1)*      VPP3 )/DNVW
        ELSE
          RVV1=(      WPP1 *(UCP3-UCP1)-      UPP1 *(WCP3-WCP1))/DNWU
          SVV1=((WCP2-WCP1)*      UPP1 -(UCP2-UCP1)*      WPP1 )/DNWU
          RVV2=(      WPP2 *(UCP3-UCP1)-      UPP2 *(WCP3-WCP1))/DNWU
          SVV2=((WCP2-WCP1)*      UPP2 -(UCP2-UCP1)*      WPP2 )/DNWU
          RVV3=(      WPP3 *(UCP3-UCP1)-      UPP3 *(WCP3-WCP1))/DNWU
          SVV3=((WCP2-WCP1)*      UPP3 -(UCP2-UCP1)*      WPP3 )/DNWU
        END IF
C
C See which subtriangle the line starts in.
C
        INDR=MAX(0,MIN(4,INT(5.*RVAL)))
        INDS=MAX(0,MIN(4,INT(5.*SVAL)))
        INDT=MAX(0,MIN(4,INT(5.*(RVAL+SVAL))))
        IOSB=2*(5*INDR+INDS)-INDR*INDR+MOD(INDR+INDS+INDT,2)
C
C If the streamline is being projected ...
C
        IF (IPRJ.NE.0)
C
C ... and the last triangle was blocked (or non-existent) and this one
C is not blocked, compute values associated with the first point of a
C new segment of streamline.  (If both triangles are unblocked, values
C computed would be identical to what we already had, but for round-off
C differences that could cause problems.)
C
          IF (ILTB.NE.0.AND.ICTB.EQ.0)
            UCND=UCP1+RVAL*(UCP2-UCP1)+SVAL*(UCP3-UCP1)
            VCND=VCP1+RVAL*(VCP2-VCP1)+SVAL*(VCP3-VCP1)
            WCND=WCP1+RVAL*(WCP2-WCP1)+SVAL*(WCP3-WCP1)
            CCND=CVP1+RVAL*(CVP2-CVP1)+SVAL*(CVP3-CVP1)
            INVOKE (COMPUTE-USER-COORDINATES)
          END IF
C
C ... and, if the new triangle is blocked and there's something in the
C polyline buffer, clear the buffer.
C
          IF (ICTB.NE.0.AND.NCPL.NE.0)
            INVOKE (CLEAR-POLYLINE-BUFFER)
          END IF
C
        END IF
C
C Initialize a flag which keeps track of whether the line has terminated
C inside the triangle, and, if so, how.
C
        JUMP=0
C
C CONTINUE TRACING LINE INSIDE TRIANGLE -------------------------------
C
C Trace the line in the requested direction.  SLNE is the length of
C line to be traced before the next event, and SLNS is a saved copy
C of SLNE.
C
  102   SLNE=MIN(SLMX-SLTR,SLAR,SLTT)
        SLNS=SLNE
C
C Jump if the next event is to happen immediately.  (This can only
C happen if the event is drawing an arrowhead.)
C
        IF (SLNE.EQ.0.) GO TO 105
C
C Take a step along the line and check for termination.  Helpful
C comments about some of the tests below are to be found in the
C file called "VectorMath".
C
  103   RVVN=RVV1+RVAL*(RVV2-RVV1)+SVAL*(RVV3-RVV1)
        SVVN=SVV1+RVAL*(SVV2-SVV1)+SVAL*(SVV3-SVV1)
C
        UPPN=RVVN*(UCP2-UCP1)+SVVN*(UCP3-UCP1)
        VPPN=RVVN*(VCP2-VCP1)+SVVN*(VCP3-VCP1)
        WPPN=RVVN*(WCP2-WCP1)+SVVN*(WCP3-WCP1)
C
        VMAG=SQRT(UPPN**2+VPPN**2+WPPN**2)
C
        IF (VMAG.GT.VVMM)
C
          TEMP=MIN(SLNE,SLPR)/VMAG
C
C Check for exit through the side joining V1 and V3.
C
          IF (RVAL+TEMP*RVVN.LT.0..AND.(RVAL.GT..001.OR.
     +        ABS(RVVN).GT..001*ABS(RVVN+2.*SVVN)))
            JUMP=1
            TEMP=-RVAL/RVVN
          END IF
C
C Check for exit through the side joining V1 and V2.
C
          IF (SVAL+TEMP*SVVN.LT.0..AND.(SVAL.GT..001.OR.
     +        ABS(SVVN).GT..001*ABS(2.*RVVN+SVVN)))
            JUMP=2
            TEMP=-SVAL/SVVN
          END IF
C
C Check for exit through the side joining V2 and V3.
C
          IF (1.-RVAL-SVAL-TEMP*(RVVN+SVVN).LT.0..AND.
     +       (1.-RVAL-SVAL.GT..001.OR.
     +        ABS(RVVN+SVVN).GT..001*ABS(RVVN-SVVN)))
            JUMP=3
            TEMP=(1.-RVAL-SVAL)/(RVVN+SVVN)
          END IF
C
          RVAL=MAX(0.,MIN(1.,RVAL+TEMP*RVVN))
          SVAL=MAX(0.,MIN(1.,SVAL+TEMP*SVVN))
C
C If the streamline is being projected and the current triangle is not
C blocked, save information about the previous point, generate values
C for the new point, and process the line segment joining them.
C
          IF (IPRJ.NE.0.AND.ICTB.EQ.0)
            UCOD=UCND
            VCOD=VCND
            WCOD=WCND
            CCOD=CCND
            XCOU=XCNU
            YCOU=YCNU
            IVOU=IVNU
            UCND=UCP1+RVAL*(UCP2-UCP1)+SVAL*(UCP3-UCP1)
            VCND=VCP1+RVAL*(VCP2-VCP1)+SVAL*(VCP3-VCP1)
            WCND=WCP1+RVAL*(WCP2-WCP1)+SVAL*(WCP3-WCP1)
            CCND=CVP1+RVAL*(CVP2-CVP1)+SVAL*(CVP3-CVP1)
            INVOKE (COMPUTE-USER-COORDINATES)
            INVOKE (INTERPOLATE-POINTS-ALONG-SEGMENT)
          END IF
C
C Reduce the streamline length to be traced before the next event.
C
          SLNE=SLNE-VMAG*TEMP
C
C If the line is now of the desired length at the next event, terminate
C it.
C
          IF (SLNE.LT..01*SLPR)
            SLNE=0.
            JUMP=4
          END IF
C
C If the streamline is actually being drawn, see which subtriangle the
C line is entering and update the appropriate mask bits.
C
          IF (IDRW.NE.0)
            IOSL=IOSB
            INDR=MAX(0,MIN(4,INT(5.*RVAL)))
            INDS=MAX(0,MIN(4,INT(5.*SVAL)))
            INDT=MAX(0,MIN(4,INT(5.*(RVAL+SVAL))))
            IOSB=2*(5*INDR+INDS)-INDR*INDR+MOD(INDR+INDS+INDT,2)
            IF (IDST.NE.0)
              ISTO=ISHIFT(ITRI(IIII+5),-3)
              ISTN=ISTA(25*IOSL+IOSB+1)
              DO 104 I=0,24
                IF (IAND(ISTO,ISHIFT(1,I)).NE.0) GO TO 104
                IF (IAND(ISTN,ISHIFT(1,I)).EQ.0) GO TO 104
                IF (I.LE.8)
                  INDR=0
                  INDS=I/2
                  INDT=(I+1)/2
                ELSE IF (I.LE.15)
                  INDR=1
                  INDS=(I-9)/2
                  INDT=(I-6)/2
                ELSE IF (I.LE.20)
                  INDR=2
                  INDS=(I-16)/2
                  INDT=(I-11)/2
                ELSE IF (I.LE.23)
                  INDR=3
                  INDS=(I-21)/2
                  INDT=(I-14)/2
                ELSE
                  INDR=4
                  INDS=0
                  INDT=4
                END IF
                IF (MOD(INDR+INDS+INDT,2).EQ.0)
                  RVL1=REAL(INDR  )/5.
                  RVL2=REAL(INDR+1)/5.
                  RVL3=REAL(INDR  )/5.
                  SVL1=REAL(INDS  )/5.
                  SVL2=REAL(INDS  )/5.
                  SVL3=REAL(INDS+1)/5.
                ELSE
                  RVL1=REAL(INDR+1)/5.
                  RVL2=REAL(INDR+1)/5.
                  RVL3=REAL(INDR  )/5.
                  SVL1=REAL(INDS  )/5.
                  SVL2=REAL(INDS+1)/5.
                  SVL3=REAL(INDS+1)/5.
                END IF
                UTRI(1)=UCP1+RVL1*(UCP2-UCP1)+SVL1*(UCP3-UCP1)
                VTRI(1)=VCP1+RVL1*(VCP2-VCP1)+SVL1*(VCP3-VCP1)
                WTRI(1)=WCP1+RVL1*(WCP2-WCP1)+SVL1*(WCP3-WCP1)
                UTRI(2)=UCP1+RVL2*(UCP2-UCP1)+SVL2*(UCP3-UCP1)
                VTRI(2)=VCP1+RVL2*(VCP2-VCP1)+SVL2*(VCP3-VCP1)
                WTRI(2)=WCP1+RVL2*(WCP2-WCP1)+SVL2*(WCP3-WCP1)
                UTRI(3)=UCP1+RVL3*(UCP2-UCP1)+SVL3*(UCP3-UCP1)
                VTRI(3)=VCP1+RVL3*(VCP2-VCP1)+SVL3*(VCP3-VCP1)
                WTRI(3)=WCP1+RVL3*(WCP2-WCP1)+SVL3*(WCP3-WCP1)
                UTRI(4)=UTRI(1)
                VTRI(4)=VTRI(1)
                WTRI(4)=WTRI(1)
                IF (IPCC.NE.ICST)
                  CALL GSPLCI (ICST)
                END IF
                CALL VTCUDR (UTRI,VTRI,WTRI,UTRI,4,0,0,IAMA,RTPL)
                IF (IPCC.NE.ICST)
                  CALL GSPLCI (IPCC)
                END IF
  104         CONTINUE
            END IF
            ITRI(IIII+5)=IOR(ITRI(IIII+5),
     +                       ISHIFT(ISTA(25*IOSL+IOSB+1),3))
          END IF
C
        ELSE
C
C The velocity is too low.
C
          JUMP=5
C
        END IF
C
        IF (JUMP.EQ.0) GO TO 103
C
        IF (JUMP.EQ.4) JUMP=0
C
C Update various line-length quantities (line length in buffer, line
C length traced already, line length to next arrowhead, and line length
C to next termination test).
C
  105   SLIB=SLNS-SLNE
        SLTR=SLTR+SLIB
        SLAR=SLAR-SLIB
        SLTT=SLTT-SLIB
C
C If we're at a point where an arrowhead is to be drawn, do it.
C
        IF (SLAR.LT..01*SLPR)
          IF (ICTB.EQ.0)
            CALL VTTLOM (RPNT,IEDG,ITRI,IIII,RVAL,SVAL,180.-AHAW/2.,
     +                   AHLR,ISTP,SLT2,IAMA,RTPL)
            CALL VTTLOM (RPNT,IEDG,ITRI,IIII,RVAL,SVAL,AHAW/2.-180.,
     +                   AHLR,ISTP,SLT2,IAMA,RTPL)
          END IF
          SLAR=SLAR+AHSR
        END IF
C
C If we're at a point where a termination test is to be done, do it.
C
        IF (SLTT.LT..01*SLPR)
          CALL VTTPOM (RPNT,IEDG,ITRI,IIII,RVAL,SVAL,
     +                 0,ICTT,TTLR,ISTP,SLT2,IDUM,RDUM,SDUM,IAMA,RTPL)
          IF (SLT2.LT..99*TTLR)
            ITER=6
            GO TO 106
          END IF
          CALL VTTPOM (RPNT,IEDG,ITRI,IIII,RVAL,SVAL,
     +                 1,ICTT,TTLR,ISTP,SLT2,IDUM,RDUM,SDUM,IAMA,RTPL)
          IF (SLT2.LT..99*TTLR)
            ITER=6
            GO TO 106
          END IF
          SLTT=SLTT+TTSR
        END IF
C
C If the length of the line has hit the maximum, terminate it.
C
        IF (SLTR.GE.SLMX)
          ITER=4
          GO TO 106
        END IF
C
C If there is more of the line to be traced in the current triangle,
C jump back to continue tracing it.
C
        IF (JUMP.EQ.0) GO TO 102
C
C Otherwise, the line terminated inside the triangle.  If that happened
C because RVAL became zero, move to the triangle, if any, that lies on
C the other side of edge 1 (joining vertices 3 and 1 of the triangle).
C
        IF (JUMP.EQ.1)
C
          IF      (IEDG(ITRI(IIII+1)+1).EQ.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+2).EQ.IPP3)
            INEW=IEDG(ITRI(IIII+1)+3)
          ELSE IF (IEDG(ITRI(IIII+1)+1).EQ.IPP3.AND.
     +             IEDG(ITRI(IIII+1)+2).EQ.IPP1)
            INEW=IEDG(ITRI(IIII+1)+4)
          ELSE
            INEW=-1
          END IF
          IF (INEW.LT.0)
            ITER=1
            GO TO 106
          END IF
          IIII=LOTN*((INEW-1)/LOTN)
          IF (IAND(ITRI(IIII+5),7).EQ.7)
            ITER=2
            GO TO 106
          END IF
          IF (IDRW.NE.0) ITRI(IIII+5)=ITRI(IIII+5)+1
          IPP2=IPP3
          IF      (IEDG(ITRI(IIII+1)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+1).NE.IPP2)
            IPP3=IEDG(ITRI(IIII+1)+1)
          ELSE IF (IEDG(ITRI(IIII+1)+2).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+2).NE.IPP2)
            IPP3=IEDG(ITRI(IIII+1)+2)
          ELSE IF (IEDG(ITRI(IIII+2)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+2)+1).NE.IPP2)
            IPP3=IEDG(ITRI(IIII+2)+1)
          ELSE
            IPP3=IEDG(ITRI(IIII+2)+2)
          END IF
          RVAL=SVAL
          SVAL=0.
C
C If the line terminated because SVAL became zero, move to the triangle,
C if any, that lies on the other side of edge 2 (joining vertices 1 and
C 2 of the triangle).
C
        ELSE IF (JUMP.EQ.2)
C
          IF      (IEDG(ITRI(IIII+2)+1).EQ.IPP1.AND.
     +             IEDG(ITRI(IIII+2)+2).EQ.IPP2)
            INEW=IEDG(ITRI(IIII+2)+4)
          ELSE IF (IEDG(ITRI(IIII+2)+1).EQ.IPP2.AND.
     +             IEDG(ITRI(IIII+2)+2).EQ.IPP1)
            INEW=IEDG(ITRI(IIII+2)+3)
          ELSE
            INEW=-1
          END IF
          IF (INEW.LT.0)
            ITER=1
            GO TO 106
          END IF
          IIII=LOTN*((INEW-1)/LOTN)
          IF (IAND(ITRI(IIII+5),7).EQ.7)
            ITER=2
            GO TO 106
          END IF
          IF (IDRW.NE.0) ITRI(IIII+5)=ITRI(IIII+5)+1
          IPP3=IPP2
          IF      (IEDG(ITRI(IIII+1)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+1).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+1)+1)
          ELSE IF (IEDG(ITRI(IIII+1)+2).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+2).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+1)+2)
          ELSE IF (IEDG(ITRI(IIII+2)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+2)+1).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+2)+1)
          ELSE
            IPP2=IEDG(ITRI(IIII+2)+2)
          END IF
          SVAL=RVAL
          RVAL=0.
C
C If the line terminated because RVAL+SVAL became equal to one, move to
C the triangle, if any, that lies on the other side of edge 3 (joining
C vertices 2 and 3 of the triangle).
C
        ELSE IF (JUMP.EQ.3)
C
          IF      (IEDG(ITRI(IIII+3)+1).EQ.IPP2.AND.
     +             IEDG(ITRI(IIII+3)+2).EQ.IPP3)
            INEW=IEDG(ITRI(IIII+3)+4)
          ELSE IF (IEDG(ITRI(IIII+3)+1).EQ.IPP3.AND.
     +             IEDG(ITRI(IIII+3)+2).EQ.IPP2)
            INEW=IEDG(ITRI(IIII+3)+3)
          ELSE
            INEW=-1
          END IF
          IF (INEW.LT.0)
            ITER=1
            GO TO 106
          END IF
          IIII=LOTN*((INEW-1)/LOTN)
          IF (IAND(ITRI(IIII+5),7).EQ.7)
            ITER=2
            GO TO 106
          END IF
          IF (IDRW.NE.0) ITRI(IIII+5)=ITRI(IIII+5)+1
          IPP1=IPP2
          IF      (IEDG(ITRI(IIII+1)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+1).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+1)+1)
          ELSE IF (IEDG(ITRI(IIII+1)+2).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+1)+2).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+1)+2)
          ELSE IF (IEDG(ITRI(IIII+2)+1).NE.IPP1.AND.
     +             IEDG(ITRI(IIII+2)+1).NE.IPP3)
            IPP2=IEDG(ITRI(IIII+2)+1)
          ELSE
            IPP2=IEDG(ITRI(IIII+2)+2)
          END IF
          SVAL=1.-RVAL
          RVAL=0.
C
        END IF
C
C If we just moved into a new triangle, we may need to recompute the
C values of the pointers to its vertices and of the coordinates of the
C point in the triangle.
C
        IF (JUMP.LT.4)
C
C Get a pointer to what should be point 1 of the triangle.  It will
C match one of the pointers we already have.
C
          IF (IEDG(ITRI(IIII+1)+1).EQ.IEDG(ITRI(IIII+2)+1).OR.
     +        IEDG(ITRI(IIII+1)+1).EQ.IEDG(ITRI(IIII+2)+2))
            IPPT=IEDG(ITRI(IIII+1)+1)
          ELSE
            IPPT=IEDG(ITRI(IIII+1)+2)
          END IF
C
C Adjust the pointers and the values of RVAL and SVAL appropriately.
C
          IF (IPPT.NE.IPP1)
            RTMP=RVAL
            STMP=SVAL
            IF (IPPT.EQ.IPP2)
              IPP2=IPP3
              IPP3=IPP1
              IPP1=IPPT
              RVAL=STMP
              SVAL=1.-RTMP-STMP
            ELSE
              IPP3=IPP2
              IPP2=IPP1
              IPP1=IPPT
              RVAL=1.-RTMP-STMP
              SVAL=RTMP
            END IF
          END IF
C
C Also, if we have been directed to examine the angles between the
C velocity vectors at its vertices, do that.
C
          IF (ANM2.NE.0.)
C
C Compute the squares of the cosines of the angles between the velocity
C vectors at pairs of vertices of the triangle.
C
            DNM1=(RPNT(IPP1+4)**2+RPNT(IPP1+5)**2+RPNT(IPP1+6)**2)*
     +           (RPNT(IPP2+4)**2+RPNT(IPP2+5)**2+RPNT(IPP2+6)**2)
            IF (DNM1.EQ.0.)
              ITER=7
              GO TO 106
            END IF
            CSA1=(RPNT(IPP1+4)*RPNT(IPP2+4)+
     +            RPNT(IPP1+5)*RPNT(IPP2+5)+
     +            RPNT(IPP1+6)*RPNT(IPP2+6))
            CSA1=CSA1*ABS(CSA1)/DNM1
C
            DNM2=(RPNT(IPP2+4)**2+RPNT(IPP2+5)**2+RPNT(IPP2+6)**2)*
     +           (RPNT(IPP3+4)**2+RPNT(IPP3+5)**2+RPNT(IPP3+6)**2)
            IF (DNM2.EQ.0.)
              ITER=7
              GO TO 106
            END IF
            CSA2=(RPNT(IPP2+4)*RPNT(IPP3+4)+
     +            RPNT(IPP2+5)*RPNT(IPP3+5)+
     +            RPNT(IPP2+6)*RPNT(IPP3+6))
            CSA2=CSA2*ABS(CSA2)/DNM2
C
            DNM3=(RPNT(IPP3+4)**2+RPNT(IPP3+5)**2+RPNT(IPP3+6)**2)*
     +           (RPNT(IPP1+4)**2+RPNT(IPP1+5)**2+RPNT(IPP1+6)**2)
            IF (DNM3.EQ.0.)
              ITER=7
              GO TO 106
            END IF
            CSA3=(RPNT(IPP3+4)*RPNT(IPP1+4)+
     +            RPNT(IPP3+5)*RPNT(IPP1+5)+
     +            RPNT(IPP3+6)*RPNT(IPP1+6))
            CSA3=CSA3*ABS(CSA3)/DNM3
C
            IF (MIN(CSA1,CSA2,CSA3).LE.CSMN)
              ITER=3
              GO TO 106
            END IF
C
          END IF
C
C Jump back to continue tracing the streamline in the new triangle.
C
          GO TO 101
C
C Otherwise, ...
C
        ELSE
C
C ... transfer the termination condition flag within the triangle to
C the appropriate return variable and drop through to the return from
C this routine.
C
          ITER=JUMP
C
        END IF
C
C Common exit point.  Process any remaining portion of the curve.
C
  106   IF (NCPL.NE.0)
          INVOKE (CLEAR-POLYLINE-BUFFER)
        END IF
C
C If the polyline color index was saved above, restore it.
C
        IF (IPCS.GE.0) CALL GSPLCI (IPCS)
C
C Return the final trace position to the caller.
C
        IEND=IIII
        REND=RVAL
        SEND=SVAL
C
C If debugging is turned on and the line is being drawn, mark the
C termination point.
C
        IF (IDBG.NE.0.AND.IDRW.NE.0.AND.ICTB.EQ.0)
          CALL HLUVTMXYZ (IMPF,UCND,VCND,WCND,XPOS,YPOS)
          IF (XPOS.NE.OORV)
            CALL GQFACI (IGER,ISFC)
            CALL GSFACI (0)
            CALL VTDREL (CUFX(XPOS),CUFY(YPOS),.0004,.0004,0.,10.,1)
            CALL GSFACI (ISFC)
            CALL PLCHHQ (XPOS,YPOS,IDIG(ITER+1:ITER+1),.0004,0.,0.)
          END IF
        END IF
C
C Done.
C
        RETURN
C
C The following internal procedure, given a line segment, adds visible
C portions of it to the coordinate arrays.
C
        BLOCK (INTERPOLATE-POINTS-ALONG-SEGMENT)
C
C If point interpolation is turned on, do the first IPIS segments.
C
          IF (IPIS.NE.0)
            USOD=UCOD
            VSOD=VCOD
            WSOD=WCOD
            CSOD=CCOD
            USND=UCND
            VSND=VCND
            WSND=WCND
            CSND=CCND
            XSNU=XCNU
            YSNU=YCNU
            ISNU=IVNU
            FOR (INTP = 1 TO ABS(IPIS))
              UCND=USOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(USND-USOD)
              VCND=VSOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(VSND-VSOD)
              WCND=WSOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(WSND-WSOD)
              CCND=CSOD+(REAL(INTP)/REAL(ABS(IPIS)+1))*(CSND-CSOD)
              INVOKE (COMPUTE-USER-COORDINATES)
              IF (IPIS.GT.0.OR.IVNU.NE.IVOU)
                INVOKE (ADD-POINTS-TO-POLYLINE)
                UCOD=UCND
                VCOD=VCND
                WCOD=WCND
                CCOD=CCND
                XCOU=XCNU
                YCOU=YCNU
                IVOU=IVNU
              END IF
            END FOR
            UCND=USND
            VCND=VSND
            WCND=WSND
            CCND=CSND
            XCNU=XSNU
            YCNU=YSNU
            IVNU=ISNU
          END IF
C
C Finish off the job.
C
          INVOKE (ADD-POINTS-TO-POLYLINE)
C
        END BLOCK
C
C The following internal procedure examines the points (UCOD,VCOD,WCOD),
C which projects into (XCOU,YCOU), and (UCND,VCND,WCND), which projects
C into (XCNU,YCNU), either of which may be visible or invisible in the
C projection space, and adds visible portions of the line segment
C between them to the polyline being built.
C
        BLOCK (ADD-POINTS-TO-POLYLINE)
C
          IF (UCND.NE.UCOD.OR.VCND.NE.VCOD.OR.WCND.NE.WCOD)
C
            IF (NCPL.EQ.0)
              IF (IVOU.NE.0)
                IF (IMPF.NE.0.AND.PITH.GT.0.)
                  UCLD=UCOD
                  VCLD=VCOD
                  WCLD=WCOD
                  CCLD=CCOD
                  XCLU=XCOU
                  YCLU=YCOU
                END IF
                NCPL=1
                XCPL(1)=XCOU
                YCPL(1)=YCOU
                IF (IPCV.NE.0)
                  CVAL=CCOD
                  INVOKE (COMPUTE-COLOR-INDEX)
                  IPCD=IPCI
                END IF
              ELSE IF (IVNU.NE.0)
                UCID=UCOD
                VCID=VCOD
                WCID=WCOD
                CCID=CCOD
                UCVD=UCND
                VCVD=VCND
                WCVD=WCND
                CCVD=CCND
                XCVU=XCNU
                YCVU=YCNU
                INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
                INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
                UCOD=UCVD
                VCOD=VCVD
                WCOD=WCVD
                CCOD=CCVD
                XCOU=XCVU
                YCOU=YCVU
                IVOU=1
              END IF
            ELSE IF (NCPL.EQ.MCPL)
              INVOKE (FLUSH-POLYLINE-BUFFER)
            END IF
C
            IF (IVNU.NE.0)
              INVOKE (OUTPUT-NEXT-POINT)
            ELSE IF (IVOU.NE.0)
              UCVD=UCOD
              VCVD=VCOD
              WCVD=WCOD
              CCVD=CCOD
              XCVU=XCOU
              YCVU=YCOU
              UCID=UCND
              VCID=VCND
              WCID=WCND
              CCID=CCND
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              UKND=UCND
              VKND=VCND
              WKND=WCND
              CKND=CCND
              XKNU=XCNU
              YKNU=YCNU
              UCND=UCVD
              VCND=VCVD
              WCND=WCVD
              CCND=CCVD
              XCNU=XCVU
              YCNU=YCVU
              INVOKE (OUTPUT-NEXT-POINT)
              UCND=UKND
              VCND=VKND
              WCND=WKND
              CCND=CKND
              XCNU=XKNU
              YCNU=YKNU
              INVOKE (CLEAR-POLYLINE-BUFFER)
            END IF
C
          END IF
C
        END BLOCK
C
C The following internal procedure outputs the next point; if mapping
C is being done and there is a sufficiently large jump in the mapped
C position of the point, we check for a discontinuity in the mapping.
C Similarly, if mapping is being done and point interpolation is
C activated, we check for a large enough jump in the mapped position
C to justify interpolating points.
C
        BLOCK (OUTPUT-NEXT-POINT)
          IF (IMPF.NE.0.AND.
     +                   (UCND.NE.UCOD.OR.VCND.NE.VCOD.OR.WCND.NE.WCOD))
            RUDO=RUDN
            RUDN=(ABS(XCNU-XCOU)+ABS(YCNU-YCOU))/
     +           (ABS(UCND-UCOD)+ABS(VCND-VCOD)+ABS(WCND-WCOD))
            IF (RUDN.GT.2.*RUDO)
              INVOKE (CHECK-FOR-POSSIBLE-DISCONTINUITY)
            END IF
            IF (PITH.GT.0.)
              UCTD=UCND
              VCTD=VCND
              WCTD=WCND
              CCTD=CCND
              XCTU=XCNU
              YCTU=YCNU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
          END IF
          NCPL=NCPL+1
          XCPL(NCPL)=XCNU
          YCPL(NCPL)=YCNU
          IF (IPCV.NE.0)
            CVAL=CCND
            INVOKE (COMPUTE-COLOR-INDEX)
            IF (IPCI.NE.IPCD)
              INVOKE (FLUSH-POLYLINE-BUFFER)
              IPCD=IPCI
            END IF
          END IF
        END BLOCK
C
C The following internal procedure is invoked when an unusually large
C jump in the position of mapped points on the curve is seen.  It
C checks for a possible discontinuity in the mapping function (as
C can happen, for example, when a cylindrical equidistant projection
C is being used); if there is such a discontinuity, we must generate
C a final point on one side of it, dump the polyline, and then start
C a new polyline on the other side.
C
        BLOCK (CHECK-FOR-POSSIBLE-DISCONTINUITY)
          UC1D=UCOD
          VC1D=VCOD
          WC1D=WCOD
          CC1D=CCOD
          XC1U=XCOU
          YC1U=YCOU
          UC2D=UCND
          VC2D=VCND
          WC2D=WCND
          CC2D=CCND
          XC2U=XCNU
          YC2U=YCNU
          ITMP=0
          LOOP
            DSTO=ABS(XC2U-XC1U)+ABS(YC2U-YC1U)
            UC3D=(UC1D+UC2D)/2.
            VC3D=(VC1D+VC2D)/2.
            WC3D=(WC1D+WC2D)/2.
            CC3D=(CC1D+CC2D)/2.
            CALL HLUCTMXYZ (IMPF,UC3D,VC3D,WC3D,XC3U,YC3U)
            IF (ICFELL('VTTSOM',2).NE.0) GO TO 106
            IF (OORV.EQ.0..OR.(XC3U.NE.OORV.AND.YC3U.NE.OORV))
              DST1=ABS(XC3U-XC1U)+ABS(YC3U-YC1U)
              DST2=ABS(XC3U-XC2U)+ABS(YC3U-YC2U)
              IF (MIN(DST1,DST2).GT.DSTO)
                ITMP=1000
                EXIT
              ELSE IF (DST1.LT.DST2)
                EXIT IF (UC3D.EQ.UC1D.AND.VC3D.EQ.VC1D.AND.WC3D.EQ.WC1D)
                UC1D=UC3D
                VC1D=VC3D
                WC1D=WC3D
                CC1D=CC3D
                XC1U=XC3U
                YC1U=YC3U
              ELSE
                EXIT IF (UC3D.EQ.UC2D.AND.VC3D.EQ.VC2D.AND.WC3D.EQ.WC2D)
                UC2D=UC3D
                VC2D=VC3D
                WC2D=WC3D
                CC2D=CC3D
                XC2U=XC3U
                YC2U=YC3U
              END IF
              ITMP=ITMP+1
              EXIT IF (ITMP.EQ.64)
            ELSE
              UCVD=UCOD
              VCVD=VCOD
              WCVD=WCOD
              CCVD=CCOD
              XCVU=XCOU
              YCVU=YCOU
              UCID=UC3D
              VCID=VC3D
              WCID=WC3D
              CCID=CC3D
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              INVOKE (CLEAR-POLYLINE-BUFFER)
              UCID=UC3D
              VCID=VC3D
              WCID=WC3D
              CCID=CC3D
              UCVD=UCND
              VCVD=VCND
              WCVD=WCND
              CCVD=CCND
              XCVU=XCNU
              YCVU=YCNU
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              ITMP=1000
              EXIT
            END IF
          END LOOP
          IF (ITMP.NE.1000.AND.
     +               (ABS(XC1U-XC2U).GT.SMLX.OR.ABS(YC1U-YC2U).GT.SMLY))
            IF (IMPF.NE.0.AND.PITH.GT.0.)
              UCTD=UC1D
              VCTD=VC1D
              WCTD=WC1D
              CCTD=CC1D
              XCTU=XC1U
              YCTU=YC1U
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
            NCPL=NCPL+1
            XCPL(NCPL)=XC1U
            YCPL(NCPL)=YC1U
            INVOKE (CLEAR-POLYLINE-BUFFER)
            IF (IMPF.NE.0.AND.PITH.GT.0.)
              UCLD=UC2D
              VCLD=VC2D
              WCLD=WC2D
              CCLD=CC2D
              XCLU=XC2U
              YCLU=YC2U
            END IF
            NCPL=1
            XCPL(1)=XC2U
            YCPL(1)=YC2U
            IF (IPCV.NE.0)
              CVAL=CC2D
              INVOKE (COMPUTE-COLOR-INDEX)
              IPCD=IPCI
            END IF
          END IF
        END BLOCK
C
C Given two points in the data-array-index coordinate system, one of
C which maps to a visible point and the other of which maps to an
C invisible point, this internal routine searches the line between
C them for a point near the edge of visibility.
C
        BLOCK (INTERPOLATE-TO-VISIBLE-EDGE)
          ITMP=0
          LOOP
            UCHD=(UCVD+UCID)/2.
            VCHD=(VCVD+VCID)/2.
            WCHD=(WCVD+WCID)/2.
            CCHD=(CCVD+CCID)/2.
            CALL HLUCTMXYZ (IMPF,UCHD,VCHD,WCHD,XCHU,YCHU)
            IF (ICFELL('VTTSOM',3).NE.0) GO TO 106
            IF (XCHU.NE.OORV.AND.YCHU.NE.OORV)
              EXIT IF (UCHD.EQ.UCVD.AND.VCHD.EQ.VCVD.AND.WCHD.EQ.WCVD)
              UCVD=UCHD
              VCVD=VCHD
              WCVD=WCHD
              CCVD=CCHD
              XCVU=XCHU
              YCVU=YCHU
            ELSE
              EXIT IF (UCHD.EQ.UCID.AND.VCHD.EQ.VCID.AND.WCHD.EQ.WCID)
              UCID=UCHD
              VCID=VCHD
              WCID=WCHD
              CCID=CCHD
            END IF
            ITMP=ITMP+1
            EXIT IF (ITMP.EQ.64)
          END LOOP
        END BLOCK
C
C The following internal procedure outputs a visible edge point found
C by the previous internal procedure.
C
        BLOCK (OUTPUT-VISIBLE-EDGE-POINT)
          IF (PITH.GT.0.)
            IF (NCPL.EQ.0)
              UCLD=UCVD
              VCLD=VCVD
              WCLD=WCVD
              CCLD=CCVD
              XCLU=XCVU
              YCLU=YCVU
            ELSE
              UCTD=UCVD
              VCTD=VCVD
              WCTD=WCVD
              CCTD=CCVD
              XCTU=XCVU
              YCTU=YCVU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
          END IF
          NCPL=NCPL+1
          XCPL(NCPL)=XCVU
          YCPL(NCPL)=YCVU
          IF (IPCV.NE.0)
            CVAL=CCVD
            INVOKE (COMPUTE-COLOR-INDEX)
            IF (IPCI.NE.IPCD)
              INVOKE (FLUSH-POLYLINE-BUFFER)
              IPCD=IPCI
            END IF
          END IF
        END BLOCK
C
C The following internal procedure is invoked when mapping is being
C done and a new point is about to be added to the polyline buffer.
C It checks for a jump (using a user-defined threshold value) in
C the mapped coordinates of the point and, if such a jump is found,
C interpolates some points in between.  The assumption is made that
C all points in between are visible; if that is found not to be the
C case, no attempt is made to rectify the situation: the user probably
C screwed up the definition of the mapping function.
C
        BLOCK (CHECK-FOR-JUMP-IN-MAPPING)
          WHILE (ABS(XCTU-XCLU).GT.PITX.OR.ABS(YCTU-YCLU).GT.PITY)
            IFND=0
            UCQD=0.
            VCQD=0.
            WCQD=0.
            CCQD=0.
            RDST=.50
            RSTP=.25
            LOOP
              UCPD=UCLD+RDST*(UCTD-UCLD)
              VCPD=VCLD+RDST*(VCTD-VCLD)
              WCPD=WCLD+RDST*(WCTD-WCLD)
              CCPD=CCLD+RDST*(CCTD-CCLD)
              CALL HLUCTMXYZ (IMPF,UCPD,VCPD,WCPD,XCPU,YCPU)
              IF (ICFELL('VTTSOM',4).NE.0) GO TO 106
              EXIT IF (OORV.NE.0..AND.(XCPU.EQ.OORV.OR.YCPU.EQ.OORV))
              IF (ABS(XCPU-XCLU).LT.PITX.AND.ABS(YCPU-YCLU).LT.PITY)
                IFND=1
                UCQD=UCPD
                VCQD=VCPD
                WCQD=WCPD
                CCQD=CCPD
                XCQU=XCPU
                YCQU=YCPU
                EXIT IF (ABS(XCQU-XCLU).GT..5*PITX.OR.
     +                   ABS(YCQU-YCLU).GT..5*PITY)
                RDST=RDST+RSTP
              ELSE
                RDST=RDST-RSTP
              END IF
              RSTP=RSTP/2.
              EXIT IF (RSTP.LT..0001)
            END LOOP
            IF (IFND.NE.0.AND.(UCQD.NE.UCLD.OR.VCQD.NE.VCLD.OR.
     +                                         WCQD.NE.WCLD))
              NCPL=NCPL+1
              XCPL(NCPL)=XCQU
              YCPL(NCPL)=YCQU
              IF (IPCV.NE.0)
                CVAL=CCQD
                INVOKE (COMPUTE-COLOR-INDEX)
                IF (IPCI.NE.IPCD)
                  INVOKE (FLUSH-POLYLINE-BUFFER)
                  IPCD=IPCI
                END IF
              END IF
              IF (NCPL.EQ.MCPL)
                INVOKE (FLUSH-POLYLINE-BUFFER)
              END IF
              UCLD=UCQD
              VCLD=VCQD
              WCLD=WCQD
              CCLD=CCQD
              XCLU=XCQU
              YCLU=YCQU
            ELSE
              UCLD=UCTD
              VCLD=VCTD
              WCLD=WCTD
              CCLD=CCTD
              XCLU=XCTU
              YCLU=YCTU
            END IF
          END WHILE
          UCLD=UCTD
          VCLD=VCTD
          WCLD=WCTD
          CCLD=CCTD
          XCLU=XCTU
          YCLU=YCTU
        END BLOCK
C
C The following internal procedure is given the data-system coordinates
C of a point (UCND,VCND,WCND) and computes the user-system coordinates
C of the point's projection (XCNU,YCNU).  It also sets a flag indicating
C whether the projection point is visible or not.
C
        BLOCK (COMPUTE-USER-COORDINATES)
C
          IF (IMPF.EQ.0)
            XCNU=UCND
            YCNU=VCND
            IVNU=1
          ELSE
            CALL HLUCTMXYZ (IMPF,UCND,VCND,WCND,XCNU,YCNU)
            IF (ICFELL('VTTSOM',5).NE.0) GO TO 106
            IF ((OORV.NE.0.).AND.(XCNU.EQ.OORV.OR.YCNU.EQ.OORV))
              IVNU=0
            ELSE
              IVNU=1
            END IF
          END IF
C
        END BLOCK
C
C The following internal procedure, given a value (CVAL), computes a
C polyline color index (IPCI) to be used to get a desired color for a
C streamline being drawn.
C
        BLOCK (COMPUTE-COLOR-INDEX)
          WHILE (ICVL.GT.1.AND.CVAL.LT.TVAL(ICVL))
            ICVL=ICVL-1
          END WHILE
          WHILE (ICVL.LT.NCLR.AND.CVAL.GE.TVAL(ICVL+1))
            ICVL=ICVL+1
          END WHILE
          IPCI=ICLR(ICVL)
        END BLOCK
C
C The following internal procedure draws the part of the curve defined
C by the contents of the polyline buffer and then removes all but the
C last point from the buffer.  IPCC is the polyline color currently
C in use and IPCD the polyline color desired for the curve.
C
        BLOCK (FLUSH-POLYLINE-BUFFER)
C
          I=1
C
          LOOP
            I=I+1
            EXIT IF (I.GT.NCPL)
            IF (ABS(XCPL(I)-XCPL(I-1)).LT.EPSX.AND.
     +          ABS(YCPL(I)-YCPL(I-1)).LT.EPSY)
              IF (I.NE.NCPL)
                DO (J=I+1,NCPL)
                  XCPL(J-1)=XCPL(J)
                  YCPL(J-1)=YCPL(J)
                END DO
              ELSE
                XCPL(NCPL-1)=XCPL(NCPL)
                YCPL(NCPL-1)=YCPL(NCPL)
              END IF
              I=I-1
              NCPL=NCPL-1
            END IF
          END LOOP
C
          IF (NCPL.GT.1)
            IF (IPCV.NE.0)
              IF (IPCC.NE.IPCD)
                CALL GSPLCI (IPCD)
                IPCC=IPCD
              END IF
            END IF
            IF (IAMA(1).EQ.0)
              CALL CURVE (XCPL,YCPL,NCPL)
            ELSE
              CALL ARDRLN (IAMA,XCPL,YCPL,NCPL,
     +                          XCPF,YCPF,MCPF,
     +                          IAAI,IAGI,MNOG,RTPL)
            END IF
          END IF
C
          XCPL(1)=XCPL(NCPL)
          YCPL(1)=YCPL(NCPL)
          NCPL=1
C
        END BLOCK
C
C The following internal procedure draws the part of the curve defined
C by the contents of the polyline buffer and then clears the buffer.
C IPCC is the polyline color currently in use and IPCD the polyline
C color desired for the curve.
C
        BLOCK (CLEAR-POLYLINE-BUFFER)
C
          I=1
C
          LOOP
            I=I+1
            EXIT IF (I.GT.NCPL)
            IF (ABS(XCPL(I)-XCPL(I-1)).LT.EPSX.AND.
     +          ABS(YCPL(I)-YCPL(I-1)).LT.EPSY)
              IF (I.NE.NCPL)
                DO (J=I+1,NCPL)
                  XCPL(J-1)=XCPL(J)
                  YCPL(J-1)=YCPL(J)
                END DO
              ELSE
                XCPL(NCPL-1)=XCPL(NCPL)
                YCPL(NCPL-1)=YCPL(NCPL)
              END IF
              I=I-1
              NCPL=NCPL-1
            END IF
          END LOOP
C
          IF (NCPL.GT.1)
            IF (IPCV.NE.0)
              IF (IPCC.NE.IPCD)
                CALL GSPLCI (IPCD)
                IPCC=IPCD
              END IF
            END IF
            IF (IAMA(1).EQ.0)
              CALL CURVE (XCPL,YCPL,NCPL)
            ELSE
              CALL ARDRLN (IAMA,XCPL,YCPL,NCPL,
     +                          XCPF,YCPF,MCPF,
     +                          IAAI,IAGI,MNOG,RTPL)
            END IF
          END IF
C
          NCPL=0
          RUDN=0.
C
        END BLOCK
C
      END
.OP   BI=77


      SUBROUTINE VTDREL (XCFR,YCFR,RADA,RADB,ROTD,DSTP,IDRW)
C
C This routine fills an ellipse.  The arguments are as follows:
C
C   XCFR and YCFR are the coordinates of the center of the ellipse, in
C   the fractional coordinate system.
C
C   RADA is the length of the semimajor axis of the ellipse (i.e., the
C   distance from the center of the ellipse to one of the two points on
C   the ellipse which are furthest from the center).  This is a distance
C   in the fractional coordinate system.
C
C   RADB is the length of the semiminor axis of the ellipse (i.e., the
C   distance from the center of the ellipse to one of the two points on
C   the ellipse which are nearest to the center).  This is a distance in
C   the fractional coordinate system.
C
C   ROTD is a rotation angle, in degrees.  If ROTD is 0, the major axis
C   of the ellipse is horizontal.  If ROTD is 90, the major axis is
C   vertical.
C
C   DSTP is the step size, in degrees, between any two consecutive
C   points used to draw the ellipse.  The actual value used will be
C   limited to the range from .1 degrees (3600 points used to draw
C   the ellipse) to 90 degrees (4 points used to draw the ellipse).
C
C   Set IDRW to 1 to just fill the ellipse, 2 to just draw the boundary
C   of the ellipse, 3 to do both.
C
C Declare work arrays to hold the coordinates.
C
        DIMENSION XCRA(3601),YCRA(3601)
C
C DTOR is pi over 180, used to convert an angle from degrees to radians.
C
        DATA DTOR / .017453292519943 /
C
C Get the rotation angle in radians.
C
        ROTR=DTOR*ROTD
C
C Compute the number of steps to be used to draw the ellipse and the
C actual number of degrees for each step.
C
        NSTP=MAX(4,MIN(3600,INT(360./MAX(.1,MIN(90.,DSTP)))))
        RSTP=360./NSTP
C
C Compute coordinates for the ellipse (just some trigonometry).
C
        DO 101 ISTP=0,NSTP
          ANGL=DTOR*REAL(ISTP)*RSTP
          XTMP=RADA*COS(ANGL)
          YTMP=RADB*SIN(ANGL)
          XCRA(ISTP+1)=CFUX(XCFR+XTMP*COS(ROTR)-YTMP*SIN(ROTR))
          YCRA(ISTP+1)=CFUY(YCFR+XTMP*SIN(ROTR)+YTMP*COS(ROTR))
  101   CONTINUE
C
C Fill it.
C
        IF (IDRW.EQ.1.OR.IDRW.EQ.3) CALL GFA (NSTP+1,XCRA,YCRA)
C
C Draw it.
C
        IF (IDRW.EQ.2.OR.IDRW.EQ.3) CALL GPL (NSTP+1,XCRA,YCRA)
C
C Done.
C
        RETURN
C
      END


      FUNCTION ICAVPT (XCRD,YCRD,ZCRD,XCVV,YCVV,ZCVV,RPNT,LOPN,
     +                                          IPPP,MPPP,NPPP)
C
        DIMENSION RPNT(LOPN,MPPP),IPPP(2,MPPP)
C
C This function, given the X, Y, and Z coordinates of a point and the
C components of the velocity vector at that point, searches the point
C list for a point having the same coordinates.  If such a point
C exists, its index is returned; if not, such a point is created and
C its index is returned.  The search is effected using a tree-sort
C technique, the pointers for which are kept in the array IPPP.
C
C If there are any points in the point list at all, ...
C
        IF (NPPP.NE.0)
C
C initialize a search index to point to the first one, and loop.
C
          ITMP=1
C
C If the search index is of the point we want, return its index.
C
  101     IF (XCRD.EQ.RPNT(1,ITMP).AND.
     +        YCRD.EQ.RPNT(2,ITMP).AND.
     +        ZCRD.EQ.RPNT(3,ITMP))
C
            ICAVPT=ITMP
C
            RETURN
C
C If the point we want would precede the one pointed at by the search
C index, reset the search index to look at lesser elements (if any),
C and loop back to continue the search.  If the pointer is null, reset
C it to point to a new element that we will create.
C
          ELSE IF ((XCRD.LT.RPNT(1,ITMP)).OR.
     +             (XCRD.EQ.RPNT(1,ITMP).AND.
     +              YCRD.LT.RPNT(2,ITMP)).OR.
     +             (XCRD.EQ.RPNT(1,ITMP).AND.
     +              YCRD.EQ.RPNT(2,ITMP).AND.
     +              ZCRD.LT.RPNT(3,ITMP)))
C
            IF (IPPP(1,ITMP).NE.0)
              ITMP=IPPP(1,ITMP)
              GO TO 101
            END IF
C
            IPPP(1,ITMP)=NPPP+1
C
C If the point we want would follow the one pointed at by the search
C index, reset the search index to look at greater elements (if any),
C and loop back to continue the search.  If the pointer is null, reset
C it to point to a new element that we will create.
C
          ELSE IF ((XCRD.GT.RPNT(1,ITMP)).OR.
     +             (XCRD.EQ.RPNT(1,ITMP).AND.
     +              YCRD.GT.RPNT(2,ITMP)).OR.
     +             (XCRD.EQ.RPNT(1,ITMP).AND.
     +              YCRD.EQ.RPNT(2,ITMP).AND.
     +              ZCRD.GT.RPNT(3,ITMP)))
C
            IF (IPPP(2,ITMP).NE.0)
              ITMP=IPPP(2,ITMP)
              GO TO 101
            END IF
C
            IPPP(2,ITMP)=NPPP+1
C
          END IF
C
        END IF
C
C Create a new point in the point list (if there's room, of course), and
C return its index to the caller.
C
        IF (NPPP.GE.MPPP)
C
          CALL SETER ('ICAVPT - POINT ARRAY IS TOO SMALL',1,1)
          ICAVPT=-1
          RETURN
C
        ELSE
C
          NPPP=NPPP+1
C
          IPPP(1,NPPP)=0
          IPPP(2,NPPP)=0
C
          RPNT(1,NPPP)=XCRD
          RPNT(2,NPPP)=YCRD
          RPNT(3,NPPP)=ZCRD
          RPNT(4,NPPP)=XCVV
          RPNT(5,NPPP)=YCVV
          RPNT(6,NPPP)=ZCVV
C
          ICAVPT=NPPP
C
        END IF
C
C Done.
C
        RETURN
C
      END


      FUNCTION ICAVPX (XCRD,YCRD,ZCRD,XCVV,YCVV,ZCVV,RPNT,LOPN,
     +                                     IPPP,MPPP,NPPP,EPST)
C
        DIMENSION RPNT(LOPN,MPPP),IPPP(3,MPPP)
C
C This function, given the X, Y, and Z coordinates of a point and the
C components of the velocity vector at that point, searches the point
C list for a point having nearly the same coordinates (within the
C epsilon specified by the value of EPST).  If such a point exists,
C its index is returned; if not, such a point is created and its index
C is returned.  The search is effected using a tree-sort technique, the
C pointers for which are kept in the array IPPP.  Each node contains
C three pointers: 1) a forward pointer to a list of lesser values;
C 2) a forward pointer to a list of greater values, and 3) a backward
C pointer to the parent.
C
C Initialize.
C
        ITMP=0
C
C If there are any points in the point list at all, ...
C
        IF (NPPP.NE.0)
C
C initialize the search index to point to the first one, and loop.
C
          ITMP=1
C
C If the search index is that of the point we want, return it.
C
  101     IF (ABS(XCRD-RPNT(1,ITMP)).LE.EPST.AND.
     +        ABS(YCRD-RPNT(2,ITMP)).LE.EPST.AND.
     +        ABS(ZCRD-RPNT(3,ITMP)).LE.EPST)
C
C 101     IF      (ABS(XCRD.EQ.RPNT(1,ITMP)).AND.
C    +             ABS(YCRD.EQ.RPNT(2,ITMP)).AND.
C    +             ABS(ZCRD.EQ.RPNT(3,ITMP)))
C
            ICAVPX=ITMP
C
            RETURN
C
C If the point we want would precede the one pointed at by the search
C index, reset the search index to look at lesser elements (if any),
C and loop back to continue the search.  If the pointer is null, reset
C it to point to a new element that we will create.
C
          ELSE IF ((XCRD.LT.RPNT(1,ITMP)).OR.
     +             (XCRD.EQ.RPNT(1,ITMP).AND.
     +              YCRD.LT.RPNT(2,ITMP)).OR.
     +             (XCRD.EQ.RPNT(1,ITMP).AND.
     +              YCRD.EQ.RPNT(2,ITMP).AND.
     +              ZCRD.LT.RPNT(3,ITMP)))
C
            IF (IPPP(1,ITMP).NE.0)
              ITMP=IPPP(1,ITMP)
              GO TO 101
            END IF
C
            INEW=1
C
C If the point we want would follow the one pointed at by the search
C index, reset the search index to look at greater elements (if any),
C and loop back to continue the search.  If the pointer is null, reset
C it to point to a new element that we will create.
C
          ELSE IF ((XCRD.GT.RPNT(1,ITMP)).OR.
     +             (XCRD.EQ.RPNT(1,ITMP).AND.
     +              YCRD.GT.RPNT(2,ITMP)).OR.
     +             (XCRD.EQ.RPNT(1,ITMP).AND.
     +              YCRD.EQ.RPNT(2,ITMP).AND.
     +              ZCRD.GT.RPNT(3,ITMP)))
C
            IF (IPPP(2,ITMP).NE.0)
              ITMP=IPPP(2,ITMP)
              GO TO 101
            END IF
C
            INEW=2
C
          END IF
C
C No point with approximately the right X, Y, and Z coordinates was
C found.  Search backward through the list looking for near matches.
C
          IBAK=ITMP
C
          LOOP
            IF (IPPP(1,IBAK).NE.0)
              IBAK=IPPP(1,IBAK)
              WHILE (IPPP(2,IBAK).NE.0)
                IBAK=IPPP(2,IBAK)
              END WHILE
            ELSE
              REPEAT
                EXIT IF (IPPP(3,IBAK).EQ.0)
                ISAV=IBAK
                IBAK=IPPP(3,IBAK)
              UNTIL (IPPP(2,IBAK).EQ.ISAV)
            END IF
            EXIT IF (RPNT(1,IBAK).LT.XCRD-EPST)
            IF (ABS(XCRD-RPNT(1,IBAK)).LE.EPST.AND.
     +          ABS(YCRD-RPNT(2,IBAK)).LE.EPST.AND.
     +          ABS(ZCRD-RPNT(3,IBAK)).LE.EPST)
              ICAVPX=IBAK
              RETURN
            END IF
          END LOOP
C
C No point with approximately the right X, Y, and Z coordinates was
C found.  Search forward through the list looking for near matches.
C
          IFOR=ITMP
C
          LOOP
            IF (IPPP(2,IFOR).NE.0)
              IFOR=IPPP(2,IFOR)
              WHILE (IPPP(1,IFOR).NE.0)
                IFOR=IPPP(1,IFOR)
              END WHILE
            ELSE
              REPEAT
                EXIT IF (IPPP(3,IFOR).EQ.0)
                ISAV=IFOR
                IFOR=IPPP(3,IFOR)
              UNTIL (IPPP(1,IFOR).EQ.ISAV)
            END IF
            EXIT IF (RPNT(1,IFOR).GT.XCRD+EPST)
            IF (ABS(XCRD-RPNT(1,IFOR)).LE.EPST.AND.
     +          ABS(YCRD-RPNT(2,IFOR)).LE.EPST.AND.
     +          ABS(ZCRD-RPNT(3,IFOR)).LE.EPST)
              ICAVPX=IFOR
              RETURN
            END IF
          END LOOP
C
        END IF
C
C Create a new point in the point list (if there's room, of course), and
C return its index to the caller.
C
        IF (NPPP.GE.MPPP)
C
          CALL SETER ('ICAVPX - POINT ARRAY IS TOO SMALL',1,1)
          ICAVPX=-1
          RETURN
C
        ELSE
C
          NPPP=NPPP+1
C
          IF (ITMP.NE.0) IPPP(INEW,ITMP)=NPPP
C
          IPPP(1,NPPP)=0
          IPPP(2,NPPP)=0
          IPPP(3,NPPP)=ITMP
C
          RPNT(1,NPPP)=XCRD
          RPNT(2,NPPP)=YCRD
          RPNT(3,NPPP)=ZCRD
          RPNT(4,NPPP)=XCVV
          RPNT(5,NPPP)=YCVV
          RPNT(6,NPPP)=ZCVV
C
          ICAVPX=NPPP
C
        END IF
C
C Done.
C
        RETURN
C
      END
