.OP LS=10001 LI=1 CB RT ES=< ET=> OC UC=0 BI=77 IF=2
.EL I
I
I $Id: CodeIftran,v 1.20.8.1 2010-03-17 20:51:57 brownrig Exp $
I
I***********************************************************************
I C O N 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 contouring package called CONPACKT.
I Double-spaced headers like the one above set off the major portions
I of the file.  Included are implementation instructions, user-level
I routines, and internal routines.
I
I***********************************************************************
I C O N 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 CONPACKT 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 CONPACKT requires various parts of the NCAR Graphics package to have
I been implemented (in particular, it uses the support routines I1MACH,
I SETER, MSKRV1, and MSKRV2, various routines from SPPS, and the utility
I packages DASHCHAR and AREAS).
I
I***********************************************************************
I C O N 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 $NCLV$ sets a limit on the maximum number of contour levels that may
I be defined at any one time.
I
.RE /$NCLV$/256/
I
I $NCP1$ and $NCP2$ define the positions, in the extended contour-level
I arrays, of parameters for grid edges and visible/invisible edges,
I respectively.
I
.RE /$NCP1$/<$NCLV$+1>/
.RE /$NCP2$/<$NCP1$+1>/
I
I $LOCV$ is the length of certain character variables.  User-specified
I dash patterns will be truncated to this length.  Do not use a value
I less than 25.  Values greater than 500 are probably too large.
I
.RE /$LOCV$/500/
I
I $NBIW$ is the number of "blocks" of integer workspace to be provided
I for.  The user of CONPACKT supplies a single integer workspace array.
I When one of the CONPACKT routines requires a block of space within the
I array, it calls CTGIWS to request the space.  CTGIWS 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 CONPACKT supplies a single real workspace array.
I When one of the CONPACKT routines requires a block of space within the
I array, it calls CTGRWS to request the space.  CTGRWS 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$/4/
I
I The CONPACKT common blocks
I --- -------- ------ ------
I
I The following SAVE block contains all of the CONPACKT common blocks.
I For descriptions of all of the variables, see the commenting in the
I block data routine CTBLDA, below.
I
.SAVE CTCOMN
C
C CTCOM1 contains integer and real variables.
C
        COMMON /CTCOM1/ ANCF,ANHL,ANIL,ANLL,CDMX,CHWM,CINS,CINT(10)
        COMMON /CTCOM1/ CINU,CLDB($NCLV$),CLDL($NCLV$),CLDR($NCLV$)
        COMMON /CTCOM1/ CLDT($NCLV$),CLEV($NCLV$),CLWA($NCP2$),CXCF
        COMMON /CTCOM1/ CXIL,CYCF,CYIL,DBLF,DBLM,DBLN,DBLV,DFLD,DMAX
        COMMON /CTCOM1/ DMIN,DOPT,DVAL,EPSI,FNCM,GRAV,GRSD,GSDM,HCHL
        COMMON /CTCOM1/ HCHS,HLSR,IAIA($NCP2$),IAIB($NCLV$),IBCF,IBHL
        COMMON /CTCOM1/ IBIL,IBLL,ICAF,ICCF,ICCL($NCP2$),ICFF,ICHI
        COMMON /CTCOM1/ ICHL,ICIL,ICLL($NCLV$),ICLO,ICLP($NCLV$),ICLS
        COMMON /CTCOM1/ ICLU($NCP2$),ICLV,ICLW,IDUF,IGCL,IGLB,IGRM
        COMMON /CTCOM1/ IGRN,IGVS,IHCF,IHLE,IIWS($NBIW$),IIWU,ILBC
        COMMON /CTCOM1/ IMPF,INCX(8),INCY(8),INHL,INIL,INIT,INLL
        COMMON /CTCOM1/ IOCF,IOHL,IOLL,IPAI,IPCF,IPIC,IPIE,IPIL,IPLL
        COMMON /CTCOM1/ IRWS($NBRW$),IRWU,ISET,ITBM,IWSO,JODP,JOMA
        COMMON /CTCOM1/ JOTZ,LCTM,LEA1,LEA2,LEA3,LEE1,LEE2,LEE3,LINS
        COMMON /CTCOM1/ LINT(10),LINU,LIWB,LIWK,LIWM,LIWS($NBIW$),LNLG
        COMMON /CTCOM1/ LOEN,LOPN,LOTN,LRWC,LRWG,LRWK,LRWM,LRWS($NBRW$)
        COMMON /CTCOM1/ LSDD,LSDL,LSDM,LTCF,LTHI,LTIL,LTLO,MIRO
        COMMON /CTCOM1/ NCLB($NCLV$),NCLV,NDGL,NEDG,NEXL,NEXT,NEXU
        COMMON /CTCOM1/ NLBS,NLSD,NLZF,NOMF,NOVS,NPNT,NR04,NSDL
        COMMON /CTCOM1/ NSDR,NTRI,OORV,PITH,SCFS,SCFU,SEGL,T2DS
        COMMON /CTCOM1/ UCMN,UCMX,UVPB,UVPL,UVPR,UVPS,UVPT,UWDB,UWDL
        COMMON /CTCOM1/ UWDR,UWDT,WCCF,WCHL,WCIL,WCLL,WLCF,WLHL,WLIL
        COMMON /CTCOM1/ WLLL,WOCH,WODA,WTCD,WTGR,WTNC,WTOD,WWCF,WWHL
        COMMON /CTCOM1/ WWIL,WWLL,XLBC,XMAX,XMIN,XVPL,XVPR,XWDL,XWDR
        COMMON /CTCOM1/ 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   /CTCOM1/
.ENDIF
C
C CTCOM2 holds character parameters.
C
        COMMON /CTCOM2/ CHEX,CLBL($NCLV$),CLDP($NCP2$),CTMA,CTMB,FRMT
        COMMON /CTCOM2/ TXCF,TXHI,TXIL,TXLO
        CHARACTER*13 CHEX
        CHARACTER*64 CLBL
        CHARACTER*128 CLDP
        CHARACTER*$LOCV$ CTMA,CTMB
        CHARACTER*8 FRMT
        CHARACTER*64 TXCF
        CHARACTER*32 TXHI
        CHARACTER*128 TXIL
        CHARACTER*32 TXLO
.IF <$SAVE-COMMON$.NE.0>
        SAVE   /CTCOM2/
.ENDIF
.END


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


      SUBROUTINE CTBLDA
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 CTBLDAX
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Below are descriptions of all the COMMON variables and default values
C for those which require defaults.
C
C
C ANCF is the parameter 'CFA', which is the angle, in degrees, at which
C the constant-field label is to be written.
C
        DATA ANCF / 0. /
C
C ANHL is the parameter 'HLA', which is the angle, in degrees, at which
C high and low labels are to be written.
C
        DATA ANHL / 0. /
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 ANLL is the parameter 'LLA', which is the angle, in degrees, at which
C line labels are to be written when ABS('LLP') is 2 or greater and
C 'LLO' is 0.
C
        DATA ANLL / 0. /
C
C CDMX is the parameter 'PC3', used in positioning labels according to
C the penalty scheme.  It specifies the maximum cumulative change in
C direction, in degrees, to be allowed along any portion of the contour
C line covered by a circle centered on a label and having a radius equal
C to half the width of the label.
C
        DATA CDMX / 60. /
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 CINS is the parameter 'CIS', the contour interval specified by the
C user (for use when 'CLS' is positive or zero).
C
        DATA CINS / 0. /
C
C CINT is the parameter 'CIT', the contour interval table.
C
        DATA CINT / 1.,2.,2.5,4.,5.,5*0. /
C
C CINU is the parameter 'CIU', the contour interval actually used.
C
        DATA CINU / 0. /
C
C CLBL is the parameter array 'LLT', each element of which is a string
C of characters to be used as a label for an associated contour level.
C
        DATA CLBL / $NCLV$*' ' /
C
C CLDP is the parameter array 'CLD', which holds the dash patterns
C associated with the contour levels.  The last two elements of this
C array give the dash patterns for the edge of the grid and the edge
C of the visible area, respectively.
C
        DATA CLDP / $NCP2$*'$$$$$$$$$$$$$$$$' /
C
C CLDB, CLDL, CLDR, and CLDT are arrays, each element of which is the
C magnitude of one of the text-extent vectors for the label in CLBL.
C
C CLEV is the parameter array 'CLV', each element of which is a contour
C level.
C
        DATA CLEV / $NCLV$*0. /
C
C CLWA is the parameter array 'CLL', each element of which specifies
C the line width to be used for an associated contour line.  The last
C two elements of this array give the line widths for the edge of the
C grid and the edge of the visible area, respectively.
C
        DATA CLWA / $NCP2$*0. /
C
C CTMA and CTMB are character-variable temporaries, used for various
C purposes throughout the code.
C
        DATA CTMA,CTMB / ' ',' ' /
C
C CXCF and CYCF are the parameters 'CFX' and 'CFY', which are the x and
C y coordinates of a basepoint relative to which the constant-field
C label is to be positioned.  These coordinates are given in a
C fractional coordinate system superimposed on the grid.
C
        DATA CXCF,CYCF / .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 grid.
C
        DATA CXIL,CYIL / .98,-.02 /
C
C DBLM is the parameter 'PC6', used in positioning labels according to
C the penalty scheme.  It specifies the minimum distance (as a fraction
C of the width of the viewport) to be allowed between any two labels on
C the same contour line.
C
        DATA DBLM / .30 /
C
C DBLF, DBLN and DBLV are the parameters 'RC1', 'RC2', and 'RC3', used
C in positioning labels at regular intervals along a contour line.
C
        DATA DBLF,DBLN,DBLV / .25,.25,.05 /
C
C DFLD is the parameter 'PC5', used in positioning labels according to
C the penalty scheme.  It is the "folding distance" (as a fraction of
C the viewport's width) in the formula for the penalty term which
C attempts to force labels to be at an optimal distance from each other.
C
        DATA DFLD / .15 /
C
C DMAX and DMIN are the parameters 'DMX' and 'DMN', the maximum and
C minimum values in the user's array of data.
C
        DATA DMAX,DMIN / 0.,0. /
C
C DOPT is the parameter 'PC4', used in positioning labels according to
C the penalty scheme.  It is the "optimal distance" (as a fraction of
C the viewport's width) in the formula for the penalty term which
C attempts to force labels to be at an optimal distance from each other.
C
        DATA DOPT / .05 /
C
C DVAL is the parameter 'DVA', which holds a data value, either the
C value at a high or low or the value of a constant field.
C
        DATA DVAL / 0. /
C
C EPSI is a machine "epsilon", whose real value is computed as required.
C
C FNCM is the parameter 'PC2', used in positioning labels according to
C the penalty scheme.  It is the maximum (estimated) number of contour
C bands allowed to cross a label.
C
        DATA FNCM / 5. /
C
C FRMT is a format to be used by the routine CTNUMB.  It is constructed
C as needed by the routine CTINRC.
C
C GRAV is the average gradient in the array of gradients computed for
C use in positioning labels according to the penalty scheme.
C
C GRSD is the standard deviation of an array of gradients.
C
C GSDM is the parameter 'PC1', used in positioning labels according to
C the penalty scheme.  "GSDM" stands for "Gradient Standard Deviation
C Multiplier".  GRAV+GSDM*GRSD is the largest gradient allowed (where
C GRAV is the average gradient and GRSD is the stardard deviation of
C the gradients).
C
        DATA GSDM / 1. /
C
C HCHL and HCHS are the parameters 'HCL' and 'HCS', respectively.  The
C former specifies the length of a hachure and the latter specifies the
C spacing of hachures along a contour line, as fractions of the width of
C the viewport.
C
        DATA HCHL,HCHS / .004,.010 /
C
C HLSR is the parameter 'HLR', which specifies the radius of a sphere
C around a possible high (low) within which field values must be less
C than (greater than) the value at the possible high (low) in order
C for it to be marked.  A positive value specifies a radius equal to
C HLSR*MAX(XMAX-XMIN,YMAX-YMIN,ZMAX-ZMIN).  A negative value specifies
C the value ABS(HLSR).
C
        DATA HLSR / .075 /
C
C IAIA is the parameter array 'AIA', each element of which is an area
C identifier for the area above the associated contour level.  The
C default values suppress area fill (except for the last two elements,
C which are used for the edge of the grid and the edge of the visible
C area, respectively - in these cases, the value is for the area on the
C other side of the edge from the area which has contour lines in it).
C
        DATA IAIA / $NCLV$*0,0,-1  /
C
C IAIB is the parameter array 'AIB', each element of which is an area
C identifier for the area below the associated contour level.  The
C default values suppress area fill.
C
        DATA IAIB / $NCLV$*0 /
C
C IBCF is the parameter 'CFB', which is zero if no box is to be drawn
C around the constant-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 IBCF / 0 /
C
C IBHL is the parameter 'HLB', which is zero if no box is to be drawn
C around the high/low labels.  Adding 1 to the value causes the box to
C be drawn and adding 2 to it causes the box to be filled.
C
        DATA IBHL / 0 /
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 IBLL is the parameter 'LLB', which is zero if no boxes are to be drawn
C around line labels.  Adding 1 to the value causes the box to be drawn
C and adding 2 to it causes the box to be filled.
C
        DATA IBLL / 0 /
C
C ICAF is the parameter 'CAF', which determines the way in which CTCICA
C modifies an element of the cell array.
C
        DATA ICAF / 0 /
C
C ICCF is the parameter 'CFC', which determines the color of the
C constant-field label.
C
        DATA ICCF / -1 /
C
C ICCL is the parameter array 'CLC', each element of which specifies
C the color index for the lines at an associated contour level (except
C for the last two elements, which are used for the edge of the grid
C and the edge of the visible area, respectively).
C
        DATA ICCL / $NCLV$*0,2*-1 /
C
C ICFF is the parameter 'CFF' (output only) which is non-zero if the
C field being contoured is constant.
C
        DATA ICFF / 0 /
C
C ICHI is the parameter 'HIC', which determines the color of the high
C labels.
C
        DATA ICHI / -1 /
C
C ICHL is the parameter 'HLC', which determines the color of the high
C and low labels (except as overridden by the values of ICHI and ICLO).
C
        DATA ICHL / -1 /
C
C ICIL is the parameter 'ILC', which determines the color of the
C informational label.
C
        DATA ICIL / -1 /
C
C ICLL is the parameter array 'LLC', each element of which specifies
C the color index for the line labels at an associated contour level.
C
        DATA ICLL / $NCLV$*-1 /
C
C ICLO is the parameter 'LOC', which determines the color of the low
C labels.
C
        DATA ICLO / -1 /
C
C ICLP is an array used to order the contour levels.
C
C ICLS is the parameter 'CLS', the contour-level selection flag.  A
C negative value "-n" indicates that "n" contour levels should be used,
C splitting the range from the minimum field value to the maximum field
C value into n+1 equal intervals.  A positive value "+n" indicates that
C CONPACKT is to choose the contour levels, in which case, if CINS is
C greater than zero, it is used as the contour interval, but if CINS is
C less than or equal to zero, a contour interval is chosen by CONPACKT
C in such a way as to give approximately "n" contour lines.  The value
C "0" suppresses the selection of contour levels by CONPACK; the user is
C expected to set them.
C
        DATA ICLS / 16 /
C
C ICLU is the parameter array 'CLU', each element of which says what is
C to be done with the associated contour level (except for the last
C two elements, which are used for the edge of the grid and the edge of
C the visible area, respectively).
C
        DATA ICLU / $NCP2$*0 /
C
C ICLV, where used, is the index of the contour level with which
C something is being done.
C
C ICLW is set by CTPKLP and used in CTPLPS; it is the index of the
C pointer, in ICLP, of the current contour level.  ICLP(ICLW-1) is then
C the index of the next smaller contour level and ICLP(ICLW+1) is the
C index of the next larger contour level.
C
C IDUF is the parameter 'DPU', the dash pattern use flag.  The value
C zero says to draw contour lines using no dash patterns, by calling
C CURVE.  A non-zero value says to use dash patterns: a negative value
C says to call DPCURV and a positive value says to call CURVED.  When
C 'DPU' is non-zero, its absolute value is the number of repetitions of
C the dash pattern to use between each occurrence of a label.
C
        DATA IDUF / 3 /
C
C IGCL and IGLB are the parameters 'GIC' and 'GIL', group identifiers
C for contour lines and label boxes, respectively.
C
        DATA IGCL,IGLB / 3,3 /
C
C IGRM and IGRN are the first and second dimensions of a gradient array
C to be computed for use in positioning labels according to the penalty
C scheme (selected by setting ABS('LLP') to 3).  When this scheme is
C used, IGRM*IGRN words are required, in the real workspace array, for
C the gradients.  IGRM and IGRN are computed using the given value of
C LRWG and the known desired aspect ratio of the gradient array.
C
C IGVS is the parameter 'GIS', the group identifier to be used for
C vertical stripping, if that is done.
C
        DATA IGVS / 4 /
C
C IHCF is the parameter 'HCF', which says whether or not hachuring is
C turned on and what type of hachuring is to be done.
C
        DATA IHCF / 0 /
C
C IHLE is the parameter 'HLE', a flag the user can set non-zero to
C enable CONPACKT to search for highs and lows involving more than
C one adjacent equal value in the field.
C
        DATA IHLE / 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 color-index specifier for area fill of label boxes.
C
        DATA ILBC / 0 /
C
C IMPF is the parameter 'MAP', the mapping flag.
C
        DATA IMPF / 0 /
C
C INCX and INCY define the x and y components of the eight possible
C directions the contour-line-following vector can assume.
C
        DATA INCX / -1 , -1 ,  0 ,  1 ,  1 ,  1 ,  0 , -1 /
        DATA INCY /  0 ,  1 ,  1 ,  1 ,  0 , -1 , -1 , -1 /
C
C INHL is used to save the index of the first high/low label in the
C list of labels.
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 INLL is used to save the index of the first contour-line label in the
C list of labels.
C
C IOCF is a flag that is set by the contour-tracing routine CTTRCL to
C indicate whether an open contour is being traced (IOCF=0) or a closed
C contour is being traced (IOCF=1).  This flag is used by the hachuring
C routines to detect a problem caused by the user's not having set the
C parameter 'RWC' big enough.  IOCF is also set by the routine CTTRVE,
C which traces the visible/invisible edge, in a slightly more complex
C way, to provide the routine that puts that edge in the area map with
C the information that it needs.
C
C IOHL is the parameter 'HLO', which specifies what is to be done with
C high/low labels which overlap the informational label or the edge of
C the viewport.
C
        DATA IOHL / 3 /
C
C IOLL is the parameter 'LLO', which specifies how line labels are to
C be oriented.
C
        DATA IOLL / 0 /
C
C IPAI is the parameter 'PAI', which is the index for parameter arrays.
C
        DATA IPAI / 0 /
C
C IPCF is the parameter 'CFP', specifying how the constant-field label
C is to be positioned.
C
        DATA IPCF / 0 /
C
C IPIC is the parameter 'PIC', which indicates the number of points to
C interpolate between each pair of points defining a contour line.
C
        DATA IPIC / 0 /
C
C IPIE is the parameter 'PIE', which indicates the number of points to
C interpolate between each pair of points defining an "edge" line.
C
        DATA IPIE / 0 /
C
C IPIL is the parameter 'ILP', specifying how the informational label
C is to be positioned.
C
        DATA IPIL / 4 /
C
C IPLL is the parameter 'LLP', which says how line labels are to be
C positioned.
C
        DATA IPLL / 1 /
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 CONPACKT is to
C call SET.
C
        DATA ISET / 1 /
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 bit of the blocking flag set.
C
        DATA ITBM / 1 /  !  ITBX = 0, ITBA = 1
C
C IWSO is the parameter 'WSO', which says what to do when workspace
C overflow occurs.
C
        DATA IWSO / 1 /
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 LINS is the parameter 'LIS', which is given the value "n" to specify
C that every nth contour level determined by a user-set value of CINS
C should be labelled; the value zero specifies that no levels are to be
C labelled.  (The contents of the array LINT determine the interval at
C which labels chosen by CONPACKT itself are labelled.)
C
        DATA LINS / 5 /
C
C LINT is the parameter 'LIT', the label interval table.
C
        DATA LINT / 5,5,4,5,5,5*0 /
C
C LINU is the parameter 'LIU', which is the label interval actually
C used.
C
        DATA LINU / 0 /
C
C LIWB is the length of the integer workspace to be made available to
C the routine CTTDBF, which is called to set the blocking flags for
C 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 CTMESH.
C
C LIWM is the parameter 'IWM', which specifies the length of the integer
C workspaces to be used in calls to ARDRLN (for the argument arrays IAI
C and IAG).
C
        DATA LIWM / 10 /
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 CTMESH.
C
C LRWC is the parameter 'RWC', the number of words to be used in the
C real workspace array to hold X coordinates of points defining a piece
C of a contour line.  If line smoothing is turned off, 2*LRWC words
C will be required, LRWC for X coordinates and LRWC for Y coordinates.
C If line smoothing is turned on, 7*LRWC words will be required, 2*LRWC
C for X and Y coordinates and 5*LRWC for various scratch arrays.
C
        DATA LRWC / 1000 /
C
C LRWG is the parameter 'RWG', the number of words to be used in the
C real workspace array for gradients required by the penalty scheme for
C label positioning (which is only used when ABS('LLP') is set to 3).
C
        DATA LRWG / 1000 /
C
C LRWK is the length of the user's real workspace array, as declared in
C the last call to CTMESH.
C
C LRWM is the parameter 'RWM', which specifies the length of the real
C workspaces to be used in calls to ARDRLN (for the argument arrays XCS
C and YCS).
C
        DATA LRWM / 100 /
C
C LRWS is described with IRWS, above.
C
C LSDD is set by CTMESH to indicate the position of the leftmost
C significant digit in ABS(DMAX-DMIN).  This information is needed
C in CTPKLB.
C
C LSDL is used for the leftmost-significant-digit argument of CTNUMB,
C which is based on, but not identical with, the leftmost-significant-
C digit parameter 'NLS'.
C
C LSDM is set by CTMESH to indicate the position of the leftmost
C significant digit in MAX(ABS(DMIN),ABS(DMAX)).  This information
C is needed in CTPKLB.
C
C LTCF is the length of the constant-field label, before substitution.
C
        DATA LTCF / 31 /
C
C LTHI is the length of the label for a high, before substitution.
C
        DATA LTHI / 12 /
C
C LTIL is the length of the informational label, before substitution.
C
        DATA LTIL / 36 /
C
C LTLO is the length of the label for a low, before substitution.
C
        DATA LTLO / 12 /
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 NCLB is an array, each element of which gives the length of the
C label in the associated element of the array CLBL.
C
C NCLV is the parameter 'NCL', which specifies the number of contour
C levels in the array CLEV.
C
        DATA NCLV / 0 /
C
C NDGL is used for the number-of-significant-digits argument of CTNUMB,
C which is based on, but not identical with, the number-of-significant-
C digits parameter 'NSD'.
C
C NEDG is the number of edges in the triangular mesh, as set by CTMESH.
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 NOVS is the parameter 'NVS', which specifies the number of vertical
C strips to be created by edges added to the area map with group
C identifier 'GIS'.
C
        DATA NOVS / 1 /
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 CONPACKT itself.
C
C NTRI is the number of triangles in the triangular mesh, as set by
C CTMESH.
C
C OORV is the parameter 'ORV', an out-of-range value to be returned by
C CTMPXY for both coordinates of a point which is invisible.
C
        DATA OORV / 0. /
C
C PITH is the parameter 'PIT', the "point interpolation threshold".  In
C routines that map polylines using CTMPXY, 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 SEGL is the parameter 'SSL', the desired distance between points used
C to draw the curves generated by contour-line-smoothing, expressed as
C a fraction of the width of the window in the coordinate system in
C which the smoothing is being done.
C
        DATA SEGL / .01 /
C
C T2DS is the parameter 'T2D', which is the contour-line smoothing flag.
C A value of zero specifies that no such smoothing is to be done.  A
C value less than zero specifies that smoothing is to be done prior to
C mapping, a value greater than zero that smoothing is to be done after
C mapping, in both cases using splines under tension.  The absolute
C value of T2DS is the desired tension.
C
        DATA T2DS / 0. /
C
C TXCF is the parameter 'CFT', the text of the constant-field label.
C
        DATA TXCF / 'CONSTANT FIELD - VALUE IS $DVA$' /
C
C TXHI is accessed by the parameter names 'HLT' and 'HIT'; it defines
C the text of the label for a high.
C
        DATA TXHI / 'H:B:$DVA$:E:' /
C
C TXIL is the parameter 'ILT', the text of the informational label.
C
        DATA TXIL / 'CONTOUR FROM $CMN$ TO $CMX$ BY $CIU$' /
C
C TXLO is accessed by the parameter names 'HLT' and 'LOT'; it defines
C the text of the label for a low.
C
        DATA TXLO / 'L:B:$DVA$:E:' /
C
C UCMN and UCMX are the parameters 'CMN' and 'CMX', which may be set to
C force use of the contour levels 'CMN', 'CMN'+'CIS', 'CMN'+2*'CIS', ...
C
        DATA UCMN,UCMX / 1.,0. /
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 CONPACKT 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 WCCF is the parameter 'CFS', which specifies the width of a character
C in the constant-field label, as a fraction of the viewport width.
C
        DATA WCCF / .012 /
C
C WCHL is the parameter 'HLS', which specifies the width of a character
C in the high/low labels, as a fraction of the viewport width.
C
        DATA WCHL / .012 /
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 WCLL is the parameter 'LLS', which specifies the width of a character
C in a contour-line label positioned using the regular scheme or the
C penalty scheme, as a fraction of the viewport width.
C
        DATA WCLL / .010 /
C
C WLCF, WLHL, WLIL, and WLLL are line-width specifiers for the boxes
C around constant-field, high/low, informational, and line labels,
C respectively.
C
        DATA WLCF,WLHL,WLIL,WLLL / 0.,0.,0.,0. /
C
C WOCH and WODA are the parameters 'DPS' and 'DPV'.  WOCH specifies the
C width of a character (other than a dollar sign or an apostrophe) in a
C dash pattern.  WODA specifies the length of the solid line represented
C by a dollar sign or the gap represented by an apostrophe in a dash
C pattern.  Both are given as fractions of the viewport width.
C
        DATA WOCH,WODA / .010,.005 /
C
C WTCD is the parameter 'PW3', used in positioning labels according to
C the penalty scheme.  It is the weight for the "change-in-direction"
C term in the penalty formula.
C
        DATA WTCD / 1. /
C
C WTGR is the parameter 'PW1', used in positioning labels according to
C the penalty scheme.  It is the weight for the "gradient" term in the
C penalty formula.
C
        DATA WTGR / 2. /
C
C WTNC is the parameter 'PW2', used in positioning labels according to
C the penalty scheme.  It is the weight for the "number-of-contours"
C term in the penalty formula.
C
        DATA WTNC / 0. /
C
C WTOD is the parameter 'PW4', used in positioning labels according to
C the penalty scheme.  It is the weight for the optimal-distance term
C in the penalty formula.
C
        DATA WTOD / 1. /
C
C WWCF is the parameter 'CFW', which specifies the width of the white
C space around the constant-field label, as a fraction of the viewport
C width.
C
        DATA WWCF / .005 /
C
C WWHL is the parameter 'HLW', which specifies the width of the white
C space around a high/low label, as a fraction of the viewport width.
C
        DATA WWHL / .005 /
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 WWLL is the parameter 'LLW', which specifies the width of the white
C space around a contour-line label positioned using the regular scheme
C or the penalty scheme, as a fraction of the viewport width.
C
        DATA WWLL / .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 C O N 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 CTBACK (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTBACK - 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 ('CTBACK - 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('CTBACK',3).NE.0) RETURN
C
C Do a simple call to PERIM.
C
        CALL PERIM (1,1,1,1)
        IF (ICFELL('CTBACK',4).NE.0) RETURN
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTCICA (RPNT,IEDG,ITRI,RWRK,IWRK,ICRA,ICA1,ICAM,ICAN,
     +                                            XFCP,YFCP,XFCQ,YFCQ)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*),ICRA(ICA1,*)
C
C This routine adds color indices to a user's cell array.
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 ICRA is the user array in which the cell array is stored.
C
C ICA1 is the first dimension of the FORTRAN array ICRA.
C
C ICAM is the first dimension of the cell array.
C
C ICAN is the second dimension of the cell array.
C
C (XFCP,YFCP) is the point at that corner of the rectangular area
C into which the cell array maps that corresponds to the cell (1,1).
C The coordinates are given in the fractional coordinate system (unlike
C what is required in a call to GCA, in which the coordinates of the
C point P are in the world coordinate system).
C
C (XFCQ,YFCQ) is the point at that corner of the rectangular area into
C which the cell array maps that corresponds to the cell (ICAM,ICAN).
C The coordinates are given in the fractional coordinate system (unlike
C what is required in a call to GCA, in which the coordinates of the
C point Q are in the world coordinate system).
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C
C HERO(A,B,C) is the area of a triangle having sides of length A, B,
C and C (formula of Hero, or Heron), times 4.  (We are using ratios of
C the areas of triangles, so we don't worry about the factor of 4.)
C
        HERO(A,B,C)=SQRT(MAX(0.,(A+B+C)*(B+C-A)*(A+C-B)*(A+B-C)))
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 Check for an uncleared prior error.
C
        IF (ICFELL('CTCICA - 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 ('CTCICA - INITIALIZATION CALL NOT DONE',2,1)
          RETURN
        END IF
C
C Check for errors in the arguments.
C
        IF (ICAM.LE.0.OR.ICAN.LE.0.OR.ICAM.GT.ICA1)
          CALL SETER ('CTCICA - DIMENSIONS OF CELL ARRAY ARE WRONG',3,1)
          RETURN
        END IF
C
        IF (XFCP.LT.0..OR.XFCP.GT.1..OR.
     +      YFCP.LT.0..OR.YFCP.GT.1..OR.
     +      XFCQ.LT.0..OR.XFCQ.GT.1..OR.
     +      YFCQ.LT.0..OR.YFCQ.GT.1.)
          CALL SETER ('CTCICA - CORNER POINTS ARE INCORRECT',4,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('CTCICA',5).NE.0) RETURN
C
C If no contour levels are defined, try to pick a set of levels.
C
        IF (NCLV.LE.0)
          CALL CTPKCL (RPNT,IEDG,ITRI,RWRK,IWRK)
          IF (ICFELL('CTCICA',6).NE.0) RETURN
        END IF
C
C If no levels are defined now, do nothing.
C
        IF (NCLV.LE.0) RETURN
C
C Get indices for the contour levels in ascending order.
C
        CALL CTSORT (CLEV,NCLV,ICLP)
C
C Compute some required tolerance values.
C
        TOL1=.00001*MIN(ABS(XVPR-XVPL),ABS(YVPT-YVPB))
        TOL2=.50000*MIN(ABS(XVPR-XVPL),ABS(YVPT-YVPB))
C
C Extract the values of ITBX and ITBA.
C
        ITBX=IAND(ISHIFT(ITBM,-12),4095)
        ITBA=IAND(       ITBM     ,4095)
C
C Initialize the cell array to contain the off-grid value of IAID.
C
        DO (I=1,ICAM)
          DO (J=1,ICAN)
            ICRA(I,J)=IAIA($NCP1$)
          END DO
        END DO
C
C If mapping is activated and an out-of-range value is defined, check
C for out-of-range cells in the cell array and redefine them to contain
C the out-of-range value of IAID.
C
        IF (IMPF.NE.0.AND.OORV.NE.0.)
C
          DO (I=1,ICAM)
C
            XFCC=XFCP+(REAL(I)-.5)*((XFCQ-XFCP)/REAL(ICAM))
            XUCC=CFUX(XFCC)
            IF (ICFELL('CTCICA',7).NE.0) RETURN
C
            DO (J=1,ICAN)
C
              YFCC=YFCP+(REAL(J)-.5)*((YFCQ-YFCP)/REAL(ICAN))
              YUCC=CFUY(YFCC)
              IF (ICFELL('CTCICA',8).NE.0) RETURN
C
              CALL HLUCTMXYZ (-IMPF,XUCC,YUCC,0.,XTMP,YTMP)
              IF (ICFELL('CTCICA',9).NE.0) RETURN
C
              IF (XTMP.EQ.OORV)
                ICRA(I,J)=IAIA($NCP2$)
              END IF
C
            END DO
C
          END DO
C
        END IF
C
C Examine each triangle of the triangular mesh in turn.
C
        DO 101 IIII=0,NTRI-LOTN,LOTN
C
C Use only unblocked triangles.
C
          IF (ITBF(ITRI(IIII+4)).NE.0) GO TO 101
C
C Find the base index of point 1 (that edges 1 and 2 have in common).
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))
            IPP1=IEDG(ITRI(IIII+1)+1)
          ELSE
            IPP1=IEDG(ITRI(IIII+1)+2)
          END IF
C
C Project point 1; if it's invisible, skip the triangle.
C
          IF (IMPF.EQ.0)
            XCU1=RPNT(IPP1+1)
            YCU1=RPNT(IPP1+2)
          ELSE
            CALL HLUCTMXYZ (IMPF,RPNT(IPP1+1),RPNT(IPP1+2),RPNT(IPP1+3),
     +                                                        XCU1,YCU1)
            IF (ICFELL('CTCICA',10).NE.0) RETURN
            IF ((OORV.NE.0.).AND.(XCU1.EQ.OORV.OR.YCU1.EQ.OORV))
     +                                                         GO TO 101
          END IF
C
C Find the base index of point 2 (that edges 2 and 3 have in common).
C
          IF (IEDG(ITRI(IIII+2)+1).EQ.IEDG(ITRI(IIII+3)+1).OR.
     +        IEDG(ITRI(IIII+2)+1).EQ.IEDG(ITRI(IIII+3)+2))
            IPP2=IEDG(ITRI(IIII+2)+1)
          ELSE
            IPP2=IEDG(ITRI(IIII+2)+2)
          END IF
C
C Project point 2; if it's invisible, skip the triangle.
C
          IF (IMPF.EQ.0)
            XCU2=RPNT(IPP2+1)
            YCU2=RPNT(IPP2+2)
          ELSE
            CALL HLUCTMXYZ (IMPF,RPNT(IPP2+1),RPNT(IPP2+2),RPNT(IPP2+3),
     +                                                        XCU2,YCU2)
            IF (ICFELL('CTCICA',11).NE.0) RETURN
            IF ((OORV.NE.0.).AND.(XCU2.EQ.OORV.OR.YCU2.EQ.OORV))
     +                                                         GO TO 101
          END IF
C
C Find the base index of point 3 (that edges 3 and 1 have in common).
C
          IF (IEDG(ITRI(IIII+3)+1).EQ.IEDG(ITRI(IIII+1)+1).OR.
     +        IEDG(ITRI(IIII+3)+1).EQ.IEDG(ITRI(IIII+1)+2))
            IPP3=IEDG(ITRI(IIII+3)+1)
          ELSE
            IPP3=IEDG(ITRI(IIII+3)+2)
          END IF
C
C Project point 3; if it's invisible, skip the triangle.
C
          IF (IMPF.EQ.0)
            XCU3=RPNT(IPP3+1)
            YCU3=RPNT(IPP3+2)
          ELSE
            CALL HLUCTMXYZ (IMPF,RPNT(IPP3+1),RPNT(IPP3+2),RPNT(IPP3+3),
     +                                                        XCU3,YCU3)
            IF (ICFELL('CTCICA',12).NE.0) RETURN
            IF ((OORV.NE.0.).AND.(XCU3.EQ.OORV.OR.YCU3.EQ.OORV))
     +                                                         GO TO 101
          END IF
C
C Find the fractional coordinates of all three points.
C
          XCF1=CUFX(XCU1)
          IF (ICFELL('CTCICA',13).NE.0) RETURN
          YCF1=CUFY(YCU1)
          IF (ICFELL('CTCICA',14).NE.0) RETURN
C
          XCF2=CUFX(XCU2)
          IF (ICFELL('CTCICA',15).NE.0) RETURN
          YCF2=CUFY(YCU2)
          IF (ICFELL('CTCICA',16).NE.0) RETURN
C
          XCF3=CUFX(XCU3)
          IF (ICFELL('CTCICA',17).NE.0) RETURN
          YCF3=CUFY(YCU3)
          IF (ICFELL('CTCICA',18).NE.0) RETURN
C
C Compute X and Y coordinate differences.
C
          XD12=XCF2-XCF1
          YD12=YCF2-YCF1
          XD23=XCF3-XCF2
          YD23=YCF3-YCF2
          XD31=XCF1-XCF3
          YD31=YCF1-YCF3
C
C If two points of the triangle are too close to each other, skip it.
C
          IF (ABS(XD12).LT.TOL1.AND.ABS(YD12).LT.TOL1) GO TO 101
          IF (ABS(XD23).LT.TOL1.AND.ABS(YD23).LT.TOL1) GO TO 101
          IF (ABS(XD31).LT.TOL1.AND.ABS(YD31).LT.TOL1) GO TO 101
C
C If two points of the triangle are too far apart, skip it.
C
          IF (ABS(XD12).GT.TOL2.OR.ABS(YD12).GT.TOL2) GO TO 101
          IF (ABS(XD23).GT.TOL2.OR.ABS(YD23).GT.TOL2) GO TO 101
          IF (ABS(XD31).GT.TOL2.OR.ABS(YD31).GT.TOL2) GO TO 101
C
C Pick up the field values at the three points.
C
          FVA1=RPNT(IPP1+4)
          FVA2=RPNT(IPP2+4)
          FVA3=RPNT(IPP3+4)
C
C Compute the lengths of the sides of the triangle.
C
          DN12=SQRT(XD12**2+YD12**2)
          DN23=SQRT(XD23**2+YD23**2)
          DN31=SQRT(XD31**2+YD31**2)
C
C Set loop limits so as to examine the center points of all cells of
C the cell array that overlap the bounding box of the triangle.
C
          ITM1=MAX(1,MIN(ICAM,INT((MIN(XCF1,XCF2,XCF3)-XFCP)/
     +                            (XFCQ-XFCP)*REAL(ICAM))+1))
          ITM2=MAX(1,MIN(ICAM,INT((MAX(XCF1,XCF2,XCF3)-XFCP)/
     +                            (XFCQ-XFCP)*REAL(ICAM))+1))
C
          IBEG=MIN(ITM1,ITM2)
          IEND=MAX(ITM1,ITM2)
C
          JTM1=MAX(1,MIN(ICAN,INT((MIN(YCF1,YCF2,YCF3)-YFCP)/
     +                            (YFCQ-YFCP)*REAL(ICAN))+1))
          JTM2=MAX(1,MIN(ICAN,INT((MAX(YCF1,YCF2,YCF3)-YFCP)/
     +                            (YFCQ-YFCP)*REAL(ICAN))+1))
C
          JBEG=MIN(JTM1,JTM2)
          JEND=MAX(JTM1,JTM2)
C
C Find each cell of the cell array whose center point lies within
C the triangle and set its color index appropriately.
C
          DO (I=IBEG,IEND)
            XFCC=XFCP+((REAL(I)-.5)/REAL(ICAM))*(XFCQ-XFCP)
            DO (J=JBEG,JEND)
              YFCC=YFCP+((REAL(J)-.5)/REAL(ICAN))*(YFCQ-YFCP)
              TS12=(YD12*XFCC-XD12*YFCC-YD12*XCF1+XD12*YCF1)/DN12
              TS23=(YD23*XFCC-XD23*YFCC-YD23*XCF2+XD23*YCF2)/DN23
              TS31=(YD31*XFCC-XD31*YFCC-YD31*XCF3+XD31*YCF3)/DN31
              IF ((TS12.LT.+.00001.AND.
     +             TS23.LT.+.00001.AND.
     +             TS31.LT.+.00001     ).OR.
     +            (TS12.GT.-.00001.AND.
     +             TS23.GT.-.00001.AND.
     +             TS31.GT.-.00001     ))
                DNC1=SQRT((XFCC-XCF1)**2+(YFCC-YCF1)**2)
                DNC2=SQRT((XFCC-XCF2)**2+(YFCC-YCF2)**2)
                DNC3=SQRT((XFCC-XCF3)**2+(YFCC-YCF3)**2)
                ATR1=HERO(DN23,DNC2,DNC3)
                ATR2=HERO(DN31,DNC3,DNC1)
                ATR3=HERO(DN12,DNC1,DNC2)
                ATOT=ATR1+ATR2+ATR3
                IF (ATOT.NE.0.)
                  CALL CTGVAI ((ATR1*FVA1+ATR2*FVA2+ATR3*FVA3)/ATOT,
     +                                                    ICRA(I,J))
                END IF
              END IF
            END DO
          END DO
C
  101   CONTINUE
C
C Adjust the values in the cell array per the user-set flag ICAF.
C
        IF (ICAF.GT.0)
          DO (I=1,ICAM)
            DO (J=1,ICAN)
              ICRA(I,J)=ICAF+ICRA(I,J)
            END DO
          END DO
        ELSE IF (ICAF.LT.0)
          DO (I=1,ICAM)
            DO (J=1,ICAN)
              CALL HLUCTSCAE (ICRA,ICA1,ICAM,ICAN,
     +                        XFCP,YFCP,XFCQ,YFCQ,I,J,ICAF,ICRA(I,J))
              IF (ICFELL('CTCICA',19).NE.0) RETURN
            END DO
          END DO
        END IF
C
C Make sure there are no negative values in ICAF.
C
        DO (I=1,ICAM)
          DO (J=1,ICAN)
            IF (ICRA(I,J).LT.0) ICRA(I,J)=0
          END DO
        END DO
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTCLAM (RPNT,IEDG,ITRI,RWRK,IWRK,IAMA)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*),IAMA(*)
C
C This routine adds contour lines to an area map.
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 IAMA is the user's area map.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Declare the common block that holds the clipping-window parameters
C for the routine CTWLAM.
C
        COMMON /CTWCMN/ XWMN,XWMX,YWMN,YWMX
C
C Define a couple of little workspace arrays required by CTTROE.
C
        DIMENSION RWKL(12),RWKR(12)
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTCLAM - 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 ('CTCLAM - 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('CTCLAM',3).NE.0) RETURN
C
C If no contour levels are defined, try to pick a set of levels.
C
        IF (NCLV.LE.0)
          CALL CTPKCL (RPNT,IEDG,ITRI,RWRK,IWRK)
          IF (ICFELL('CTCLAM',4).NE.0) RETURN
        END IF
C
C Get indices for the contour levels in ascending order.
C
        IF (NCLV.GT.0) CALL CTSORT (CLEV,NCLV,ICLP)
C
C Get a little real workspace to use and re-do the call to SET so that
C we can use fractional coordinates.
C
        CALL CTGRWS (RWRK,1,10,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CTCLAM',5).NE.0) RETURN
        CALL SET (XVPL,XVPR,YVPB,YVPT,XVPL,XVPR,YVPB,YVPT,1)
        IF (ICFELL('CTCLAM',6).NE.0) RETURN
C
C Add the viewport perimeter to the area map.  This avoids problems
C which arise when mapping is turned on and the mapping function has
C a discontinuity (as, for example, a cylindrical equidistant EZMAP
C projection does).  This used to be done only when the mapping flag
C was turned on, but now it is done unconditionally, so as to force
C an area identifier of "-1" outside the viewport.  The area identifier
C on the inside of the viewport is set to zero, rather than to a value
C associated with a contour level.  As of 8/24/04, I'm pinching in
C the viewport just slightly.
C
        RWRK(IR01+ 1)=XVPL+.000001
        RWRK(IR01+ 2)=XVPR-.000001
        RWRK(IR01+ 3)=XVPR-.000001
        RWRK(IR01+ 4)=XVPL+.000001
        RWRK(IR01+ 5)=XVPL+.000001
        RWRK(IR01+ 6)=YVPB+.000001
        RWRK(IR01+ 7)=YVPB+.000001
        RWRK(IR01+ 8)=YVPT-.000001
        RWRK(IR01+ 9)=YVPT-.000001
        RWRK(IR01+10)=YVPB+.000001
C
        CALL AREDAM (IAMA,RWRK(IR01+1),RWRK(IR01+6),5,IGCL,0,-1)
        IF (ICFELL('CTCLAM',7).NE.0) RETURN
C
C If it is to be done, put into the area map edges creating a set of
C vertical strips.
C
        IF (NOVS.NE.0)
          CALL AREDAM (IAMA,RWRK(IR01+1),RWRK(IR01+6),5,IGVS,0,-1)
          IF (ICFELL('CTCLAM',8).NE.0) RETURN
          DO (IOVS=1,NOVS-1)
            RWRK(IR01+1)=XVPL+REAL(IOVS)*(XVPR-XVPL)/REAL(NOVS)
            RWRK(IR01+2)=RWRK(IR01+1)
            CALL AREDAM (IAMA,RWRK(IR01+1),RWRK(IR01+9),2,IGVS,0,0)
            IF (ICFELL('CTCLAM',9).NE.0) RETURN
          END DO
        END IF
C
C Discard the real workspace used above and re-call SET.
C
        LR01=0
        CALL SET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
        IF (ICFELL('CTCLAM',10).NE.0) RETURN
C
C Put edges of areas which are invisible into the area map.  This one
C is done first because the area-identifier information on the visible
C side is not as good as that provided by the other edges.  Of course,
C it is only done if the mapping flag is turned on and there is the
C possibility that some points are invisible under the mapping.
C
        IF (IMPF.NE.0.AND.OORV.NE.0.)
C
          XWMN=XVPL
          XWMX=XVPR
          YWMN=YVPB
          YWMX=YVPT
C
          IJMP=0
          IAIC=0
C
          LOOP
            CALL CTTRVE (RPNT,IEDG,ITRI,RWRK,IWRK,IJMP,IRW1,IRW2,NRWK)
            IF (ICFELL('CTCLAM',15).NE.0) RETURN
            EXIT IF (IJMP.EQ.0)
            DO (I=1,NRWK)
              RWRK(IRW1+I)=CUFX(RWRK(IRW1+I))
              IF (ICFELL('CTCLAM',16).NE.0) RETURN
              RWRK(IRW2+I)=CUFY(RWRK(IRW2+I))
              IF (ICFELL('CTCLAM',17).NE.0) RETURN
            END DO
            CALL CTTROE (RWRK(IRW1+1),RWRK(IRW2+1),NRWK,+.0005,RWKL,
     +                             IOCF,IAMA,IGCL,IAIA($NCP2$),IAIC)
            IF (ICFELL('CTCLAM',18).NE.0) RETURN
            CALL CTTROE (RWRK(IRW1+1),RWRK(IRW2+1),NRWK,-.0005,RWKR,
     +                             IOCF,IAMA,IGCL,IAIA($NCP2$),IAIC)
            IF (ICFELL('CTCLAM',19).NE.0) RETURN
          END LOOP
C
        END IF
C
C Add the edge of the grid.
C
        IJMP=0
        IAIC=0
C
        LOOP
          CALL CTTREG (RPNT,IEDG,ITRI,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,
     +                                                         NRWK)
          IF (ICFELL('CTCLAM',20).NE.0) RETURN
          EXIT IF (IJMP.EQ.0)
          IF (MIRO.EQ.0)
            CALL AREDAM (IAMA,RWRK(IRW1+1),RWRK(IRW2+1),NRWK,IGCL,
     +                                                IAIC,IAIA($NCP1$))
            IF (ICFELL('CTCLAM',21).NE.0) RETURN
          ELSE
            CALL AREDAM (IAMA,RWRK(IRW1+1),RWRK(IRW2+1),NRWK,IGCL,
     +                                                IAIA($NCP1$),IAIC)
            IF (ICFELL('CTCLAM',22).NE.0) RETURN
          END IF
        END LOOP
C
C If the constant-field flag is not set, add the selected contour lines
C to the area map.
C
        CLVP=0.
C
        IF (ICFF.EQ.0)
C
          FOR (I = 1 TO NCLV)
C
            ICLV=ICLP(I)
C
            IF (I.EQ.1.OR.CLEV(ICLV).NE.CLVP)
C
              CLVP=CLEV(ICLV)
C
              IF (CLEV(ICLV).GT.DMIN.AND.CLEV(ICLV).LT.DMAX)
C
                JAIA=IAIA(ICLV)
                JAIB=IAIB(ICLV)
C
                DO (J=I+1,NCLV)
                  JCLV=ICLP(J)
                  IF (CLEV(JCLV).NE.CLEV(ICLV)) GO TO 101
                  IF (IAIA(JCLV).NE.0)
                    IF (JAIA.NE.0.AND.JAIA.NE.IAIA(JCLV))
                      CALL SETER ('CTCLAM - CONTRADICTORY AREA-IDENTIFIE
     +R INFORMATION',26,1)
                      RETURN
                    END IF
                    JAIA=IAIA(JCLV)
                  END IF
                  IF (IAIB(JCLV).NE.0)
                    IF (JAIB.NE.0.AND.JAIB.NE.IAIB(JCLV))
                      CALL SETER ('CTCLAM - CONTRADICTORY AREA-IDENTIFIE
     +R INFORMATION',27,1)
                      RETURN
                    END IF
                    JAIB=IAIB(JCLV)
                  END IF
                END DO
C
  101           IF (JAIA.NE.0.OR.JAIB.NE.0)
C
                  IJMP=0
C
                  LOOP
                    CALL CTTRCL (RPNT,IEDG,ITRI,RWRK,IWRK,CLEV(ICLV),
     +                                           IJMP,IRW1,IRW2,NRWK)
                    IF (ICFELL('CTCLAM',28).NE.0) RETURN
                    EXIT IF (IJMP.EQ.0)
                    IF (MIRO.EQ.0)
                      CALL AREDAM (IAMA,RWRK(IRW1+1),RWRK(IRW2+1),NRWK,
     +                                                   IGCL,JAIB,JAIA)
                      IF (ICFELL('CTCLAM',29).NE.0) RETURN
                    ELSE
                      CALL AREDAM (IAMA,RWRK(IRW1+1),RWRK(IRW2+1),NRWK,
     +                                                   IGCL,JAIA,JAIB)
                      IF (ICFELL('CTCLAM',30).NE.0) RETURN
                    END IF
                  END LOOP
C
                END IF
C
              END IF
C
            END IF
C
          END FOR
C
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTCLDM (RPNT,IEDG,ITRI,RWRK,IWRK,IAMA,RTPL)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*),IAMA(*)
C
C This routine draws contour lines masked by an existing area map.
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 IAMA is the user's area map.
C
C RTPL is the routine which is to process segments of the contour line.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Declare the dash-package common block which contains the smoothing
C flag, so that it may be temporarily turned off as needed.
C
        COMMON /SMFLAG/ ISMO
C
C Declare local variables in which to manipulate DASHPACK parameters.
C
        CHARACTER*1 CHRB,CHRG,CHRS
        CHARACTER*16 CDPS
        CHARACTER*256 CHDP
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTCLDM - 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 ('CTCLDM - 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('CTCLDM',3).NE.0) RETURN
C
C If no contour levels are defined, try to pick a set of levels.
C
        IF (NCLV.LE.0)
          CALL CTPKCL (RPNT,IEDG,ITRI,RWRK,IWRK)
          IF (ICFELL('CTCLDM',4).NE.0) RETURN
        END IF
C
C Get indices for the contour levels in ascending order.
C
        IF (NCLV.GT.0) CALL CTSORT (CLEV,NCLV,ICLP)
C
C Get real and integer workspaces to use in the calls to ARDRLN.
C
        CALL CTGRWS (RWRK,2,2*LRWM,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CTCLDM',5).NE.0) RETURN
C
        CALL CTGIWS (IWRK,2,2*LIWM,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CTCLDM',6).NE.0) RETURN
C
C Initialize whichever dash package (if any) is to be used.
C
        IF (IDUF.LT.0)
C
          CALL DPGETC ('CRB',CHRB)
          IF (ICFELL('CTCLDM',7).NE.0) RETURN
          CALL DPGETC ('CRG',CHRG)
          IF (ICFELL('CTCLDM',8).NE.0) RETURN
          CALL DPGETC ('CRS',CHRS)
          IF (ICFELL('CTCLDM',9).NE.0) RETURN
          CALL DPGETI ('DPL',IDPL)
          IF (ICFELL('CTCLDM',10).NE.0) RETURN
          CALL DPGETI ('DPS',IDPS)
          IF (ICFELL('CTCLDM',11).NE.0) RETURN
          CALL DPGETC ('DPT',CHDP)
          IF (ICFELL('CTCLDM',12).NE.0) RETURN
          CALL DPGETR ('TCS',RTCS)
          IF (ICFELL('CTCLDM',13).NE.0) RETURN
          CALL DPGETR ('WOC',RWOC)
          IF (ICFELL('CTCLDM',14).NE.0) RETURN
          CALL DPGETR ('WOG',RWOG)
          IF (ICFELL('CTCLDM',15).NE.0) RETURN
          CALL DPGETR ('WOS',RWOS)
          IF (ICFELL('CTCLDM',16).NE.0) RETURN
C
          CALL DPSETI ('DPS',0)
          IF (ICFELL('CTCLDM',17).NE.0) RETURN
          CDPS=CHRS//CHRS//CHRS//CHRS//CHRS//CHRS//CHRS//CHRS//
     +         CHRS//CHRS//CHRS//CHRS//CHRS//CHRS//CHRS//CHRS
          CALL DPSETC ('DPT',CDPS)
          IF (ICFELL('CTCLDM',18).NE.0) RETURN
          CALL DPSETR ('TCS',-1.)
          IF (ICFELL('CTCLDM',19).NE.0) RETURN
          CALL DPSETR ('WOC',CHWM*WOCH*(XVPR-XVPL))
          IF (ICFELL('CTCLDM',20).NE.0) RETURN
          CALL DPSETR ('WOG',CHWM*WODA*(XVPR-XVPL))
          IF (ICFELL('CTCLDM',21).NE.0) RETURN
          CALL DPSETR ('WOS',CHWM*WODA*(XVPR-XVPL))
          IF (ICFELL('CTCLDM',22).NE.0) RETURN
C
        ELSE IF (IDUF.GT.0)
C
          CALL GETSI (IP2X,IP2Y)
          IF (ICFELL('CTCLDM',23).NE.0) RETURN
          ILDA=MAX(1,INT(CHWM*WODA*(XVPR-XVPL)*(2.**IP2X-1.)+.5))
          ILCH=MAX(4,INT(CHWM*WOCH*(XVPR-XVPL)*(2.**IP2X-1.)+.5))
          CALL DASHDC ('$$$$$$$$$$$$$$$$',ILDA,ILCH)
          IF (ICFELL('CTCLDM',24).NE.0) RETURN
          ISMS=ISMO
          ISMO=1
C
        END IF
C
C If the constant-field flag is set, just output a warning message.
C
.OP     BI=66
        IF (ICFF.NE.0)
C
          CALL CTCFLB (1,RWRK,IWRK)
          IF (ICFELL('CTCLDM',25).NE.0) RETURN
C
C Otherwise, draw contours.
C
        ELSE
C
C If labels are being written by the dash package, make sure the labels
C are completely defined.
C
          IF (ABS(IPLL).EQ.1)
            CALL CTPKLB (RPNT,IEDG,ITRI,RWRK,IWRK)
            IF (ICFELL('CTCLDM',26).NE.0) RETURN
            CALL CTSTLS (RPNT,IEDG,ITRI,RWRK,IWRK)
            IF (ICFELL('CTCLDM',27).NE.0) RETURN
          END IF
C
C Loop through the selected contour levels, drawing contour lines for
C the appropriate ones.
C
          FOR (ICLV = 1 TO NCLV)
C
            IF (CLEV(ICLV).GT.DMIN.AND.CLEV(ICLV).LT.DMAX)
C
C If dash patterns are in use, find the length of the dash pattern at
C this contour level.
C
              IF (IDUF.NE.0)
                INVOKE (FIND-LENGTH-OF-DASH-PATTERN)
              END IF
C
C If only the line is being drawn, the dash-pattern-use flag determines
C whether it will be done using CURVE, DPCURV, or CURVED.
C
              IF (MOD(ICLU(ICLV),4).EQ.1)
C
                IF (IDUF.LT.0)
                  CALL DPSETC ('DPT',CLDP(ICLV)(1:LCLD))
                  IF (ICFELL('CTCLDM',28).NE.0) RETURN
                ELSE IF (IDUF.GT.0)
                  CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
                  IF (ICFELL('CTCLDM',29).NE.0) RETURN
                END IF
C
                INVOKE (CALL-CTTRCL)
C
C If only the labels are being drawn, it can be handled here only if
C the dash-pattern use flag indicates that DPCURV or CURVED is to be
C used and the label-positioning flag implies that the labels are to
C be incorporated into the dash pattern.
C
              ELSE IF (MOD(ICLU(ICLV),4).EQ.2)
C
                IF (ABS(IPLL).EQ.1.AND.IDUF.NE.0)
                  NCHL=NCLB(ICLV)
                  NCHD=MAX(1,MIN(ABS(IDUF)*LCLD,$LOCV$-NCHL))
                  CTMA=' '
                  IF (IDUF.LT.0)
                    DO (ICHD=1,NCHD)
                      CTMA(ICHD:ICHD)=CHRG
                    END DO
                    LCTM=NCHD+NCHL
                    CTMA(NCHD+1:LCTM)=CLBL(ICLV)(1:NCHL)
                    CALL DPSETC ('DPT',CTMA(1:LCTM))
                    IF (ICFELL('CTCLDM',30).NE.0) RETURN
                  ELSE IF (IDUF.GT.0)
                    DO (ICHD=1,NCHD)
                      CTMA(ICHD:ICHD)=''''
                    END DO
                    LCTM=NCHD+NCHL
                    CTMA(NCHD+1:LCTM)=CLBL(ICLV)(1:NCHL)
                    CALL DASHDC (CTMA(1:LCTM),ILDA,ILCH)
                    IF (ICFELL('CTCLDM',31).NE.0) RETURN
                  END IF
                  INVOKE (CALL-CTTRCL)
                END IF
C
C If both lines and labels are being drawn, there are various cases,
C depending on whether dashed lines are being used and how labels are
C being positioned.
C
              ELSE IF (MOD(ICLU(ICLV),4).EQ.3)
C
                IF (IDUF.NE.0)
                  IF (ABS(IPLL).EQ.1)
                    NCHL=NCLB(ICLV)
                    NCHD=MAX(1,MIN(ABS(IDUF)*LCLD,$LOCV$-NCHL))
                    CTMA=' '
                    DO (ICHD=1,NCHD)
                      JCHD=MOD(ICHD-1,LCLD)+1
                      CTMA(ICHD:ICHD)=CLDP(ICLV)(JCHD:JCHD)
                    END DO
                    IF (IDUF.LT.0)
                      LCTM=NCHD+NCHL
                      CTMA(NCHD+1:LCTM)=CLBL(ICLV)(1:NCHL)
                      CALL DPSETC ('DPT',CTMA(1:LCTM))
                      IF (ICFELL('CTCLDM',32).NE.0) RETURN
                    ELSE
                      LCTM=NCHD+NCHL
                      CTMA(NCHD+1:LCTM)=CLBL(ICLV)(1:NCHL)
                      CALL DASHDC (CTMA(1:LCTM),ILDA,ILCH)
                      IF (ICFELL('CTCLDM',33).NE.0) RETURN
                    END IF
                  ELSE
                    IF (IDUF.LT.0)
                      CALL DPSETC ('DPT',CLDP(ICLV)(1:LCLD))
                      IF (ICFELL('CTCLDM',34).NE.0) RETURN
                    ELSE
                      CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
                      IF (ICFELL('CTCLDM',35).NE.0) RETURN
                    END IF
                  END IF
                END IF
C
                INVOKE (CALL-CTTRCL)
C
              END IF
C
            END IF
C
          END FOR
C
        END IF
C
C Draw boundaries for areas which are invisible.
C
        IF (ICLU($NCP2$).NE.0.AND.IMPF.NE.0.AND.OORV.NE.0.)
          ICLV=$NCP2$
          IF (IDUF.NE.0)
            INVOKE (FIND-LENGTH-OF-DASH-PATTERN)
            IF (IDUF.LT.0)
              CALL DPSETC ('DPT',CLDP(ICLV)(1:LCLD))
              IF (ICFELL('CTCLDM',41).NE.0) RETURN
            ELSE
              CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
              IF (ICFELL('CTCLDM',42).NE.0) RETURN
            END IF
          END IF
          INVOKE (SET-LINE-COLOR-AND-WIDTH)
          IJMP=0
          LOOP
            CALL CTTRVE (RPNT,IEDG,ITRI,RWRK,IWRK,IJMP,IRW1,IRW2,NRWK)
            IF (ICFELL('CTCLDM',44).NE.0) RETURN
            EXIT IF (IJMP.EQ.0)
            CALL ARDRLN (IAMA,RWRK(IRW1+1),RWRK(IRW2+1),NRWK,
     +                   RWRK(IR02+1),RWRK(IR02+1+LRWM),LRWM,
     +                   IWRK(II02+1),IWRK(II02+1+LIWM),LIWM,RTPL)
            IF (ICFELL('CTCLDM',45).NE.0) RETURN
          END LOOP
          INVOKE (RESET-LINE-COLOR-AND-WIDTH)
        END IF
C
C Draw the edge of the grid.
C
        IF (ICLU($NCP1$).NE.0)
          ICLV=$NCP1$
          IF (IDUF.NE.0)
            INVOKE (FIND-LENGTH-OF-DASH-PATTERN)
            IF (IDUF.LT.0)
              CALL DPSETC ('DPT',CLDP(ICLV)(1:LCLD))
              IF (ICFELL('CTCLDM',46).NE.0) RETURN
            ELSE
              CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
              IF (ICFELL('CTCLDM',47).NE.0) RETURN
            END IF
          END IF
          INVOKE (SET-LINE-COLOR-AND-WIDTH)
          IJMP=0
          IAIC=-9
          LOOP
            CALL CTTREG (RPNT,IEDG,ITRI,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,
     +                                                           NRWK)
            IF (ICFELL('CTCLDM',48).NE.0) RETURN
            EXIT IF (IJMP.EQ.0)
            CALL ARDRLN (IAMA,RWRK(IRW1+1),RWRK(IRW2+1),NRWK,
     +                   RWRK(IR02+1),RWRK(IR02+1+LRWM),LRWM,
     +                   IWRK(II02+1),IWRK(II02+1+LIWM),LIWM,RTPL)
            IF (ICFELL('CTCLDM',49).NE.0) RETURN
          END LOOP
          INVOKE (RESET-LINE-COLOR-AND-WIDTH)
        END IF
.OP     BI=77
C
C Restore the state of the dash package (if any) that was used.
C
        IF (IDUF.LT.0)
C
          CALL DPSETI ('DPS',IDPS)
          IF (ICFELL('CTCLDM',50).NE.0) RETURN
          CALL DPSETC ('DPT',CHDP(1:IDPL))
          IF (ICFELL('CTCLDM',51).NE.0) RETURN
          CALL DPSETR ('TCS',RTCS)
          IF (ICFELL('CTCLDM',52).NE.0) RETURN
          CALL DPSETR ('WOC',RWOC)
          IF (ICFELL('CTCLDM',53).NE.0) RETURN
          CALL DPSETR ('WOG',RWOG)
          IF (ICFELL('CTCLDM',54).NE.0) RETURN
          CALL DPSETR ('WOS',RWOS)
          IF (ICFELL('CTCLDM',55).NE.0) RETURN
C
        ELSE IF (IDUF.GT.0)
C
          CALL DASHDC ('$$$$$$$$$$$$$$$$',ILDA,ILCH)
          IF (ICFELL('CTCLDM',56).NE.0) RETURN
          ISMO=ISMS
C
        END IF
C
C Release the workspaces used in the calls to ARDRLN.
C
        LR02=0
        LI02=0
C
C Done.
C
        RETURN
C
C The following internal procedure finds the length of a dash pattern.
C
        BLOCK (FIND-LENGTH-OF-DASH-PATTERN)
          LCLD=1
          DO (I=1,128)
            IF (CLDP(ICLV)(I:I).NE.' ') LCLD=I
          END DO
        END BLOCK
C
C The following internal procedure calls CTTRCL to draw the contour
C line at a given level.  The user-change routine is called before
C and after the calls to CTTRCL.
C
        BLOCK (CALL-CTTRCL)
          INVOKE (SET-LINE-COLOR-AND-WIDTH)
          IJMP=0
          LOOP
            CALL CTTRCL (RPNT,IEDG,ITRI,RWRK,IWRK,CLEV(ICLV),IJMP,IRW1,
     +                                                       IRW2,NRWK)
            IF (ICFELL('CTCLDM',57).NE.0) RETURN
            EXIT IF (IJMP.EQ.0)
            CALL ARDRLN (IAMA,RWRK(IRW1+1),RWRK(IRW2+1),NRWK,
     +                   RWRK(IR02+1),RWRK(IR02+1+LRWM),LRWM,
     +                   IWRK(II02+1),IWRK(II02+1+LIWM),LIWM,RTPL)
            IF (ICFELL('CTCLDM',58).NE.0) RETURN
            IF (IHCF.NE.0)
              CALL CTHCHM (RWRK,IRW1,IRW2,NRWK,IAMA,IWRK,RTPL)
              IF (ICFELL('CTCLDM',59).NE.0) RETURN
            END IF
          END LOOP
          INVOKE (RESET-LINE-COLOR-AND-WIDTH)
        END BLOCK
C
C The following internal procedures set and reset line color and width
C before and after a particular line is drawn.
C
        BLOCK (SET-LINE-COLOR-AND-WIDTH)
          CALL PLOTIF (0.,0.,2)
          IF (ICFELL('CTCLDM',60).NE.0) RETURN
          JCCL=ICCL(ICLV)
          IF (JCCL.GE.0)
            CALL GQPLCI (IGER,ISLC)
            IF (IGER.NE.0)
              CALL SETER ('CTCLDM - ERROR EXIT FROM GQPLCI',61,1)
              RETURN
            END IF
            CALL GQTXCI (IGER,ISTC)
            IF (IGER.NE.0)
              CALL SETER ('CTCLDM - ERROR EXIT FROM GQTXCI',62,1)
              RETURN
            END IF
            CALL GSPLCI (JCCL)
            CALL GSTXCI (JCCL)
          END IF
          CLWS=CLWA(ICLV)
          IF (CLWS.GT.0.)
            CALL GQLWSC (IGER,SFLW)
            IF (IGER.NE.0)
              CALL SETER ('CTCLDM - ERROR EXIT FROM GQLWSC',63,1)
              RETURN
            END IF
            CALL GSLWSC (CLWS)
          END IF
          IPAI=ICLV
          IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
          CALL HLUCTCHCL (+1)
          IF (ICFELL('CTCLDM',64).NE.0) RETURN
        END BLOCK
C
        BLOCK (RESET-LINE-COLOR-AND-WIDTH)
          CALL PLOTIF (0.,0.,2)
          IF (ICFELL('CTCLDM',65).NE.0) RETURN
          IPAI=ICLV
          IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
          CALL HLUCTCHCL (-1)
          IF (ICFELL('CTCLDM',66).NE.0) RETURN
          IF (JCCL.GE.0)
            CALL GSPLCI (ISLC)
            CALL GSTXCI (ISTC)
          END IF
          IF (CLWS.GT.0.)
            CALL GSLWSC (SFLW)
          END IF
        END BLOCK
C
      END


      SUBROUTINE CTCLDR (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C This routine draws contour lines.
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
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Declare the dash-package common block which contains the smoothing
C flag, so that it may be temporarily turned off as needed.
C
        COMMON /SMFLAG/ ISMO
C
C Declare local variables in which to manipulate DASHPACK parameters.
C
        CHARACTER*1 CHRB,CHRG,CHRS
        CHARACTER*16 CDPS
        CHARACTER*256 CHDP
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTCLDR - 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 ('CTCLDR - 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('CTCLDR',3).NE.0) RETURN
C
C If no contour levels are defined, try to pick a set of levels.
C
        IF (NCLV.LE.0)
          CALL CTPKCL (RPNT,IEDG,ITRI,RWRK,IWRK)
          IF (ICFELL('CTCLDR',4).NE.0) RETURN
        END IF
C
C Get indices for the contour levels in ascending order.
C
        IF (NCLV.GT.0) CALL CTSORT (CLEV,NCLV,ICLP)
C
C Initialize whichever dash package (if any) is to be used.
C
        IF (IDUF.LT.0)
C
          CALL DPGETC ('CRB',CHRB)
          IF (ICFELL('CTCLDR',5).NE.0) RETURN
          CALL DPGETC ('CRG',CHRG)
          IF (ICFELL('CTCLDR',6).NE.0) RETURN
          CALL DPGETC ('CRS',CHRS)
          IF (ICFELL('CTCLDR',7).NE.0) RETURN
          CALL DPGETI ('DPL',IDPL)
          IF (ICFELL('CTCLDR',8).NE.0) RETURN
          CALL DPGETI ('DPS',IDPS)
          IF (ICFELL('CTCLDR',9).NE.0) RETURN
          CALL DPGETC ('DPT',CHDP)
          IF (ICFELL('CTCLDR',10).NE.0) RETURN
          CALL DPGETR ('TCS',RTCS)
          IF (ICFELL('CTCLDR',11).NE.0) RETURN
          CALL DPGETR ('WOC',RWOC)
          IF (ICFELL('CTCLDR',12).NE.0) RETURN
          CALL DPGETR ('WOG',RWOG)
          IF (ICFELL('CTCLDR',13).NE.0) RETURN
          CALL DPGETR ('WOS',RWOS)
          IF (ICFELL('CTCLDR',14).NE.0) RETURN
C
          CALL DPSETI ('DPS',0)
          IF (ICFELL('CTCLDR',15).NE.0) RETURN
          CDPS=CHRS//CHRS//CHRS//CHRS//CHRS//CHRS//CHRS//CHRS//
     +         CHRS//CHRS//CHRS//CHRS//CHRS//CHRS//CHRS//CHRS
          CALL DPSETC ('DPT',CDPS)
          IF (ICFELL('CTCLDR',16).NE.0) RETURN
          CALL DPSETR ('TCS',-1.)
          IF (ICFELL('CTCLDR',17).NE.0) RETURN
          CALL DPSETR ('WOC',CHWM*WOCH*(XVPR-XVPL))
          IF (ICFELL('CTCLDR',18).NE.0) RETURN
          CALL DPSETR ('WOG',CHWM*WODA*(XVPR-XVPL))
          IF (ICFELL('CTCLDR',19).NE.0) RETURN
          CALL DPSETR ('WOS',CHWM*WODA*(XVPR-XVPL))
          IF (ICFELL('CTCLDR',20).NE.0) RETURN
C
        ELSE IF (IDUF.GT.0)
C
          CALL GETSI (IP2X,IP2Y)
          IF (ICFELL('CTCLDR',21).NE.0) RETURN
          ILDA=MAX(1,INT(CHWM*WODA*(XVPR-XVPL)*(2.**IP2X-1.)+.5))
          ILCH=MAX(4,INT(CHWM*WOCH*(XVPR-XVPL)*(2.**IP2X-1.)+.5))
          CALL DASHDC ('$$$$$$$$$$$$$$$$',ILDA,ILCH)
          IF (ICFELL('CTCLDR',22).NE.0) RETURN
          ISMS=ISMO
          ISMO=1
C
        END IF
C
C If the constant-field flag is set, just output a warning message.
C
.OP     BI=66
        IF (ICFF.NE.0)
C
          CALL CTCFLB (1,RWRK,IWRK)
          IF (ICFELL('CTCLDR',23).NE.0) RETURN
C
C Otherwise, draw contours.
C
        ELSE
C
C If labels are being written by the dash package, make sure the labels
C are completely defined.
C
          IF (ABS(IPLL).EQ.1)
            CALL CTPKLB (RPNT,IEDG,ITRI,RWRK,IWRK)
            IF (ICFELL('CTCLDR',24).NE.0) RETURN
            CALL CTSTLS (RPNT,IEDG,ITRI,RWRK,IWRK)
            IF (ICFELL('CTCLDR',25).NE.0) RETURN
          END IF
C
C Loop through the selected contour levels, drawing contour lines for
C the appropriate ones.
C
          FOR (ICLV = 1 TO NCLV)
C
            IF (CLEV(ICLV).GT.DMIN.AND.CLEV(ICLV).LT.DMAX)
C
C If dash patterns are in use, find the length of the dash pattern at
C this contour level.
C
              IF (IDUF.NE.0)
                INVOKE (FIND-LENGTH-OF-DASH-PATTERN)
              END IF
C
C If only the line is being drawn, the dash-pattern-use flag determines
C whether it will be done using CURVE, DPCURV, or CURVED.
C
              IF (MOD(ICLU(ICLV),4).EQ.1)
C
                IF (IDUF.LT.0)
                  CALL DPSETC ('DPT',CLDP(ICLV)(1:LCLD))
                  IF (ICFELL('CTCLDR',26).NE.0) RETURN
                ELSE IF (IDUF.GT.0)
                  CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
                  IF (ICFELL('CTCLDR',27).NE.0) RETURN
                END IF
C
                INVOKE (CALL-CTTRCL)
C
C If only the labels are being drawn, it can be handled here only if
C the dash-pattern use flag indicates that DPCURV or CURVED is to be
C used and the label-positioning flag implies that the labels are to
C be incorporated into the dash pattern.
C
              ELSE IF (MOD(ICLU(ICLV),4).EQ.2)
C
                IF (ABS(IPLL).EQ.1.AND.IDUF.NE.0)
                  NCHL=NCLB(ICLV)
                  NCHD=MAX(1,MIN(ABS(IDUF)*LCLD,$LOCV$-NCHL))
                  CTMA=' '
                  IF (IDUF.LT.0)
                    DO (ICHD=1,NCHD)
                      CTMA(ICHD:ICHD)=CHRG
                    END DO
                    LCTM=NCHD+NCHL
                    CTMA(NCHD+1:LCTM)=CLBL(ICLV)(1:NCHL)
                    CALL DPSETC ('DPT',CTMA(1:LCTM))
                    IF (ICFELL('CTCLDR',28).NE.0) RETURN
                  ELSE IF (IDUF.GT.0)
                    DO (ICHD=1,NCHD)
                      CTMA(ICHD:ICHD)=''''
                    END DO
                    LCTM=NCHD+NCHL
                    CTMA(NCHD+1:LCTM)=CLBL(ICLV)(1:NCHL)
                    CALL DASHDC (CTMA(1:LCTM),ILDA,ILCH)
                    IF (ICFELL('CTCLDR',29).NE.0) RETURN
                  END IF
                  INVOKE (CALL-CTTRCL)
                END IF
C
C If both lines and labels are being drawn, there are various cases,
C depending on whether dashed lines are being used and how labels are
C being positioned.
C
              ELSE IF (MOD(ICLU(ICLV),4).EQ.3)
C
                IF (IDUF.NE.0)
                  IF (ABS(IPLL).EQ.1)
                    NCHL=NCLB(ICLV)
                    NCHD=MAX(1,MIN(ABS(IDUF)*LCLD,$LOCV$-NCHL))
                    CTMA=' '
                    DO (ICHD=1,NCHD)
                      JCHD=MOD(ICHD-1,LCLD)+1
                      CTMA(ICHD:ICHD)=CLDP(ICLV)(JCHD:JCHD)
                    END DO
                    IF (IDUF.LT.0)
                      LCTM=NCHD+NCHL
                      CTMA(NCHD+1:LCTM)=CLBL(ICLV)(1:NCHL)
                      CALL DPSETC ('DPT',CTMA(1:LCTM))
                      IF (ICFELL('CTCLDR',30).NE.0) RETURN
                    ELSE
                      LCTM=NCHD+NCHL
                      CTMA(NCHD+1:LCTM)=CLBL(ICLV)(1:NCHL)
                      CALL DASHDC (CTMA(1:LCTM),ILDA,ILCH)
                      IF (ICFELL('CTCLDR',31).NE.0) RETURN
                    END IF
                  ELSE
                    IF (IDUF.LT.0)
                      CALL DPSETC ('DPT',CLDP(ICLV)(1:LCLD))
                      IF (ICFELL('CTCLDR',32).NE.0) RETURN
                    ELSE
                      CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
                      IF (ICFELL('CTCLDR',33).NE.0) RETURN
                    END IF
                  END IF
                END IF
C
                INVOKE (CALL-CTTRCL)
C
              END IF
C
            END IF
C
          END FOR
C
        END IF
C
C Draw boundaries for areas that are invisible.
C
        IF (ICLU($NCP2$).NE.0.AND.IMPF.NE.0.AND.OORV.NE.0.)
          ICLV=$NCP2$
          IF (IDUF.NE.0)
            INVOKE (FIND-LENGTH-OF-DASH-PATTERN)
            IF (IDUF.LT.0)
              CALL DPSETC ('DPT',CLDP(ICLV)(1:LCLD))
              IF (ICFELL('CTCLDR',39).NE.0) RETURN
            ELSE
              CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
              IF (ICFELL('CTCLDR',40).NE.0) RETURN
            END IF
          END IF
          INVOKE (SET-LINE-COLOR-AND-WIDTH)
          IJMP=0
          LOOP
            CALL CTTRVE (RPNT,IEDG,ITRI,RWRK,IWRK,IJMP,IRW1,IRW2,NRWK)
            IF (ICFELL('CTCLDR',42).NE.0) RETURN
            EXIT IF (IJMP.EQ.0)
            CALL CTDRSG (RWRK,IRW1,IRW2,NRWK)
            IF (ICFELL('CTCLDR',43).NE.0) RETURN
          END LOOP
          INVOKE (RESET-LINE-COLOR-AND-WIDTH)
        END IF
C
C Draw the edge of the grid.
C
        IF (ICLU($NCP1$).NE.0)
          ICLV=$NCP1$
          IF (IDUF.NE.0)
            INVOKE (FIND-LENGTH-OF-DASH-PATTERN)
            IF (IDUF.LT.0)
              CALL DPSETC ('DPT',CLDP(ICLV)(1:LCLD))
              IF (ICFELL('CTCLDR',44).NE.0) RETURN
            ELSE
              CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
              IF (ICFELL('CTCLDR',45).NE.0) RETURN
            END IF
          END IF
          INVOKE (SET-LINE-COLOR-AND-WIDTH)
          IJMP=0
          IAIC=-9
          LOOP
            CALL CTTREG (RPNT,IEDG,ITRI,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,
     +                                                           NRWK)
            IF (ICFELL('CTCLDR',46).NE.0) RETURN
            EXIT IF (IJMP.EQ.0)
            CALL CTDRSG (RWRK,IRW1,IRW2,NRWK)
            IF (ICFELL('CTCLDR',47).NE.0) RETURN
          END LOOP
          INVOKE (RESET-LINE-COLOR-AND-WIDTH)
        END IF
.OP     BI=77
C
C Restore the state of the dash package (if any) that was used.
C
        IF (IDUF.LT.0)
C
          CALL DPSETI ('DPS',IDPS)
          IF (ICFELL('CTCLDR',48).NE.0) RETURN
          CALL DPSETC ('DPT',CHDP(1:IDPL))
          IF (ICFELL('CTCLDR',49).NE.0) RETURN
          CALL DPSETR ('TCS',RTCS)
          IF (ICFELL('CTCLDR',50).NE.0) RETURN
          CALL DPSETR ('WOC',RWOC)
          IF (ICFELL('CTCLDR',51).NE.0) RETURN
          CALL DPSETR ('WOG',RWOG)
          IF (ICFELL('CTCLDR',52).NE.0) RETURN
          CALL DPSETR ('WOS',RWOS)
          IF (ICFELL('CTCLDR',53).NE.0) RETURN
C
        ELSE IF (IDUF.GT.0)
C
          CALL DASHDC ('$$$$$$$$$$$$$$$$',ILDA,ILCH)
          IF (ICFELL('CTCLDR',54).NE.0) RETURN
          ISMO=ISMS
C
        END IF
C
C Done.
C
        RETURN
C
C The following internal procedure finds the length of a dash pattern.
C
        BLOCK (FIND-LENGTH-OF-DASH-PATTERN)
          LCLD=1
          DO (I=1,128)
            IF (CLDP(ICLV)(I:I).NE.' ') LCLD=I
          END DO
        END BLOCK
C
C The following internal procedure calls CTTRCL to draw the contour
C line at a given level.  The user-change routine is called before
C and after the calls to CTTRCL.
C
        BLOCK (CALL-CTTRCL)
          INVOKE (SET-LINE-COLOR-AND-WIDTH)
          IJMP=0
          LOOP
            CALL CTTRCL (RPNT,IEDG,ITRI,RWRK,IWRK,CLEV(ICLV),IJMP,IRW1,
     +                                                       IRW2,NRWK)
            IF (ICFELL('CTCLDR',55).NE.0) RETURN
            EXIT IF (IJMP.EQ.0)
            CALL CTDRSG (RWRK,IRW1,IRW2,NRWK)
            IF (ICFELL('CTCLDR',56).NE.0) RETURN
            IF (IHCF.NE.0)
              CALL CTHCHR (RWRK,IRW1,IRW2,NRWK)
              IF (ICFELL('CTCLDR',57).NE.0) RETURN
            END IF
          END LOOP
          INVOKE (RESET-LINE-COLOR-AND-WIDTH)
        END BLOCK
C
C The following internal procedures set and reset line color and width
C before and after a particular line is drawn.
C
        BLOCK (SET-LINE-COLOR-AND-WIDTH)
          CALL PLOTIF (0.,0.,2)
          IF (ICFELL('CTCLDR',58).NE.0) RETURN
          JCCL=ICCL(ICLV)
          IF (JCCL.GE.0)
            CALL GQPLCI (IGER,ISLC)
            IF (IGER.NE.0)
              CALL SETER ('CTCLDR - ERROR EXIT FROM GQPLCI',59,1)
              RETURN
            END IF
            CALL GQTXCI (IGER,ISTC)
            IF (IGER.NE.0)
              CALL SETER ('CTCLDR - ERROR EXIT FROM GQTXCI',60,1)
              RETURN
            END IF
            CALL GSPLCI (JCCL)
            CALL GSTXCI (JCCL)
          END IF
          CLWS=CLWA(ICLV)
          IF (CLWS.GT.0.)
            CALL GQLWSC (IGER,SFLW)
            IF (IGER.NE.0)
              CALL SETER ('CTCLDR - ERROR EXIT FROM GQLWSC',61,1)
              RETURN
            END IF
            CALL GSLWSC (CLWS)
          END IF
          IPAI=ICLV
          IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
          CALL HLUCTCHCL (+1)
          IF (ICFELL('CTCLDR',62).NE.0) RETURN
        END BLOCK
C
        BLOCK (RESET-LINE-COLOR-AND-WIDTH)
          CALL PLOTIF (0.,0.,2)
          IF (ICFELL('CTCLDR',63).NE.0) RETURN
          IPAI=ICLV
          IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
          CALL HLUCTCHCL (-1)
          IF (ICFELL('CTCLDR',64).NE.0) RETURN
          IF (JCCL.GE.0)
            CALL GSPLCI (ISLC)
            CALL GSTXCI (ISTC)
          END IF
          IF (CLWS.GT.0.)
            CALL GSLWSC (SFLW)
          END IF
        END BLOCK
C
      END


      SUBROUTINE CTCLTR (RPNT,IEDG,ITRI,RWRK,IWRK,CLVL,IJMP,IRW1,IRW2,
     +                                                           NRWK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C This routine just provides a user interface to the internal routine
C CTTRCL, which traces the contour lines at a specified level.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTCLTR - 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 ('CTCLTR - INITIALIZATION CALL NOT DONE',2,1)
          IJMP=0
          RETURN
        END IF
C
C Do the proper SET call.
C
        CALL SET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
        IF (ICFELL('CTCLTR',3).NE.0) RETURN
C
C If the constant-field flag is set, do nothing.
C
        IF (ICFF.NE.0) RETURN
C
C Call the internal routine.
C
        CALL CTTRCL (RPNT,IEDG,ITRI,RWRK,IWRK,CLVL,IJMP,IRW1,IRW2,NRWK)
        IF (ICFELL('CTCLTR',4).NE.0) RETURN
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTDRPL (XCS,YCS,NCS,IAI,IAG,NAI)
C
        DIMENSION XCS(*),YCS(*),IAI(*),IAG(*)
C
C This version of CTDRPL 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 either
C CURVE or CURVED to do the drawing, depending on the value of the
C internal parameter 'DPU'.
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$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)
          IF (IDUF.EQ.0)
            CALL CURVE  (XCS,YCS,NCS)
            IF (ICFELL('CTDRPL',1).NE.0) RETURN
          ELSE IF (IDUF.LT.0)
            CALL DPCURV (XCS,YCS,NCS)
            IF (ICFELL('CTDRPL',2).NE.0) RETURN
          ELSE
            CALL CURVED (XCS,YCS,NCS)
            IF (ICFELL('CTDRPL',3).NE.0) RETURN
          END IF
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTGETC (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 CTGETC.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTGETC - 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)='CTGETC - 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.'CLD'.OR.WHCH(1:3).EQ.'cld')
          IF (IPAI.GE.1.AND.IPAI.LE.NCLV)
            JPAI=IPAI
          ELSE IF (IPAI.LE.-1.AND.IPAI.GE.-3)
            JPAI=$NCLV$+ABS(IPAI)
          ELSE
            INVOKE (PAI-INCORRECT,NR)
          END IF
        ELSE IF (WHCH(1:3).EQ.'LLT'.OR.WHCH(1:3).EQ.'llt')
          IF (IPAI.LT.1.OR.IPAI.GT.NCLV)
            INVOKE (PAI-INCORRECT,NR)
          END IF
        END IF
C
        BLOCK (PAI-INCORRECT,NR)
          CTMB(1:36)='CTGETC - 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.'CFT'.OR.WHCH(1:3).EQ.'cft')
          CVAL=TXCF(1:LTCF)
        ELSE IF (WHCH(1:3).EQ.'CLD'.OR.WHCH(1:3).EQ.'cld')
          CVAL=CLDP(JPAI)
        ELSE 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 CTSBST ('$DVA$',CVAL,LCVL)
        ELSE IF (WHCH(1:3).EQ.'DVU'.OR.WHCH(1:3).EQ.'dvu')
          CALL CTSBST ('$DVAU$',CVAL,LCVL)
        ELSE IF (WHCH(1:3).EQ.'HIT'.OR.WHCH(1:3).EQ.'hit')
          CVAL=TXHI(1:LTHI)
        ELSE IF (WHCH(1:3).EQ.'HLT'.OR.WHCH(1:3).EQ.'hlt')
          IF (TXHI(1:LTHI).EQ.TXLO(1:LTLO))
            CVAL=TXHI
          ELSE
            CVAL=TXHI(1:LTHI)//''''//TXLO(1:LTLO)
          END IF
        ELSE IF (WHCH(1:3).EQ.'ILT'.OR.WHCH(1:3).EQ.'ilt')
          CVAL=TXIL(1:LTIL)
        ELSE IF (WHCH(1:3).EQ.'LLT'.OR.WHCH(1:3).EQ.'llt')
          CVAL=CLBL(IPAI)
        ELSE IF (WHCH(1:3).EQ.'LOT'.OR.WHCH(1:3).EQ.'lot')
          CVAL=TXLO(1:LTLO)
        ELSE
          CTMB(1:36)='CTGETC - 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 CTGETI (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 CTGETI.
C
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTGETI - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Use CTGETR to retrieve the real value, fix it, and return it to the
C user.
C
        CALL CTGETR (WHCH,RVAL)
        IF (ICFELL('CTGETI',2).NE.0) RETURN
        IVAL=INT(RVAL)
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTGETR (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 CTGETR.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTGETR - 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)='CTGETR - 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.'AIA'.OR.WHCH(1:3).EQ.'aia'.OR.
     +      WHCH(1:3).EQ.'CLC'.OR.WHCH(1:3).EQ.'clc'.OR.
     +      WHCH(1:3).EQ.'CLL'.OR.WHCH(1:3).EQ.'cll'.OR.
     +      WHCH(1:3).EQ.'CLU'.OR.WHCH(1:3).EQ.'clu')
          IF (IPAI.GE.1.AND.IPAI.LE.NCLV)
            JPAI=IPAI
          ELSE IF (IPAI.LE.-1.AND.IPAI.GE.-3)
            JPAI=$NCLV$+ABS(IPAI)
          ELSE
            INVOKE (PAI-INCORRECT,NR)
          END IF
        ELSE IF ((WHCH(1:3).EQ.'AIB'.OR.WHCH(1:3).EQ.'aib'.OR.
     +            WHCH(1:3).EQ.'CLV'.OR.WHCH(1:3).EQ.'clv'.OR.
     +            WHCH(1:3).EQ.'LLC'.OR.WHCH(1:3).EQ.'llc').AND.
     +           (IPAI.LT.1.OR.IPAI.GT.NCLV))
          INVOKE (PAI-INCORRECT,NR)
        ELSE IF ((WHCH(1:3).EQ.'CIT'.OR.WHCH(1:3).EQ.'cit'.OR.
     +            WHCH(1:3).EQ.'LIT'.OR.WHCH(1:3).EQ.'lit').AND.
     +           (IPAI.LT.1.OR.IPAI.GT.10))
          INVOKE (PAI-INCORRECT,NR)
        END IF
C
        BLOCK (PAI-INCORRECT,NR)
          CTMB(1:36)='CTGETR - 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.  (09/15/00) Because of a compiler
C problem on certain systems, the following long IF statement has been
C broken in two: we check for parameter names in the first half of the
C alphabet in one IF and for parameter names in the second half of the
C alphabet in another IF.
C
        IF      (WHCH(1:3).EQ.'AIA'.OR.WHCH(1:3).EQ.'aia')
          RVAL=REAL(IAIA(JPAI))
        ELSE IF (WHCH(1:3).EQ.'AIB'.OR.WHCH(1:3).EQ.'aib')
          RVAL=REAL(IAIB(IPAI))
        ELSE IF (WHCH(1:3).EQ.'CAF'.OR.WHCH(1:3).EQ.'caf')
          RVAL=REAL(ICAF)
        ELSE IF (WHCH(1:3).EQ.'CFA'.OR.WHCH(1:3).EQ.'cfa')
          RVAL=ANCF
        ELSE IF (WHCH(1:3).EQ.'CFB'.OR.WHCH(1:3).EQ.'cfb')
          RVAL=REAL(IBCF)
        ELSE IF (WHCH(1:3).EQ.'CFC'.OR.WHCH(1:3).EQ.'cfc')
          RVAL=REAL(ICCF)
        ELSE IF (WHCH(1:3).EQ.'CFF'.OR.WHCH(1:3).EQ.'cff')
          RVAL=ICFF
        ELSE IF (WHCH(1:3).EQ.'CFL'.OR.WHCH(1:3).EQ.'cfl')
          RVAL=WLCF
        ELSE IF (WHCH(1:3).EQ.'CFP'.OR.WHCH(1:3).EQ.'cfp')
          RVAL=REAL(IPCF)
        ELSE IF (WHCH(1:3).EQ.'CFS'.OR.WHCH(1:3).EQ.'cfs')
          RVAL=WCCF
        ELSE IF (WHCH(1:3).EQ.'CFW'.OR.WHCH(1:3).EQ.'cfw')
          RVAL=WWCF
        ELSE IF (WHCH(1:3).EQ.'CFX'.OR.WHCH(1:3).EQ.'cfx')
          RVAL=CXCF
        ELSE IF (WHCH(1:3).EQ.'CFY'.OR.WHCH(1:3).EQ.'cfy')
          RVAL=CYCF
        ELSE IF (WHCH(1:3).EQ.'CIS'.OR.WHCH(1:3).EQ.'cis')
          RVAL=CINS
        ELSE IF (WHCH(1:3).EQ.'CIT'.OR.WHCH(1:3).EQ.'cit')
          RVAL=CINT(IPAI)
        ELSE IF (WHCH(1:3).EQ.'CIU'.OR.WHCH(1:3).EQ.'ciu')
          RVAL=CINU
        ELSE IF (WHCH(1:3).EQ.'CLC'.OR.WHCH(1:3).EQ.'clc')
          RVAL=REAL(ICCL(JPAI))
        ELSE IF (WHCH(1:3).EQ.'CLL'.OR.WHCH(1:3).EQ.'cll')
          RVAL=CLWA(JPAI)
        ELSE IF (WHCH(1:3).EQ.'CLS'.OR.WHCH(1:3).EQ.'cls')
          RVAL=REAL(ICLS)
        ELSE IF (WHCH(1:3).EQ.'CLU'.OR.WHCH(1:3).EQ.'clu')
          RVAL=REAL(ICLU(JPAI))
        ELSE IF (WHCH(1:3).EQ.'CLV'.OR.WHCH(1:3).EQ.'clv')
          RVAL=CLEV(IPAI)
        ELSE IF (WHCH(1:3).EQ.'CMN'.OR.WHCH(1:3).EQ.'cmn')
          RVAL=UCMN
        ELSE IF (WHCH(1:3).EQ.'CMX'.OR.WHCH(1:3).EQ.'cmx')
          RVAL=UCMX
        ELSE IF (WHCH(1:3).EQ.'CWM'.OR.WHCH(1:3).EQ.'cwm')
          RVAL=CHWM
        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.'DPS'.OR.WHCH(1:3).EQ.'dps')
          RVAL=WOCH
        ELSE IF (WHCH(1:3).EQ.'DPU'.OR.WHCH(1:3).EQ.'dpu')
          RVAL=REAL(IDUF)
        ELSE IF (WHCH(1:3).EQ.'DPV'.OR.WHCH(1:3).EQ.'dpv')
          RVAL=WODA
        ELSE IF (WHCH(1:3).EQ.'DVA'.OR.WHCH(1:3).EQ.'dva')
          RVAL=DVAL
        ELSE IF (WHCH(1:3).EQ.'GIC'.OR.WHCH(1:3).EQ.'gic')
          RVAL=REAL(IGCL)
        ELSE IF (WHCH(1:3).EQ.'GIL'.OR.WHCH(1:3).EQ.'gil')
          RVAL=REAL(IGLB)
        ELSE IF (WHCH(1:3).EQ.'GIS'.OR.WHCH(1:3).EQ.'gis')
          RVAL=REAL(IGVS)
        ELSE IF (WHCH(1:3).EQ.'HCF'.OR.WHCH(1:3).EQ.'hcf')
          RVAL=REAL(IHCF)
        ELSE IF (WHCH(1:3).EQ.'HCL'.OR.WHCH(1:3).EQ.'hcl')
          RVAL=HCHL
        ELSE IF (WHCH(1:3).EQ.'HCS'.OR.WHCH(1:3).EQ.'hcs')
          RVAL=HCHS
        ELSE IF (WHCH(1:3).EQ.'HIC'.OR.WHCH(1:3).EQ.'hic')
          RVAL=REAL(ICHI)
        ELSE IF (WHCH(1:3).EQ.'HLA'.OR.WHCH(1:3).EQ.'hla')
          RVAL=ANHL
        ELSE IF (WHCH(1:3).EQ.'HLB'.OR.WHCH(1:3).EQ.'hlb')
          RVAL=REAL(IBHL)
        ELSE IF (WHCH(1:3).EQ.'HLC'.OR.WHCH(1:3).EQ.'hlc')
          RVAL=REAL(ICHL)
        ELSE IF (WHCH(1:3).EQ.'HLE'.OR.WHCH(1:3).EQ.'hle')
          RVAL=REAL(IHLE)
        ELSE IF (WHCH(1:3).EQ.'HLL'.OR.WHCH(1:3).EQ.'hll')
          RVAL=WLHL
        ELSE IF (WHCH(1:3).EQ.'HLO'.OR.WHCH(1:3).EQ.'hlo')
          RVAL=REAL(IOHL)
        ELSE IF (WHCH(1:3).EQ.'HLR'.OR.WHCH(1:3).EQ.'hlr')
          RVAL=HLSR
        ELSE IF (WHCH(1:3).EQ.'HLS'.OR.WHCH(1:3).EQ.'hls')
          RVAL=WCHL
        ELSE IF (WHCH(1:3).EQ.'HLW'.OR.WHCH(1:3).EQ.'hlw')
          RVAL=WWHL
        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.'IWB'.OR.WHCH(1:3).EQ.'iwb')
          RVAL=REAL(LIWB)
        ELSE IF (WHCH(1:3).EQ.'IWM'.OR.WHCH(1:3).EQ.'iwm')
          RVAL=REAL(LIWM)
        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.'LIS'.OR.WHCH(1:3).EQ.'lis')
          RVAL=REAL(LINS)
        ELSE IF (WHCH(1:3).EQ.'LIT'.OR.WHCH(1:3).EQ.'lit')
          RVAL=REAL(LINT(IPAI))
        ELSE IF (WHCH(1:3).EQ.'LIU'.OR.WHCH(1:3).EQ.'liu')
          RVAL=REAL(LINU)
        ELSE IF (WHCH(1:3).EQ.'LLA'.OR.WHCH(1:3).EQ.'lla')
          RVAL=ANLL
        ELSE IF (WHCH(1:3).EQ.'LLB'.OR.WHCH(1:3).EQ.'llb')
          RVAL=REAL(IBLL)
        ELSE IF (WHCH(1:3).EQ.'LLC'.OR.WHCH(1:3).EQ.'llc')
          RVAL=REAL(ICLL(IPAI))
        ELSE IF (WHCH(1:3).EQ.'LLL'.OR.WHCH(1:3).EQ.'lll')
          RVAL=WLLL
        ELSE IF (WHCH(1:3).EQ.'LLO'.OR.WHCH(1:3).EQ.'llo')
          RVAL=REAL(IOLL)
        ELSE IF (WHCH(1:3).EQ.'LLP'.OR.WHCH(1:3).EQ.'llp')
          RVAL=REAL(IPLL)
        ELSE IF (WHCH(1:3).EQ.'LLS'.OR.WHCH(1:3).EQ.'lls')
          RVAL=WCLL
        ELSE IF (WHCH(1:3).EQ.'LLW'.OR.WHCH(1:3).EQ.'llw')
          RVAL=WWLL
        ELSE IF (WHCH(1:3).EQ.'LOC'.OR.WHCH(1:3).EQ.'loc')
          RVAL=REAL(ICLO)
        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
C Check parameter names in the second half of the alphabet.
C
  101   IF      (WHCH(1:3).EQ.'NCL'.OR.WHCH(1:3).EQ.'ncl')
          RVAL=REAL(NCLV)
        ELSE 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.'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.'NVS'.OR.WHCH(1:3).EQ.'nvs')
          RVAL=REAL(NOVS)
        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.'PC1'.OR.WHCH(1:3).EQ.'pc1')
          RVAL=GSDM
        ELSE IF (WHCH(1:3).EQ.'PC2'.OR.WHCH(1:3).EQ.'pc2')
          RVAL=FNCM
        ELSE IF (WHCH(1:3).EQ.'PC3'.OR.WHCH(1:3).EQ.'pc3')
          RVAL=CDMX
        ELSE IF (WHCH(1:3).EQ.'PC4'.OR.WHCH(1:3).EQ.'pc4')
          RVAL=DOPT
        ELSE IF (WHCH(1:3).EQ.'PC5'.OR.WHCH(1:3).EQ.'pc5')
          RVAL=DFLD
        ELSE IF (WHCH(1:3).EQ.'PC6'.OR.WHCH(1:3).EQ.'pc6')
          RVAL=DBLM
        ELSE IF (WHCH(1:3).EQ.'PIC'.OR.WHCH(1:3).EQ.'pic')
          RVAL=REAL(IPIC)
        ELSE IF (WHCH(1:3).EQ.'PIE'.OR.WHCH(1:3).EQ.'pie')
          RVAL=REAL(IPIE)
        ELSE IF (WHCH(1:3).EQ.'PIT'.OR.WHCH(1:3).EQ.'pit')
          RVAL=PITH
        ELSE IF (WHCH(1:3).EQ.'PW1'.OR.WHCH(1:3).EQ.'pw1')
          RVAL=WTGR
        ELSE IF (WHCH(1:3).EQ.'PW2'.OR.WHCH(1:3).EQ.'pw2')
          RVAL=WTNC
        ELSE IF (WHCH(1:3).EQ.'PW3'.OR.WHCH(1:3).EQ.'pw3')
          RVAL=WTCD
        ELSE IF (WHCH(1:3).EQ.'PW4'.OR.WHCH(1:3).EQ.'pw4')
          RVAL=WTOD
        ELSE IF (WHCH(1:3).EQ.'RC1'.OR.WHCH(1:3).EQ.'rc1')
          RVAL=DBLF
        ELSE IF (WHCH(1:3).EQ.'RC2'.OR.WHCH(1:3).EQ.'rc2')
          RVAL=DBLN
        ELSE IF (WHCH(1:3).EQ.'RC3'.OR.WHCH(1:3).EQ.'rc3')
          RVAL=DBLV
        ELSE IF (WHCH(1:3).EQ.'RWC'.OR.WHCH(1:3).EQ.'rwc')
          RVAL=REAL(LRWC)
        ELSE IF (WHCH(1:3).EQ.'RWG'.OR.WHCH(1:3).EQ.'rwg')
          RVAL=REAL(LRWG)
        ELSE IF (WHCH(1:3).EQ.'RWM'.OR.WHCH(1:3).EQ.'rwm')
          RVAL=REAL(LRWM)
        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.'SSL'.OR.WHCH(1:3).EQ.'ssl')
          RVAL=SEGL
        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.'T2D'.OR.WHCH(1:3).EQ.'t2d')
          RVAL=T2DS
        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.'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.'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)='CTGETR - 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 CTLBAM (RPNT,IEDG,ITRI,RWRK,IWRK,IAMA)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*),IAMA(*)
C
C The function of the routine CTLBAM is to add to an area map boxes
C surrounding all of the labels.
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 IAMA is the user's area-map array.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTLBAM - 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 ('CTLBAM - 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('CTLBAM',3).NE.0) RETURN
C
C Make sure we have space for 10 coordinate values in real workspace 1.
C
        CALL CTGRWS (RWRK,1,10,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CTLBAM',4).NE.0) GO TO 102
C
C If the constant-field flag is set, put the constant-field message box
C into the area map and quit.
C
        IF (ICFF.NE.0)
          CALL CTCFLB (2,RWRK,IAMA)
          IF (ICFELL('CTLBAM',5).NE.0) RETURN
          GO TO 101
        END IF
C
C Make sure label positions have been chosen.
C
        CALL CTPKLP (RPNT,IEDG,ITRI,RWRK,IWRK)
        IF (ICFELL('CTLBAM',6).NE.0)
          NLBS=0
          NR04=0
          INIL=0
          INHL=0
          INLL=0
          RETURN
        END IF
C
C If there are no labels in the label list, quit.
C
        IF (NLBS.LE.0) GO TO 101
C
C Put label boxes into the area map.
C
        CALL SET (XVPL,XVPR,YVPB,YVPT,XVPL,XVPR,YVPB,YVPT,1)
        IF (ICFELL('CTLBAM',7).NE.0) RETURN
C
        DO (I=1,NLBS)
          XCLB=RWRK(IR03+4*(I-1)+1)
          YCLB=RWRK(IR03+4*(I-1)+2)
          ANLB=RWRK(IR03+4*(I-1)+3)
          SALB=SIN(ANLB)
          CALB=COS(ANLB)
          ICLB=INT(RWRK(IR03+4*(I-1)+4))
          IF (ICLB.LE.0)
            DLLB=RWRK(IR04-ICLB+3)
            DRLB=RWRK(IR04-ICLB+4)
            DBLB=RWRK(IR04-ICLB+5)
            DTLB=RWRK(IR04-ICLB+6)
          ELSE
            DLLB=CLDL(ICLB)
            DRLB=CLDR(ICLB)
            DBLB=CLDB(ICLB)
            DTLB=CLDT(ICLB)
          END IF
          RWRK(IR01+ 1)=XCLB-DLLB*CALB+DBLB*SALB
          RWRK(IR01+ 2)=XCLB+DRLB*CALB+DBLB*SALB
          RWRK(IR01+ 3)=XCLB+DRLB*CALB-DTLB*SALB
          RWRK(IR01+ 4)=XCLB-DLLB*CALB-DTLB*SALB
          RWRK(IR01+ 5)=RWRK(IR01+1)
          RWRK(IR01+ 6)=YCLB-DLLB*SALB-DBLB*CALB
          RWRK(IR01+ 7)=YCLB+DRLB*SALB-DBLB*CALB
          RWRK(IR01+ 8)=YCLB+DRLB*SALB+DTLB*CALB
          RWRK(IR01+ 9)=YCLB-DLLB*SALB+DTLB*CALB
          RWRK(IR01+10)=RWRK(IR01+6)
          CALL AREDAM (IAMA,RWRK(IR01+1),RWRK(IR01+6),5,IGLB,-1,0)
          IF (ICFELL('CTLBAM',8).NE.0) RETURN
        END DO
C
        CALL SET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
        IF (ICFELL('CTLBAM',9).NE.0) RETURN
C
C If the area map has no edges in it, something has gone wrong.  Put
C a dummy rectangle in the area map to prevent problems which result.
C
  101   IF (IAMA(7).EQ.0)
          CALL SET (XVPL,XVPR,YVPB,YVPT,XVPL,XVPR,YVPB,YVPT,1)
          IF (ICFELL('CTLBAM',10).NE.0) RETURN
          RWRK(IR01+ 1)=0.
          RWRK(IR01+ 2)=1.
          RWRK(IR01+ 3)=1.
          RWRK(IR01+ 4)=0.
          RWRK(IR01+ 5)=RWRK(IR01+1)
          RWRK(IR01+ 6)=0.
          RWRK(IR01+ 7)=0.
          RWRK(IR01+ 8)=1.
          RWRK(IR01+ 9)=1.
          RWRK(IR01+10)=RWRK(IR01+6)
          CALL AREDAM (IAMA,RWRK(IR01+1),RWRK(IR01+6),5,IGLB,0,-1)
          IF (ICFELL('CTLBAM',11).NE.0) RETURN
          CALL SET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
          IF (ICFELL('CTLBAM',12).NE.0) RETURN
        END IF
C
C Release real workspace 1.
C
  102   LR01=0
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTLBDR (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C The function of the routine CTLBDR is to draw all of the labels.
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
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Declare local arrays to hold coordinates for area fill of boxes.
C
        DIMENSION BFXC(4),BFYC(4)
C
C Define a local array to receive some information we don't care about
C from the GKS routine GQCLIP.
C
        DIMENSION DUMI(4)
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTLBDR - 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 ('CTLBDR - 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('CTLBDR',3).NE.0) RETURN
C
C If the constant-field flag is set, write the constant-field message
C and quit.
C
        IF (ICFF.NE.0)
          CALL CTCFLB (1,RWRK,IWRK)
          IF (ICFELL('CTLBDR',4).NE.0) RETURN
          RETURN
        END IF
C
C Make sure label positions have been chosen.
C
        CALL CTPKLP (RPNT,IEDG,ITRI,RWRK,IWRK)
        IF (ICFELL('CTLBDR',5).NE.0)
          NLBS=0
          NR04=0
          INIL=0
          INHL=0
          INLL=0
          RETURN
        END IF
C
C If there are no labels in the label list, quit.
C
        IF (NLBS.LE.0) RETURN
C
C Redo the SET call so that we can use fractional-system coordinates.
C
        CALL SET (XVPL,XVPR,YVPB,YVPT,XVPL,XVPR,YVPB,YVPT,1)
        IF (ICFELL('CTLBDR',6).NE.0) RETURN
C
C Set up color-index controls.
C
        CALL GQPLCI (IGER,ISLC)
        IF (IGER.NE.0)
          CALL SETER ('CTLBDR - ERROR EXIT FROM GQPLCI',7,1)
          RETURN
        END IF
        CALL GQTXCI (IGER,ISTC)
        IF (IGER.NE.0)
          CALL SETER ('CTLBDR - ERROR EXIT FROM GQTXCI',8,1)
          RETURN
        END IF
        CALL GQFACI (IGER,ISFC)
        IF (IGER.NE.0)
          CALL SETER ('CTLBDR - ERROR EXIT FROM GQFACI',9,1)
          RETURN
        END IF
C
        IF (ICIL.GE.0)
          JCIL=ICIL
        ELSE
          JCIL=ISTC
        END IF
C
        IF (ICHI.GE.0)
          JCHI=ICHI
        ELSE IF (ICHL.GE.0)
          JCHI=ICHL
        ELSE
          JCHI=ISTC
        END IF
C
        IF (ICLO.GE.0)
          JCLO=ICLO
        ELSE IF (ICHL.GE.0)
          JCLO=ICHL
        ELSE
          JCLO=ISTC
        END IF
C
        IF (ILBC.GE.0)
          JLBC=ILBC
        ELSE
          JLBC=ISFC
        END IF
C
        JSLC=ISLC
        JSTC=ISTC
        JSFC=ISFC
C
C Draw all the labels.
C
        DO (I=1,NLBS)
C
          XCLB=RWRK(IR03+4*(I-1)+1)
          YCLB=RWRK(IR03+4*(I-1)+2)
          XLBC=XCLB
          YLBC=YCLB
          ANLB=RWRK(IR03+4*(I-1)+3)
          SALB=SIN(ANLB)
          CALB=COS(ANLB)
          ANGD=57.2957795130823*ANLB
          ICLB=INT(RWRK(IR03+4*(I-1)+4))
C
          IF (ICLB.LE.0)
C
            ICLX=ICLB
C
            IF (RWRK(IR04-ICLB+1).EQ.0.)
              ITYP=1
              DVAL=0.
              CALL CTSBST (TXIL(1:LTIL),CTMA,LCTM)
              WCHR=(XVPR-XVPL)*CHWM*WCIL
              IBOX=IBIL
              JCOL=JCIL
              WDTH=WLIL
            ELSE IF (RWRK(IR04-ICLB+1).EQ.1.)
              ITYP=2
              DVAL=RWRK(IR04-ICLB+2)
              CALL CTSBST (TXHI(1:LTHI),CTMA,LCTM)
              WCHR=(XVPR-XVPL)*CHWM*WCHL
              IBOX=IBHL
              JCOL=JCHI
              WDTH=WLHL
            ELSE IF (RWRK(IR04-ICLB+1).EQ.2.)
              ITYP=3
              DVAL=RWRK(IR04-ICLB+2)
              CALL CTSBST (TXLO(1:LTLO),CTMA,LCTM)
              WCHR=(XVPR-XVPL)*CHWM*WCHL
              IBOX=IBHL
              JCOL=JCLO
              WDTH=WLHL
            ELSE
              ICLB=INT(RWRK(IR04-ICLB+2))
              ITYP=4
              DVAL=CLEV(ICLB)
              LCTM=NCLB(ICLB)
              CTMA=CLBL(ICLB)(1:LCTM)
              WCHR=(XVPR-XVPL)*CHWM*WCLL
              IBOX=IBLL
              JCOL=ISTC
              IF (ICLL(ICLB).GE.0) JCOL=ICLL(ICLB)
              WDTH=WLLL
            END IF
C
            IF (IBOX.NE.0)
              DLLB=RWRK(IR04-ICLX+3)
              DRLB=RWRK(IR04-ICLX+4)
              DBLB=RWRK(IR04-ICLX+5)
              DTLB=RWRK(IR04-ICLX+6)
            END IF
C
          ELSE
C
            ITYP=4
            DVAL=CLEV(ICLB)
            LCTM=NCLB(ICLB)
            CTMA=CLBL(ICLB)(1:LCTM)
            WCHR=(XVPR-XVPL)*CHWM*WCLL
            IBOX=IBLL
            JCOL=ISTC
            IF (ICLL(ICLB).GE.0) JCOL=ICLL(ICLB)
            WDTH=WLLL
C
            IF (IBOX.NE.0)
              DLLB=CLDL(ICLB)
              DRLB=CLDR(ICLB)
              DBLB=CLDB(ICLB)
              DTLB=CLDT(ICLB)
            END IF
C
          END IF
C
          IF (ITYP.EQ.1)
            CALL GQCLIP (IGER,IGCF,DUMI)
            IF (IGER.NE.0)
              CALL SETER ('CTLBDR - ERROR EXIT FROM GQCLIP',10,1)
              RETURN
            END IF
            IF (IGCF.NE.0)
              CALL PLOTIF (0.,0.,2)
              IF (ICFELL('CTLBDR',11).NE.0) RETURN
              CALL GSCLIP (0)
            END IF
          END IF
C
          IF (MOD(IBOX/2,2).NE.0)
            IF (JSFC.NE.JLBC)
              CALL GSFACI (JLBC)
              JSFC=JLBC
            END IF
            IF (ITYP.EQ.1)
              CALL HLUCTCHIL (+2)
              IF (ICFELL('CTLBDR',12).NE.0) RETURN
            ELSE IF (ITYP.EQ.2)
              CALL HLUCTCHHL (+2)
              IF (ICFELL('CTLBDR',13).NE.0) RETURN
            ELSE IF (ITYP.EQ.3)
              CALL HLUCTCHHL (+6)
              IF (ICFELL('CTLBDR',14).NE.0) RETURN
            ELSE
              IPAI=ICLB
              IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
              CALL HLUCTCHLL (+2)
              IF (ICFELL('CTLBDR',15).NE.0) RETURN
            END IF
            BFXC(1)=XCLB-DLLB*CALB+DBLB*SALB
            BFYC(1)=YCLB-DLLB*SALB-DBLB*CALB
            BFXC(2)=XCLB+DRLB*CALB+DBLB*SALB
            BFYC(2)=YCLB+DRLB*SALB-DBLB*CALB
            BFXC(3)=XCLB+DRLB*CALB-DTLB*SALB
            BFYC(3)=YCLB+DRLB*SALB+DTLB*CALB
            BFXC(4)=XCLB-DLLB*CALB-DTLB*SALB
            BFYC(4)=YCLB-DLLB*SALB+DTLB*CALB
            CALL GFA (4,BFXC,BFYC)
            IF (ITYP.EQ.1)
              CALL HLUCTCHIL (-2)
              IF (ICFELL('CTLBDR',16).NE.0) RETURN
            ELSE IF (ITYP.EQ.2)
              CALL HLUCTCHHL (-2)
              IF (ICFELL('CTLBDR',17).NE.0) RETURN
            ELSE IF (ITYP.EQ.3)
              CALL HLUCTCHHL (-6)
              IF (ICFELL('CTLBDR',18).NE.0) RETURN
            ELSE
              IPAI=ICLB
              IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
              CALL HLUCTCHLL (-2)
              IF (ICFELL('CTLBDR',19).NE.0) RETURN
            END IF
          END IF
C
          IF (JSLC.NE.JCOL)
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('CTLBDR',20).NE.0) RETURN
            CALL GSPLCI (JCOL)
            JSLC=JCOL
          END IF
C
          IF (JSTC.NE.JCOL)
            CALL GSTXCI (JCOL)
            JSTC=JCOL
          END IF
C
          IF (ITYP.EQ.1)
            CALL HLUCTCHIL (+3)
            IF (ICFELL('CTLBDR',21).NE.0) RETURN
          ELSE IF (ITYP.EQ.2)
            CALL HLUCTCHHL (+3)
            IF (ICFELL('CTLBDR',22).NE.0) RETURN
          ELSE IF (ITYP.EQ.3)
            CALL HLUCTCHHL (+7)
            IF (ICFELL('CTLBDR',23).NE.0) RETURN
          ELSE
            IPAI=ICLB
            IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
            CALL HLUCTCHLL (+3)
            IF (ICFELL('CTLBDR',24).NE.0) RETURN
          END IF
          CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCHR,ANGD,0.)
          IF (ICFELL('CTLBDR',25).NE.0) RETURN
          IF (ITYP.EQ.1)
            CALL HLUCTCHIL (-3)
            IF (ICFELL('CTLBDR',26).NE.0) RETURN
          ELSE IF (ITYP.EQ.2)
            CALL HLUCTCHHL (-3)
            IF (ICFELL('CTLBDR',27).NE.0) RETURN
          ELSE IF (ITYP.EQ.3)
            CALL HLUCTCHHL (-7)
            IF (ICFELL('CTLBDR',28).NE.0) RETURN
          ELSE
            IPAI=ICLB
            IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
            CALL HLUCTCHLL (-3)
            IF (ICFELL('CTLBDR',29).NE.0) RETURN
          END IF
C
          IF (MOD(IBOX,2).NE.0)
            IF (WDTH.GT.0.)
              CALL GQLWSC (IGER,SFLW)
              IF (IGER.NE.0)
                CALL SETER ('CTLBDR - ERROR EXIT FROM GQLWSC',30,1)
                RETURN
              END IF
              CALL PLOTIF (0.,0.,2)
              IF (ICFELL('CTLBDR',31).NE.0) RETURN
              CALL GSLWSC (WDTH)
            END IF
            IF (ITYP.EQ.1)
              CALL HLUCTCHIL (+4)
              IF (ICFELL('CTLBDR',32).NE.0) RETURN
            ELSE IF (ITYP.EQ.2)
              CALL HLUCTCHHL (+4)
              IF (ICFELL('CTLBDR',33).NE.0) RETURN
            ELSE IF (ITYP.EQ.3)
              CALL HLUCTCHHL (+8)
              IF (ICFELL('CTLBDR',34).NE.0) RETURN
            ELSE
              IPAI=ICLB
              IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
              CALL HLUCTCHLL (+4)
              IF (ICFELL('CTLBDR',35).NE.0) RETURN
            END IF
            CALL PLOTIF (XCLB-DLLB*CALB+DBLB*SALB,
     +                   YCLB-DLLB*SALB-DBLB*CALB,0)
            IF (ICFELL('CTLBDR',36).NE.0) RETURN
            CALL PLOTIF (XCLB+DRLB*CALB+DBLB*SALB,
     +                   YCLB+DRLB*SALB-DBLB*CALB,1)
            IF (ICFELL('CTLBDR',37).NE.0) RETURN
            CALL PLOTIF (XCLB+DRLB*CALB-DTLB*SALB,
     +                   YCLB+DRLB*SALB+DTLB*CALB,1)
            IF (ICFELL('CTLBDR',38).NE.0) RETURN
            CALL PLOTIF (XCLB-DLLB*CALB-DTLB*SALB,
     +                   YCLB-DLLB*SALB+DTLB*CALB,1)
            IF (ICFELL('CTLBDR',39).NE.0) RETURN
            CALL PLOTIF (XCLB-DLLB*CALB+DBLB*SALB,
     +                   YCLB-DLLB*SALB-DBLB*CALB,1)
            IF (ICFELL('CTLBDR',40).NE.0) RETURN
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('CTLBDR',41).NE.0) RETURN
            IF (ITYP.EQ.1)
              CALL HLUCTCHIL (-4)
              IF (ICFELL('CTLBDR',42).NE.0) RETURN
            ELSE IF (ITYP.EQ.2)
              CALL HLUCTCHHL (-4)
              IF (ICFELL('CTLBDR',43).NE.0) RETURN
            ELSE IF (ITYP.EQ.3)
              CALL HLUCTCHHL (-8)
              IF (ICFELL('CTLBDR',44).NE.0) RETURN
            ELSE
              IPAI=ICLB
              IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
              CALL HLUCTCHLL (-4)
              IF (ICFELL('CTLBDR',45).NE.0) RETURN
            END IF
            IF (WDTH.GT.0.)
              CALL PLOTIF (0.,0.,2)
              IF (ICFELL('CTLBDR',46).NE.0) RETURN
              CALL GSLWSC (SFLW)
            END IF
          END IF
C
          IF (ITYP.EQ.1)
            IF (IGCF.NE.0)
              CALL PLOTIF (0.,0.,2)
              IF (ICFELL('CTLBDR',47).NE.0) RETURN
              CALL GSCLIP (IGCF)
            END IF
          END IF
C
        END DO
C
C Return the color indices to their original values.
C
        IF (JSLC.NE.ISLC)
          CALL PLOTIF (0.,0.,2)
          IF (ICFELL('CTLBDR',48).NE.0) RETURN
          CALL GSPLCI (ISLC)
        END IF
        IF (JSTC.NE.ISTC) CALL GSTXCI (ISTC)
        IF (JSFC.NE.ISFC) CALL GSFACI (ISFC)
C
C Restore the original SET parameters.
C
        CALL SET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
        IF (ICFELL('CTLBDR',49).NE.0) RETURN
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTMESH (RPNT,KPNT,KOPN,
     +                   IEDG,KEDG,KOEN,
     +                   ITRI,KTRI,KOTN,
     +                   RWRK,KRWK,
     +                   IWRK,KIWK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C The routine CTMESH is called to start the process of drawing a
C contour 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 CONPACKT common blocks.
C
.CALL CTCOMN,/$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('CTMESH - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C If no CONPACKT routine has been called before, initialize required
C constants.
C
        IF (INIT.EQ.0)
          CALL CTINRC
          IF (ICFELL('CTMESH',2).NE.0) RETURN
        END IF
C
C Extract the values of ITBX and ITBA.
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 Swap the end points of each edge of the mesh so that the field value
C at the first point is less than or equal to the field value at the
C second point.  Because this changes the definitions of "left" and
C "right" for the edge, the pointers to the triangles to the left and
C right of the edge must also be swapped.
C
        DO (IPTE=0,NEDG-LOEN,LOEN)
          IF (RPNT(IEDG(IPTE+1)+4).GT.RPNT(IEDG(IPTE+2)+4))
            ITMP=IEDG(IPTE+1)
            IEDG(IPTE+1)=IEDG(IPTE+2)
            IEDG(IPTE+2)=ITMP
            ITMP=IEDG(IPTE+3)
            IEDG(IPTE+3)=IEDG(IPTE+4)
            IEDG(IPTE+4)=ITMP
          END IF
        END DO
C
C Find the ranges of the X, Y, and Z coordinates, the field values,
C and the values of the 2D coordinates in the projection plane, over
C the unblocked portion of the mesh.
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)
                  DMIN=RPNT(L+4)
                  DMAX=RPNT(L+4)
                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))
                  DMIN=MIN(DMIN,RPNT(L+4))
                  DMAX=MAX(DMAX,RPNT(L+4))
                END IF
                IF (IMPF.EQ.0)
                  UTMP=RPNT(L+1)
                  VTMP=RPNT(L+2)
                ELSE
                  CALL HLUCTMXYZ (IMPF,RPNT(L+1),RPNT(L+2),RPNT(L+3),
     +                                                     UTMP,VTMP)
                  IF (ICFELL('CTMESH',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
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('CTMESH',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('CTMESH',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 HLUCTMXYZ (IMPF,
     +                        RPNT(IPP1+1),RPNT(IPP1+2),RPNT(IPP1+3),
     +                                                        XCP1,YCP1)
              IF (ICFELL('CTMESH',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 HLUCTMXYZ (IMPF,
     +                        RPNT(IPP2+1),RPNT(IPP2+2),RPNT(IPP2+3),
     +                                                        XCP2,YCP2)
              IF (ICFELL('CTMESH',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 HLUCTMXYZ (IMPF,
     +                        RPNT(IPP3+1),RPNT(IPP3+2),RPNT(IPP3+3),
     +                                                        XCP3,YCP3)
              IF (ICFELL('CTMESH',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 three indices which indicate where the different kinds
C of labels are stored.
C
  103   NLBS=0
        NR04=0
        INIL=0
        INHL=0
        INLL=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 contour levels are being chosen by CONPACKT, zero the number of
C levels and the values of the contour interval and label interval
C used.  If new levels are not being chosen, force recomputation of
C the text-extent parameter elements for all existing contour levels,
C in case the user changes the character-quality parameter of PLOTCHAR.
C
        IF (ICLS.NE.0)
          NCLV=0
          CINU=0.
          LINU=0
        ELSE
          DO (I=1,NCLV)
            NCLB(I)=-ABS(NCLB(I))
          END DO
        END IF
C
C If the field is (effectively) constant, set a flag to indicate that
C and force the scale factor back to 1.  Otherwise, clear the flag.
C
        IF (DMAX-DMIN.LE.10.*EPSI*ABS((DMIN+DMAX)/2.))
          ICFF=1
          SCFU=1.
        ELSE
          ICFF=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 constant, the latter value is set equal to the former.
C
        CALL CTNUMB (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 (ICFF.EQ.0)
          CALL CTNUMB ((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('CTMESH',9).NE.0) RETURN
C
C If highs and lows are to be labelled, attempt to make sure that the
C string will be treated properly by PLOTCHAR.
C
        IF (LTHI.GE.4)
          IF (TXHI(1:1).EQ.'H'.AND.TXHI(3:3).EQ.'B')
            DO (I=4,LTHI)
              IF (TXHI(I:I).EQ.TXHI(2:2)) TXHI(I:I)=SCHR
            END DO
            TXHI(2:2)=SCHR
          END IF
        END IF
C
        IF (LTLO.GE.4)
          IF (TXLO(1:1).EQ.'L'.AND.TXLO(3:3).EQ.'B')
            DO (I=4,LTLO)
              IF (TXLO(I:I).EQ.TXLO(2:2)) TXLO(I:I)=SCHR
            END DO
            TXLO(2:2)=SCHR
          END IF
        END IF
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 constant 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 (ICFF.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 CTMVIW (IWKO,IWKN,LWKN)
C
        DIMENSION IWKO(LIWK),IWKN(LWKN)
C
C This subroutine is called to move what CONPACKT 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 CONPACKT common blocks.
C
.CALL CTCOMN,/$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('CTMVIW - 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 ('CTMVIW - 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 CTMVRW (RWKO,RWKN,LWKN)
C
        DIMENSION RWKO(LRWK),RWKN(LWKN)
C
C This subroutine is called to move what CONPACKT 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 CONPACKT common blocks.
C
.CALL CTCOMN,/$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('CTMVRW - 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 ('CTMVRW - 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 CTPKCL (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C The routine CTPKCL is called to pick a set of contour levels.
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
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTPKCL - 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 ('CTPKCL - INITIALIZATION CALL NOT DONE',2,1)
          RETURN
        END IF
C
C If contour level selection is suppressed, do nothing.
C
        IF (ICLS.EQ.0) RETURN
C
C If the constant-field flag is set, do nothing.
C
        IF (ICFF.NE.0) RETURN
C
C If the contour-selection flag is negative and is equal to "-n",
C generate "n" contour levels, equally spaced between the minimum and
C the maximum.  By default, none of these levels will be labelled.
C
        IF (ICLS.LT.0)
C
          IF (-ICLS.GT.$NCLV$)
            CALL SETER ('CTPKCL - TOO MANY CONTOUR LEVELS',3,1)
            RETURN
          END IF
C
          NCLV=MIN(-ICLS,$NCLV$)
          CINU=(DMAX-DMIN)/REAL(NCLV+1)
          LINU=0
C
          DO (I=1,NCLV)
            CLEV(I)=DMIN+REAL(I)*CINU
            ICLU(I)=1
            IAIA(I)=I+1
            IAIB(I)=I
            CLBL(I)=' '
            NCLB(I)=-1
            CLDP(I)='$$$$$$$$$$$$$$$$'
            ICCL(I)=-1
            ICLL(I)=-1
            CLWA(I)=0.
          END DO
C
C Otherwise (if the contour-selection flag is positive), generate the
C contour levels at equal intervals, either as specified by the user
C or as chosen in order to get roughly the right number of levels.
C Certain levels will be labelled.
C
        ELSE
C
          IF (CINS.LE.0.)
            CINU=0.
          ELSE
            CINU=CINS
            LINU=LINS
            IF (UCMN.LE.UCMX)
              NCLV=0
              LOOP
                NCLV=NCLV+1
                CLEV(NCLV)=UCMN+REAL(NCLV-1)*CINU
                IF (ABS(CLEV(NCLV)).LT..001*CINU) CLEV(NCLV)=0.
                IF (MOD(NCLV-1,LINU).NE.0)
                  ICLU(NCLV)=1
                ELSE
                  ICLU(NCLV)=3
                END IF
                IAIA(NCLV)=NCLV+1
                IAIB(NCLV)=NCLV
                CLBL(NCLV)=' '
                NCLB(NCLV)=-1
                CLDP(NCLV)='$$$$$$$$$$$$$$$$'
                ICCL(NCLV)=-1
                ICLL(NCLV)=-1
                CLWA(NCLV)=0.
                EXIT IF (NCLV.EQ.$NCLV$.OR.CLEV(NCLV)+.999*CINU.GT.UCMX)
              END LOOP
              GO TO 101
            END IF
          END IF
C
          IF (CINU.EQ.0.)
            CINU=(DMAX-DMIN)/REAL(ICLS)
            LINU=1
            ITMP=INT(10000.+ALOG10(CINU))-10000
            CINU=CINU/10.**ITMP
            IF (CINU.LT.1.)
              ITMP=ITMP-1
              CINU=CINU*10.
            ELSE IF (CINU.GE.10.)
              ITMP=ITMP+1
              CINU=CINU/10.
            END IF
            IINV=0
            DO (I=1,10)
              IF (CINT(I).NE.0..AND.CINT(I).LE.CINU) IINV=I
            END DO
            IF (IINV.NE.0)
              CINU=CINT(IINV)
              LINU=LINT(IINV)
            END IF
            IF (ITMP.LT.0)
              CINU=CINU*(1./10.**(-ITMP))
            ELSE IF (ITMP.GT.0)
              CINU=CINU*10.**ITMP
            END IF
          END IF
          NCLV=0
          RTM2=DMIN+.001*(DMAX-DMIN)
          IF (RTM2.LT.0.)
            RTM1=-REAL(INT(-RTM2/CINU))
          ELSE
            RTM1=1.+REAL(INT(RTM2/CINU))
          END IF
          RTM2=DMAX-.001*(DMAX-DMIN)
          WHILE (NCLV.LT.$NCLV$.AND.RTM1*CINU.LT.RTM2)
            NCLV=NCLV+1
            CLEV(NCLV)=RTM1*CINU
            IF (MOD(RTM1,REAL(LINU)).NE.0)
              ICLU(NCLV)=1
            ELSE
              ICLU(NCLV)=3
            END IF
            IAIA(NCLV)=NCLV+1
            IAIB(NCLV)=NCLV
            CLBL(NCLV)=' '
            NCLB(NCLV)=-1
            CLDP(NCLV)='$$$$$$$$$$$$$$$$'
            ICCL(NCLV)=-1
            ICLL(NCLV)=-1
            CLWA(NCLV)=0.
            RTM1=RTM1+1.
          END WHILE
        END IF
C
C Done.
C
  101   RETURN
C
      END


      SUBROUTINE CTPKLB (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C The routine CTPKLB is called to pick the labels to be associated with
C the contour levels.
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
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C SCHR is a one-character temporary variable.
C
        CHARACTER*1 SCHR
C
C SCHX is a thirteen-character temporary variable.
C
        CHARACTER*13 SCHX
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTPKLB - 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 ('CTPKLB - INITIALIZATION CALL NOT DONE',2,1)
          RETURN
        END IF
C
C If the constant-field flag is set, do nothing.
C
        IF (ICFF.NE.0) RETURN
C
C If no contour levels are defined, try to define them.
C
        IF (NCLV.LE.0)
          CALL CTPKCL (RPNT,IEDG,ITRI,RWRK,IWRK)
          IF (ICFELL('CTPKLB',3).NE.0) RETURN
        END IF
C
C Get indices for the contour levels in ascending order.
C
        IF (NCLV.GT.0) CALL CTSORT (CLEV,NCLV,ICLP)
C
C Find the positions of the leftmost and rightmost digits in the
C character representations of all the contour levels.
C
        MINI=+10000
        MAXI=-10000
        ITMP=0
C
        DO (ICLV=1,NCLV)
          IF (MOD(ICLU(ICLV)/2,2).NE.0.AND.CLBL(ICLV).EQ.' ')
            ITMP=ITMP+1
            CALL CTNUMB (CLEV(ICLV)/SCFU,NDGL,-10000,-1,-1,' ',' ',' ',
     +                                  0,0,0,0,0,0,SCHR,NCHS,NDGS,IEVA)
            IF (SCHR.NE.'0')
              MINI=MIN(MINI,IEVA-NDGS)
              MAXI=MAX(MAXI,IEVA-1)
            END IF
          END IF
        END DO
C
C If no unset contour labels were found, quit.  There are no labels to
C be filled in and no information on which to base the selection of a
C scale factor.  CTPKLB has probably been called needlessly for a second
C time.
C
        IF (ITMP.EQ.0) RETURN
C
C If no meaningful information was found about the position of digits
C in the contour levels (which probably means there was only one
C unspecified label and it should be just a zero), find the position
C of the leftmost digit in the minimum and maximum values and use it.
C
        IF (MINI.GT.MAXI)
          CALL CTNUMB (MAX(ABS(DMIN),ABS(DMAX))/SCFU,NDGL,-10000,-1,-1,
     +                      ' ',' ',' ',0,0,0,0,0,0,SCHR,NCHS,NDGS,IEVA)
          MINI=IEVA
          MAXI=IEVA
        END IF
C
C If the leftmost digit in the contour levels is too far to the right
C of the digit to be considered the leftmost significant digit while
C generating labels, increase the number of digits to be used from that
C point rightward.  This may result in recomputing the scale factor and
C other dependent quantities.
C
        IF (MAXI.LT.LSDL-1)
          NDGL=NDGL+LSDL-MAXI
          IF (SCFS.LE.0..AND.SCFS.GE.-3.)
            SCFO=SCFU
            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
            LSDL=LSDM-ITMP
            ITMP=NINT(ALOG10(SCFO/SCFU))
            MINI=MINI+ITMP
            MAXI=MAXI+ITMP
          END IF
        END IF
C
C Determine the number of significant digits to be used for the contour
C labels.
C
        NSDU=MIN(MAX(LSDL,MAXI)-MINI+1,NDGL)
C
C If the scale factor is to be based on contour-level values, compute
C it now.
C
        IF (SCFS.EQ.-4.)
          IF (MINI*(MAXI+1).GT.0)
            SCFU=10.**MINI
            IF (LSDL.NE.-10000) LSDL=LSDL-MINI
          END IF
        END IF
C
C Generate labels for those contour lines which will be labelled.
C
        ISNX=0
        IF (ABS(IPLL).EQ.1.AND.NEXT.EQ.1.AND.IDUF.GT.0)
          ISNX=1
          NEXT=0
          SCHX=CHEX
          CHEX=' E '
          LEA1=1
          LEA2=1
          LEA3=1
          LEE1=0
          LEE2=1
          LEE3=0
        END IF
C
        DO (ICLV=1,NCLV)
          IF (MOD(ICLU(ICLV)/2,2).NE.0.AND.CLBL(ICLV).EQ.' ')
            CALL CTNUMB (CLEV(ICLV)/SCFU,NSDU,LSDL,NEXU,NEXL,
     +                   CHEX(1:LEA1),CHEX(LEA1+1:LEA1+LEA2),
     +                   CHEX(LEA1+LEA2+1:LEA1+LEA2+LEA3),LEE1,LEE2,
     +                   LEE3,JOMA,JODP,JOTZ,CLBL(ICLV),NCHS,NDGS,
     +                                                       IEVA)
            NCLB(ICLV)=-NCHS
          END IF
        END DO
C
        IF (ISNX.NE.0)
          NEXT=1
          CHEX=SCHX
          LEA1=5
          LEA2=5
          LEA3=3
          LEE1=1
          LEE2=2
          LEE3=0
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTPKLP (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C The routine CTPKLP is called to pick the label positions.
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
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTPKLP - 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 ('CTPKLP - 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('CTPKLP',3).NE.0) RETURN
C
C If the constant-field flag is set, do nothing.
C
        IF (ICFF.NE.0) RETURN
C
C If labels have already been positioned, don't do it again.
C
        IF (NLBS.NE.0) RETURN
C
C Make sure contour labels are completely defined.
C
        CALL CTPKLB (RPNT,IEDG,ITRI,RWRK,IWRK)
        IF (ICFELL('CTPKLP',4).NE.0) RETURN
        CALL CTSTLS (RPNT,IEDG,ITRI,RWRK,IWRK)
        IF (ICFELL('CTPKLP',5).NE.0) RETURN
C
C Save the index of the informational label.
C
        INIL=NLBS+1
C
C Add the informational label, if any, to the list.
C
        CALL CTINLB (RPNT,IEDG,ITRI,RWRK,IWRK)
        IF (ICFELL('CTPKLP',6).NE.0) RETURN
C
C Save the index of the high/low labels.
C
        INHL=NLBS+1
C
C Add the high/low labels, if any, to the list.
C
        CALL CTHLLB (RPNT,IEDG,ITRI,RWRK,IWRK)
        IF (ICFELL('CTPKLP',7).NE.0) RETURN
C
C Save the index of the contour-line labels.
C
        INLL=NLBS+1
C
C If labels are not being positioned along the contour lines using the
C regular scheme or the penalty scheme, quit now.
C
        IF (ABS(IPLL).NE.2.AND.ABS(IPLL).NE.3) RETURN
C
C If it will be needed, compute the array of gradients.
C
        IF (ABS(IPLL).EQ.3.AND.(WTGR.GT.0..OR.WTNC.GT.0.))
          RWTH=(XVPR-XVPL)/(YVPT-YVPB)
          IGRM=MAX(10,INT(SQRT(RWTH*REAL(LRWG))))
          IGRN=MAX(10,LRWG/IGRM)
          CALL CTGRWS (RWRK,2,IGRM*IGRN,IWSE)
          IF (IWSE.NE.0.OR.ICFELL('CTPKLP',8).NE.0) RETURN
          CALL CTCPAG (RPNT,IEDG,ITRI,RWRK)
          IF (ICFELL('CTPKLP',9).NE.0) RETURN
        END IF
C
C If the label-positioning flag is positive, force 2D smoothing off
C temporarily.
C
        IF (IPLL.GT.0)
          S2DS=T2DS
          T2DS=0.
        END IF
C
C Trace all the contour lines, positioning labels along each.
C
        FOR (ICLW = 1 TO NCLV)
          IF (CLEV(ICLW).GT.DMIN.AND.CLEV(ICLW).LT.DMAX)
            ICLV=ICLP(ICLW)
            IF (MOD(ICLU(ICLV)/2,2).NE.0)
              IJMP=0
              LOOP
                CALL CTTRCL (RPNT,IEDG,ITRI,RWRK,IWRK,CLEV(ICLV),IJMP,
     +                                                 IRW1,IRW2,NRWK)
                IF (ICFELL('CTPKLP',10).NE.0) RETURN
                EXIT IF (IJMP.EQ.0)
                IF (ABS(IPLL).EQ.2)
                  CALL CTPLAR (RWRK,IRW1,IRW2,NRWK)
                  IF (ICFELL('CTPKLP',11).NE.0) RETURN
                ELSE
                  CALL CTPLPS (RWRK,IRW1,IRW2,NRWK)
                  IF (ICFELL('CTPKLP',12).NE.0) RETURN
                END IF
              END LOOP
            END IF
          END IF
        END FOR
C
C If the label-positioning flag is positive, restore 2D smoothing to
C its original state.
C
        IF (IPLL.GT.0)
          T2DS=S2DS
        END IF
C
C Release the space used for the gradient array, if any.
C
        LR02=0
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTRSET
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 CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTRSET - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Reset individual parameters.
C
        ANCF=0.
        ANHL=0.
        ANIL=0.
        ANLL=0.
        CDMX=60.
        CHWM=1.
        CINS=0.
        CINU=0.
        CTMA=' '
        CTMB=' '
        CXCF=.50
        CYCF=.50
        CXIL=.98
        CYIL=-.02
        DBLF=.25
        DBLM=.30
        DBLN=.25
        DBLV=.05
        DFLD=.15
        DMAX=0.
        DMIN=0.
        DOPT=.05
        DVAL=0.
        FNCM=5.
        GSDM=1.
        HCHL=.004
        HCHS=.010
        HLSR=.075
        IBCF=0
        IBHL=0
        IBIL=0
        IBLL=0
        ICAF=0
        ICCF=-1
        ICFF=0
        ICHI=-1
        ICHL=-1
        ICIL=-1
        ICLO=-1
        ICLS=16
        IDUF=3
        IGCL=3
        IGLB=3
        IGVS=4
        IHCF=0
        IHLE=0
        IIWU=0
        ILBC=0
        IMPF=0
        INIT=0
        IOHL=3
        IOLL=0
        IPAI=0
        IPCF=0
        IPIC=0
        IPIE=0
        IPIL=4
        IPLL=1
        IRWU=0
        ISET=1
        ITBM=1
        IWSO=1
        LCTM=1
        LINS=5
        LINU=0
        LIWB=2500
        LIWM=10
        LRWC=1000
        LRWM=100
        LRWG=1000
        LTCF=31
        LTHI=12
        LTIL=36
        LTLO=12
        MIRO=0
        NCLV=0
        NEXL=0
        NEXT=1
        NEXU=5
        NLBS=0
        NLSD=1
        NLZF=0
        NOMF=6
        NOVS=1
        NSDL=4
        OORV=0.
        PITH=0.
        SCFS=1.
        SCFU=1.
        SEGL=.01
        T2DS=0.
        TXCF='CONSTANT FIELD - VALUE IS $DVA$'
        TXHI='H:B:$DVA$:E:'
        TXIL='CONTOUR FROM $CMN$ TO $CMX$ BY $CIU$'
        TXLO='L:B:$DVA$:E:'
        UCMN=1.
        UCMX=0.
        UVPL=.05
        UVPR=.95
        UVPB=.05
        UVPT=.95
        UVPS=.25
        UWDL=0.
        UWDR=0.
        UWDB=0.
        UWDT=0.
        WCCF=.012
        WCHL=.012
        WCIL=.012
        WCLL=.010
        WLCF=0.
        WLHL=0.
        WLIL=0.
        WLLL=0.
        WOCH=.010
        WODA=.005
        WTCD=1.
        WTGR=2.
        WTNC=0.
        WTOD=1.
        WWCF=.005
        WWHL=.005
        WWIL=.005
        WWLL=.005
        XLBC=0.
        XMAX=0.
        XMIN=0.
        YLBC=0.
        YMAX=0.
        YMIN=0.
        ZMAX=0.
        ZMIN=0.
C
C Reset parameter array elements.
C
        CINT(1)=1.
        CINT(2)=2.
        CINT(3)=2.5
        CINT(4)=4.
        CINT(5)=5.
        DO (I=6,10)
          CINT(I)=0.
        END DO
        DO (I=1,$NCLV$)
          CLBL(I)=' '
          CLEV(I)=0.
          IAIA(I)=0
          IAIB(I)=0
          ICCL(I)=0
          ICLL(I)=-1
        END DO
        IAIA($NCP1$)=0
        IAIA($NCP2$)=-1
        ICCL($NCP1$)=-1
        ICCL($NCP2$)=-1
        DO (I=1,$NCP2$)
          CLDP(I)='$$$$$$$$$$$$$$$$'
          CLWA(I)=0.
          ICLU(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
        LINT(1)=5
        LINT(2)=5
        LINT(3)=4
        LINT(4)=5
        LINT(5)=5
        DO (I=6,10)
          LINT(I)=0
        END DO
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTSETC (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 CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTSETC - 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)='CTSETC - 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.'CLD'.OR.WHCH(1:3).EQ.'cld')
          IF (IPAI.GE.1.AND.IPAI.LE.NCLV)
            JPAI=IPAI
          ELSE IF (IPAI.LE.-1.AND.IPAI.GE.-3)
            JPAI=$NCLV$+ABS(IPAI)
          ELSE
            INVOKE (PAI-INCORRECT,NR)
          END IF
        ELSE IF (WHCH(1:3).EQ.'LLT'.OR.WHCH(1:3).EQ.'llt')
          IF (IPAI.LT.1.OR.IPAI.GT.NCLV)
            INVOKE (PAI-INCORRECT,NR)
          END IF
        END IF
C
        BLOCK (PAI-INCORRECT,NR)
          CTMB(1:36)='CTSETC - SETTING XXX - PAI INCORRECT'
          CTMB(18:20)=WHCH(1:3)
          CALL SETER (CTMB(1:36),3,1)
          RETURN
        END BLOCK
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.'CFT'.OR.WHCH(1:3).EQ.'cft')
          TXCF=CVAL
          LTCF=MAX(1,MIN(40,LCVL))
        ELSE IF (WHCH(1:3).EQ.'CLD'.OR.WHCH(1:3).EQ.'cld')
          CLDP(JPAI)=CVAL
        ELSE 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.'HIT'.OR.WHCH(1:3).EQ.'hit')
          TXHI=CVAL
          LTHI=MAX(1,MIN(20,LCVL))
        ELSE IF (WHCH(1:3).EQ.'HLT'.OR.WHCH(1:3).EQ.'hlt')
          TXHI=' '
          LTHI=1
          TXLO=' '
          LTLO=1
          LCVL=LEN(CVAL)
          IF (LCVL.GT.0.AND.CVAL.NE.' ')
            DO (I=1,LCVL)
              IF (CVAL(I:I).EQ.'''')
                IF (I.NE.1.AND.CVAL(1:I-1).NE.' ')
                  TXHI=CVAL(1:I-1)
                  LTHI=MIN(20,I-1)
                END IF
                IF (I.NE.LCVL.AND.CVAL(I+1:LCVL).NE.' ')
                  TXLO=CVAL(I+1:LCVL)
                  LTLO=MIN(20,LCVL-I)
                END IF
                GO TO 101
              END IF
            END DO
            TXHI=CVAL
            LTHI=MAX(1,MIN(20,LCVL))
            TXLO=CVAL
            LTLO=MAX(1,MIN(20,LCVL))
          END IF
        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.'LLT'.OR.WHCH(1:3).EQ.'llt')
          CLBL(IPAI)=CVAL
          NCLB(IPAI)=-LCVL
        ELSE IF (WHCH(1:3).EQ.'LOT'.OR.WHCH(1:3).EQ.'lot')
          TXLO=CVAL
          LTLO=MAX(1,MIN(20,LCVL))
        ELSE
          CTMB(1:36)='CTSETC - PARAMETER NAME NOT KNOWN - '
          CTMB(37:39)=WHCH(1:3)
          CALL SETER (CTMB(1:39),4,1)
          RETURN
        END IF
C
C Done.
C
  101   RETURN
C
      END


      SUBROUTINE CTSETI (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 CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C ------------------------------------------------------------------
C RLB 3/2010: Previously the integer parameter was converted to a float
C   and the work was delegated off to CTSETR. This provided a sort
C   of "automatic type conversion", allowing the user to set a real
C   parameter using either ctseti() or ctsetr(), as in:
C        CALL CTSETI ('xxx',-9999)
C     or
C        CALL CTSETR ('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 CTSETR.
C -------------------------------------------------------
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTSETI - 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)='CTSETI - 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.'AIA'.OR.WHCH(1:3).EQ.'aia'.OR.
     +      WHCH(1:3).EQ.'CLC'.OR.WHCH(1:3).EQ.'clc'.OR.
     +      WHCH(1:3).EQ.'CLD'.OR.WHCH(1:3).EQ.'cld'.OR.
     +      WHCH(1:3).EQ.'CLL'.OR.WHCH(1:3).EQ.'cll'.OR.
     +      WHCH(1:3).EQ.'CLU'.OR.WHCH(1:3).EQ.'clu')
          IF (IPAI.GE.1.AND.IPAI.LE.NCLV)
            JPAI=IPAI
          ELSE IF (IPAI.LE.-1.AND.IPAI.GE.-3)
            JPAI=$NCLV$+ABS(IPAI)
          ELSE
            INVOKE (PAI-INCORRECT,NR)
          END IF
        ELSE IF ((WHCH(1:3).EQ.'AIB'.OR.WHCH(1:3).EQ.'aib'.OR.
     +            WHCH(1:3).EQ.'CLV'.OR.WHCH(1:3).EQ.'clv'.OR.
     +            WHCH(1:3).EQ.'LLC'.OR.WHCH(1:3).EQ.'llc').AND.
     +           (IPAI.LT.1.OR.IPAI.GT.NCLV))
          INVOKE (PAI-INCORRECT,NR)
        ELSE IF ((WHCH(1:3).EQ.'CIT'.OR.WHCH(1:3).EQ.'cit'.OR.
     +            WHCH(1:3).EQ.'LIT'.OR.WHCH(1:3).EQ.'lit').AND.
     +           (IPAI.LT.1.OR.IPAI.GT.10))
          INVOKE (PAI-INCORRECT,NR)
        END IF
C
        BLOCK (PAI-INCORRECT,NR)
          CTMB(1:36)='CTSETI - SETTING XXX - PAI INCORRECT'
          CTMB(18:20)=WHCH(1:3)
          CALL SETER (CTMB(1:36),3,1)
          RETURN
        END BLOCK
C
C Set the appropriate parameter value.
C
        IF      (WHCH(1:3).EQ.'AIA'.OR.WHCH(1:3).EQ.'aia')
          IAIA(JPAI)=IVAL
        ELSE IF (WHCH(1:3).EQ.'AIB'.OR.WHCH(1:3).EQ.'aib')
          IAIB(IPAI)=IVAL
        ELSE IF (WHCH(1:3).EQ.'CAF'.OR.WHCH(1:3).EQ.'caf')
          ICAF=IVAL
        ELSE IF (WHCH(1:3).EQ.'CFB'.OR.WHCH(1:3).EQ.'cfb')
          IBCF=MAX(0,MIN(3,IVAL))
        ELSE IF (WHCH(1:3).EQ.'CFC'.OR.WHCH(1:3).EQ.'cfc')
          ICCF=MAX(-1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'CFP'.OR.WHCH(1:3).EQ.'cfp')
          IPCF=MAX(-4,MIN(4,IVAL))
        ELSE IF (WHCH(1:3).EQ.'CLC'.OR.WHCH(1:3).EQ.'clc')
          ICCL(JPAI)=MAX(-1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'CLD'.OR.WHCH(1:3).EQ.'cld')
          CLDP(JPAI)=' '
          ITMP=IVAL
          DO (I=16,1,-1)
            IF (IAND(ITMP,1).NE.0)
              CLDP(JPAI)(I:I)='$'
            ELSE
              CLDP(JPAI)(I:I)=''''
            END IF
            ITMP=ISHIFT(ITMP,-1)
          END DO
        ELSE IF (WHCH(1:3).EQ.'CLS'.OR.WHCH(1:3).EQ.'cls')
          ICLS=IVAL
        ELSE IF (WHCH(1:3).EQ.'CLU'.OR.WHCH(1:3).EQ.'clu')
          ICLU(JPAI)=MAX(0,MIN(3,IVAL))
        ELSE IF (WHCH(1:3).EQ.'DPU'.OR.WHCH(1:3).EQ.'dpu')
          IDUF=IVAL
        ELSE IF (WHCH(1:3).EQ.'GIC'.OR.WHCH(1:3).EQ.'gic')
          IGCL=MAX(1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'GIL'.OR.WHCH(1:3).EQ.'gil')
          IGLB=MAX(1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'GIS'.OR.WHCH(1:3).EQ.'gis')
          IGVS=MAX(1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'HCF'.OR.WHCH(1:3).EQ.'hcf')
          IHCF=MAX(-4,MIN(+4,IVAL))
        ELSE IF (WHCH(1:3).EQ.'HIC'.OR.WHCH(1:3).EQ.'hic')
          ICHI=MAX(-1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'HLB'.OR.WHCH(1:3).EQ.'hlb')
          IBHL=MAX(0,MIN(3,IVAL))
        ELSE IF (WHCH(1:3).EQ.'HLC'.OR.WHCH(1:3).EQ.'hlc')
          ICHL=MAX(-1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'HLE'.OR.WHCH(1:3).EQ.'hle')
          IHLE=MAX(0,IVAL)
        ELSE IF (WHCH(1:3).EQ.'HLO'.OR.WHCH(1:3).EQ.'hlo')
          IOHL=MAX(0,MIN(15,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.'IWB'.OR.WHCH(1:3).EQ.'iwb')
          LIWB=MAX(1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'IWM'.OR.WHCH(1:3).EQ.'iwm')
          LIWM=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.'LIS'.OR.WHCH(1:3).EQ.'lis')
          LINS=MAX(1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'LIT'.OR.WHCH(1:3).EQ.'lit')
          LINT(IPAI)=MAX(1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'LLB'.OR.WHCH(1:3).EQ.'llb')
          IBLL=MAX(0,MIN(3,IVAL))
        ELSE IF (WHCH(1:3).EQ.'LLC'.OR.WHCH(1:3).EQ.'llc')
          ICLL(IPAI)=MAX(-1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'LLO'.OR.WHCH(1:3).EQ.'llo')
          IOLL=MAX(0,MIN(1,IVAL))
        ELSE IF (WHCH(1:3).EQ.'LLP'.OR.WHCH(1:3).EQ.'llp')
          IPLL=MAX(-3,MIN(3,IVAL))
        ELSE IF (WHCH(1:3).EQ.'LOC'.OR.WHCH(1:3).EQ.'loc')
          ICLO=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.'NCL'.OR.WHCH(1:3).EQ.'ncl')
          NCLV=IVAL
          IF (NCLV.LT.1.OR.NCLV.GT.$NCLV$)
            CALL SETER ('CTSETI - NCL LESS THAN 1 OR GREATER THAN $NCLV$
     +',4,1)
          RETURN
          END IF
        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.'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.'NVS'.OR.WHCH(1:3).EQ.'nvs')
          NOVS=MAX(0,IVAL)
        ELSE IF (WHCH(1:3).EQ.'PAI'.OR.WHCH(1:3).EQ.'pai')
          IPAI=IVAL
        ELSE IF (WHCH(1:3).EQ.'PIC'.OR.WHCH(1:3).EQ.'pic')
          IPIC=IVAL
        ELSE IF (WHCH(1:3).EQ.'PIE'.OR.WHCH(1:3).EQ.'pie')
          IPIE=IVAL
        ELSE IF (WHCH(1:3).EQ.'RWC'.OR.WHCH(1:3).EQ.'rwc')
          LRWC=MAX(5,IVAL)
        ELSE IF (WHCH(1:3).EQ.'RWG'.OR.WHCH(1:3).EQ.'rwg')
          LRWG=MAX(1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'RWM'.OR.WHCH(1:3).EQ.'rwm')
          LRWM=MAX(2,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.'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.'WSO'.OR.WHCH(1:3).EQ.'wso')
          IWSO=MAX(0,MIN(3,IVAL))
        ELSE
C         Float the integer value and pass it on to CTSETR.
          RVAL=REAL(IVAL)
          CALL CTSETR (WHCH,RVAL)
          IF (ICFELL('CTSETI',2).NE.0) RETURN
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTSETR (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 CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CTSETR - 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)='CTSETR - 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.'AIA'.OR.WHCH(1:3).EQ.'aia'.OR.
     +      WHCH(1:3).EQ.'CLC'.OR.WHCH(1:3).EQ.'clc'.OR.
     +      WHCH(1:3).EQ.'CLD'.OR.WHCH(1:3).EQ.'cld'.OR.
     +      WHCH(1:3).EQ.'CLL'.OR.WHCH(1:3).EQ.'cll'.OR.
     +      WHCH(1:3).EQ.'CLU'.OR.WHCH(1:3).EQ.'clu')
          IF (IPAI.GE.1.AND.IPAI.LE.NCLV)
            JPAI=IPAI
          ELSE IF (IPAI.LE.-1.AND.IPAI.GE.-3)
            JPAI=$NCLV$+ABS(IPAI)
          ELSE
            INVOKE (PAI-INCORRECT,NR)
          END IF
        ELSE IF ((WHCH(1:3).EQ.'AIB'.OR.WHCH(1:3).EQ.'aib'.OR.
     +            WHCH(1:3).EQ.'CLV'.OR.WHCH(1:3).EQ.'clv'.OR.
     +            WHCH(1:3).EQ.'LLC'.OR.WHCH(1:3).EQ.'llc').AND.
     +           (IPAI.LT.1.OR.IPAI.GT.NCLV))
          INVOKE (PAI-INCORRECT,NR)
        ELSE IF ((WHCH(1:3).EQ.'CIT'.OR.WHCH(1:3).EQ.'cit'.OR.
     +            WHCH(1:3).EQ.'LIT'.OR.WHCH(1:3).EQ.'lit').AND.
     +           (IPAI.LT.1.OR.IPAI.GT.10))
          INVOKE (PAI-INCORRECT,NR)
        END IF
C
        BLOCK (PAI-INCORRECT,NR)
          CTMB(1:36)='CTSETR - SETTING XXX - PAI INCORRECT'
          CTMB(18:20)=WHCH(1:3)
          CALL SETER (CTMB(1:36),3,1)
          RETURN
        END BLOCK
C
C Set the appropriate parameter value.
C
        IF      (WHCH(1:3).EQ.'AIA'.OR.WHCH(1:3).EQ.'aia')
          IAIA(JPAI)=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'AIB'.OR.WHCH(1:3).EQ.'aib')
          IAIB(IPAI)=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'CAF'.OR.WHCH(1:3).EQ.'caf')
          ICAF=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'CFA'.OR.WHCH(1:3).EQ.'cfa')
          ANCF=RVAL
        ELSE IF (WHCH(1:3).EQ.'CFB'.OR.WHCH(1:3).EQ.'cfb')
          IBCF=MAX(0,MIN(3,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'CFC'.OR.WHCH(1:3).EQ.'cfc')
          ICCF=MAX(-1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'CFL'.OR.WHCH(1:3).EQ.'cfl')
          WLCF=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'CFP'.OR.WHCH(1:3).EQ.'cfp')
          IPCF=MAX(-4,MIN(4,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'CFS'.OR.WHCH(1:3).EQ.'cfs')
          WCCF=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'CFW'.OR.WHCH(1:3).EQ.'cfw')
          WWCF=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'CFX'.OR.WHCH(1:3).EQ.'cfx')
          CXCF=RVAL
        ELSE IF (WHCH(1:3).EQ.'CFY'.OR.WHCH(1:3).EQ.'cfy')
          CYCF=RVAL
        ELSE IF (WHCH(1:3).EQ.'CIS'.OR.WHCH(1:3).EQ.'cis')
          CINS=RVAL
        ELSE IF (WHCH(1:3).EQ.'CIT'.OR.WHCH(1:3).EQ.'cit')
          CINT(IPAI)=RVAL
        ELSE IF (WHCH(1:3).EQ.'CIU'.OR.WHCH(1:3).EQ.'ciu')
          CINU=RVAL
        ELSE IF (WHCH(1:3).EQ.'CLC'.OR.WHCH(1:3).EQ.'clc')
          ICCL(JPAI)=MAX(-1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'CLD'.OR.WHCH(1:3).EQ.'cld')
          CLDP(JPAI)=' '
          ITMP=INT(RVAL)
          DO (I=16,1,-1)
            IF (IAND(ITMP,1).NE.0)
              CLDP(JPAI)(I:I)='$'
            ELSE
              CLDP(JPAI)(I:I)=''''
            END IF
            ITMP=ISHIFT(ITMP,-1)
          END DO
        ELSE IF (WHCH(1:3).EQ.'CLL'.OR.WHCH(1:3).EQ.'cll')
          CLWA(JPAI)=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'CLS'.OR.WHCH(1:3).EQ.'cls')
          ICLS=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'CLU'.OR.WHCH(1:3).EQ.'clu')
          ICLU(JPAI)=MAX(0,MIN(3,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'CLV'.OR.WHCH(1:3).EQ.'clv')
          CLEV(IPAI)=RVAL
          ICLU(IPAI)=1
          IAIA(IPAI)=IPAI+1
          IAIB(IPAI)=IPAI
          CLBL(IPAI)=' '
          NCLB(IPAI)=-1
          CLDP(IPAI)='$$$$$$$$$$$$$$$$'
          ICCL(IPAI)=-1
          ICLL(IPAI)=-1
          CLWA(IPAI)=0.
          IF (IPAI.EQ.1) CINU=0.
        ELSE IF (WHCH(1:3).EQ.'CMN'.OR.WHCH(1:3).EQ.'cmn')
          UCMN=RVAL
        ELSE IF (WHCH(1:3).EQ.'CMX'.OR.WHCH(1:3).EQ.'cmx')
          UCMX=RVAL
        ELSE IF (WHCH(1:3).EQ.'CWM'.OR.WHCH(1:3).EQ.'cwm')
          CHWM=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'DPS'.OR.WHCH(1:3).EQ.'dps')
          WOCH=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'DPU'.OR.WHCH(1:3).EQ.'dpu')
          IDUF=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'DPV'.OR.WHCH(1:3).EQ.'dpv')
          WODA=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'DVA'.OR.WHCH(1:3).EQ.'dva')
          DVAL=RVAL
        ELSE IF (WHCH(1:3).EQ.'GIC'.OR.WHCH(1:3).EQ.'gic')
          IGCL=MAX(1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'GIL'.OR.WHCH(1:3).EQ.'gil')
          IGLB=MAX(1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'GIS'.OR.WHCH(1:3).EQ.'gis')
          IGVS=MAX(1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'HCF'.OR.WHCH(1:3).EQ.'hcf')
          IHCF=MAX(-4,MIN(+4,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'HCL'.OR.WHCH(1:3).EQ.'hcl')
          HCHL=RVAL
        ELSE IF (WHCH(1:3).EQ.'HCS'.OR.WHCH(1:3).EQ.'hcs')
          HCHS=MAX(.0001,MIN(10.,RVAL))
        ELSE IF (WHCH(1:3).EQ.'HIC'.OR.WHCH(1:3).EQ.'hic')
          ICHI=MAX(-1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'HLA'.OR.WHCH(1:3).EQ.'hla')
          ANHL=RVAL
        ELSE IF (WHCH(1:3).EQ.'HLB'.OR.WHCH(1:3).EQ.'hlb')
          IBHL=MAX(0,MIN(3,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'HLC'.OR.WHCH(1:3).EQ.'hlc')
          ICHL=MAX(-1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'HLE'.OR.WHCH(1:3).EQ.'hle')
          IHLE=MAX(0,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'HLL'.OR.WHCH(1:3).EQ.'hll')
          WLHL=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'HLO'.OR.WHCH(1:3).EQ.'hlo')
          IOHL=MAX(0,MIN(15,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'HLR'.OR.WHCH(1:3).EQ.'hlr')
          HLSR=RVAL
        ELSE IF (WHCH(1:3).EQ.'HLS'.OR.WHCH(1:3).EQ.'hls')
          WCHL=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'HLW'.OR.WHCH(1:3).EQ.'hlw')
          WWHL=MAX(0.,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.'IWB'.OR.WHCH(1:3).EQ.'iwb')
          LIWB=MAX(1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'IWM'.OR.WHCH(1:3).EQ.'iwm')
          LIWM=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.'LIS'.OR.WHCH(1:3).EQ.'lis')
          LINS=MAX(1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'LIT'.OR.WHCH(1:3).EQ.'lit')
          LINT(IPAI)=MAX(1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'LLA'.OR.WHCH(1:3).EQ.'lla')
          ANLL=RVAL
        ELSE IF (WHCH(1:3).EQ.'LLB'.OR.WHCH(1:3).EQ.'llb')
          IBLL=MAX(0,MIN(3,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'LLC'.OR.WHCH(1:3).EQ.'llc')
          ICLL(IPAI)=MAX(-1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'LLL'.OR.WHCH(1:3).EQ.'lll')
          WLLL=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'LLO'.OR.WHCH(1:3).EQ.'llo')
          IOLL=MAX(0,MIN(1,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'LLP'.OR.WHCH(1:3).EQ.'llp')
          IPLL=MAX(-3,MIN(3,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'LLS'.OR.WHCH(1:3).EQ.'lls')
          WCLL=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'LLW'.OR.WHCH(1:3).EQ.'llw')
          WWLL=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'LOC'.OR.WHCH(1:3).EQ.'loc')
          ICLO=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.'NCL'.OR.WHCH(1:3).EQ.'ncl')
          NCLV=INT(RVAL)
          IF (NCLV.LT.1.OR.NCLV.GT.$NCLV$)
            CALL SETER ('CTSETR - NCL LESS THAN 1 OR GREATER THAN $NCLV$
     +',4,1)
          RETURN
          END IF
        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.'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.'NVS'.OR.WHCH(1:3).EQ.'nvs')
          NOVS=MAX(0,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.'PC1'.OR.WHCH(1:3).EQ.'pc1')
          GSDM=RVAL
        ELSE IF (WHCH(1:3).EQ.'PC2'.OR.WHCH(1:3).EQ.'pc2')
          FNCM=RVAL
        ELSE IF (WHCH(1:3).EQ.'PC3'.OR.WHCH(1:3).EQ.'pc3')
          CDMX=RVAL
        ELSE IF (WHCH(1:3).EQ.'PC4'.OR.WHCH(1:3).EQ.'pc4')
          DOPT=RVAL
        ELSE IF (WHCH(1:3).EQ.'PC5'.OR.WHCH(1:3).EQ.'pc5')
          DFLD=RVAL
        ELSE IF (WHCH(1:3).EQ.'PC6'.OR.WHCH(1:3).EQ.'pc6')
          DBLM=RVAL
        ELSE IF (WHCH(1:3).EQ.'PIC'.OR.WHCH(1:3).EQ.'pic')
          IPIC=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'PIE'.OR.WHCH(1:3).EQ.'pie')
          IPIE=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'PIT'.OR.WHCH(1:3).EQ.'pit')
          PITH=RVAL
        ELSE IF (WHCH(1:3).EQ.'PW1'.OR.WHCH(1:3).EQ.'pw1')
          WTGR=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'PW2'.OR.WHCH(1:3).EQ.'pw2')
          WTNC=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'PW3'.OR.WHCH(1:3).EQ.'pw3')
          WTCD=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'PW4'.OR.WHCH(1:3).EQ.'pw4')
          WTOD=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'RC1'.OR.WHCH(1:3).EQ.'rc1')
          DBLF=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'RC2'.OR.WHCH(1:3).EQ.'rc2')
          DBLN=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'RC3'.OR.WHCH(1:3).EQ.'rc3')
          DBLV=MAX(0.,RVAL)
        ELSE IF (WHCH(1:3).EQ.'RWC'.OR.WHCH(1:3).EQ.'rwc')
          LRWC=MAX(5,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'RWG'.OR.WHCH(1:3).EQ.'rwg')
          LRWG=MAX(1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'RWM'.OR.WHCH(1:3).EQ.'rwm')
          LRWM=MAX(2,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.'SSL'.OR.WHCH(1:3).EQ.'ssl')
          SEGL=MAX(.0001,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.'T2D'.OR.WHCH(1:3).EQ.'t2d')
          T2DS=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.'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
          CTMB(1:36)='CTSETR - PARAMETER NAME NOT KNOWN - '
          CTMB(37:39)=WHCH(1:3)
          CALL SETER (CTMB(1:39),5,1)
          RETURN
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTTMRG (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, CTTMRG 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 CTTMRG to determine the
C mapping of the indices of the mesh.  It must be declared EXTERNAL in
C the routine that calls CTTMRG.  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 (12/01/2006) In order to make this routine more efficient, I have had
C to impose the following condition on the behavior of RTMI.  It must
C be the case that IINO is returned less than or equal to IINI and that
C JINO is returned less than or equal to JINI.  I think this has been
C the case for every version of it that I have written and I think it
C should always be possible to satisfy this condition.
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('CTTMRG - 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 upper left to lower
C right on cells of one "color" and that from lower left to upper 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 and that the diagonal always be
C the third edge of each triangle processed.
C
                IF (MOD(I+J,2).EQ.0)
                  IF (K.EQ.0)
                    INI1=I
                    INJ1=J+1
                    INI2=I
                    INJ2=J
                    INI3=I+1
                    INJ3=J
                  ELSE
                    INI1=I+1
                    INJ1=J
                    INI2=I+1
                    INJ2=J+1
                    INI3=I
                    INJ3=J+1
                  END IF
                ELSE
                  IF (K.EQ.0)
                    INI1=I+1
                    INJ1=J+1
                    INI2=I
                    INJ2=J+1
                    INI3=I
                    INJ3=J
                  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
C for 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 104
                IF (IOI2.EQ.IOI3.AND.IOJ2.EQ.IOJ3) GO TO 104
                IF (IOI3.EQ.IOI1.AND.IOJ3.EQ.IOJ1) GO TO 104
C
C Skip the triangle if its points all lie too nearly on the same great
C circle.  The code actually checks each of the three angles in the
C triangle and skips it if any of those angles are too small or too
C large.  There's probably a more efficient way to do this.
C
                ANGL=CTABGC(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 104
C
                ANGL=CTABGC(RLAT(IOI2,IOJ2),RLON(IOI2,IOJ2),
     +                      RLAT(IOI3,IOJ3),RLON(IOI3,IOJ3),
     +                      RLAT(IOI1,IOJ1),RLON(IOI1,IOJ1))
C
                IF (ANGL.LT..1.OR.ANGL.GT.179.9) GO TO 104
C
                ANGL=CTABGC(RLAT(IOI3,IOJ3),RLON(IOI3,IOJ3),
     +                      RLAT(IOI1,IOJ1),RLON(IOI1,IOJ1),
     +                      RLAT(IOI2,IOJ2),RLON(IOI2,IOJ2))
C
                IF (ANGL.LT..1.OR.ANGL.GT.179.9) GO TO 104
C
C Deal with the first point of the triangle, being careful not to put
C the point into the structure more than once; that way, we can test to
C see if two edges contain the same point by looking only at pointers -
C we don't have to look at coordinates.  The first time we process a
C point having mapped indices (IOI1,IOJ1), we save the base address of
C the node in the point list where information about the point was put;
C subsequently, when we process that point again, we can just use the
C saved base address.
C
                IF (ISCR(IOI1,IOJ1,4).GE.0)
                  IPP1=ISCR(IOI1,IOJ1,4)
                ELSE IF (NPNT+LOPN.GT.MPNT)
                  CALL SETER ('CTTMRG - 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 ('CTTMRG - 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 ('CTTMRG - 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 Just as we are careful not to put a point into the structure more
C than once, we are careful not to put an edge into it more than once,
C so that two triangles sharing an edge will have pointers to the same
C edge.
C
                INIM=MIN(INI1,INI2)
                INJM=MIN(INJ1,INJ2)
C
                IF (INI1.EQ.INI2)
                  INTY=1
                ELSE
                  INTY=2
                END IF
C
                IF (ISCR(INIM,INJM,INTY).GE.0)
                  IPE1=ISCR(INIM,INJM,INTY)
                  IEDG(IPE1+4)=NTRI+1
                  GO TO 101
                END IF
C
                IF (ABS(IOI1-IOI2).LE.1.AND.ABS(IOJ1-IOJ2).LE.1)
                  IOIM=MIN(IOI1,IOI2)
                  IOJM=MIN(IOJ1,IOJ2)
                  IF (IOI1.EQ.IOI2)
                    IOTY=1
                  ELSE IF (IOJ1.EQ.IOJ2)
                    IOTY=2
                  ELSE
                    IOTY=3
                  END IF
                  IF (ISCR(IOIM,IOJM,IOTY).GE.0)
                    IPE1=ISCR(IOIM,IOJM,IOTY)
                    IEDG(IPE1+4)=NTRI+1
                    GO TO 101
                  END IF
                END IF
C
                IF (NEDG+LOEN.GT.MEDG)
                  CALL SETER ('CTTMRG - EDGE ARRAY IS TOO SMALL',5,1)
                  RETURN
                ELSE
                  IPE1=NEDG
                  IEDG(IPE1+1)=IPP1
                  IEDG(IPE1+2)=IPP2
                  IEDG(IPE1+3)=NTRI+1
                  IEDG(IPE1+4)=-1
                  ISCR(INIM,INJM,INTY)=IPE1
                  NEDG=NEDG+LOEN
                END IF
C
C Deal with the second edge of the triangle (joining points 2 and 3).
C
  101           INIM=MIN(INI2,INI3)
                INJM=MIN(INJ2,INJ3)
C
                IF (INI2.EQ.INI3)
                  INTY=1
                ELSE
                  INTY=2
                END IF
C
                IF (ISCR(INIM,INJM,INTY).GE.0)
                  IPE2=ISCR(INIM,INJM,INTY)
                  IEDG(IPE2+4)=NTRI+2
                  GO TO 102
                END IF
C
                IF (ABS(IOI2-IOI3).LE.1.AND.ABS(IOJ2-IOJ3).LE.1)
                  IOIM=MIN(IOI2,IOI3)
                  IOJM=MIN(IOJ2,IOJ3)
                  IF (IOI2.EQ.IOI3)
                    IOTY=1
                  ELSE IF (IOJ2.EQ.IOJ3)
                    IOTY=2
                  ELSE
                    IOTY=3
                  END IF
                  IF (ISCR(IOIM,IOJM,IOTY).GE.0)
                    IPE2=ISCR(IOIM,IOJM,IOTY)
                    IEDG(IPE2+4)=NTRI+2
                    GO TO 102
                  END IF
                END IF
C
                IF (NEDG+LOEN.GT.MEDG)
                  CALL SETER ('CTTMRG - EDGE ARRAY IS TOO SMALL',6,1)
                  RETURN
                ELSE
                  IPE2=NEDG
                  IEDG(IPE2+1)=IPP2
                  IEDG(IPE2+2)=IPP3
                  IEDG(IPE2+3)=NTRI+2
                  IEDG(IPE2+4)=-1
                  ISCR(INIM,INJM,INTY)=IPE2
                  NEDG=NEDG+LOEN
                END IF
C
C Deal with the third edge of the triangle (joining points 3 and 1).
C All the diagonals of the original grid cells are processed here and
C the code is somewhat different because somewhat different things can
C happen to mapped diagonals than can happen to mapped horizontal and
C vertical segments.
C
  102           INIM=MIN(INI3,INI1)
                INJM=MIN(INJ3,INJ1)
C
                IF (ISCR(INIM,INJM,3).GE.0)
                  IPE3=ISCR(INIM,INJM,3)
                  IEDG(IPE3+4)=NTRI+3
                  GO TO 103
                END IF
C
                IF (ABS(IOI3-IOI1).LE.1.AND.ABS(IOJ3-IOJ1).LE.1)
                  IOIM=MIN(IOI3,IOI1)
                  IOJM=MIN(IOJ3,IOJ1)
                  IF (IOI3.EQ.IOI1)
                    IOTY=1
                  ELSE IF (IOJ3.EQ.IOJ1)
                    IOTY=2
                  ELSE
                    IOTY=3
                  END IF
                  IF (ISCR(IOIM,IOJM,IOTY).GE.0)
                    IPE3=ISCR(IOIM,IOJM,IOTY)
                    IEDG(IPE3+4)=NTRI+3
                    GO TO 103
                  END IF
                END IF
C
                IF ((I.EQ.1.OR.I.EQ.IDIM-1).AND.J.GT.1)
                  IF (ISCR(I,J-1,3).GE.0)
                    IF (IEDG(ISCR(I,J-1,3)+1).EQ.IPP1.AND.
     +                  IEDG(ISCR(I,J-1,3)+2).EQ.IPP3)
                      IPE3=ISCR(I,J-1,3)
                      IEDG(IPE3+4)=NTRI+3
                      GO TO 103
                    END IF
                  END IF
                END IF
C
                IF ((I.EQ.1.OR.I.EQ.IDIM-1).AND.J.EQ.JDIM-1)
                  IF (ISCR(I,1,3).GE.0)
                    IF (IEDG(ISCR(I,1,3)+1).EQ.IPP1.AND.
     +                  IEDG(ISCR(I,1,3)+2).EQ.IPP3)
                      IPE3=ISCR(I,1,3)
                      IEDG(IPE3+4)=NTRI+3
                      GO TO 103
                    END IF
                  END IF
                END IF
C
                IF ((J.EQ.1.OR.J.EQ.JDIM-1).AND.I.GT.1)
                  IF (ISCR(I-1,J,3).GE.0)
                    IF (IEDG(ISCR(I-1,J,3)+1).EQ.IPP1.AND.
     +                  IEDG(ISCR(I-1,J,3)+2).EQ.IPP3)
                      IPE3=ISCR(I-1,J,3)
                      IEDG(IPE3+4)=NTRI+3
                      GO TO 103
                    END IF
                  END IF
                END IF
C
                IF ((J.EQ.1.OR.J.EQ.JDIM-1).AND.I.EQ.IDIM-1)
                  IF (ISCR(1,J,3).GE.0)
                    IF (IEDG(ISCR(1,J,3)+1).EQ.IPP1.AND.
     +                  IEDG(ISCR(1,J,3)+2).EQ.IPP3)
                      IPE3=ISCR(1,J,3)
                      IEDG(IPE3+4)=NTRI+3
                      GO TO 103
                    END IF
                  END IF
                END IF
C
                IF (NEDG+LOEN.GT.MEDG)
                  CALL SETER ('CTTMRG - EDGE ARRAY IS TOO SMALL',7,1)
                  RETURN
                ELSE
                  IPE3=NEDG
                  IEDG(IPE3+1)=IPP3
                  IEDG(IPE3+2)=IPP1
                  IEDG(IPE3+3)=NTRI+3
                  IEDG(IPE3+4)=-1
                  ISCR(INIM,INJM,3)=IPE3
                  NEDG=NEDG+LOEN
                END IF
C
C Finally, add the triangle itself to the triangle list.
C
  103           IF (NTRI+LOTN.GT.MTRI)
                  CALL SETER ('CTTMRG - 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
  104         END DO
C
            END IF
C
          END DO
C
        END DO
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTTMTL (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(12,MBUF)
        DIMENSION IPPP(2,MPPP),IPPE(2,MPPE)
        DIMENSION RPNT(MPNT),IEDG(MEDG),ITRI(MTRI)
C
C The routine CTTMTL 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)*CTFRAN())))
C
C Use the function ICAPNT 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=(ICAPNT(TBUF( 1,IBUF),
     +                 TBUF( 2,IBUF),
     +                 TBUF( 3,IBUF),
     +                 TBUF( 4,IBUF),
     +                 RPNT,LOPN,IPPP,MPPP,NPPP)-1)*LOPN
C
          IF (ICFELL('CTTMTL',1).NE.0) RETURN
C
          IPP2=(ICAPNT(TBUF( 5,IBUF),
     +                 TBUF( 6,IBUF),
     +                 TBUF( 7,IBUF),
     +                 TBUF( 8,IBUF),
     +                 RPNT,LOPN,IPPP,MPPP,NPPP)-1)*LOPN
C
          IF (ICFELL('CTTMTL',2).NE.0) RETURN
C
          IPP3=(ICAPNT(TBUF( 9,IBUF),
     +                 TBUF(10,IBUF),
     +                 TBUF(11,IBUF),
     +                 TBUF(12,IBUF),
     +                 RPNT,LOPN,IPPP,MPPP,NPPP)-1)*LOPN
C
          IF (ICFELL('CTTMTL',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('CTTMTL',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('CTTMTL',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('CTTMTL',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 ('CTTMTL - 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 CTTMTX (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(12,MBUF)
        DIMENSION IPPP(3,MPPP),IPPE(2,MPPE)
        DIMENSION RPNT(MPNT),IEDG(MEDG),ITRI(MTRI)
C
C The routine CTTMTX 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)*CTFRAN())))
C
C Use the function ICAPNX 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=(ICAPNX(TBUF( 1,IBUF),
     +                 TBUF( 2,IBUF),
     +                 TBUF( 3,IBUF),
     +                 TBUF( 4,IBUF),
     +                 RPNT,LOPN,IPPP,MPPP,NPPP,EPST)-1)*LOPN
C
          IF (ICFELL('CTTMTX',1).NE.0) RETURN
C
          IPP2=(ICAPNX(TBUF( 5,IBUF),
     +                 TBUF( 6,IBUF),
     +                 TBUF( 7,IBUF),
     +                 TBUF( 8,IBUF),
     +                 RPNT,LOPN,IPPP,MPPP,NPPP,EPST)-1)*LOPN
C
          IF (ICFELL('CTTMTX',2).NE.0) RETURN
C
          IPP3=(ICAPNX(TBUF( 9,IBUF),
     +                 TBUF(10,IBUF),
     +                 TBUF(11,IBUF),
     +                 TBUF(12,IBUF),
     +                 RPNT,LOPN,IPPP,MPPP,NPPP,EPST)-1)*LOPN
C
          IF (ICFELL('CTTMTX',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('CTTMTX',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('CTTMTX',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('CTTMTX',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 ('CTTMTX - 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 C O N 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 HLUCTCHCF (IFLG)
C
C This routine stands between CONPACKT and the user call-back routine
C CTCHCF.  When HLUs are not in use, this version of the routine gets
C loaded, so that CTCHCF 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 CTCHCF.
C
        CALL CTCHCF (IFLG)
C
        RETURN
C
      END


      SUBROUTINE CTCHCF (IFLG)
C
C This routine is a dummy.  It is called just before and just after
C each action involving a constant-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 constant-field label
C   2 - filling the box around the constant-field label
C   3 - drawing the constant-field label
C   4 - outlining the box around the constant-field label
C
C When IFLG = 2, 3, or 4, CTCHCF 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 HLUCTCHCL (IFLG)
C
C This routine stands between CONPACKT and the user call-back routine
C CTCHCL.  When HLUs are not in use, this version of the routine gets
C loaded, so that CTCHCL 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 CTCHCL.
C
        CALL CTCHCL (IFLG)
C
        RETURN
C
      END


      SUBROUTINE CTCHCL (IFLG)
C
C This routine is a dummy.  It is called just before and just after each
C contour line is drawn.  A user version may be substituted to change
C dash pattern, color, and/or line width.
C
C IFLG is +1 if a contour line is about to be drawn, -1 if a contour
C line has just been drawn.
C
C When CTCHCL is called, the internal parameter 'PAI' will have been
C set to the index of the appropriate contour level.  Thus, parameters
C associated with that level may easily be retrieved by calls to CTGETx.
C
        RETURN
C
      END


      SUBROUTINE HLUCTCHHL (IFLG)
C
C This routine stands between CONPACKT and the user call-back routine
C CTCHHL.  When HLUs are not in use, this version of the routine gets
C loaded, so that CTCHHL 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 CTCHHL.
C
        CALL CTCHHL (IFLG)
C
        RETURN
C
      END


      SUBROUTINE CTCHHL (IFLG)
C
C This routine is a dummy.  It is called just before and just after
C each action involving a high/low label.  A user version may take
C action to change the label.
C
C IFLG is positive if an action is about to be taken, negative if the
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 a high label at a given point
C   2 - filling the box around the label for a high
C   3 - drawing the label for a high
C   4 - outlining the box around the label for a high
C   5 - deciding whether to put a low label at a given point
C   6 - filling the box around the label for a low
C   7 - drawing the label for a low
C   8 - outlining the box around the label for a low
C
C CTCHHL may retrieve the value of the internal parameter 'DVA', which
C is the value associated with the high or low being labelled.
C
C CTCHHL 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, 3, 5, or 7, CTCHHL is permitted to change the value
C of the internal parameter 'CTM' (a character string); if IFLG is 1 or
C 5 and 'CTM' is made blank, the label is suppressed; otherwise, the
C new value of 'CTM' will replace whatever CONPACKT was about to use.
C If this is done for either IFLG = 1 or IFLG = 3, it must be done for
C both, and the same replacement label must be supplied in both cases.
C Similarly, if it is done for either IFLG = 5 or IFLG = 7, it must be
C done for both, and the same replacement label must be specified in
C both cases.
C
C When IFLG = 2, 3, 4, 6, 7, or 8, CTCHHL may make GKS calls to change
C color or line width; during the following call with IFLG = -2, -3,
C -4, -6, -7, or -8, such changes should be undone.
C
        RETURN
C
      END


      SUBROUTINE HLUCTCHIL (IFLG)
C
C This routine stands between CONPACKT and the user call-back routine
C CTCHIL.  When HLUs are not in use, this version of the routine gets
C loaded, so that CTCHIL 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 CTCHIL.
C
        CALL CTCHIL (IFLG)
C
        RETURN
C
      END


      SUBROUTINE CTCHIL (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 CTCHIL 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, CTCHIL 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 CONPACKT 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, CTCHIL 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 HLUCTCHLL (IFLG)
C
C This routine stands between CONPACKT and the user call-back routine
C CTCHLL.  When HLUs are not in use, this version of the routine gets
C loaded, so that CTCHLL 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 CTCHLL.
C
        CALL CTCHLL (IFLG)
C
        RETURN
C
      END


      SUBROUTINE CTCHLL (IFLG)
C
C This routine is a dummy.  It is called just before and just after
C each action involving a contour line 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 a line label at a given point
C   2 - filling the box around a line label
C   3 - drawing a line label
C   4 - outlining the box around a line label
C
C When CTCHLL is called, the internal parameter 'PAI' will have been
C set to the index of the appropriate contour level.  Thus, parameters
C associated with that level may easily be retrieved by calls to CTGETx.
C
C CTCHLL may retrieve the value of the internal parameter 'DVA', which
C is the contour level associated with the contour line being labelled.
C
C CTCHLL 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, CTCHLL 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 CONPACKT 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, CTCHLL 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 HLUCTMXYZ (IMAP,XINP,YINP,ZINP,XOTP,YOTP)
C
C This routine stands between CONPACKT and the user call-back routine
C CTMXYZ.  When HLUs are not in use, this version of the routine gets
C loaded, so that CTMXYZ 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 CTMXYZ.
C
        CALL CTMXYZ (IMAP,XINP,YINP,ZINP,XOTP,YOTP)
C
        RETURN
C
      END


      SUBROUTINE CTMXYZ (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


      SUBROUTINE HLUCTSCAE (ICRA,ICA1,ICAM,ICAN,XCPF,YCPF,XCQF,YCQF,
     +                                          IND1,IND2,ICAF,IAID)
C
        DIMENSION ICRA(ICA1,*)
C
C This routine stands between CONPACKT and the user call-back routine
C CTSCAE.  When HLUs are not in use, this version of the routine gets
C loaded, so that CTSCAE 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 CTSCAE.
C
        CALL CTSCAE (ICRA,ICA1,ICAM,ICAN,XCPF,YCPF,XCQF,YCQF,
     +                                   IND1,IND2,ICAF,IAID)
C
        RETURN
C
      END


      SUBROUTINE CTSCAE (ICRA,ICA1,ICAM,ICAN,XCPF,YCPF,XCQF,YCQF,
     +                                       IND1,IND2,ICAF,IAID)
        DIMENSION ICRA(ICA1,*)
C
C This routine is called by CTCICA when the internal parameter 'CAF' is
C given a negative value.  Each call is intended to create a particular
C element in the user's cell array.  The arguments are as follows:
C
C ICRA is the user's cell array.
C
C ICA1 is the first dimension of the FORTRAN array ICRA.
C
C ICAM and ICAN are the first and second dimensions of the cell array
C stored in ICRA.
C
C (XCPF,YCPF) is the point at that corner of the rectangular area
C into which the cell array maps that corresponds to the cell (1,1).
C The coordinates are given in the fractional coordinate system (unlike
C what is required in a call to GCA, in which the coordinates of the
C point P are in the world coordinate system).
C
C (XCQF,YCQF) is the point at that corner of the rectangular area into
C which the cell array maps that corresponds to the cell (ICAM,ICAN).
C The coordinates are given in the fractional coordinate system (unlike
C what is required in a call to GCA, in which the coordinates of the
C point Q are in the world coordinate system).
C
C IND1 is the 1st index of the cell that is to be updated.
C
C IND2 is the 2nd index of the cell that is to be updated.
C
C ICAF is the current value of the internal parameter 'CAF'.  This
C value will always be an integer which is less than zero (because
C when 'CAF' is zero or greater, this routine is not called).
C
C IAID is the area identifier associated with the cell.  It will have
C been given one of the values from the internal parameter array 'AIA'
C (the one for 'PAI' = -2 if the cell lies in an out-of-range area, the
C one for 'PAI' = -1 if the cell lies off the data grid, or the one for
C some value of 'PAI' between 1 and 'NCL' if the cell lies on the data
C grid).  The value zero may occur if the cell falls in an out-of-range
C area and the value of 'AIA' for 'PAI' = -2 is 0 or if the cell lies
C off the data grid and the value of 'AIA' for 'PAI' = -1 is 0, or if
C the cell falls on the data grid, but no contour level below the cell
C has a non-zero 'AIA' and no contour level above the cell has a
C non-zero 'AIB'.  Note that, if the values of 'AIA' for 'PAI' = -1
C and -2 are given non-zero values, IAID can only be given a zero
C value in one way.
C
C The default behavior of CTSCAE is as follows:  If the area identifier
C is non-negative, it is treated as a color index, to be stored in the
C appropriate cell in the cell array; but if the area identifier is
C negative, a zero is stored for the color index.  The user may supply
C a version of CTSCAE that does something different; it may simply map
C the area identifiers into color indices or it may somehow modify the
C existing cell array element to incorporate the information provided
C by the area identifier.
C
        ICRA(IND1,IND2)=MAX(0,IAID)
C
        RETURN
C
      END


I***********************************************************************
I C O N 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 CTTDCA (RPNT,IEDG,ITRI,RWRK,IWRK,ICRA,ICA1,ICAM,ICAN,
     +                                            XFCP,YFCP,XFCQ,YFCQ)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*),ICRA(ICA1,*)
C
C This routine is a version of CTCICA that assumes TDPACK routines are
C being used to map the triangular mesh from 3-space into 2-space and
C generates color indices using the triangles nearest the eye.
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 ICRA is the user array in which a cell array is to be returned.
C
C ICA1 is the first dimension of the FORTRAN array ICRA.
C
C ICAM is the first dimension of the cell array.
C
C ICAN is the second dimension of the cell array.
C
C (XFCP,YFCP) is the point at that corner of the rectangular area
C into which the cell array maps that corresponds to the cell (1,1).
C The coordinates are given in the fractional coordinate system (unlike
C what is required in a call to GCA, in which the coordinates of the
C point P are in the world coordinate system).
C
C (XFCQ,YFCQ) is the point at that corner of the rectangular area into
C which the cell array maps that corresponds to the cell (ICAM,ICAN).
C The coordinates are given in the fractional coordinate system (unlike
C what is required in a call to GCA, in which the coordinates of the
C point Q are in the world coordinate system).
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$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 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 HERO(A,B,C) is the area of a triangle having sides of length A, B,
C and C (formula of Hero, or Heron), times 4.  (We are using ratios of
C the areas of triangles, so we don't worry about the factor of 4.)
C
        HERO(A,B,C)=SQRT(MAX(0.,(A+B+C)*(B+C-A)*(A+C-B)*(A+B-C)))
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('CTTDCA - 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 ('CTTDCA - INITIALIZATION CALL NOT DONE',2,1)
          RETURN
        END IF
C
C Check for errors in the arguments.
C
        IF (ICAM.LE.0.OR.ICAN.LE.0.OR.ICAM.GT.ICA1)
          CALL SETER ('CTTDCA - DIMENSIONS OF CELL ARRAY ARE WRONG',3,1)
          RETURN
        END IF
C
        IF (XFCP.LT.0..OR.XFCP.GT.1..OR.
     +      YFCP.LT.0..OR.YFCP.GT.1..OR.
     +      XFCQ.LT.0..OR.XFCQ.GT.1..OR.
     +      YFCQ.LT.0..OR.YFCQ.GT.1.)
          CALL SETER ('CTTDCA - CORNER POINTS ARE INCORRECT',4,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('CTTDCA',5).NE.0) RETURN
C
C Compute a required tolerance value.
C
        TOLR=.00001*MIN(ABS(XWDR-XWDL),ABS(YWDT-YWDB))
C
C Extract the values of ITBX and ITBA.
C
        ITBX=IAND(ISHIFT(ITBM,-12),4095)
        ITBA=IAND(       ITBM     ,4095)
C
C If no contour levels are defined, try to pick a set of levels.
C
        IF (NCLV.LE.0)
          CALL CTPKCL (RPNT,IEDG,ITRI,RWRK,IWRK)
          IF (ICFELL('CTTDCA',6).NE.0) RETURN
        END IF
C
C If no levels are defined now, do nothing.
C
        IF (NCLV.LE.0) RETURN
C
C Get indices for the contour levels in ascending order.
C
        CALL CTSORT (CLEV,NCLV,ICLP)
C
C Initially, we want to generate values in the cell array as follows:
C
C   The value 0 implies that the center point of the cell is not along
C   the line of sight to any part of the mesh.
C
C   A non-zero value, call it I, says that ABS(I)-1 is the base index,
C   in ITRI, of that triangle of the mesh which is nearest the eye along
C   the line of sight to the center point of the cell.  If I is greater
C   than zero, the "front" of the triangle is visible (its projection is
C   traversed in a counterclockwise direction); otherwise, the "back" of
C   the triangle is visible (its projection is traversed in a clockwise
C   direction).
C
C First, initialize the cell array to contain zeroes.
C
        DO (I=1,ICAM)
          DO (J=1,ICAN)
            ICRA(I,J)=0
          END DO
        END DO
C
C Examine each triangle of the triangular mesh in turn.
C
        DO 101 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 101
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 If any two points are too close together, skip the triangle.
C
          IF (ABS(XPA2-XPA1).LT.TOLR.AND.
     +        ABS(YPA2-YPA1).LT.TOLR) GO TO 101
          IF (ABS(XPA3-XPA2).LT.TOLR.AND.
     +        ABS(YPA3-YPA2).LT.TOLR) GO TO 101
          IF (ABS(XPA1-XPA3).LT.TOLR.AND.
     +        ABS(YPA1-YPA3).LT.TOLR) GO TO 101
C
C Set a flag that says whether the projected triangle is given in
C clockwise or counterclockwise order.
C
          IF (SIDE(XPA1,YPA1,XPA2,YPA2,XPA3,YPA3).LT.0.)
            ICCW=-1
          ELSE
            ICCW=+1
          END IF
C
C Compute the coordinates of the center point of the triangle and the
C square of the distance from the eye to that point.
C
C THINK ABOUT THIS: SHOULD I USE THE DISTANCES TO THE CENTERS OF THE
C TRIANGLES OR THE DISTANCES ALONG THE RAY THROUGH THE CENTER POINT OF
C THE CELL?  I'M PRETTY SURE THE 1ST IS FASTER.  IS THE 2ND BETTER?
C
          XCTA=(RPNT(IPA1+1)+RPNT(IPA2+1)+RPNT(IPA3+1))/3.
          YCTA=(RPNT(IPA1+2)+RPNT(IPA2+2)+RPNT(IPA3+2))/3.
          ZCTA=(RPNT(IPA1+3)+RPNT(IPA2+3)+RPNT(IPA3+3))/3.
C
          SDTA=(XCTA-XE)**2+(YCTA-YE)**2+(ZCTA-ZE)**2
C
C Find the fractional coordinates of all three points.
C
          XFA1=CUFX(XPA1)
          IF (ICFELL('CTTDCA',7).NE.0) RETURN
          YFA1=CUFY(YPA1)
          IF (ICFELL('CTTDCA',8).NE.0) RETURN
C
          XFA2=CUFX(XPA2)
          IF (ICFELL('CTTDCA',9).NE.0) RETURN
          YFA2=CUFY(YPA2)
          IF (ICFELL('CTTDCA',10).NE.0) RETURN
C
          XFA3=CUFX(XPA3)
          IF (ICFELL('CTTDCA',11).NE.0) RETURN
          YFA3=CUFY(YPA3)
          IF (ICFELL('CTTDCA',12).NE.0) RETURN
C
C Compute X and Y coordinate differences.
C
          XD12=XFA2-XFA1
          YD12=YFA2-YFA1
          XD23=XFA3-XFA2
          YD23=YFA3-YFA2
          XD31=XFA1-XFA3
          YD31=YFA1-YFA3
C
C Compute the lengths of the sides of the triangle.
C
          DN12=SQRT(XD12**2+YD12**2)
          DN23=SQRT(XD23**2+YD23**2)
          DN31=SQRT(XD31**2+YD31**2)
C
C Set loop limits so as to examine the center points of all cells of
C the cell array that overlap the bounding box of the triangle.
C
          ITM1=MAX(1,MIN(ICAM,INT((MIN(XFA1,XFA2,XFA3)-XFCP)/
     +                            (XFCQ-XFCP)*REAL(ICAM))+1))
          ITM2=MAX(1,MIN(ICAM,INT((MAX(XFA1,XFA2,XFA3)-XFCP)/
     +                            (XFCQ-XFCP)*REAL(ICAM))+1))
C
          IBEG=MIN(ITM1,ITM2)
          IEND=MAX(ITM1,ITM2)
C
          JTM1=MAX(1,MIN(ICAN,INT((MIN(YFA1,YFA2,YFA3)-YFCP)/
     +                            (YFCQ-YFCP)*REAL(ICAN))+1))
          JTM2=MAX(1,MIN(ICAN,INT((MAX(YFA1,YFA2,YFA3)-YFCP)/
     +                            (YFCQ-YFCP)*REAL(ICAN))+1))
C
          JBEG=MIN(JTM1,JTM2)
          JEND=MAX(JTM1,JTM2)
C
C Find each cell of the cell array whose center point lies within the
C triangle and set the cell array element to point to the triangle; if
C it already points to some other triangle, make it point to the one
C nearest the eye.
C
          IPTB=-1
C
          DO (I=IBEG,IEND)
            XFCC=XFCP+((REAL(I)-.5)/REAL(ICAM))*(XFCQ-XFCP)
            DO (J=JBEG,JEND)
              YFCC=YFCP+((REAL(J)-.5)/REAL(ICAN))*(YFCQ-YFCP)
              TS12=(YD12*XFCC-XD12*YFCC-YD12*XFA1+XD12*YFA1)/DN12
              TS23=(YD23*XFCC-XD23*YFCC-YD23*XFA2+XD23*YFA2)/DN23
              TS31=(YD31*XFCC-XD31*YFCC-YD31*XFA3+XD31*YFA3)/DN31
              IF ((TS12.LT.+.00001.AND.
     +             TS23.LT.+.00001.AND.
     +             TS31.LT.+.00001     ).OR.
     +            (TS12.GT.-.00001.AND.
     +             TS23.GT.-.00001.AND.
     +             TS31.GT.-.00001     ))
                IF (ICRA(I,J).EQ.0)
                  ICRA(I,J)=ICCW*(IPTA+1)
                ELSE
                  IF (IPTB.NE.ABS(ICRA(I,J)-1))
                    IPTB=ABS(ICRA(I,J))-1
                    XCTB=(RPNT(IEDG(ITRI(IPTB+1)+1)+1)+
     +                    RPNT(IEDG(ITRI(IPTB+1)+2)+1)+
     +                    RPNT(IEDG(ITRI(IPTB+2)+1)+1)+
     +                    RPNT(IEDG(ITRI(IPTB+2)+2)+1)+
     +                    RPNT(IEDG(ITRI(IPTB+3)+1)+1)+
     +                    RPNT(IEDG(ITRI(IPTB+3)+2)+1))/6.
                    YCTB=(RPNT(IEDG(ITRI(IPTB+1)+1)+2)+
     +                    RPNT(IEDG(ITRI(IPTB+1)+2)+2)+
     +                    RPNT(IEDG(ITRI(IPTB+2)+1)+2)+
     +                    RPNT(IEDG(ITRI(IPTB+2)+2)+2)+
     +                    RPNT(IEDG(ITRI(IPTB+3)+1)+2)+
     +                    RPNT(IEDG(ITRI(IPTB+3)+2)+2))/6.
                    ZCTB=(RPNT(IEDG(ITRI(IPTB+1)+1)+3)+
     +                    RPNT(IEDG(ITRI(IPTB+1)+2)+3)+
     +                    RPNT(IEDG(ITRI(IPTB+2)+1)+3)+
     +                    RPNT(IEDG(ITRI(IPTB+2)+2)+3)+
     +                    RPNT(IEDG(ITRI(IPTB+3)+1)+3)+
     +                    RPNT(IEDG(ITRI(IPTB+3)+2)+3))/6.
                    SDTB=(XCTB-XE)**2+(YCTB-YE)**2+(ZCTB-ZE)**2
                  END IF
                  IF (SDTA.LT.SDTB) ICRA(I,J)=ICCW*(IPTA+1)
                END IF
              END IF
            END DO
          END DO
C
  101   CONTINUE
C
C Replace the triangle indices in the cell array with area identifiers.
C
        DO (I=1,ICAM)
          XFCC=XFCP+((REAL(I)-.5)/REAL(ICAM))*(XFCQ-XFCP)
          DO (J=1,ICAN)
            YFCC=YFCP+((REAL(J)-.5)/REAL(ICAN))*(YFCQ-YFCP)
            IF (ICRA(I,J).LT.0)
              ICRA(I,J)=IAIA($NCP1$)
            ELSE IF (ICRA(I,J).EQ.0)
              ICRA(I,J)=IAIA($NCP2$)
            ELSE
              IPTA=ICRA(I,J)-1
              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
              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
              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
              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)
              XFA1=CUFX(XPA1)
              IF (ICFELL('CTTDCA',13).NE.0) RETURN
              YFA1=CUFY(YPA1)
              IF (ICFELL('CTTDCA',14).NE.0) RETURN
              XFA2=CUFX(XPA2)
              IF (ICFELL('CTTDCA',15).NE.0) RETURN
              YFA2=CUFY(YPA2)
              IF (ICFELL('CTTDCA',16).NE.0) RETURN
              XFA3=CUFX(XPA3)
              IF (ICFELL('CTTDCA',17).NE.0) RETURN
              YFA3=CUFY(YPA3)
              IF (ICFELL('CTTDCA',18).NE.0) RETURN
              XD12=XFA2-XFA1
              YD12=YFA2-YFA1
              XD23=XFA3-XFA2
              YD23=YFA3-YFA2
              XD31=XFA1-XFA3
              YD31=YFA1-YFA3
              FVA1=RPNT(IPA1+4)
              FVA2=RPNT(IPA2+4)
              FVA3=RPNT(IPA3+4)
              DN12=SQRT(XD12**2+YD12**2)
              DN23=SQRT(XD23**2+YD23**2)
              DN31=SQRT(XD31**2+YD31**2)
              DNC1=SQRT((XFCC-XFA1)**2+(YFCC-YFA1)**2)
              DNC2=SQRT((XFCC-XFA2)**2+(YFCC-YFA2)**2)
              DNC3=SQRT((XFCC-XFA3)**2+(YFCC-YFA3)**2)
              ATR1=HERO(DN23,DNC2,DNC3)
              ATR2=HERO(DN31,DNC3,DNC1)
              ATR3=HERO(DN12,DNC1,DNC2)
              ATOT=ATR1+ATR2+ATR3
              IF (ATOT.NE.0.)
                CALL CTGVAI ((ATR1*FVA1+ATR2*FVA2+ATR3*FVA3)/ATOT,
     +                                                  ICRA(I,J))
              END IF
            END IF
          END DO
        END DO
C
C Replace the area identifiers in the cell array with color indices, as
C directed by the value of the user-set flag ICAF.
C
        IF (ICAF.GT.0)
          DO (I=1,ICAM)
            DO (J=1,ICAN)
              ICRA(I,J)=ICAF+ICRA(I,J)
            END DO
          END DO
        ELSE IF (ICAF.LT.0)
          DO (I=1,ICAM)
            DO (J=1,ICAN)
              CALL HLUCTSCAE (ICRA,ICA1,ICAM,ICAN,
     +                        XFCP,YFCP,XFCQ,YFCQ,I,J,ICAF,ICRA(I,J))
              IF (ICFELL('CTTDCA',19).NE.0) RETURN
            END DO
          END DO
        END IF
C
C Make sure there are no negative values in the cell array.
C
        DO (I=1,ICAM)
          DO (J=1,ICAN)
            IF (ICRA(I,J).LT.0) ICRA(I,J)=0
          END DO
        END DO
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTTDBF (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 contour lines; 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 CONPACKT common blocks.
C
.CALL CTCOMN,/$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('CTTDBF - 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 ('CTTDBF - INITIALIZATION CALL NOT DONE',2,1)
          RETURN
        END IF
C
C Extract the values of ITBX and ITBA.
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
        ICLR=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),ICLR)
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 CTGIWS (IWRK,1,IBLM*IBLN,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CTTDBF',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 CTPITT (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.
C
  105   LI01=0
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTTDBM (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 CONPACKT common blocks.
C
.CALL CTCOMN,/$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 CTTDDM (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 CONPACKT common blocks.
C
.CALL CTCOMN,/$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.
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


I***********************************************************************
I C O N 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 CTCFLB (IACT,RWRK,IAMA)
C
        DIMENSION RWRK(*),IAMA(*)
C
C CTCFLB generates the constant-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
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
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 ('CTCFLB - ERROR EXIT FROM GQCNTN',1,1)
          RETURN
        END IF
C
        CALL GQNT (NCNT,IGER,WIND,VPRT)
C
        IF (IGER.NE.0)
          CALL SETER ('CTCFLB - ERROR EXIT FROM GQNT',2,1)
          RETURN
        END IF
C
C If the text string for the constant-field label is blank, do nothing.
C
        IF (TXCF(1:LTCF).EQ.' ') RETURN
C
C Otherwise, form the constant-field label ...
C
        DVAL=DMIN
        CALL CTSBST (TXCF(1:LTCF),CTMA,LCTM)
C
C ... get sizing information for the label ...
C
        XPFS=XVPL+CXCF*(XVPR-XVPL)
        YPFS=YVPB+CYCF*(YVPT-YVPB)
        XLBC=CFUX(XPFS)
        IF (ICFELL('CTCFLB',3).NE.0) RETURN
        YLBC=CFUY(YPFS)
        IF (ICFELL('CTCFLB',4).NE.0) RETURN
        WCFS=CHWM*WCCF*(XVPR-XVPL)
        WWFS=CHWM*WWCF*(XVPR-XVPL)
C
        CALL PCGETI ('TE',ISTE)
        IF (ICFELL('CTCFLB',5).NE.0) RETURN
        CALL PCSETI ('TE',1)
        IF (ICFELL('CTCFLB',6).NE.0) RETURN
        CALL HLUCTCHCF (+1)
        IF (ICFELL('CTCFLB',7).NE.0) RETURN
        CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,360.,0.)
        IF (ICFELL('CTCFLB',8).NE.0) RETURN
        CALL HLUCTCHCF (-1)
        IF (ICFELL('CTCFLB',9).NE.0) RETURN
        CALL PCGETR ('DL',DSTL)
        IF (ICFELL('CTCFLB',10).NE.0) RETURN
        CALL PCGETR ('DR',DSTR)
        IF (ICFELL('CTCFLB',11).NE.0) RETURN
        CALL PCGETR ('DB',DSTB)
        IF (ICFELL('CTCFLB',12).NE.0) RETURN
        CALL PCGETR ('DT',DSTT)
        IF (ICFELL('CTCFLB',13).NE.0) RETURN
        CALL PCSETI ('TE',ISTE)
        IF (ICFELL('CTCFLB',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*ANCF)
        COSA=COS(.017453292519943*ANCF)
C
        IXPO=MOD(IPCF+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=(IPCF+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('CTCFLB',15).NE.0) RETURN
        YLBC=CFUY(YPFS)
        IF (ICFELL('CTCFLB',16).NE.0) RETURN
C
        IF (IACT.EQ.1)
          IF (MOD(IBCF/2,2).NE.0)
            JLBC=ILBC
            IF (JLBC.GE.0)
              CALL GQFACI (IGER,ISFC)
              IF (IGER.NE.0)
                CALL SETER ('CTCFLB - ERROR EXIT FROM GQFACI',17,1)
                RETURN
              END IF
              IF (ISFC.NE.JLBC) CALL GSFACI (JLBC)
            END IF
            CALL HLUCTCHCF (+2)
            IF (ICFELL('CTCFLB',18).NE.0) RETURN
            BFXC(1)=CFWX(XPFS-DSTL*COSA+DSTB*SINA)
            IF (ICFELL('CTCFLB',19).NE.0) RETURN
            BFYC(1)=CFWY(YPFS-DSTL*SINA-DSTB*COSA)
            IF (ICFELL('CTCFLB',20).NE.0) RETURN
            BFXC(2)=CFWX(XPFS+DSTR*COSA+DSTB*SINA)
            IF (ICFELL('CTCFLB',21).NE.0) RETURN
            BFYC(2)=CFWY(YPFS+DSTR*SINA-DSTB*COSA)
            IF (ICFELL('CTCFLB',22).NE.0) RETURN
            BFXC(3)=CFWX(XPFS+DSTR*COSA-DSTT*SINA)
            IF (ICFELL('CTCFLB',23).NE.0) RETURN
            BFYC(3)=CFWY(YPFS+DSTR*SINA+DSTT*COSA)
            IF (ICFELL('CTCFLB',24).NE.0) RETURN
            BFXC(4)=CFWX(XPFS-DSTL*COSA-DSTT*SINA)
            IF (ICFELL('CTCFLB',25).NE.0) RETURN
            BFYC(4)=CFWY(YPFS-DSTL*SINA+DSTT*COSA)
            IF (ICFELL('CTCFLB',26).NE.0) RETURN
            CALL GFA (4,BFXC,BFYC)
            CALL HLUCTCHCF (-2)
            IF (ICFELL('CTCFLB',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 ('CTCFLB - ERROR EXIT FROM GQPLCI',28,1)
            RETURN
          END IF
          CALL GQTXCI (IGER,ISTC)
          IF (IGER.NE.0)
            CALL SETER ('CTCFLB - ERROR EXIT FROM GQTXCI',29,1)
            RETURN
          END IF
          IF (ICCF.GE.0)
            JCCF=ICCF
          ELSE
            JCCF=ISTC
          END IF
          JSLC=ISLC
          JSTC=ISTC
          IF (JSLC.NE.JCCF)
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('CTCFLB',30).NE.0) RETURN
            CALL GSPLCI (JCCF)
            JSLC=JCCF
          END IF
          IF (JSTC.NE.JCCF)
            CALL GSTXCI (JCCF)
            JSTC=JCCF
          END IF
          CALL GQCLIP (IGER,IGCF,DUMI)
          IF (IGER.NE.0)
            CALL SETER ('CTCFLB - ERROR EXIT FROM GQCLIP',31,1)
            RETURN
          END IF
          IF (IGCF.NE.0)
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('CTCFLB',32).NE.0) RETURN
            CALL GSCLIP (0)
          END IF
          CALL HLUCTCHCF (+3)
          IF (ICFELL('CTCFLB',33).NE.0) RETURN
          CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,ANCF,0.)
          IF (ICFELL('CTCFLB',34).NE.0) RETURN
          CALL HLUCTCHCF (-3)
          IF (ICFELL('CTCFLB',35).NE.0) RETURN
          IF (IGCF.NE.0)
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('CTCFLB',36).NE.0) RETURN
            CALL GSCLIP (IGCF)
          END IF
          IF (MOD(IBCF,2).NE.0)
            WDTH=WLCF
            IF (WDTH.GT.0.)
              CALL GQLWSC (IGER,SFLW)
              IF (IGER.NE.0)
                CALL SETER ('CTCFLB - ERROR EXIT FROM GQLWSC',37,1)
                RETURN
              END IF
              CALL PLOTIF (0.,0.,2)
              IF (ICFELL('CTCFLB',38).NE.0) RETURN
              CALL GSLWSC (WDTH)
            END IF
            CALL HLUCTCHCF (+4)
            IF (ICFELL('CTCFLB',39).NE.0) RETURN
            CALL PLOTIF (XPFS-DSTL*COSA+DSTB*SINA,
     +                   YPFS-DSTL*SINA-DSTB*COSA,0)
            IF (ICFELL('CTCFLB',40).NE.0) RETURN
            CALL PLOTIF (XPFS+DSTR*COSA+DSTB*SINA,
     +                   YPFS+DSTR*SINA-DSTB*COSA,1)
            IF (ICFELL('CTCFLB',41).NE.0) RETURN
            CALL PLOTIF (XPFS+DSTR*COSA-DSTT*SINA,
     +                   YPFS+DSTR*SINA+DSTT*COSA,1)
            IF (ICFELL('CTCFLB',42).NE.0) RETURN
            CALL PLOTIF (XPFS-DSTL*COSA-DSTT*SINA,
     +                   YPFS-DSTL*SINA+DSTT*COSA,1)
            IF (ICFELL('CTCFLB',43).NE.0) RETURN
            CALL PLOTIF (XPFS-DSTL*COSA+DSTB*SINA,
     +                   YPFS-DSTL*SINA-DSTB*COSA,1)
            IF (ICFELL('CTCFLB',44).NE.0) RETURN
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('CTCFLB',45).NE.0) RETURN
            CALL HLUCTCHCF (-4)
            IF (ICFELL('CTCFLB',46).NE.0) RETURN
            IF (WDTH.GT.0.)
              CALL PLOTIF (0.,0.,2)
              IF (ICFELL('CTCFLB',47).NE.0) RETURN
              CALL GSLWSC (SFLW)
            END IF
          END IF
          IF (ISLC.NE.JSLC)
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('CTCFLB',48).NE.0) RETURN
            CALL GSPLCI (ISLC)
          END IF
          IF (ISTC.NE.JSTC) CALL GSTXCI (ISTC)
        ELSE
          CALL CTGRWS (RWRK,1,10,IWSE)
          IF (IWSE.NE.0.OR.ICFELL('CTCFLB',49).NE.0) RETURN
          ANLB=.017453292519943*ANCF
          SALB=SIN(ANLB)
          CALB=COS(ANLB)
          RWRK(IR01+ 1)=CFUX(XPFS-DSTL*CALB+DSTB*SALB)
          IF (ICFELL('CTCFLB',50).NE.0) RETURN
          RWRK(IR01+ 2)=CFUX(XPFS+DSTR*CALB+DSTB*SALB)
          IF (ICFELL('CTCFLB',51).NE.0) RETURN
          RWRK(IR01+ 3)=CFUX(XPFS+DSTR*CALB-DSTT*SALB)
          IF (ICFELL('CTCFLB',52).NE.0) RETURN
          RWRK(IR01+ 4)=CFUX(XPFS-DSTL*CALB-DSTT*SALB)
          IF (ICFELL('CTCFLB',53).NE.0) RETURN
          RWRK(IR01+ 5)=RWRK(IR01+1)
          RWRK(IR01+ 6)=CFUY(YPFS-DSTL*SALB-DSTB*CALB)
          IF (ICFELL('CTCFLB',54).NE.0) RETURN
          RWRK(IR01+ 7)=CFUY(YPFS+DSTR*SALB-DSTB*CALB)
          IF (ICFELL('CTCFLB',55).NE.0) RETURN
          RWRK(IR01+ 8)=CFUY(YPFS+DSTR*SALB+DSTT*CALB)
          IF (ICFELL('CTCFLB',56).NE.0) RETURN
          RWRK(IR01+ 9)=CFUY(YPFS-DSTL*SALB+DSTT*CALB)
          IF (ICFELL('CTCFLB',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('CTCFLB',58).NE.0) RETURN
          ELSE
            CALL AREDAM (IAMA,RWRK(IR01+1),RWRK(IR01+6),5,IGLB,0,-1)
            IF (ICFELL('CTCFLB',59).NE.0) RETURN
          END IF
          LR01=0
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTCPAG (RPNT,IEDG,ITRI,RWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*)
C
C Given an array of data to be contoured, the routine CTCPAG computes
C an array of IGRM*IGRN gradients to be used in positioning labels.
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 This routine also computes values for the quantities NGRV, which is
C the number of gradient values computed, GRAV, which is the average
C gradient found, and GRSD, which is the standard deviation of the
C gradient distribution.
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$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 Compute some required tolerance values.
C
        TOL1=.0001*MIN(ABS(XVPR-XVPL),ABS(YVPT-YVPB))
        TOL2=.5000*MIN(ABS(XVPR-XVPL),ABS(YVPT-YVPB))
C
C Extract the values of ITBX and ITBA.
C
        ITBX=IAND(ISHIFT(ITBM,-12),4095)
        ITBA=IAND(       ITBM     ,4095)
C
C Initialize the gradient array.
C
        DO (I=1,IGRM*IGRN)
          RWRK(IR02+I)=-1.
        END DO
C
C Examine each triangle of the triangular mesh in turn.
C
        DO 101 I=0,NTRI-LOTN,LOTN
C
C Use only unblocked triangles.
C
          IF (ITBF(ITRI(I+4)).NE.0) GO TO 101
C
C Find the base index of point 1 (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 Project point 1; if it's invisible, skip the triangle.
C
          IF (IMPF.EQ.0)
            XCD1=RPNT(IPP1+1)
            YCD1=RPNT(IPP1+2)
          ELSE
            CALL HLUCTMXYZ (IMPF,RPNT(IPP1+1),RPNT(IPP1+2),RPNT(IPP1+3),
     +                                                        XCD1,YCD1)
            IF (ICFELL('CTCPAG',1).NE.0) RETURN
            IF ((OORV.NE.0.).AND.(XCD1.EQ.OORV.OR.YCD1.EQ.OORV))
     +                                                         GO TO 101
          END IF
C
C Find the base index of point 2 (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 Project point 2; if it's invisible, skip the triangle.
C
          IF (IMPF.EQ.0)
            XCD2=RPNT(IPP2+1)
            YCD2=RPNT(IPP2+2)
          ELSE
            CALL HLUCTMXYZ (IMPF,RPNT(IPP2+1),RPNT(IPP2+2),RPNT(IPP2+3),
     +                                                        XCD2,YCD2)
            IF (ICFELL('CTCPAG',2).NE.0) RETURN
            IF ((OORV.NE.0.).AND.(XCD2.EQ.OORV.OR.YCD2.EQ.OORV))
     +                                                         GO TO 101
          END IF
C
C Find the base index of point 3 (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 3; if it's invisible, skip the triangle.
C
          IF (IMPF.EQ.0)
            XCD3=RPNT(IPP3+1)
            YCD3=RPNT(IPP3+2)
          ELSE
            CALL HLUCTMXYZ (IMPF,RPNT(IPP3+1),RPNT(IPP3+2),RPNT(IPP3+3),
     +                                                        XCD3,YCD3)
            IF (ICFELL('CTCPAG',3).NE.0) RETURN
            IF ((OORV.NE.0.).AND.(XCD3.EQ.OORV.OR.YCD3.EQ.OORV))
     +                                                         GO TO 101
          END IF
C
C Find the fractional coordinates of all three points.
C
          XGD1=CUFX(XCD1)
          IF (ICFELL('CTCPAG',4).NE.0) RETURN
          YGD1=CUFY(YCD1)
          IF (ICFELL('CTCPAG',5).NE.0) RETURN
C
          XGD2=CUFX(XCD2)
          IF (ICFELL('CTCPAG',6).NE.0) RETURN
          YGD2=CUFY(YCD2)
          IF (ICFELL('CTCPAG',7).NE.0) RETURN
          ZGD2=ZCD2
C
          XGD3=CUFX(XCD3)
          IF (ICFELL('CTCPAG',8).NE.0) RETURN
          YGD3=CUFY(YCD3)
          IF (ICFELL('CTCPAG',9).NE.0) RETURN
          ZGD3=ZCD3
C
C Compute X and Y coordinate differences.
C
          XD12=XGD2-XGD1
          YD12=YGD2-YGD1
          XD23=XGD3-XGD2
          YD23=YGD3-YGD2
          XD31=XGD1-XGD3
          YD31=YGD1-YGD3
C
C If two points of the triangle are too close to each other, skip it.
C
          IF (ABS(XD12).LT.TOL1.AND.ABS(YD12).LT.TOL1) GO TO 101
          IF (ABS(XD23).LT.TOL1.AND.ABS(YD23).LT.TOL1) GO TO 101
          IF (ABS(XD31).LT.TOL1.AND.ABS(YD31).LT.TOL1) GO TO 101
C
C If two points of the triangle are too far apart, skip it.
C
          IF (ABS(XD12).GT.TOL2.OR.ABS(YD12).GT.TOL2) GO TO 101
          IF (ABS(XD23).GT.TOL2.OR.ABS(YD23).GT.TOL2) GO TO 101
          IF (ABS(XD31).GT.TOL2.OR.ABS(YD31).GT.TOL2) GO TO 101
C
C Pick up the field values at the three points.
C
          ZGD1=RPNT(IPP1+4)
          ZGD2=RPNT(IPP2+4)
          ZGD3=RPNT(IPP3+4)
C
C Compute the gradient of the triangle and use that to update values
C in the gradient array.
C
          IF (ZGD1.LT.ZGD2)
            IF (ZGD2.LT.ZGD3)
              XGDA=XGD1
              YGDA=YGD1
              ZGDA=ZGD1
              XGDB=XGD2
              YGDB=YGD2
              ZGDB=ZGD2
              XGDC=XGD3
              YGDC=YGD3
              ZGDC=ZGD3
            ELSE
              IF (ZGD1.LT.ZGD3)
                XGDA=XGD1
                YGDA=YGD1
                ZGDA=ZGD1
                XGDB=XGD3
                YGDB=YGD3
                ZGDB=ZGD3
                XGDC=XGD2
                YGDC=YGD2
                ZGDC=ZGD2
              ELSE
                XGDA=XGD3
                YGDA=YGD3
                ZGDA=ZGD3
                XGDB=XGD1
                YGDB=YGD1
                ZGDB=ZGD1
                XGDC=XGD2
                YGDC=YGD2
                ZGDC=ZGD2
              END IF
            END IF
          ELSE
            IF (ZGD1.LT.ZGD3)
              XGDA=XGD2
              YGDA=YGD2
              ZGDA=ZGD2
              XGDB=XGD1
              YGDB=YGD1
              ZGDB=ZGD1
              XGDC=XGD3
              YGDC=YGD3
              ZGDC=ZGD3
            ELSE
              IF (ZGD2.LT.ZGD3)
                XGDA=XGD2
                YGDA=YGD2
                ZGDA=ZGD2
                XGDB=XGD3
                YGDB=YGD3
                ZGDB=ZGD3
                XGDC=XGD1
                YGDC=YGD1
                ZGDC=ZGD1
              ELSE
                XGDA=XGD3
                YGDA=YGD3
                ZGDA=ZGD3
                XGDB=XGD2
                YGDB=YGD2
                ZGDB=ZGD2
                XGDC=XGD1
                YGDC=YGD1
                ZGDC=ZGD1
              END IF
            END IF
          END IF
          DNOM=(XGDC-XGDB)*YGDA+(XGDA-XGDC)*YGDB+(XGDB-XGDA)*YGDC
          IF (DNOM.NE.0.)
            IF (ZGDC-ZGDA.NE.0.)
              COFA=((YGDB-YGDC)*ZGDA+(YGDC-YGDA)*ZGDB+
     +                                        (YGDA-YGDB)*ZGDC)/DNOM
              COFB=((XGDC-XGDB)*ZGDA+(XGDA-XGDC)*ZGDB+
     +                                        (XGDB-XGDA)*ZGDC)/DNOM
              XDMX=YGDB-YGDA+(YGDA-YGDC)*(ZGDB-ZGDA)/(ZGDC-ZGDA)
              YDMX=XGDA-XGDB+(XGDC-XGDA)*(ZGDB-ZGDA)/(ZGDC-ZGDA)
              GRMX=ABS(COFA*XDMX+COFB*YDMX)/SQRT(XDMX**2+YDMX**2)
C             GANG=ATAN2(YDMX,XDMX)
            ELSE
              GRMX=0.
C             GANG=0.
            END IF
            KMIN=MAX(   1,  INT((MIN(XGD1,XGD2,XGD3)-XVPL)/
     +                                      (XVPR-XVPL)*REAL(IGRM)))
            KMAX=MIN(IGRM,1+INT((MAX(XGD1,XGD2,XGD3)-XVPL)/
     +                                      (XVPR-XVPL)*REAL(IGRM)))
            LMIN=MAX(   1,  INT((MIN(YGD1,YGD2,YGD3)-YVPB)/
     +                                      (YVPT-YVPB)*REAL(IGRN)))
            LMAX=MIN(IGRN,1+INT((MAX(YGD1,YGD2,YGD3)-YVPB)/
     +                                      (YVPT-YVPB)*REAL(IGRN)))
            DN12=SQRT(XD12*XD12+YD12*YD12)
            DN23=SQRT(XD23*XD23+YD23*YD23)
            DN31=SQRT(XD31*XD31+YD31*YD31)
            DO (K=KMIN,KMAX)
              XCBX=XVPL+(REAL(K)-.5)/REAL(IGRM)*(XVPR-XVPL)
              DO (L=LMIN,LMAX)
                YCBX=YVPB+(REAL(L)-.5)/REAL(IGRN)*(YVPT-YVPB)
                TS12=(YD12*XCBX-XD12*YCBX-YD12*XGD1+XD12*YGD1)/DN12
                TS23=(YD23*XCBX-XD23*YCBX-YD23*XGD2+XD23*YGD2)/DN23
                TS31=(YD31*XCBX-XD31*YCBX-YD31*XGD3+XD31*YGD3)/DN31
                IF ((TS12.LT.+.0001.AND.
     +               TS23.LT.+.0001.AND.
     +               TS31.LT.+.0001     ).OR.
     +              (TS12.GT.-.0001.AND.
     +               TS23.GT.-.0001.AND.
     +               TS31.GT.-.0001     ))
                  IF (GRMX.GT.RWRK(IR02+(L-1)*IGRM+K))
                    RWRK(IR02+(L-1)*IGRM+K)=GRMX
C                   RWRK(IGRM*IGRN+IR02+(L-1)*IGRM+K)=GANG
                  END IF
                END IF
              END DO
            END DO
          END IF
C
  101   CONTINUE
C
C Compute the average gradient and the standard deviation of the
C distribution of gradients.
C
        NGRV=0
        GRAV=0.
        GRSD=0.
C
        DO (I=1,IGRM*IGRN)
          IF (RWRK(IR02+I).GE.0.)
            NGRV=NGRV+1
            GRAV=GRAV+RWRK(IR02+I)
C           GRSD=GRSD+RWRK(IR02+I)**2
          END IF
        END DO
C
        IF (NGRV.NE.0)
          GRAV=GRAV/NGRV
C         GRSD=SQRT(GRSD/NGRV-GRAV*GRAV)
          IF (GRAV.NE.0.)
            DO (I=1,IGRM*IGRN)
              IF (RWRK(IR02+I).GE.0.)
                GRSD=GRSD+((RWRK(IR02+I)-GRAV)/GRAV)**2
              END IF
            END DO
            GRSD=GRAV*SQRT(GRSD/NGRV)
          END IF
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTDRSG (RWRK,IPTX,IPTY,NXYC)
C
        DIMENSION RWRK(*)
C
C (RWRK(I),I=IPTX+1,IPTX+NXYC) and (RWRK(I),I=IPTY+1,IPTY+NXYC) contain
C the X and Y coordinates (in the user coordinate system) of points
C which define a segment of a contour line.  The function of the routine
C CTDRSG is to draw the segment.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Draw the curve with the SPPS routine CURVE, if dash patterns are not
C in use, or with CURVED, if they are.
C
        IF (IDUF.EQ.0)
          CALL CURVE (RWRK(IPTX+1),RWRK(IPTY+1),NXYC)
          IF (ICFELL('CTDRSG',1).NE.0) RETURN
        ELSE IF (IDUF.LT.0)
          CALL DPCURV (RWRK(IPTX+1),RWRK(IPTY+1),NXYC)
          IF (ICFELL('CTDRSG',2).NE.0) RETURN
        ELSE
          CALL CURVED (RWRK(IPTX+1),RWRK(IPTY+1),NXYC)
          IF (ICFELL('CTDRSG',3).NE.0) RETURN
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTGIWS (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 CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Check for argument error.
C
        IF (IOWS.LT.1.OR.IOWS.GT.$NBIW$.OR.LOWS.LT.0)
          CALL SETER ('CTGIWS - 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),'('' CTGIWS'',
     +                         I8,'' WORDS REQUESTED'',
     +                         I8,'' WORDS AVAILABLE'')') LOWS,NLFT
          IF (IWSO.LE.0)
            CALL SETER ('CTGIWS - INTEGER WORKSPACE OVERFLOW',2,2)
            STOP
          ELSE IF (IWSO.GE.3)
            CALL SETER ('CTGIWS - 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 CTGRWS (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 CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Check for argument error.
C
        IF (IOWS.LT.1.OR.IOWS.GT.$NBRW$.OR.LOWS.LT.0)
          CALL SETER ('CTGRWS - 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),'('' CTGRWS'',
     +                         I8,'' WORDS REQUESTED'',
     +                         I8,'' WORDS AVAILABLE'')') LOWS,NLFT
          IF (IWSO.LE.0)
            CALL SETER ('CTGRWS - REAL WORKSPACE OVERFLOW',2,2)
            STOP
          ELSE IF (IWSO.GE.3)
            CALL SETER ('CTGRWS - 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 CTGVAI (ZVAL,IAID)
C
C Given a field value ZVAL, CTGVAI searches the current contour list to
C determine the area identifier IAID to be associated with that value.
C It is called by CTCICA and CTTREG.
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Zero will be returned if nothing better turns up.
C
        IAID=0
C
C First, search forward for a value in the parameter array 'AIB'.  This
C search is complicated by the latitude the user is given in the way he
C or she defines the area identifiers to be associated with the contour
C bands.
C
        JCLV=0
C
        DO (I=1,NCLV)
          KCLV=ICLP(I)
          IF (ZVAL.LT.CLEV(KCLV))
            IF (JCLV.NE.0)
              IF (CLEV(KCLV).NE.CLEV(JCLV)) GO TO 101
            END IF
            IF (IAIB(KCLV).NE.0)
              IAID=IAIB(KCLV)
              GO TO 102
            ELSE IF (IAIA(KCLV).NE.0)
              JCLV=KCLV
            END IF
          END IF
        END DO
C
C If necessary, search backward, in the same way, for a value in the
C parameter array 'AIA'.
C
  101  JCLV=0
C
        DO (I=NCLV,1,-1)
          KCLV=ICLP(I)
          IF (ZVAL.GE.CLEV(KCLV))
            IF (JCLV.NE.0)
              IF (CLEV(KCLV).NE.CLEV(JCLV)) GO TO 102
            END IF
            IF (IAIA(KCLV).NE.0)
              IAID=IAIA(KCLV)
              GO TO 102
            ELSE IF (IAIB(KCLV).NE.0)
              JCLV=KCLV
            END IF
          END IF
        END DO
C
C Done.
C
  102   RETURN
C
      END


      SUBROUTINE CTHCHM (RWRK,IPTX,IPTY,NXYC,IAMA,IWRK,RTPL)
C
        DIMENSION RWRK(*),IAMA(*),IWRK(*)
C
C (RWRK(I),I=IPTX+1,IPTX+NXYC) and (RWRK(I),I=IPTY+1,IPTY+NXYC) contain
C the X and Y coordinates (in the user coordinate system) of points
C that define a segment of a contour line.  The function of the routine
C CTHCHM is to hachure the segment, if appropriate, masking the hachures
C against the area map in IAMA in the manner determined by the user
C routine RTPL.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Define arrays to hold the endpoints of hachures to be masked against
C the area map.
C
        DIMENSION XCPT(2),YCPT(2)
C
C Define required constants.
C
        DATA DTOR / .017453292519943 /
        DATA RTOD / 57.2957795130823 /
C
C Determine whether or not hachuring is to be done for this segment.
C
        IF (ABS(IHCF).GT.1)
C
          IF (RWRK(IPTX+NXYC).NE.RWRK(IPTX+1).OR.
     +        RWRK(IPTY+NXYC).NE.RWRK(IPTY+1))
            IF (IOCF.NE.0) GO TO 101
            IF (ABS(IHCF).EQ.2) GO TO 101
            IF (ABS(IHCF).EQ.3) RETURN
            ANGN=RTOD*ARRAT2(RWRK(IPTY+2)-RWRK(IPTY+1),
     +                       RWRK(IPTX+2)-RWRK(IPTX+1))
          ELSE
C
            ANGN=RTOD*ARRAT2(RWRK(IPTY+NXYC)-RWRK(IPTY+NXYC-1),
     +                       RWRK(IPTX+NXYC)-RWRK(IPTX+NXYC-1))
          END IF
C
          ANGT=0.
C
          DO (I=1,NXYC-1)
            ANGO=ANGN
            ANGN=RTOD*ARRAT2(RWRK(IPTY+I+1)-RWRK(IPTY+I),
     +                       RWRK(IPTX+I+1)-RWRK(IPTX+I))
            IF (ABS(ANGN-ANGO).GT.180.) ANGO=ANGO+SIGN(360.,ANGN-ANGO)
            ANGT=ANGT+ANGN-ANGO
          END DO
C
          IF ((MIRO.EQ.0.AND.ANGT.LT.0.).OR.
     +        (MIRO.NE.0.AND.ANGT.GT.0.))
            IF (IHCF.GT.0) RETURN
          ELSE
            IF (IHCF.LT.0) RETURN
          END IF
C
        END IF
C
C Convert all the X and Y coordinates to the fractional system.
C
  101   DO (I=1,NXYC)
          RWRK(IPTX+I)=CUFX(RWRK(IPTX+I))
          IF (ICFELL('CTHCHM',1).NE.0) RETURN
          RWRK(IPTY+I)=CUFY(RWRK(IPTY+I))
          IF (ICFELL('CTHCHM',2).NE.0) RETURN
        END DO
C
C Compute the total length of the polyline.
C
        TLEN=0.
C
        DO (I=1,NXYC-1)
          TLEN=TLEN+SQRT((RWRK(IPTX+I+1)-RWRK(IPTX+I))**2+
     +                   (RWRK(IPTY+I+1)-RWRK(IPTY+I))**2)
        END DO
C
C Decide how long the hachures ought to be and on which side of the
C polyline they ought to go.
C
        HCHD=HCHL*(XVPR-XVPL)
        IF (MIRO.NE.0) HCHD=-HCHD
        IF ((XWDL.LT.XWDR.AND.YWDB.GT.YWDT).OR.
     +      (XWDL.GT.XWDR.AND.YWDB.LT.YWDT)) HCHD=-HCHD
C
C Draw hachures along the polyline.
C
        TEMP=REAL(INT(TLEN/(HCHS*(XVPR-XVPL))))
        IF (TEMP.LE.0.) RETURN
        DBHM=TLEN/TEMP
        PNHM=DBHM/2.
C
        I=0
        CLEN=0.
C
        WHILE (I.LT.NXYC-1)
          I=I+1
          SLEN=SQRT((RWRK(IPTX+I+1)-RWRK(IPTX+I))**2+
     +              (RWRK(IPTY+I+1)-RWRK(IPTY+I))**2)
          WHILE (PNHM.LT.CLEN+SLEN)
            FRCT=(PNHM-CLEN)/SLEN
            XCPT(1)=RWRK(IPTX+I)+FRCT*(RWRK(IPTX+I+1)-RWRK(IPTX+I))
            YCPT(1)=RWRK(IPTY+I)+FRCT*(RWRK(IPTY+I+1)-RWRK(IPTY+I))
            XCPT(2)=XCPT(1)-HCHD*(RWRK(IPTY+I+1)-RWRK(IPTY+I))/SLEN
            YCPT(2)=YCPT(1)+HCHD*(RWRK(IPTX+I+1)-RWRK(IPTX+I))/SLEN
            XCPT(1)=CFUX(XCPT(1))
            IF (ICFELL('CTHCHM',3).NE.0) RETURN
            YCPT(1)=CFUY(YCPT(1))
            IF (ICFELL('CTHCHM',4).NE.0) RETURN
            XCPT(2)=CFUX(XCPT(2))
            IF (ICFELL('CTHCHM',5).NE.0) RETURN
            YCPT(2)=CFUY(YCPT(2))
            IF (ICFELL('CTHCHM',6).NE.0) RETURN
            CALL ARDRLN (IAMA,XCPT,YCPT,2,
     +                   RWRK(IR02+1),RWRK(IR02+1+LRWM),LRWM,
     +                   IWRK(II02+1),IWRK(II02+1+LIWM),LIWM,RTPL)
            IF (ICFELL('CTHCHM',7).NE.0) RETURN
            PNHM=PNHM+DBHM
          END WHILE
          CLEN=CLEN+SLEN
        END WHILE
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTHCHR (RWRK,IPTX,IPTY,NXYC)
C
        DIMENSION RWRK(*)
C
C (RWRK(I),I=IPTX+1,IPTX+NXYC) and (RWRK(I),I=IPTY+1,IPTY+NXYC) contain
C the X and Y coordinates (in the user coordinate system) of points
C that define a segment of a contour line.  The function of the routine
C CTHCHR is to hachure the segment, if appropriate.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Define required constants.
C
        DATA DTOR / .017453292519943 /
        DATA RTOD / 57.2957795130823 /
C
C Determine whether or not hachuring is to be done for this segment.
C
        IF (ABS(IHCF).GT.1)
C
          IF (RWRK(IPTX+NXYC).NE.RWRK(IPTX+1).OR.
     +        RWRK(IPTY+NXYC).NE.RWRK(IPTY+1))
            IF (IOCF.NE.0) GO TO 101
            IF (ABS(IHCF).EQ.2) GO TO 101
            IF (ABS(IHCF).EQ.3) RETURN
            ANGN=RTOD*ARRAT2(RWRK(IPTY+2)-RWRK(IPTY+1),
     +                       RWRK(IPTX+2)-RWRK(IPTX+1))
          ELSE
C
            ANGN=RTOD*ARRAT2(RWRK(IPTY+NXYC)-RWRK(IPTY+NXYC-1),
     +                       RWRK(IPTX+NXYC)-RWRK(IPTX+NXYC-1))
          END IF
C
          ANGT=0.
C
          DO (I=1,NXYC-1)
            ANGO=ANGN
            ANGN=RTOD*ARRAT2(RWRK(IPTY+I+1)-RWRK(IPTY+I),
     +                       RWRK(IPTX+I+1)-RWRK(IPTX+I))
            IF (ABS(ANGN-ANGO).GT.180.) ANGO=ANGO+SIGN(360.,ANGN-ANGO)
            ANGT=ANGT+ANGN-ANGO
          END DO
C
          IF ((MIRO.EQ.0.AND.ANGT.LT.0.).OR.
     +        (MIRO.NE.0.AND.ANGT.GT.0.))
            IF (IHCF.GT.0) RETURN
          ELSE
            IF (IHCF.LT.0) RETURN
          END IF
C
        END IF
C
C Convert all the X and Y coordinates to the fractional system.
C
  101   DO (I=1,NXYC)
          RWRK(IPTX+I)=CUFX(RWRK(IPTX+I))
          IF (ICFELL('CTHCHR',1).NE.0) RETURN
          RWRK(IPTY+I)=CUFY(RWRK(IPTY+I))
          IF (ICFELL('CTHCHR',2).NE.0) RETURN
        END DO
C
C Compute the total length of the polyline.
C
        TLEN=0.
C
        DO (I=1,NXYC-1)
          TLEN=TLEN+SQRT((RWRK(IPTX+I+1)-RWRK(IPTX+I))**2+
     +                   (RWRK(IPTY+I+1)-RWRK(IPTY+I))**2)
        END DO
C
C Decide how long the hachures ought to be and on which side of the
C polyline they ought to go.
C
        HCHD=HCHL*(XVPR-XVPL)
        IF (MIRO.NE.0) HCHD=-HCHD
        IF ((XWDL.LT.XWDR.AND.YWDB.GT.YWDT).OR.
     +      (XWDL.GT.XWDR.AND.YWDB.LT.YWDT)) HCHD=-HCHD
C
C Draw hachures along the polyline.
C
        TEMP=REAL(INT(TLEN/(HCHS*(XVPR-XVPL))))
        IF (TEMP.LE.0.) RETURN
        DBHM=TLEN/TEMP
        PNHM=DBHM/2.
C
        I=0
        CLEN=0.
C
        WHILE (I.LT.NXYC-1)
          I=I+1
          SLEN=SQRT((RWRK(IPTX+I+1)-RWRK(IPTX+I))**2+
     +              (RWRK(IPTY+I+1)-RWRK(IPTY+I))**2)
          WHILE (PNHM.LT.CLEN+SLEN)
            FRCT=(PNHM-CLEN)/SLEN
            XCP1=RWRK(IPTX+I)+FRCT*(RWRK(IPTX+I+1)-RWRK(IPTX+I))
            YCP1=RWRK(IPTY+I)+FRCT*(RWRK(IPTY+I+1)-RWRK(IPTY+I))
            CALL PLOTIF (XCP1,YCP1,0)
            IF (ICFELL('CTHCHR',3).NE.0) RETURN
            XCP2=XCP1-HCHD*(RWRK(IPTY+I+1)-RWRK(IPTY+I))/SLEN
            YCP2=YCP1+HCHD*(RWRK(IPTX+I+1)-RWRK(IPTX+I))/SLEN
            CALL PLOTIF (XCP2,YCP2,1)
            IF (ICFELL('CTHCHR',4).NE.0) RETURN
            PNHM=PNHM+DBHM
          END WHILE
          CLEN=CLEN+SLEN
        END WHILE
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTHLLB (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C CTHLLB generates the high and low labels for the contour field; the
C quantities defining the labels are added to the lists in real
C workspaces 3 and 4.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$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 If the text strings for high and low labels are blank, do nothing.
C
        IF (TXHI(1:LTHI).EQ.' '.AND.TXLO(1:LTLO).EQ.' ') RETURN
C
C Extract the values of ITBX and ITBA.
C
        ITBX=IAND(ISHIFT(ITBM,-12),4095)
        ITBA=IAND(       ITBM     ,4095)
C
C Compute the value of the angle at which the labels are written, in
C radians, and the sine and cosine of that angle.
C
        ANLB=.017453292519943*ANHL
        SALB=SIN(ANLB)
        CALB=COS(ANLB)
C
C Compute the width of a character in the fractional system and the
C width of the white space in the fractional system.
C
        WCFS=CHWM*WCHL*(XVPR-XVPL)
        WWFS=CHWM*WWHL*(XVPR-XVPL)
C
C Make PLOTCHAR compute text-extent quantities.
C
        CALL PCGETI ('TE',ISTE)
        IF (ICFELL('CTHLLB',1).NE.0) RETURN
        CALL PCSETI ('TE',1)
        IF (ICFELL('CTHLLB',2).NE.0) RETURN
C
C Compute the square of the specified high/low search radius, which
C will be needed below.
C
        IF (HLSR.LT.0.)
          HLRS=HLSR*HLSR
        ELSE
          HLRS=HLSR*HLSR*MAX(XMAX-XMIN,YMAX-YMIN,ZMAX-ZMIN)**2
        END IF
C
C Tell IFTRAN to use the FORTRAN-66 implementation of block-IFs.
C
.OP     BI=66
C
C Look for highs in the data field.  The algorithm takes advantage
C of two facts: 1) each edge is essentially a directed vector
C pointing uphill; and 2) the edges of each triangle are defined
C in counterclockwise order.
C
        IF (TXHI(1:LTHI).NE.' ')
C
C Zero the utility flags in all the edge nodes.  (They will be used to
C mark edges we've already visited.)
C
          DO (I=0,NEDG-LOEN,LOEN)
            IEDG(I+5)=0
          END DO
C
C Loop through the edge list, searching for starting edges.
C
          FOR (I = 0 TO NEDG-LOEN BY LOEN)
C
C Skip the edge if it has already been used.
C
            IF (IEDG(I+5).NE.0) GO TO 104
C
C Otherwise, construct a path of connected edges along which the field
C values increase, and keep going until a high point is reached.
C
            IPTE=I
C
C Control loops back here to search for the best edge to follow edge
C IPTE.  First, mark the edge as used.
C
  101       IEDG(IPTE+5)=1
C
C IPTA is used for edges under consideration.
C
            IPTA=IPTE
C
C Skip the edge if it has no non-blocked triangle on either its left or
C its right.
C
            IFLL=0
C
            IF (IEDG(IPTA+3).GE.0)
              IF (ITBF(ITRI(LOTN*((IEDG(IPTA+3)-1)/LOTN)+4)).EQ.0)
     +                                                           IFLL=1
            END IF
C
            IFLR=0
C
            IF (IEDG(IPTA+4).GE.0)
              IF (ITBF(ITRI(LOTN*((IEDG(IPTA+4)-1)/LOTN)+4)).EQ.0)
     +                                                           IFLR=1
            END IF
C
            IF (IFLL.EQ.0.AND.IFLR.EQ.0) GO TO 104
C
C IPTB is used for the best following edge found so far.
C
            IPTB=IPTE
C
C There are two ways we can look for edges connected to the end of the
C edge IPTE.  We first look for them in clockwise order; if that search
C terminates by running into an external edge of the triangular mesh, we
C search for the rest in counterclockwise order; the flag IMEE is set
C non-zero to cause the second search to be done.
C
            IMEE=0
C
C If edge IPTA ends at the same point as edge IPTE,
C
  102       IF (IEDG(IPTA+2).EQ.IEDG(IPTE+2))
C
C mark it as used;
C
              IEDG(IPTA+5)=1
C
C if there is a non-blocked triangle to its left,
C
              IFLL=0
C
              IF (IEDG(IPTA+3).GE.0)
                IF (ITBF(ITRI(LOTN*((IEDG(IPTA+3)-1)/LOTN)+4))
     +                                                     .EQ.0) IFLL=1
              END IF
C
              IF (IFLL.NE.0)
C
C move to its next edge,
C
                IPTT=LOTN*((IEDG(IPTA+3)-1)/LOTN)
                IPTI=MOD(IEDG(IPTA+3)-IPTT,3)+1
                IPTA=ITRI(IPTT+IPTI)
C
C and, if that edge is not the one we started with, loop back to
C continue the search;
C
                IF (IPTA.NE.IPTE) GO TO 102
C
C otherwise (no non-blocked triangle to left),
C
              ELSE
C
C search in the other direction.
C
                IMEE=1
C
              END IF
C
C If edge IPTA ends with a different point than edge IPTE does,
C
            ELSE
C
C a possible following edge has been found; update the "best" pointer.
C
              IF (RPNT(IEDG(IPTA+2)+4).GT.
     +            RPNT(IEDG(IPTB+2)+4)) IPTB=IPTA
C
C If there is a non-blocked triangle to the right, move to its next
C edge; otherwise, search in the opposite direction.
C
              IFLR=0
C
              IF (IEDG(IPTA+4).GE.0)
                IF (ITBF(ITRI(LOTN*((IEDG(IPTA+4)-1)/LOTN)+4))
     +                                                     .EQ.0) IFLR=1
              END IF
C
              IF (IFLR.NE.0)
                IPTT=LOTN*((IEDG(IPTA+4)-1)/LOTN)
                IPTI=MOD(IEDG(IPTA+4)-IPTT,3)+1
                IPTA=ITRI(IPTT+IPTI)
                IF (IPTA.NE.IPTE) GO TO 102
              ELSE
                IMEE=1
              END IF
C
            END IF
C
C If the mesh edge was encountered while searching in one direction,
C
            IF (IMEE.NE.0)
C
C look at triangles in the other direction from edge IPTE.
C
              IPTA=IPTE
C
C If edge IPTA ends with the same point as edge IPTE,
C
  103         IF (IEDG(IPTA+2).EQ.IEDG(IPTE+2))
C
C mark it as used;
C
                IEDG(IPTA+5)=1
C
C if there is a non-blocked triangle to its right,
C
                IFLR=0
C
                IF (IEDG(IPTA+4).GE.0)
                  IF (ITBF(ITRI(LOTN*((IEDG(IPTA+4)-1)/LOTN)+4))
     +                                                     .EQ.0) IFLR=1
                END IF
C
                IF (IFLR.NE.0)
C
C move to its previous edge,
C
                  IPTT=LOTN*((IEDG(IPTA+4)-1)/LOTN)
                  IPTI=MOD(IEDG(IPTA+4)-IPTT+1,3)+1
                  IPTA=ITRI(IPTT+IPTI)
C
C and, if that edge is not the one we started with, loop back to
C continue the search.
C
                  IF (IPTA.NE.IPTE) GO TO 103
C
                END IF
C
C If edge IPTA ends with a different point than edge IPTE does,
C
              ELSE
C
C a possible following edge has been found; update the "best" pointer.
C
                IF (RPNT(IEDG(IPTA+2)+4).GT.
     +              RPNT(IEDG(IPTB+2)+4)) IPTB=IPTA
C
C If there is a non-blocked triangle to the left, move to its previous
C edge.
C
                IFLL=0
C
                IF (IEDG(IPTA+3).GE.0)
                  IF (ITBF(ITRI(LOTN*((IEDG(IPTA+3)-1)/LOTN)+4))
     +                                                     .EQ.0) IFLL=1
                END IF
C
                IF (IFLL.NE.0)
                  IPTT=LOTN*((IEDG(IPTA+3)-1)/LOTN)
                  IPTI=MOD(IEDG(IPTA+3)-IPTT+1,3)+1
                  IPTA=ITRI(IPTT+IPTI)
                  IF (IPTA.NE.IPTE) GO TO 103
                END IF
C
              END IF
C
            END IF
C
C If a following edge was found,
C
            IF (IPTB.NE.IPTE)
C
C and it's one we've used before, skip it (because, if we continued,
C we'd only arrive at a high we found already).
C
              IF (IEDG(IPTB+5).NE.0) GO TO 104
C
C Otherwise, move to it and loop back to continue the search.
C
              IPTE=IPTB
              GO TO 101
C
C If no following edge was found and the endpoint was not on an
C external edge of the mesh,
C
            ELSE IF (IMEE.EQ.0)
C
C we have found a possible high, so look at field values at all points
C within a specified distance; if any are found that are greater than
C or equal to the field value at the possible high, skip it.
C
              VAPH=RPNT(IEDG(IPTE+2)+4)
C
              IF (RPNT(IEDG(IPTE+1)+4).EQ.VAPH) GO TO 104
C
              DO (J=0,NPNT-LOPN,LOPN)
                IF (J.NE.IEDG(IPTE+2))
                  IF ((RPNT(J+1)-RPNT(IEDG(IPTE+2)+1))**2+
     +                (RPNT(J+2)-RPNT(IEDG(IPTE+2)+2))**2+
     +                (RPNT(J+3)-RPNT(IEDG(IPTE+2)+3))**2.LT.HLRS)
                    IF (RPNT(J+4).GE.VAPH) GO TO 104
                  END IF
                END IF
              END DO
C
C Otherwise, mark the high.
C
              IHOL=0
              XTMP=RPNT(IEDG(IPTE+2)+1)
              YTMP=RPNT(IEDG(IPTE+2)+2)
              ZTMP=RPNT(IEDG(IPTE+2)+3)
              DVAL=RPNT(IEDG(IPTE+2)+4)
              INVOKE (WRITE-A-LABEL)
C
            END IF
C
  104     END FOR
C
        END IF
C
C Look for lows in the data field.  The algorithm takes advantage
C of two facts: 1) each edge is essentially a directed vector
C pointing uphill; and 2) the edges of each triangle are defined
C in counterclockwise order.
C
        IF (TXLO(1:LTLO).NE.' ')
C
C Zero the utility flags in all the edge nodes.  (They will be used to
C mark edges we've already visited.)
C
          DO (I=0,NEDG-LOEN,LOEN)
            IEDG(I+5)=0
          END DO
C
C Loop through the edge list, searching for starting edges.
C
          FOR (I = 0 TO NEDG-LOEN BY LOEN)
C
C Skip the edge if it has already been used.
C
            IF (IEDG(I+5).NE.0) GO TO 108
C
C Otherwise, construct a path of connected edges along which the field
C values decrease, and keep going until a low point is reached.
C
            IPTE=I
C
C Control loops back here to search for the best edge to precede edge
C IPTE.  First, mark the edge as used.
C
  105       IEDG(IPTE+5)=1
C
C IPTA is used for edges under consideration.
C
            IPTA=IPTE
C
C Skip the edge if it has no non-blocked triangle on either its left or
C its right.
C
            IFLL=0
C
            IF (IEDG(IPTA+3).GE.0)
              IF (ITBF(ITRI(LOTN*((IEDG(IPTA+3)-1)/LOTN)+4))
     +                                                     .EQ.0) IFLL=1
            END IF
C
            IFLR=0
C
            IF (IEDG(IPTA+4).GE.0)
              IF (ITBF(ITRI(LOTN*((IEDG(IPTA+4)-1)/LOTN)+4))
     +                                                     .EQ.0) IFLR=1
            END IF
C
            IF (IFLL.EQ.0.AND.IFLR.EQ.0) GO TO 108
C
C IPTB is used for the best preceding edge found so far.
C
            IPTB=IPTE
C
C There are two ways we can look for edges connected to the start of the
C edge IPTE.  We first look for them in clockwise order; if that search
C terminates by running into an external edge of the triangular mesh, we
C search for the rest in counterclockwise order; the flag IMEE is set
C non-zero to cause the second search to be done.
C
            IMEE=0
C
C If edge IPTA begins at the same point as edge IPTE,
C
  106       IF (IEDG(IPTA+1).EQ.IEDG(IPTE+1))
C
C mark it as used;
C
              IEDG(IPTA+5)=1
C
C if there is a non-blocked triangle to its right,
C
              IFLR=0
C
              IF (IEDG(IPTA+4).GE.0)
                IF (ITBF(ITRI(LOTN*((IEDG(IPTA+4)-1)/LOTN)+4))
     +                                                     .EQ.0) IFLR=1
              END IF
C
              IF (IFLR.NE.0)
C
C move to its next edge,
C
                IPTT=LOTN*((IEDG(IPTA+4)-1)/LOTN)
                IPTI=MOD(IEDG(IPTA+4)-IPTT,3)+1
                IPTA=ITRI(IPTT+IPTI)
C
C and, if that edge is not the one we started with, loop back to
C continue the search;
C
                IF (IPTA.NE.IPTE) GO TO 106
C
C otherwise (no non-blocked triangle to right),
C
              ELSE
C
C search in the other direction.
C
                IMEE=1
C
              END IF
C
C If edge IPTA begins with a different point than edge IPTE does,
C
            ELSE
C
C a possible preceding edge has been found; update the "best" pointer.
C
              IF (RPNT(IEDG(IPTA+1)+4).LT.
     +            RPNT(IEDG(IPTB+1)+4)) IPTB=IPTA
C
C If there is a non-blocked triangle to the left, move to its next
C edge; otherwise, search in the opposite direction.
C
              IFLL=0
C
              IF (IEDG(IPTA+3).GE.0)
                IF (ITBF(ITRI(LOTN*((IEDG(IPTA+3)-1)/LOTN)+4))
     +                                                     .EQ.0) IFLL=1
              END IF
C
              IF (IFLL.NE.0)
                IPTT=LOTN*((IEDG(IPTA+3)-1)/LOTN)
                IPTI=MOD(IEDG(IPTA+3)-IPTT,3)+1
                IPTA=ITRI(IPTT+IPTI)
                IF (IPTA.NE.IPTE) GO TO 106
              ELSE
                IMEE=1
              END IF
C
            END IF
C
C If the mesh edge was encountered while searching in one direction,
C
            IF (IMEE.NE.0)
C
C look at triangles in the other direction from edge IPTE.
C
              IPTA=IPTE
C
C If edge IPTA begins with the same point as edge IPTE,
C
  107         IF (IEDG(IPTA+1).EQ.IEDG(IPTE+1))
C
C mark it as used;
C
                IEDG(IPTA+5)=1
C
C if there is a non-blocked triangle to its left,
C
                IFLL=0
C
                IF (IEDG(IPTA+3).GE.0)
                  IF (ITBF(ITRI(LOTN*((IEDG(IPTA+3)-1)/LOTN)+4))
     +                                                     .EQ.0) IFLL=1
                END IF
C
                IF (IFLL.NE.0)
C
C move to its previous edge,
C
                  IPTT=LOTN*((IEDG(IPTA+3)-1)/LOTN)
                  IPTI=MOD(IEDG(IPTA+3)-IPTT+1,3)+1
                  IPTA=ITRI(IPTT+IPTI)
C
C and, if that edge is not the one we started with, loop back to
C continue the search.
C
                  IF (IPTA.NE.IPTE) GO TO 107
C
                END IF
C
C If edge IPTA begins with a different point than edge IPTE does,
C
              ELSE
C
C a possible preceding edge has been found; update the "best" pointer.
C
                IF (RPNT(IEDG(IPTA+1)+4).LT.
     +              RPNT(IEDG(IPTB+1)+4)) IPTB=IPTA
C
C If there is a non-blocked triangle to the right, move to its previous
C edge.
C
                IFLR=0
C
                IF (IEDG(IPTA+4).GE.0)
                  IF (ITBF(ITRI(LOTN*((IEDG(IPTA+4)-1)/LOTN)+4))
     +                                                     .EQ.0) IFLR=1
                END IF
C
                IF (IFLR.NE.0)
                  IPTT=LOTN*((IEDG(IPTA+4)-1)/LOTN)
                  IPTI=MOD(IEDG(IPTA+4)-IPTT+1,3)+1
                  IPTA=ITRI(IPTT+IPTI)
                  IF (IPTA.NE.IPTE) GO TO 107
                END IF
C
              END IF
C
            END IF
C
C If a preceding edge was found,
C
            IF (IPTB.NE.IPTE)
C
C and it's one we've used before, skip it (because, if we continued,
C we'd only arrive at a low we found already).
C
              IF (IEDG(IPTB+5).NE.0) GO TO 108
C
C Otherwise, move to it and loop back to continue the search.
C
              IPTE=IPTB
              GO TO 105
C
C If no preceding edge was found and the endpoint was not on an
C external edge of the mesh,
C
            ELSE IF (IMEE.EQ.0)
C
C we have found a possible low, so look at field values at all points
C within a specified distance; if any are found that are less than or
C equal to the field value at the possible high, skip it.
C
              VAPL=RPNT(IEDG(IPTE+1)+4)
C
              IF (RPNT(IEDG(IPTE+2)+4).EQ.VAPL) GO TO 108
C
              DO (J=0,NPNT-LOPN,LOPN)
                IF (J.NE.IEDG(IPTE+1))
                  IF ((RPNT(J+1)-RPNT(IEDG(IPTE+1)+1))**2+
     +                (RPNT(J+2)-RPNT(IEDG(IPTE+1)+2))**2+
     +                (RPNT(J+3)-RPNT(IEDG(IPTE+1)+3))**2.LT.HLRS)
                    IF (RPNT(J+4).LE.VAPL) GO TO 108
                  END IF
                END IF
              END DO
C
C Otherwise, mark the low.
C
              IHOL=1
              XTMP=RPNT(IEDG(IPTE+1)+1)
              YTMP=RPNT(IEDG(IPTE+1)+2)
              ZTMP=RPNT(IEDG(IPTE+1)+3)
              DVAL=RPNT(IEDG(IPTE+1)+4)
              INVOKE (WRITE-A-LABEL)
C
            END IF
C
  108     END FOR
C
        END IF
C
C If the user wants to look for high and low values that were missed by
C the normal algorithm because of equal field values at opposite ends of
C an edge, do it.
C
        IF (IHLE.NE.0)
C
C Check for any edge having equal field values at its ends.  If any such
C edges are found, we have to do the special search.
C
          DO (I=0,NEDG-LOEN,LOEN)
            IF (RPNT(IEDG(I+1)+4).EQ.RPNT(IEDG(I+2)+4)) GO TO 109
          END DO
C
C No problem edges were found, so we're done; return to caller.
C
          GO TO 113
C
C At least one problem edge was found.  Proceed with special search.
C Grab a chunk of integer workspace.  Quit if space is not available.
C
  109     CALL CTGIWS (IWRK,1,NPNT/LOPN,IWSE)
          IF (IWSE.NE.0.OR.ICFELL('CTHLLB',3).NE.0) GO TO 112
C
C Form an array indicating which points are blocked.  First, mark them
C all as unblocked.
C
          DO (I=1,NPNT/LOPN)
            IWRK(II01+I)=0
          END DO
C
C Find all the blocked triangles and mark their vertices as blocked.
C
          DO (I=0,NTRI-LOTN,LOTN)
            IF (ITBF(ITRI(I+4)).NE.0)
              IWRK(II01+IEDG(ITRI(I+1)+1)/LOPN+1)=1
              IWRK(II01+IEDG(ITRI(I+1)+2)/LOPN+1)=1
              IWRK(II01+IEDG(ITRI(I+2)+1)/LOPN+1)=1
              IWRK(II01+IEDG(ITRI(I+2)+2)/LOPN+1)=1
              IWRK(II01+IEDG(ITRI(I+3)+1)/LOPN+1)=1
              IWRK(II01+IEDG(ITRI(I+3)+2)/LOPN+1)=1
            END IF
          END DO
C
C Form an array of all the base indices of unblocked point nodes.
C
          NUBN=0
C
          DO (I=1,NPNT/LOPN)
            IF (IWRK(II01+I).EQ.0)
              NUBN=NUBN+1
              IWRK(II01+NUBN)=(I-1)*LOPN
            END IF
          END DO
C
          IF (NUBN.LT.2) GO TO 113
C
C Sort the base indices of unblocked point nodes in order of increasing
C data value.
C
          CALL CTHLSO (RPNT,NUBN,LOPN,-4,IWRK(II01+1))
C
C Initialize a scan of the array to look for points of the mesh having
C equal field values.
C
          DNXT=RPNT(IWRK(II01+1)+4)
          NEQU=0
C
C Loop through the elements of the index array.
C
          FOR (INDX = 1 TO NUBN)
C
C DNOW is the field value at the point identified by element INDX of the
C index array.
C
            DNOW=DNXT
C
C DNXT is the field value at the point identified by element INDX+1 of
C the index array.  If element INDX is the last element of the array,
C DNXT is just set to a value different from DNOW (the smallest field
C value in the mesh).
C
            IF (INDX.LT.NUBN)
              DNXT=RPNT(IWRK(II01+INDX+1)+4)
            ELSE
              DNXT=RPNT(IWRK(II01+1)+4)
            END IF
C
C If DNXT is equal to DNOW, bump the value of NEQU, which keeps track
C of the number of consecutive elements of the index array identifying
C points having the same field value.
C
            IF (DNXT.EQ.DNOW)
C
              NEQU=NEQU+1
C
C Otherwise, ...
C
            ELSE
C
C ... if a group of equal values has been seen but not yet processed and
C if it's not too big (where "too big" is defined pretty heuristically,
C the object being to prevent the code from burning up a bunch of time
C on what is probably a pointless search for a high/low label position
C that the user won't care about) ...
C
              IF (NEQU.GT.0..AND.NEQU.LT.32)
C
C ... process the group.  Processing consists of dividing the group into
C subgroups that are spatially connected (meaning that, given any two
C elements, A and B, of the subgroup, there's a sequence of elements of
C the subgroup that begins with A, ends with B, and is such that any two
C consecutive elements of the sequence identify points of the mesh that
C are connected by an edge.  NEQU is the number of equalities seen and
C is therefore one less than the number of values in the group.  INDX
C points to the element of the index array defining the last element of
C the group.  JNDX points to the element of the index array defining the
C first element of the group.  KNDX points to the element of the index
C array defining the last element of the subgroup currently being worked
C on.
C
                JNDX=INDX-NEQU
                KNDX=JNDX
C
C Loop as long as elements of the group remain.
C
                WHILE (JNDX.LT.INDX)
C
C Look for another subgroup.
C
  110             DO (LNDX=KNDX+1,INDX)
                    DO (MNDX=JNDX,KNDX)
                      DO (I=0,NEDG-LOEN,LOEN)
                        IF ((IEDG(I+1).EQ.IWRK(II01+LNDX).AND.
     +                       IEDG(I+2).EQ.IWRK(II01+MNDX)).OR.
     +                      (IEDG(I+1).EQ.IWRK(II01+MNDX).AND.
     +                       IEDG(I+2).EQ.IWRK(II01+LNDX)))
                          KNDX=KNDX+1
                          IF (KNDX.NE.LNDX)
                            ITMP=IWRK(II01+KNDX)
                            IWRK(II01+KNDX)=IWRK(II01+LNDX)
                            IWRK(II01+LNDX)=ITMP
                          END IF
                          GO TO 110
                        END IF
                      END DO
                    END DO
                  END DO
C
C A subgroup has been found.  If it contains more than one element and
C not more than the number of elements specified by 'HLE' as the upper
C limit ...
C
                  IF (JNDX.LT.KNDX.AND.(IHLE.EQ.1.OR.KNDX-JNDX.LT.IHLE))
C
C ... examine the mesh points identified by members of the subgroup to
C see whether the subgroup can be considered a high or a low.  ITMP is
C set positive to indicate that the subgroup is a high or negative to
C indicate that it is a low.  XTMP, YTMP, ZTMP, and NTMP are used to
C compute a mean position for the high or the low.
C
                    ITMP=0
                    XTMP=0.
                    YTMP=0.
                    ZTMP=0.
                    NTMP=KNDX-JNDX+1
C
C Loop through the elements of the subgroup.
C
                    DO (LNDX=JNDX,KNDX)
                      I=IWRK(II01+LNDX)
                      XTMP=XTMP+RPNT(I+1)
                      YTMP=YTMP+RPNT(I+2)
                      ZTMP=ZTMP+RPNT(I+3)
                      DO (J=0,NPNT-LOPN,LOPN)
                        IF (J.NE.I)
                          IF ((RPNT(I+1)-RPNT(J+1))**2+
     +                        (RPNT(I+2)-RPNT(J+2))**2+
     +                        (RPNT(I+3)-RPNT(J+3))**2.LT.HLRS)
                            IF      (RPNT(I+4).GT.RPNT(J+4))
                              IF (ITMP.LT.0) GO TO 111
                              ITMP=+1
                            ELSE IF (RPNT(I+4).LT.RPNT(J+4))
                              IF (ITMP.GT.0) GO TO 111
                              ITMP=-1
                            END IF
                          END IF
                        END IF
                      END DO
                    END DO
C
C Finish computing the location of the "high" or "low" and, ...
C
                    XTMP=XTMP/REAL(NTMP)
                    YTMP=YTMP/REAL(NTMP)
                    ZTMP=ZTMP/REAL(NTMP)
C
C ??? MOVE POINT BACK ONTO MESH ???  The point (XTMP,YTMP,ZTMP) is at
C the center of mass of a connected group of points on the surface of
C the mesh, all of which have the same data value associated with them.
C It is possible, particularly if the group is large, that this point
C is some distance off the mesh, in which case we would like to either
C 1) move the point back onto the mesh, or 2) not put a high or low
C there after all, or 3) something else, perhaps under user control.
C
                    DVAL=DNOW
C
C ... if all comparisons indicate that a high has been found, ...
C
                    IF (ITMP.GT.0)
C
C ... put a "high" label there; ...
C
                      IF (TXHI(1:LTHI).NE.' ')
                        IHOL=0
                        INVOKE (WRITE-A-LABEL)
                      END IF
C
C ... but if all comparisons indicate that a low has been found, ...
C
                    ELSE IF (ITMP.LT.0)
C
C ... put a "low" label there.
C
                      IF (TXLO(1:LTLO).NE.' ')
                        IHOL=1
                        INVOKE (WRITE-A-LABEL)
                      END IF
C
                    END IF
C
                  END IF
C
C We're done with that subgroup; initialize to look for the next one.
C
  111             JNDX=KNDX+1
                  KNDX=JNDX
C
                END WHILE
C
              END IF
C
C All elements of the group have been processed, so zero NEQU and keep
C looking through the index array.
C
              NEQU=0
C
            END IF
C
          END FOR
C
        END IF
C
C Tell IFTRAN to use the FORTRAN-77 implementation of block-IFs.
C
.OP     BI=77
C
C Discard any integer workspace possibly acquired above.
C
  112     LI01=0
C
C Return PLOTCHAR to its default state.
C
  113   CALL PCSETI ('TE',ISTE)
        IF (ICFELL('CTHLLB',3).NE.0) RETURN
C
C Done.
C
        RETURN
C
C The following internal procedure writes a high (if IHOL=0) or low (if
C IHOL=1) label, centered at the point whose coordinates are XTMP, YTMP,
C and ZTMP; the field value is taken to be DVAL.
C
        BLOCK (WRITE-A-LABEL)
C
          IF (IMPF.EQ.0)
            XLBC=XTMP
            YLBC=YTMP
            IVIS=1
          ELSE
            CALL HLUCTMXYZ (IMPF,XTMP,YTMP,ZTMP,XLBC,YLBC)
            IF (ICFELL('CTHLLB',4).NE.0) RETURN
            IF ((OORV.NE.0.).AND.(XLBC.EQ.OORV.OR.YLBC.EQ.OORV))
              IVIS=0
            ELSE
              IVIS=1
            END IF
          END IF
C
          IF (IVIS.NE.0)
            XCLB=CUFX(XLBC)
            IF (ICFELL('CTHLLB',5).NE.0) RETURN
            YCLB=CUFY(YLBC)
            IF (ICFELL('CTHLLB',6).NE.0) RETURN
            IF (IHOL.EQ.0)
              CALL CTSBST(TXHI(1:LTHI),CTMA,LCTM)
            ELSE
              CALL CTSBST(TXLO(1:LTLO),CTMA,LCTM)
            END IF
            CALL HLUCTCHHL (+1+4*IHOL)
            IF (ICFELL('CTHLLB',7).NE.0) RETURN
            IF (CTMA(1:LCTM).EQ.' ') GO TO 114
            CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,360.,0.)
            IF (ICFELL('CTHLLB',8).NE.0) RETURN
            CALL HLUCTCHHL (-1-4*IHOL)
            IF (ICFELL('CTHLLB',9).NE.0) RETURN
            CALL PCGETR ('DL',DTOL)
            IF (ICFELL('CTHLLB',10).NE.0) RETURN
            CALL PCGETR ('DR',DTOR)
            IF (ICFELL('CTHLLB',11).NE.0) RETURN
            CALL PCGETR ('DB',DTOB)
            IF (ICFELL('CTHLLB',12).NE.0) RETURN
            CALL PCGETR ('DT',DTOT)
            IF (ICFELL('CTHLLB',13).NE.0) RETURN
            DTOL=DTOL+WWFS
            DTOR=DTOR+WWFS
            DTOB=DTOB+WWFS
            DTOT=DTOT+WWFS
            XTRA=.5*CHWM*WCHL*(XVPR-XVPL)
            DSTL=DTOL+XTRA
            DSTR=DTOR+XTRA
            DSTB=DTOB+XTRA
            DSTT=DTOT+XTRA
C
            IF (IOHL.NE.0)
C
              IF (ANLB.EQ.0.)
                XLLB=XCLB-DSTL
                XRLB=XCLB+DSTR
                YBLB=YCLB-DSTB
                YTLB=YCLB+DSTT
              ELSE
                XLBL=XCLB-DSTL*COS(ANLB)+DSTB*SIN(ANLB)
                XRBL=XCLB+DSTR*COS(ANLB)+DSTB*SIN(ANLB)
                XRTL=XCLB+DSTR*COS(ANLB)-DSTT*SIN(ANLB)
                XLTL=XCLB-DSTL*COS(ANLB)-DSTT*SIN(ANLB)
                YLBL=YCLB-DSTL*SIN(ANLB)-DSTB*COS(ANLB)
                YRBL=YCLB+DSTR*SIN(ANLB)-DSTB*COS(ANLB)
                YRTL=YCLB+DSTR*SIN(ANLB)+DSTT*COS(ANLB)
                YLTL=YCLB-DSTL*SIN(ANLB)+DSTT*COS(ANLB)
                XLLB=MIN(XLBL,XRBL,XRTL,XLTL)
                XRLB=MAX(XLBL,XRBL,XRTL,XLTL)
                YBLB=MIN(YLBL,YRBL,YRTL,YLTL)
                YTLB=MAX(YLBL,YRBL,YRTL,YLTL)
              END IF
C
              IF (IOHL/4.EQ.1)
                IF (XLLB.LT.XVPL.OR.XRLB.GT.XVPR.OR.
     +              YBLB.LT.YVPB.OR.YTLB.GT.YVPT) GO TO 114
              ELSE IF (IOHL/4.GE.2)
                DELX=0.
                IF (XLLB.LT.XVPL) DELX=XVPL-XLLB
                IF (XRLB+DELX.GT.XVPR)
                  IF (DELX.NE.0.) GO TO 114
                  DELX=XVPR-XRLB
                END IF
                DELY=0.
                IF (YBLB.LT.YVPB) DELY=YVPB-YBLB
                IF (YTLB+DELY.GT.YVPT)
                  IF (DELY.NE.0.) GO TO 114
                  DELY=YVPT-YTLB
                END IF
                XCLB=XCLB+DELX
                XLLB=XLLB+DELX
                XRLB=XRLB+DELX
                YCLB=YCLB+DELY
                YBLB=YBLB+DELY
                YTLB=YTLB+DELY
                XLBC=CFUX(XCLB)
                IF (ICFELL('CTHLLB',14).NE.0) RETURN
                YLBC=CFUY(YCLB)
                IF (ICFELL('CTHLLB',15).NE.0) RETURN
              END IF
C
            END IF
C
            IF (MOD(IOHL,4).NE.0)
C
              ILB1=1
              ILB2=NLBS
              IF (MOD(IOHL,2).EQ.0) ILB1=INHL
              IF (MOD(IOHL/2,2).EQ.0) ILB2=INHL-1
C
              FOR (ILBL = ILB1 TO ILB2)
C
                IF (ILBL.EQ.INIL) ETRA=.5*CHWM*WCIL*(XVPR-XVPL)
                IF (ILBL.EQ.INHL) ETRA=.5*CHWM*WCHL*(XVPR-XVPL)
                XCOL=RWRK(IR03+4*(ILBL-1)+1)
                YCOL=RWRK(IR03+4*(ILBL-1)+2)
                ANOL=RWRK(IR03+4*(ILBL-1)+3)
                SAOL=SIN(ANOL)
                CAOL=COS(ANOL)
                ICOL=INT(RWRK(IR03+4*(ILBL-1)+4))
                ODSL=RWRK(IR04-ICOL+3)+ETRA
                ODSR=RWRK(IR04-ICOL+4)+ETRA
                ODSB=RWRK(IR04-ICOL+5)+ETRA
                ODST=RWRK(IR04-ICOL+6)+ETRA
C
                IF (ANOL.EQ.0.)
                  XLOL=XCOL-ODSL
                  XROL=XCOL+ODSR
                  YBOL=YCOL-ODSB
                  YTOL=YCOL+ODST
                ELSE
                  XLBO=XCOL-ODSL*CAOL+ODSB*SAOL
                  XRBO=XCOL+ODSR*CAOL+ODSB*SAOL
                  XRTO=XCOL+ODSR*CAOL-ODST*SAOL
                  XLTO=XCOL-ODSL*CAOL-ODST*SAOL
                  YLBO=YCOL-ODSL*SAOL-ODSB*CAOL
                  YRBO=YCOL+ODSR*SAOL-ODSB*CAOL
                  YRTO=YCOL+ODSR*SAOL+ODST*CAOL
                  YLTO=YCOL-ODSL*SAOL+ODST*CAOL
                  XLOL=MIN(XLBO,XRBO,XRTO,XLTO)
                  XROL=MAX(XLBO,XRBO,XRTO,XLTO)
                  YBOL=MIN(YLBO,YRBO,YRTO,YLTO)
                  YTOL=MAX(YLBO,YRBO,YRTO,YLTO)
                END IF
C
                IF (XRLB.GE.XLOL.AND.XLLB.LE.XROL.AND.
     +              YTLB.GE.YBOL.AND.YBLB.LE.YTOL) GO TO 114
C
              END FOR
C
            END IF
C
            NLBS=NLBS+1
            IF (4*NLBS.GT.LR03)
              CALL CTGRWS (RWRK,3,MAX(4*NLBS,LR03+100),IWSE)
              IF (IWSE.NE.0)
                NLBS=NLBS-1
                GO TO 112
              ELSE IF (ICFELL('CTHLLB',16).NE.0)
                NLBS=NLBS-1
                RETURN
              END IF
            END IF
            RWRK(IR03+4*(NLBS-1)+1)=XCLB
            RWRK(IR03+4*(NLBS-1)+2)=YCLB
            RWRK(IR03+4*(NLBS-1)+3)=ANLB
            RWRK(IR03+4*(NLBS-1)+4)=-NR04
            NR04=NR04+6
            IF (NR04.GT.LR04)
              CALL CTGRWS (RWRK,4,MAX(NR04,LR04+100),IWSE)
              IF (IWSE.NE.0)
                NLBS=NLBS-1
                GO TO 112
              ELSE IF (ICFELL('CTHLLB',17).NE.0)
                NLBS=NLBS-1
                RETURN
              END IF
            END IF
            RWRK(IR04+NR04-5)=REAL(IHOL+1)
            RWRK(IR04+NR04-4)=DVAL
            RWRK(IR04+NR04-3)=DTOL
            RWRK(IR04+NR04-2)=DTOR
            RWRK(IR04+NR04-1)=DTOB
            RWRK(IR04+NR04  )=DTOT
C
          END IF
C
  114   END BLOCK
C
      END


      SUBROUTINE CTHLSO (RWRK,NORN,LORN,ISES,IWRK)
C
        DIMENSION RWRK(*),IWRK(*)
C
C This is a modification of a sort routine from TDPACK.  I think the
C original came from Fred Clare.
C
C Given NORN nodes, each consisting of LORN reals, in an array RWRK, a
C sort element selector ISEL [= ABS(ISES)] and an integer array IWRK of
C length NORN, CTHLSO returns in IWRK an array of base indices of nodes
C of RWRK such that if M and N are both in [1,NORN] and M is less than
C or equal to N, then RWRK(IWRK(M)+ISEL) is less than or equal to
C RWRK(IWRK(N)+ISEL).  The base indices returned in IWRK allow one
C to step through the nodes of RWRK in increasing order of the node
C element ISEL.
C
C If the input value of ISES is positive, IWRK is initialized to contain
C the base indices of the first NORN nodes (of length LORN) in RWRK, but
C if the input value of ISES is negative, the initialization of IWRK is
C skipped; it is assumed that the user has initialized IWRK himself and
C that the NORN nodes being sorted on constitute a noncontiguous subset
C of all the nodes (of length LORN) in RWRK.
C
C If requested, generate base indices in the array IWRK.  In any case,
C set the sort element selector ISEL.
C
        IF (ISES.LT.0)
          ISEL=-ISES
        ELSE
          ISEL=+ISES
          DO (I=1,NORN)
            IWRK(I)=(I-1)*LORN
          END DO
        END IF
C
C Sort the NORN nodes into increasing order.
C                                                                       
        K=0
C
  101   IF (3*K+1.LT.NORN)
          K=3*K+1
          GO TO 101
        END IF
C
  102   IF (K.GT.0)
C
          DO 104 I=1,NORN-K
C
            J=I
C
  103       IF (RWRK(IWRK(J)+ISEL).LE.RWRK(IWRK(J+K)+ISEL)) GO TO 104
            ITMP=IWRK(J)
            IWRK(J)=IWRK(J+K)
            IWRK(J+K)=ITMP
            J=J-K
            IF (J.LT.1) GO TO 104
            GO TO 103
C
  104     CONTINUE
C
          K=(K-1)/3
C
          GO TO 102
C
        END IF
C
C Done.
C
        RETURN
C
      END                                                               


      SUBROUTINE CTINLB (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C CTINLB 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 CONPACKT common blocks.
C
.CALL CTCOMN,/$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 CTSBST (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('CTINLB',1).NE.0) RETURN
        YLBC=CFUY(YPFS)
        IF (ICFELL('CTINLB',2).NE.0) RETURN
        WCFS=CHWM*WCIL*(XVPR-XVPL)
        WWFS=CHWM*WWIL*(XVPR-XVPL)
C
        CALL PCGETI ('TE',ISTE)
        IF (ICFELL('CTINLB',3).NE.0) RETURN
        CALL PCSETI ('TE',1)
        IF (ICFELL('CTINLB',4).NE.0) RETURN
        CALL HLUCTCHIL (+1)
        IF (ICFELL('CTINLB',5).NE.0) RETURN
        IF (CTMA(1:LCTM).EQ.' ') GO TO 101
        CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,360.,0.)
        IF (ICFELL('CTINLB',6).NE.0) RETURN
        CALL HLUCTCHIL (-1)
        IF (ICFELL('CTINLB',7).NE.0) RETURN
        CALL PCGETR ('DL',DSTL)
        IF (ICFELL('CTINLB',8).NE.0) RETURN
        CALL PCGETR ('DR',DSTR)
        IF (ICFELL('CTINLB',9).NE.0) RETURN
        CALL PCGETR ('DB',DSTB)
        IF (ICFELL('CTINLB',10).NE.0) RETURN
        CALL PCGETR ('DT',DSTT)
        IF (ICFELL('CTINLB',11).NE.0) RETURN
        CALL PCSETI ('TE',ISTE)
        IF (ICFELL('CTINLB',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('CTINLB',13).NE.0) RETURN
        YLBC=CFUY(YPFS)
        IF (ICFELL('CTINLB',14).NE.0) RETURN
C
        NLBS=NLBS+1
        IF (4*NLBS.GT.LR03)
          CALL CTGRWS (RWRK,3,MAX(4*NLBS,LR03+100),IWSE)
          IF (IWSE.NE.0.OR.ICFELL('CTINLB',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 CTGRWS (RWRK,4,MAX(NR04,LR04+100),IWSE)
          IF (IWSE.NE.0.OR.ICFELL('CTINLB',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 CTINRC
C
C CTINRC sets constants that are required by CONPACKT 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 CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Do a call forcing a BLOCKDATA to be loaded from a binary library.
C
        CALL CTBLDA
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 CTNUMB.
C
        NSDR=0
C
        REPEAT
          NSDR=NSDR+1
          CALL CTINRK (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 CTINRK (NSDR,TMP1,TMP2,TMP3)
C
C This routine computes some quantities needed by CTINRC; 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 CTNUMB (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 CONPACKT common blocks.
C
.CALL CTCOMN,/$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 CTPISB (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 CTPITT (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 non-zero; otherwise, it is a count of the number of
C 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 CTPISB (XCA1,YCA1,XCA2,YCA2,XCB1,YCB1,XCB2,YCB2,
     +                                         XCOP,YCOP,IFLG)
         CALL CTPISB (XCA1,YCA1,XCA2,YCA2,XCB2,YCB2,XCB3,YCB3,
     +                                         XCOP,YCOP,IFLG)
         CALL CTPISB (XCA1,YCA1,XCA2,YCA2,XCB3,YCB3,XCB1,YCB1,
     +                                         XCOP,YCOP,IFLG)
         CALL CTPISB (XCA2,YCA2,XCA3,YCA3,XCB1,YCB1,XCB2,YCB2,
     +                                         XCOP,YCOP,IFLG)
         CALL CTPISB (XCA2,YCA2,XCA3,YCA3,XCB2,YCB2,XCB3,YCB3,
     +                                         XCOP,YCOP,IFLG)
         CALL CTPISB (XCA2,YCA2,XCA3,YCA3,XCB3,YCB3,XCB1,YCB1,
     +                                         XCOP,YCOP,IFLG)
         CALL CTPISB (XCA3,YCA3,XCA1,YCA1,XCB1,YCB1,XCB2,YCB2,
     +                                         XCOP,YCOP,IFLG)
         CALL CTPISB (XCA3,YCA3,XCA1,YCA1,XCB2,YCB2,XCB3,YCB3,
     +                                         XCOP,YCOP,IFLG)
         CALL CTPISB (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 CTPLAR (RWRK,IPTX,IPTY,NXYC)
C
        DIMENSION RWRK(*)
C
C (RWRK(I),I=IPTX+1,IPTX+NXYC) and (RWRK(I),I=IPTY+1,IPTY+NXYC) contain
C the X and Y coordinates (in the user coordinate system) of points
C defining a portion of a contour line.  The function of the routine
C CTPLAR is to position one or more labels at regular intervals along
C that portion.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C If there are fewer than three points, skip it.
C
        IF (NXYC.LT.3) RETURN
C
C Compute character-size and white-space-size variables.
C
        WCFS=CHWM*WCLL*(XVPR-XVPL)
        WWFS=CHWM*WWLL*(XVPR-XVPL)
C
        XTRA=.5*WCFS
C
C Convert all the coordinates from the user system to the fractional
C system.
C
        DO (I=1,NXYC)
          RWRK(IPTX+I)=CUFX(RWRK(IPTX+I))
          IF (ICFELL('CTPLAR',1).NE.0) RETURN
          RWRK(IPTY+I)=CUFY(RWRK(IPTY+I))
          IF (ICFELL('CTPLAR',2).NE.0) RETURN
        END DO
C
C Initialize.  NLBI is the number of labels initially in the list, DATL
C is the distance along the line from the first point to the current
C point, and DANL is the desired distance to the next label.
C
        NLBI=NLBS
        DATL=0.
        DANL=DBLF+2.*(CTRANF()-.5)*DBLV
C
C Examine points along the contour line, putting labels at chosen ones.
C
        DO (I=2,NXYC-1)
C
C Wait until we have gone sufficiently far along the line.
C
          DATL=DATL+SQRT((RWRK(IPTX+I)-RWRK(IPTX+I-1))**2+
     +                   (RWRK(IPTY+I)-RWRK(IPTY+I-1))**2)
C
          IF (DATL.GE.DANL)
C
C Consider a possible label centered at the point (XCLB,YCLB).
C
            XCLB=RWRK(IPTX+I)
            YCLB=RWRK(IPTY+I)
C
C Call a user routine which may change the label to be used; if the
C label string is blanked by that routine, don't put a label there.
C
            XLBC=CFUX(XCLB)
            IF (ICFELL('CTPLAR',3).NE.0) RETURN
            YLBC=CFUY(YCLB)
            IF (ICFELL('CTPLAR',4).NE.0) RETURN
C
            DVAL=CLEV(ICLV)
C
            LCTM=NCLB(ICLV)
            CTMA(1:LCTM)=CLBL(ICLV)(1:LCTM)
            CTMB(1:LCTM)=CTMA(1:LCTM)
C
            CALL HLUCTCHLL (+1)
            IF (ICFELL('CTPLAR',5).NE.0) RETURN
C
C If the label string was blanked by the user, don't put a label there.
C
            IF (CTMA(1:LCTM).EQ.' ') GO TO 101
C
C Set text extent variables; how this is done depends on whether the
C user changed the label string or not.
C
            IF (CTMA(1:LCTM).EQ.CTMB(1:LCTM))
              DSTL=CLDL(ICLV)+XTRA
              DSTR=CLDR(ICLV)+XTRA
              DSTB=CLDB(ICLV)+XTRA
              DSTT=CLDT(ICLV)+XTRA
            ELSE
              CALL PCGETI ('TE',ISTE)
              IF (ICFELL('CTPLAR',6).NE.0) RETURN
              CALL PCSETI ('TE',1)
              IF (ICFELL('CTPLAR',7).NE.0) RETURN
              CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,360.,0.)
              IF (ICFELL('CTPLAR',8).NE.0) RETURN
              CALL PCGETR ('DL',DTOL)
              IF (ICFELL('CTPLAR',9).NE.0) RETURN
              CALL PCGETR ('DR',DTOR)
              IF (ICFELL('CTPLAR',10).NE.0) RETURN
              CALL PCGETR ('DB',DTOB)
              IF (ICFELL('CTPLAR',11).NE.0) RETURN
              CALL PCGETR ('DT',DTOT)
              IF (ICFELL('CTPLAR',12).NE.0) RETURN
              CALL PCSETI ('TE',ISTE)
              IF (ICFELL('CTPLAR',13).NE.0) RETURN
              DTOL=DTOL+WWFS
              DTOR=DTOR+WWFS
              DTOB=DTOB+WWFS
              DTOT=DTOT+WWFS
              DSTL=DTOL+XTRA
              DSTR=DTOR+XTRA
              DSTB=DTOB+XTRA
              DSTT=DTOT+XTRA
            END IF
C
C Determine at what angle the label would be written and compute the
C coordinates of the left, right, bottom, and top edges of it.
C
            IF (IOLL.EQ.0)
              ANLB=.017453292519943*ANLL
            ELSE
              IF (I.EQ.1)
                ANLB=ATAN2(RWRK(IPTY+2)-YCLB,RWRK(IPTX+2)-XCLB)
              ELSE IF (I.EQ.NXYC)
                ANLB=ATAN2(YCLB-RWRK(IPTY+NXYC-1),
     +                     XCLB-RWRK(IPTX+NXYC-1))
              ELSE
                ANLB=.5*(ATAN2(YCLB-RWRK(IPTY+I-1),XCLB-RWRK(IPTX+I-1))+
     +                   ATAN2(RWRK(IPTY+I+1)-YCLB,RWRK(IPTX+I+1)-XCLB))
              END IF
              IF (ANLB.LT.-1.57079632679490) ANLB=ANLB+3.14159265358979
              IF (ANLB.GT.+1.57079632679490) ANLB=ANLB-3.14159265358979
            END IF
C
            IF (ANLB.EQ.0.)
              XLLB=XCLB-DSTL
              XRLB=XCLB+DSTR
              YBLB=YCLB-DSTB
              YTLB=YCLB+DSTT
            ELSE
              XLBL=XCLB-DSTL*COS(ANLB)+DSTB*SIN(ANLB)
              XRBL=XCLB+DSTR*COS(ANLB)+DSTB*SIN(ANLB)
              XRTL=XCLB+DSTR*COS(ANLB)-DSTT*SIN(ANLB)
              XLTL=XCLB-DSTL*COS(ANLB)-DSTT*SIN(ANLB)
              YLBL=YCLB-DSTL*SIN(ANLB)-DSTB*COS(ANLB)
              YRBL=YCLB+DSTR*SIN(ANLB)-DSTB*COS(ANLB)
              YRTL=YCLB+DSTR*SIN(ANLB)+DSTT*COS(ANLB)
              YLTL=YCLB-DSTL*SIN(ANLB)+DSTT*COS(ANLB)
              XLLB=MIN(XLBL,XRBL,XRTL,XLTL)
              XRLB=MAX(XLBL,XRBL,XRTL,XLTL)
              YBLB=MIN(YLBL,YRBL,YRTL,YLTL)
              YTLB=MAX(YLBL,YRBL,YRTL,YLTL)
            END IF
C
C If the label would extend outside the viewport, forget it.
C
            IF (XLLB.LE.XVPL.OR.XRLB.GE.XVPR.OR.
     +          YBLB.LE.YVPB.OR.YTLB.GE.YVPT) GO TO 101
C
C If the label would overlap a previous label, forget it.
C
            FOR (ILBL = 1 TO NLBS)
C
              IF (ILBL.EQ.INIL) ETRA=.5*CHWM*WCIL*(XVPR-XVPL)
              IF (ILBL.EQ.INHL) ETRA=.5*CHWM*WCHL*(XVPR-XVPL)
              IF (ILBL.EQ.INLL) ETRA=.5*CHWM*WCLL*(XVPR-XVPL)
              XCOL=RWRK(IR03+4*(ILBL-1)+1)
              YCOL=RWRK(IR03+4*(ILBL-1)+2)
              ANOL=RWRK(IR03+4*(ILBL-1)+3)
              SAOL=SIN(ANOL)
              CAOL=COS(ANOL)
              ICOL=INT(RWRK(IR03+4*(ILBL-1)+4))
              IF (ICOL.LE.0)
                ODSL=RWRK(IR04-ICOL+3)+ETRA
                ODSR=RWRK(IR04-ICOL+4)+ETRA
                ODSB=RWRK(IR04-ICOL+5)+ETRA
                ODST=RWRK(IR04-ICOL+6)+ETRA
              ELSE
                ODSL=CLDL(ICOL)+ETRA
                ODSR=CLDR(ICOL)+ETRA
                ODSB=CLDB(ICOL)+ETRA
                ODST=CLDT(ICOL)+ETRA
              END IF
C
              IF (ANOL.EQ.0.)
                XLOL=XCOL-ODSL
                XROL=XCOL+ODSR
                YBOL=YCOL-ODSB
                YTOL=YCOL+ODST
              ELSE
                XLBO=XCOL-ODSL*CAOL+ODSB*SAOL
                XRBO=XCOL+ODSR*CAOL+ODSB*SAOL
                XRTO=XCOL+ODSR*CAOL-ODST*SAOL
                XLTO=XCOL-ODSL*CAOL-ODST*SAOL
                YLBO=YCOL-ODSL*SAOL-ODSB*CAOL
                YRBO=YCOL+ODSR*SAOL-ODSB*CAOL
                YRTO=YCOL+ODSR*SAOL+ODST*CAOL
                YLTO=YCOL-ODSL*SAOL+ODST*CAOL
                XLOL=MIN(XLBO,XRBO,XRTO,XLTO)
                XROL=MAX(XLBO,XRBO,XRTO,XLTO)
                YBOL=MIN(YLBO,YRBO,YRTO,YLTO)
                YTOL=MAX(YLBO,YRBO,YRTO,YLTO)
              END IF
C
              IF (XRLB.GE.XLOL.AND.XLLB.LE.XROL.AND.
     +            YTLB.GE.YBOL.AND.YBLB.LE.YTOL) GO TO 101
C
            END FOR
C
C No problem.  Go ahead and put a label at this point.
C
            NLBS=NLBS+1
            IF (4*NLBS.GT.LR03)
              IS01=IR01
              CALL CTGRWS (RWRK,3,MAX(4*NLBS,LR03+100),IWSE)
              IPTX=IPTX-IS01+IR01
              IPTY=IPTY-IS01+IR01
              IF (IWSE.NE.0.OR.ICFELL('CTPLAR',14).NE.0)
                NLBS=NLBS-1
                RETURN
              END IF
            END IF
            RWRK(IR03+4*(NLBS-1)+1)=RWRK(IPTX+I)
            RWRK(IR03+4*(NLBS-1)+2)=RWRK(IPTY+I)
            RWRK(IR03+4*(NLBS-1)+3)=ANLB
            IF (CTMA(1:LCTM).EQ.CTMB(1:LCTM))
              RWRK(IR03+4*(NLBS-1)+4)=REAL(ICLV)
            ELSE
              RWRK(IR03+4*(NLBS-1)+4)=-NR04
              NR04=NR04+6
              IF (NR04.GT.LR04)
                IS01=IR01
                CALL CTGRWS (RWRK,4,MAX(NR04,LR04+100),IWSE)
                IPTX=IPTX-IS01+IR01
                IPTY=IPTY-IS01+IR01
                IF (IWSE.NE.0.OR.ICFELL('CTPLAR',15).NE.0)
                  NLBS=NLBS-1
                  RETURN
                END IF
              END IF
              RWRK(IR04+NR04-5)=3.
              RWRK(IR04+NR04-4)=REAL(ICLV)
              RWRK(IR04+NR04-3)=DTOL
              RWRK(IR04+NR04-2)=DTOR
              RWRK(IR04+NR04-1)=DTOB
              RWRK(IR04+NR04  )=DTOT
            END IF
C
C Update the distance along the line to the next label.
C
            DANL=DBLF+REAL(NLBS-NLBI)*DBLN+2.*(CTRANF()-.5)*DBLV
C
          END IF
C
  101   END DO
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CTPLPS (RWRK,IPTX,IPTY,NXYC)
C
        DIMENSION RWRK(*)
C
C (RWRK(I),I=IPTX+1,IPTX+NXYC) and (RWRK(I),I=IPTY+1,IPTY+NXYC) contain
C the X and Y coordinates (in the user coordinate system) of points
C defining a portion of a contour line.  The function of the routine
C CTPLPS is to position one or more labels along that portion, using
C the "penalty scheme" of Starley Thompson and Phil Rasch.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C If there are fewer than three points, skip it.
C
        IF (NXYC.LT.3) RETURN
C
C Set up some needed constants.
C
        DBLS=DBLM*(XVPR-XVPL)*DBLM*(XVPR-XVPL)
C
C Save the current count of labels generated.
C
        NLBI=NLBS
C
C If it is possible to do it and if the value will be needed, estimate
C the contour interval at the current level.
C
        IF (NCLV.LE.1.OR.WTNC.LE.0.)
          ESCI=0.
        ELSE
          IF (CINU.NE.0.)
            ESCI=CINU
          ELSE
            IF (ICLW.EQ.1)
              ESCI=ABS(CLEV(ICLP(2))-CLEV(ICLP(1)))
            ELSE IF (ICLW.EQ.NCLV)
              ESCI=ABS(CLEV(ICLP(NCLV))-CLEV(ICLP(NCLV-1)))
            ELSE
              ESCI=.5*ABS(CLEV(ICLP(ICLW+1))-CLEV(ICLP(ICLW-1)))
            END IF
          END IF
        END IF
C
C Compute character-size and white-space-size variables.
C
        WCFS=CHWM*WCLL*(XVPR-XVPL)
        WWFS=CHWM*WWLL*(XVPR-XVPL)
C
        XTRA=.5*WCFS
C
C Convert all the coordinates from the user system to the fractional
C system.
C
        DO (I=1,NXYC)
          RWRK(IPTX+I)=CUFX(RWRK(IPTX+I))
          IF (ICFELL('CTPLPS',1).NE.0) RETURN
          RWRK(IPTY+I)=CUFY(RWRK(IPTY+I))
          IF (ICFELL('CTPLPS',2).NE.0) RETURN
        END DO
C
C Cull points that are too close to one another.
C
        NXYT=1
C
        LOOP
          NXYT=NXYT+1
          EXIT IF (NXYT.GT.NXYC)
          IF (ABS(RWRK(IPTX+NXYT)-RWRK(IPTX+NXYT-1)).LT.EPSI.AND.
     +        ABS(RWRK(IPTY+NXYT)-RWRK(IPTY+NXYT-1)).LT.EPSI)
            IF (NXYT.NE.NXYC)
              DO (I=NXYT+1,NXYC)
                RWRK(IPTX+I-1)=RWRK(IPTX+I)
                RWRK(IPTY+I-1)=RWRK(IPTY+I)
              END DO
            ELSE
              RWRK(IPTX+NXYC-1)=RWRK(IPTX+NXYC)
              RWRK(IPTY+NXYC-1)=RWRK(IPTY+NXYC)
            END IF
            NXYT=NXYT-1
            NXYC=NXYC-1
          END IF
        END LOOP
C
C If there are fewer than three points left, skip it.
C
        IF (NXYC.LT.3) RETURN
C
C Examine each point along the curve, looking for the point at which
C the penalty function exists and is minimal.  Put a label there and
C repeat until no more such points are found.
C
        REPEAT
C
C IVMN will hold the index of the point at which the penalty function
C is minimized and PVMN will hold the value of the penalty function
C there.  Give them initial values which indicate nothing found so far.
C
          IVMN=0
          PVMN=0.
C
C Loop through the points on the line.
C
          DO (I=1,NXYC)
C
C Consider a possible label centered at the point (XCLB,YCLB).
C
            XCLB=RWRK(IPTX+I)
            YCLB=RWRK(IPTY+I)
C
C If the center point is too close to the center point of a label
C already put on this line, forget it.
C
            FOR (ILBL = NLBI+1 TO NLBS)
              IF ((XCLB-RWRK(IR03+4*(ILBL-1)+1))**2+
     +            (YCLB-RWRK(IR03+4*(ILBL-1)+2))**2.LE.DBLS) GO TO 102
            END FOR
C
C Call a user routine which may change the label to be used; if the
C label string is blanked by that routine, don't put a label there.
C
            XLBC=CFUX(XCLB)
            IF (ICFELL('CTPLPS',3).NE.0) RETURN
            YLBC=CFUY(YCLB)
            IF (ICFELL('CTPLPS',4).NE.0) RETURN
C
            DVAL=CLEV(ICLV)
C
            LCTM=NCLB(ICLV)
            CTMA(1:LCTM)=CLBL(ICLV)(1:LCTM)
            CTMB(1:LCTM)=CTMA(1:LCTM)
C
            CALL HLUCTCHLL (+1)
            IF (ICFELL('CTPLPS',5).NE.0) RETURN
C
C If the label string was blanked by the user, don't put a label there.
C
            IF (CTMA(1:LCTM).EQ.' ') GO TO 102
C
C Set text extent variables; how this is done depends on whether the
C user changed the label string or not.
C
            IF (CTMA(1:LCTM).EQ.CTMB(1:LCTM))
              ICHF=0
              DSTB=CLDB(ICLV)+XTRA
              DSTL=CLDL(ICLV)+XTRA
              DSTR=CLDR(ICLV)+XTRA
              DSTT=CLDT(ICLV)+XTRA
            ELSE
              ICHF=1
              CALL PCGETI ('TE',ISTE)
              IF (ICFELL('CTPLPS',6).NE.0) RETURN
              CALL PCSETI ('TE',1)
              IF (ICFELL('CTPLPS',7).NE.0) RETURN
              CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,360.,0.)
              IF (ICFELL('CTPLPS',8).NE.0) RETURN
              CALL PCGETR ('DL',DTOL)
              IF (ICFELL('CTPLPS',9).NE.0) RETURN
              CALL PCGETR ('DR',DTOR)
              IF (ICFELL('CTPLPS',10).NE.0) RETURN
              CALL PCGETR ('DB',DTOB)
              IF (ICFELL('CTPLPS',11).NE.0) RETURN
              CALL PCGETR ('DT',DTOT)
              IF (ICFELL('CTPLPS',12).NE.0) RETURN
              CALL PCSETI ('TE',ISTE)
              IF (ICFELL('CTPLPS',13).NE.0) RETURN
              DTOL=DTOL+WWFS
              DTOR=DTOR+WWFS
              DTOB=DTOB+WWFS
              DTOT=DTOT+WWFS
              DSTL=DTOL+XTRA
              DSTR=DTOR+XTRA
              DSTB=DTOB+XTRA
              DSTT=DTOT+XTRA
            END IF
C
            WLBL=DSTL+DSTR
            HLBL=DSTB+DSTT
            CRAD=MAX(DSTB,DSTL,DSTR,DSTT)
C
C Determine at what angle the label would be written and compute the
C coordinates of the left, right, bottom, and top edges of it.
C
            IF (IOLL.EQ.0)
              ANLB=.017453292519943*ANLL
            ELSE
              IF (I.EQ.1)
                ANLB=ATAN2(RWRK(IPTY+2)-YCLB,RWRK(IPTX+2)-XCLB)
              ELSE IF (I.EQ.NXYC)
                ANLB=ATAN2(YCLB-RWRK(IPTY+NXYC-1),
     +                     XCLB-RWRK(IPTX+NXYC-1))
              ELSE
                ANLB=.5*(ATAN2(YCLB-RWRK(IPTY+I-1),XCLB-RWRK(IPTX+I-1))+
     +                   ATAN2(RWRK(IPTY+I+1)-YCLB,RWRK(IPTX+I+1)-XCLB))
              END IF
              IF (ANLB.LT.-1.57079632679490) ANLB=ANLB+3.14159265358979
              IF (ANLB.GT.+1.57079632679490) ANLB=ANLB-3.14159265358979
            END IF
C
            IF (ANLB.EQ.0.)
              XLLB=XCLB-DSTL
              XRLB=XCLB+DSTR
              YBLB=YCLB-DSTB
              YTLB=YCLB+DSTT
            ELSE
              XLBL=XCLB-DSTL*COS(ANLB)+DSTB*SIN(ANLB)
              XRBL=XCLB+DSTR*COS(ANLB)+DSTB*SIN(ANLB)
              XRTL=XCLB+DSTR*COS(ANLB)-DSTT*SIN(ANLB)
              XLTL=XCLB-DSTL*COS(ANLB)-DSTT*SIN(ANLB)
              YLBL=YCLB-DSTL*SIN(ANLB)-DSTB*COS(ANLB)
              YRBL=YCLB+DSTR*SIN(ANLB)-DSTB*COS(ANLB)
              YRTL=YCLB+DSTR*SIN(ANLB)+DSTT*COS(ANLB)
              YLTL=YCLB-DSTL*SIN(ANLB)+DSTT*COS(ANLB)
              XLLB=MIN(XLBL,XRBL,XRTL,XLTL)
              XRLB=MAX(XLBL,XRBL,XRTL,XLTL)
              YBLB=MIN(YLBL,YRBL,YRTL,YLTL)
              YTLB=MAX(YLBL,YRBL,YRTL,YLTL)
            END IF
C
C If the label would extend outside the viewport, forget it.
C
            IF (XLLB.LE.XVPL.OR.XRLB.GE.XVPR.OR.
     +          YBLB.LE.YVPB.OR.YTLB.GE.YVPT) GO TO 102
C
C If the label would overlap a previous label, forget it.
C
            FOR (ILBL = 1 TO NLBI)
C
              IF (ILBL.EQ.INIL) ETRA=.5*CHWM*WCIL*(XVPR-XVPL)
              IF (ILBL.EQ.INHL) ETRA=.5*CHWM*WCHL*(XVPR-XVPL)
              IF (ILBL.EQ.INLL) ETRA=.5*CHWM*WCLL*(XVPR-XVPL)
              XCOL=RWRK(IR03+4*(ILBL-1)+1)
              YCOL=RWRK(IR03+4*(ILBL-1)+2)
              ANOL=RWRK(IR03+4*(ILBL-1)+3)
              SAOL=SIN(ANOL)
              CAOL=COS(ANOL)
              ICOL=INT(RWRK(IR03+4*(ILBL-1)+4))
              IF (ICOL.LE.0)
                ODSL=RWRK(IR04-ICOL+3)+ETRA
                ODSR=RWRK(IR04-ICOL+4)+ETRA
                ODSB=RWRK(IR04-ICOL+5)+ETRA
                ODST=RWRK(IR04-ICOL+6)+ETRA
              ELSE
                ODSL=CLDL(ICOL)+ETRA
                ODSR=CLDR(ICOL)+ETRA
                ODSB=CLDB(ICOL)+ETRA
                ODST=CLDT(ICOL)+ETRA
              END IF
C
              IF (ANOL.EQ.0.)
                XLOL=XCOL-ODSL
                XROL=XCOL+ODSR
                YBOL=YCOL-ODSB
                YTOL=YCOL+ODST
              ELSE
                XLBO=XCOL-ODSL*CAOL+ODSB*SAOL
                XRBO=XCOL+ODSR*CAOL+ODSB*SAOL
                XRTO=XCOL+ODSR*CAOL-ODST*SAOL
                XLTO=XCOL-ODSL*CAOL-ODST*SAOL
                YLBO=YCOL-ODSL*SAOL-ODSB*CAOL
                YRBO=YCOL+ODSR*SAOL-ODSB*CAOL
                YRTO=YCOL+ODSR*SAOL+ODST*CAOL
                YLTO=YCOL-ODSL*SAOL+ODST*CAOL
                XLOL=MIN(XLBO,XRBO,XRTO,XLTO)
                XROL=MAX(XLBO,XRBO,XRTO,XLTO)
                YBOL=MIN(YLBO,YRBO,YRTO,YLTO)
                YTOL=MAX(YLBO,YRBO,YRTO,YLTO)
              END IF
C
              IF (XRLB.GE.XLOL.AND.XLLB.LE.XROL.AND.
     +            YTLB.GE.YBOL.AND.YBLB.LE.YTOL) GO TO 102
C
            END FOR
C
C Compute the value of the penalty function at this point.  Initialize
C to zero.
C
            PNAL=0.
C
C If it will be needed below, estimate the gradient.  If the gradient
C does not exist (which can happen in special-value regions), skip the
C point.
C
            IF (WTGR.GT.0..OR.ESCI.NE.0.)
              IGIN=MAX(1,MIN(IGRM,1+INT((XCLB-XVPL)/(XVPR-XVPL)*
     +                                                     REAL(IGRM))))
              JGIN=MAX(1,MIN(IGRN,1+INT((YCLB-YVPB)/(YVPT-YVPB)*
     +                                                     REAL(IGRN))))
              GRAD=RWRK(IR02+(JGIN-1)*IGRM+IGIN)
              IF (GRAD.LT.0.) GO TO 102
            END IF
C
C Penalize if the point is in a high-gradient region relative to the
C average gradient.  If the gradient exceeds user-specified tolerances,
C skip the point completely.
C
            IF (WTGR.GT.0.)
              IF (GRAD.GT.GRAV+GSDM*GRSD) GO TO 102
              PNAL=PNAL+WTGR*GRAD/(GRAV+GSDM*GRSD)
            END IF
C
C Penalize if the number of contour lines crossing the label is too
C large.  If the number is greater than a user-specified value, skip
C the point entirely.
C
            IF (ESCI.NE.0.)
              IF (I.EQ.1)
                ANCL=ATAN2(RWRK(IPTY+2)-YCLB,RWRK(IPTX+2)-XCLB)
              ELSE IF (I.EQ.NXYC)
                ANCL=ATAN2(YCLB-RWRK(IPTY+NXYC-1),
     +                     XCLB-RWRK(IPTX+NXYC-1))
              ELSE
                ANCL=.5*(ATAN2(YCLB-RWRK(IPTY+I-1),XCLB-RWRK(IPTX+I-1))+
     +                   ATAN2(RWRK(IPTY+I+1)-YCLB,RWRK(IPTX+I+1)-XCLB))
              END IF
              FNCL=(WLBL*ABS(SIN(ANLB-ANCL))+HLBL*ABS(COS(ANLB-ANCL)))/
     +             (ESCI/GRAD)
              IF (FNCL.GT.FNCM) GO TO 102
              PNAL=PNAL+WTNC*FNCL/FNCM
            END IF
C
C Penalize if the point is in a curvy part of the line.  Curviness is
C estimated by looking at all the points on the line within a radius
C CRAD and adding up all the changes in direction at those points.
C
            IF (WTCD.GT.0.)
C
              CDIR=0.
C
              J=I
              LOOP
                K=J
                EXIT IF ((RWRK(IPTX+K)-XCLB)**2+
     +                   (RWRK(IPTY+K)-YCLB)**2.GT.CRAD**2)
                IF (K.NE.1)
                  J=K-1
                ELSE
                  IF (ABS(RWRK(IPTX+NXYC)-RWRK(IPTX+1)).GT..0001.OR.
     +                ABS(RWRK(IPTY+NXYC)-RWRK(IPTY+1)).GT..0001)
                    J=0
                    EXIT
                  END IF
                  IF (I.EQ.NXYC)
                    J=I
                    EXIT
                  END IF
                  J=NXYC-1
                END IF
                IF (K.NE.NXYC)
                  L=K+1
                ELSE
                  IF (ABS(RWRK(IPTX+NXYC)-RWRK(IPTX+1)).GT..0001.OR.
     +                ABS(RWRK(IPTY+NXYC)-RWRK(IPTY+1)).GT..0001)
     +                GO TO 101
                  L=2
                END IF
                CDAP=57.2957795130823*
     +                             ABS(ATAN2(RWRK(IPTY+L)-RWRK(IPTY+K),
     +                                       RWRK(IPTX+L)-RWRK(IPTX+K))-
     +                                 ATAN2(RWRK(IPTY+K)-RWRK(IPTY+J),
     +                                       RWRK(IPTX+K)-RWRK(IPTX+J)))
                IF (CDAP.GT.180.) CDAP=ABS(CDAP-360.)
                CDIR=CDIR+CDAP
  101           EXIT IF (J.EQ.I)
              END LOOP
C
              IF (J.NE.I)
                L=I
                LOOP
                  K=L
                  EXIT IF ((RWRK(IPTX+K)-XCLB)**2+
     +                     (RWRK(IPTY+K)-YCLB)**2.GT.CRAD**2)
                  J=K-1
                  IF (K.NE.NXYC)
                    L=K+1
                  ELSE
                    EXIT IF (ABS(RWRK(IPTX+NXYC)-RWRK(IPTX+1)).GT..0001
     +                   .OR.ABS(RWRK(IPTY+NXYC)-RWRK(IPTY+1)).GT..0001)
                    EXIT IF ((RWRK(IPTX+1)-XCLB)**2+
     +                       (RWRK(IPTY+1)-YCLB)**2.GT.CRAD**2)
                    L=2
                  END IF
                  IF (K.NE.I)
                    CDAP=57.2957795130823*
     +                             ABS(ATAN2(RWRK(IPTY+L)-RWRK(IPTY+K),
     +                                       RWRK(IPTX+L)-RWRK(IPTX+K))-
     +                                 ATAN2(RWRK(IPTY+K)-RWRK(IPTY+J),
     +                                       RWRK(IPTX+K)-RWRK(IPTX+J)))
                    IF (CDAP.GT.180.) CDAP=ABS(CDAP-360.)
                    CDIR=CDIR+CDAP
                  END IF
                END LOOP
              END IF
C
              IF (CDIR.GT.CDMX) GO TO 102
C
              PNAL=PNAL+WTCD*CDIR/CDMX
C
            END IF
C
C Penalize for being at other than the optimum distance from a label on
C contour lines previously considered.
C
            IF (WTOD.GT.0.)
C
              POPD=1.
C
              FOR (ILBL = INLL TO NLBI)
                IF (INT(RWRK(IR03+4*(ILBL-1)+4)).NE.ICLV)
                  DIST=SQRT((XCLB-RWRK(IR03+4*(ILBL-1)+1))**2+
     +                      (YCLB-RWRK(IR03+4*(ILBL-1)+2))**2)
                  POPD=MIN(POPD,1.-EXP(-((DIST-DOPT*(XVPR-XVPL))
     +                                         /(DFLD*(XVPR-XVPL)))**2))
                END IF
              END FOR
C
              PNAL=PNAL+WTOD*POPD
C
            END IF
C
C If the value of the penalty function at this point is less than the
C previous minimum value found, update the information about the
C minimum.
C
            IF (IVMN.EQ.0.OR.PNAL.LT.PVMN)
              IVMN=I
              PVMN=PNAL
              XVMN=XCLB
              YVMN=YCLB
              AVMN=ANLB
              ISCF=ICHF
              SDTL=DTOL
              SDTR=DTOR
              SDTB=DTOB
              SDTT=DTOT
            END IF
C
  102     END DO
C
          IF (IVMN.NE.0)
            NLBS=NLBS+1
            IF (4*NLBS.GT.LR03)
              IS01=IR01
              CALL CTGRWS (RWRK,3,MAX(4*NLBS,LR03+100),IWSE)
              IPTX=IPTX-IS01+IR01
              IPTY=IPTY-IS01+IR01
              IF (IWSE.NE.0.OR.ICFELL('CTPLPS',14).NE.0)
                NLBS=NLBS-1
                RETURN
              END IF
            END IF
            RWRK(IR03+4*(NLBS-1)+1)=XVMN
            RWRK(IR03+4*(NLBS-1)+2)=YVMN
            RWRK(IR03+4*(NLBS-1)+3)=AVMN
            IF (ISCF.EQ.0)
              RWRK(IR03+4*(NLBS-1)+4)=REAL(ICLV)
            ELSE
              RWRK(IR03+4*(NLBS-1)+4)=-NR04
              NR04=NR04+6
              IF (NR04.GT.LR04)
                IS01=IR01
                CALL CTGRWS (RWRK,4,MAX(NR04,LR04+100),IWSE)
                IPTX=IPTX-IS01+IR01
                IPTY=IPTY-IS01+IR01
                IF (IWSE.NE.0.OR.ICFELL('CTPLPS',15).NE.0)
                  NLBS=NLBS-1
                  RETURN
                END IF
              END IF
              RWRK(IR04+NR04-5)=4.
              RWRK(IR04+NR04-4)=REAL(ICLV)
              RWRK(IR04+NR04-3)=SDTL
              RWRK(IR04+NR04-2)=SDTR
              RWRK(IR04+NR04-1)=SDTB
              RWRK(IR04+NR04  )=SDTT
            END IF
          END IF
C
        UNTIL (IVMN.EQ.0)
C
C Done.
C
        RETURN
C
      END


      FUNCTION CTRANF ()
C
C This function generates a sequence of "random" numbers.  Obviously,
C it repeats after the 100th such number.  This is not very important,
C because of the way in which these numbers are being used.
C
        DIMENSION RSEQ (100)
        SAVE ISEQ
        DATA RSEQ / .749,.973,.666,.804,.081,.483,.919,.903,.951,.960 ,
     +              .039,.269,.270,.756,.222,.478,.621,.063,.550,.798 ,
     +              .027,.569,.149,.697,.451,.738,.508,.041,.266,.249 ,
     +              .019,.191,.266,.625,.492,.940,.508,.406,.972,.311 ,
     +              .757,.378,.299,.536,.619,.844,.342,.295,.447,.499 ,
     +              .688,.193,.225,.520,.954,.749,.997,.693,.217,.273 ,
     +              .961,.948,.902,.104,.495,.257,.524,.100,.492,.347 ,
     +              .981,.019,.225,.806,.678,.710,.235,.600,.994,.758 ,
     +              .682,.373,.009,.469,.203,.730,.588,.603,.213,.495 ,
     +              .884,.032,.185,.127,.010,.180,.689,.354,.372,.429 /
        DATA ISEQ / 0 /
        ISEQ=MOD(ISEQ,100)+1
        CTRANF=RSEQ(ISEQ)
        RETURN
      END


      SUBROUTINE CTSBST (CHSI,CHSO,NCHO)
C
        CHARACTER*(*) CHSI,CHSO
C
C The routine CTSBST 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 CONPACKT common blocks.
C
.CALL CTCOMN,/$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.'CIU')
                VALU=CINU
                INVOKE (TRANSLATE-CONTOUR-INTERVAL-OR-LEVEL)
              ELSE IF (CHSI(KCHI+1:KCHI+3).EQ.'CMN')
                IF (NCLV.LE.0)
                  VALU=0.
                ELSE
                  VALU=CLEV(ICLP(1))
                END IF
                INVOKE (TRANSLATE-CONTOUR-INTERVAL-OR-LEVEL)
              ELSE IF (CHSI(KCHI+1:KCHI+3).EQ.'CMX')
                IF (NCLV.LE.0)
                  VALU=0.
                ELSE
                  VALU=CLEV(ICLP(NCLV))
                END IF
                INVOKE (TRANSLATE-CONTOUR-INTERVAL-OR-LEVEL)
              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 determines whether to treat $CIU$,
C $CMN$, and $CMX$ as unrounded or rounded numbers.
C
.OP     BI=66
        BLOCK (TRANSLATE-CONTOUR-INTERVAL-OR-LEVEL)
          IF (ICLS.LT.0)
            INVOKE (TRANSLATE-UNROUNDED-NUMBER)
          ELSE
            INVOKE (TRANSLATE-ROUNDED-NUMBER)
          END IF
        END BLOCK
.OP     BI=77
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 is used to handle numbers which are
C likely to have been rounded to nice values, so that it is probably a
C good idea to trim off trailing zeroes.
C
        BLOCK (TRANSLATE-ROUNDED-NUMBER)
          IF (CHSI(KCHI+4:KCHI+4).NE.'U') VALU=VALU/SCFU
          LMSD=LSDL
          IEXP=NEXU
          LEXP=NEXL
          IOMA=JOMA
          IODP=JODP
          IOTZ=1
          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 CTNUMB (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


      SUBROUTINE CTSORT (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 CONPACKT; 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                                                               


      SUBROUTINE CTSTLS (RPNT,IEDG,ITRI,RWRK,IWRK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C The routine CTSTLS is called to set the label-size parameters.
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
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/1/
C
C Fill in the internal parameters giving the number of characters in
C each label and its extent in four directions.
C
        DO (ICLV=1,NCLV)
          IF (MOD(ICLU(ICLV)/2,2).NE.0.AND.NCLB(ICLV).LE.0)
            KCLB=MAX(1,ABS(NCLB(ICLV)))
            NCLB(ICLV)=KCLB
            XLBC=(XWDL+XWDR)/2.
            YLBC=(YWDB+YWDT)/2.
            SIZE=CHWM*WCLL*(XVPR-XVPL)
            WWSP=CHWM*WWLL*(XVPR-XVPL)
            CALL PCGETI ('TE',ISTE)
            IF (ICFELL('CTSTLS',1).NE.0) RETURN
            CALL PCSETI ('TE',1)
            IF (ICFELL('CTSTLS',2).NE.0) RETURN
            LCTM=KCLB
            CTMA(1:LCTM)=CLBL(ICLV)(1:KCLB)
            CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),SIZE,360.,0.)
            IF (ICFELL('CTSTLS',3).NE.0) RETURN
            CALL PCGETR ('DB',DSTB)
            IF (ICFELL('CTSTLS',4).NE.0) RETURN
            CALL PCGETR ('DL',DSTL)
            IF (ICFELL('CTSTLS',5).NE.0) RETURN
            CALL PCGETR ('DR',DSTR)
            IF (ICFELL('CTSTLS',6).NE.0) RETURN
            CALL PCGETR ('DT',DSTT)
            IF (ICFELL('CTSTLS',7).NE.0) RETURN
            CALL PCSETI ('TE',ISTE)
            IF (ICFELL('CTSTLS',8).NE.0) RETURN
            CLDB(ICLV)=DSTB+WWSP
            CLDL(ICLV)=DSTL+WWSP
            CLDR(ICLV)=DSTR+WWSP
            CLDT(ICLV)=DSTT+WWSP
          END IF
        END DO
C
C Done.
C
        RETURN
C
      END


.OP   BI=66
      SUBROUTINE CTTRCL (RPNT,IEDG,ITRI,RWRK,IWRK,CLVL,IJMP,IRW1,IRW2,
     +                                                           NRWK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C Given RPNT, IEDG, and ITRI (which define a triangular mesh), RWRK (a
C real workspace), IWRK (an integer workspace), and CLVL (a particular
C contour level), CTTRCL finds the beginning of each contour line at
C the level CLVL and then traces it.  Control is passed back to the
C caller to process the line segments generated.
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 a real workspace array.
C
C IWRK is an integer workspace array.
C
C CLVL is the contour level being worked on.
C
C IJMP is initially set to zero by the caller.  Upon return, it will be
C zero if all segments have been traced and processed, non-zero if the
C caller is expected to process a segment and recall CTTRCL.
C
C IRW1 and IRW2 are output variables.  If IJMP is non-zero, they are
C base indices of X and Y coordinate arrays in RWRK.
C
C NRWK is an output variable.  If IJMP is non-zero, NRWK is the number
C of coordinates to be processed by the caller.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/0/
C
C Because of the way this routine is entered and reentered, we need to
C save every variable it uses.
C
        SAVE
C
C Define an interpolation function.
C
        FRCT(ZDT1,ZDT2)=(CLVL-ZDT1)/(ZDT2-ZDT1)
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 If this is a re-entry after coordinate processing by the caller, jump
C back to the appropriate point in the code.
C
        IF (IJMP.NE.0) GO TO (102,103) , IJMP
C
C Extract the values of ITBX and ITBA.
C
        ITBX=IAND(ISHIFT(ITBM,-12),4095)
        ITBA=IAND(       ITBM     ,4095)
C
C Assign space to use for storing the coordinates of points on contour
C lines.
C
        IF (T2DS.EQ.0.)
          CALL CTGRWS (RWRK,1,2*LRWC,IWSE)
        ELSE
          CALL CTGRWS (RWRK,1,7*LRWC,IWSE)
        END IF
C
        IF (IWSE.NE.0.OR.ICFELL('CTTRCL',1).NE.0) GO TO 101
C
C Set the offset from one portion of the real workspace to the next.
C
        MPLS=LRWC
C
C Set some tolerances.
C
        DBPI=ABS(XWDR-XWDL)*SEGL
        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 four variables to prevent the code from blowing up.  (The
C values only have to be legal values on the machine; they are used in
C one clause of a block-IF, the other clause of which makes the value
C immaterial.)
C
        XBFS=0.
        YBFS=0.
        XELS=0.
        YELS=0.
C
C Zero the utility flags in all of the edge nodes.  (They will be used
C to mark edges we've already visited.)
C
        DO (IIII=0,NEDG-LOEN,LOEN)
          IEDG(IIII+5)=0
        END DO
C
C Search for open contours (those that start and end on an external
C edge of the mesh).
C
        IOCF=0
C
        FOR (IIII = 0 TO NEDG-LOEN BY LOEN)
          IF (IEDG(IIII+5).EQ.0.AND.IEDG(IIII+4).LT.0)
            IF (RPNT(IEDG(IIII+1)+4).LE.CLVL.AND.
     +          RPNT(IEDG(IIII+2)+4).GT.CLVL)
              IPTE=IIII
              INVOKE (FOLLOW-THE-LINE)
            END IF
          END IF
        END FOR
C
C Search for closed contours (those that never touch an external edge
C of the mesh).
C
        IOCF=1
C
        FOR (IIII = 0 TO NEDG-LOEN BY LOEN)
          IF (IEDG(IIII+5).EQ.0)
            IF (RPNT(IEDG(IIII+1)+4).LE.CLVL.AND.
     +          RPNT(IEDG(IIII+2)+4).GT.CLVL)
              IPTE=IIII
              INVOKE (FOLLOW-THE-LINE)
            END IF
          END IF
        END FOR
C
C Done.
C
  101   LR01=0
        IJMP=0
        RETURN
C
C Line-following algorithm.  This internal routine moves from edge
C to edge in the triangular mesh, generating the points defining the
C contour line, stopping when either a previously-used edge of the
C mesh or an external edge of the mesh is encountered.
C
        BLOCK (FOLLOW-THE-LINE)
C
C Find the coordinates, in the data coordinate system, of the starting
C position of the contour line.  If the point is very close to a grid
C intersection, put it at the intersection; this avoids problems caused
C by very short line segments.  Also, be careful to compute the value
C of DFRA using code exactly like that in CTTREG, thus ensuring that
C points it interpolates where contour lines intersect the edges of
C the grid will match the points generated here.  ??? INCOMPLETE ???
C
          DFRA=FRCT(RPNT(IEDG(IPTE+1)+4),RPNT(IEDG(IPTE+2)+4))
C
          IF (DFRA.LE..00001) DFRA=0.
          IF (DFRA.GE..99999) DFRA=1.
C
          XCND=RPNT(IEDG(IPTE+1)+1)+DFRA*
     +        (RPNT(IEDG(IPTE+2)+1)-RPNT(IEDG(IPTE+1)+1))
C
          YCND=RPNT(IEDG(IPTE+1)+2)+DFRA*
     +        (RPNT(IEDG(IPTE+2)+2)-RPNT(IEDG(IPTE+1)+2))
C
          ZCND=RPNT(IEDG(IPTE+1)+3)+DFRA*
     +        (RPNT(IEDG(IPTE+2)+3)-RPNT(IEDG(IPTE+1)+3))
C
C Map the point (XCND,YCND,ZCND) to the position (XCNU,YCNU).
C
          INVOKE (COMPUTE-USER-COORDINATES)
C
C Zero the number of points in the coordinate arrays, initialize the
C flag that indicates we're working on the first segment, and zero
C the variable that keeps track of the ratio of segment length in
C the user coordinate system to segment length in the data coordinate
C system.
C
          NPLS=0
          IFSF=1
          RUDN=0.
C
C Loop to generate the rest of the points on the contour line.
C
          LOOP
C
C Mark the current edge as having been used.
C
            IEDG(IPTE+5)=1
C
C Exit the loop if there is no triangle to the left of the current edge;
C an open contour line has hit an external edge of the triangular mesh.
C
            EXIT IF (IEDG(IPTE+3).LT.0)
C
C Get a base pointer, IPTT, for the triangle to the left of the current
C edge, and an offset, IPTI, to its pointer to that edge.
C
            IPTT=LOTN*((IEDG(IPTE+3)-1)/LOTN)
            IPTI=IEDG(IPTE+3)-IPTT
C
C Reset IPTE to point to that edge of the triangle where the contour
C line exits.  Logically, the "EXIT" statement should not be reachable.
C
            IPTI=MOD(IPTI,3)+1
            IPTE=ITRI(IPTT+IPTI)
C
            IF (RPNT(IEDG(IPTE+1)+4).GT.CLVL.OR.
     +          RPNT(IEDG(IPTE+2)+4).LE.CLVL)
C
              IPTI=MOD(IPTI,3)+1
              IPTE=ITRI(IPTT+IPTI)
C
              EXIT IF (RPNT(IEDG(IPTE+1)+4).GT.CLVL.OR.
     +                 RPNT(IEDG(IPTE+2)+4).LE.CLVL)
C
            END IF
C
C Save the coordinates of the previous point on the contour line and
C compute coordinates of a new one.
C
            XCOD=XCND
            YCOD=YCND
            ZCOD=ZCND
C
            XCOU=XCNU
            YCOU=YCNU
C
            IVOU=IVNU
C
            DFRA=FRCT(RPNT(IEDG(IPTE+1)+4),RPNT(IEDG(IPTE+2)+4))
C
            IF (DFRA.LE..00001) DFRA=0.
            IF (DFRA.GE..99999) DFRA=1.
C
            XCND=RPNT(IEDG(IPTE+1)+1)+DFRA*
     +          (RPNT(IEDG(IPTE+2)+1)-RPNT(IEDG(IPTE+1)+1))
C
            YCND=RPNT(IEDG(IPTE+1)+2)+DFRA*
     +          (RPNT(IEDG(IPTE+2)+2)-RPNT(IEDG(IPTE+1)+2))
C
            ZCND=RPNT(IEDG(IPTE+1)+3)+DFRA*
     +          (RPNT(IEDG(IPTE+2)+3)-RPNT(IEDG(IPTE+1)+3))
C
C Map the point (XCND,YCND,ZCND) to the position (XCNU,YCNU).
C
            INVOKE (COMPUTE-USER-COORDINATES)
C
C If the triangle to the right of the edge (the one about to be crossed
C by the contour line) is in a blocked area, dump anything in the buffer
C and clear it.  Otherwise, process the contour-line segment from the
C old point to the new one.
C
            IF (ITBF(ITRI(LOTN*((IEDG(IPTE+4)-1)/LOTN)+4)).NE.0)
              INVOKE (DUMP-POLYLINE-BUFFER)
            ELSE
              INVOKE (INTERPOLATE-POINTS-ALONG-SEGMENT)
            END IF
C
C Exit the loop if the current edge has been used before; a closed
C contour line has been completely traced.
C
            EXIT IF (IEDG(IPTE+5).NE.0)
C
C Loop back to find the next point on the contour line.
C
          END LOOP
C
C Process any remaining portion of the contour line.
C
          INVOKE (DUMP-POLYLINE-BUFFER)
C
C Done.
C
        END BLOCK
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 IPIC segments.
C
          IF (IPIC.NE.0)
            XSOD=XCOD
            YSOD=YCOD
            ZSOD=ZCOD
            XSND=XCND
            YSND=YCND
            ZSND=ZCND
            XSNU=XCNU
            YSNU=YCNU
            ISNU=IVNU
            FOR (INTP = 1 TO ABS(IPIC))
              XCND=XSOD+(REAL(INTP)/REAL(ABS(IPIC)+1))*(XSND-XSOD)
              YCND=YSOD+(REAL(INTP)/REAL(ABS(IPIC)+1))*(YSND-YSOD)
              ZCND=ZSOD+(REAL(INTP)/REAL(ABS(IPIC)+1))*(ZSND-ZSOD)
              INVOKE (COMPUTE-USER-COORDINATES)
              IF (IPIC.GT.0.OR.IVNU.NE.IVOU)
                INVOKE (ADD-POINTS-TO-POLYLINE)
                XCOD=XCND
                YCOD=YCND
                ZCOD=ZCND
                XCOU=XCNU
                YCOU=YCNU
                IVOU=IVNU
              END IF
            END FOR
            XCND=XSND
            YCND=YSND
            ZCND=ZSND
            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 (XCOD,YCOD,ZCOD),
C which projects into (XCOU,YCOU), and (XCND,YCND,ZCND), 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 (XCND.NE.XCOD.OR.YCND.NE.YCOD.OR.ZCND.NE.ZCOD)
C
            IF (NPLS.EQ.0)
              IF (IVOU.NE.0)
                IF (IMPF.NE.0.AND.PITH.GT.0.)
                  XCLD=XCOD
                  YCLD=YCOD
                  ZCLD=ZCOD
                  XCLU=XCOU
                  YCLU=YCOU
                END IF
                RWRK(IR01+1)=XCOU
                RWRK(IR01+MPLS+1)=YCOU
                NPLS=1
              ELSE IF (IVNU.NE.0)
                XCID=XCOD
                YCID=YCOD
                ZCID=ZCOD
                XCVD=XCND
                YCVD=YCND
                ZCVD=ZCND
                XCVU=XCNU
                YCVU=YCNU
                INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
                INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
                XCOD=XCVD
                YCOD=YCVD
                ZCOD=ZCVD
                XCOU=XCVU
                YCOU=YCVU
                IVOU=1
              END IF
            ELSE IF (NPLS.EQ.MPLS)
              XSAV=RWRK(IR01+NPLS)
              YSAV=RWRK(IR01+MPLS+NPLS)
              INVOKE (DUMP-POLYLINE-BUFFER)
              RWRK(IR01+1)=XSAV
              RWRK(IR01+MPLS+1)=YSAV
              NPLS=1
            END IF
C
            IF (IVNU.NE.0)
              INVOKE (OUTPUT-NEXT-POINT)
            ELSE IF (IVOU.NE.0)
              XCVD=XCOD
              YCVD=YCOD
              ZCVD=ZCOD
              XCVU=XCOU
              YCVU=YCOU
              XCID=XCND
              YCID=YCND
              ZCID=ZCND
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              XKND=XCND
              YKND=YCND
              ZKND=ZCND
              XKNU=XCNU
              YKNU=YCNU
              XCND=XCVD
              YCND=YCVD
              ZCND=ZCVD
              XCNU=XCVU
              YCNU=YCVU
              INVOKE (OUTPUT-NEXT-POINT)
              XCND=XKND
              YCND=YKND
              ZCND=ZKND
              XCNU=XKNU
              YCNU=YKNU
              INVOKE (DUMP-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.
     +                   (XCND.NE.XCOD.OR.YCND.NE.YCOD.OR.ZCND.NE.ZCOD))
            RUDO=RUDN
            RUDN=(ABS(XCNU-XCOU)+ABS(YCNU-YCOU))/
     +           (ABS(XCND-XCOD)+ABS(YCND-YCOD)+ABS(ZCND-ZCOD))
            IF (RUDN.GT.2.*RUDO)
              INVOKE (CHECK-FOR-POSSIBLE-DISCONTINUITY)
            END IF
            IF (PITH.GT.0.)
              XCTD=XCND
              YCTD=YCND
              ZCTD=ZCND
              XCTU=XCNU
              YCTU=YCNU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
          END IF
          NPLS=NPLS+1
          RWRK(IR01+NPLS)=XCNU
          RWRK(IR01+MPLS+NPLS)=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 contour line is seen.
C It 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)
          XC1D=XCOD
          YC1D=YCOD
          ZC1D=ZCOD
          XC1U=XCOU
          YC1U=YCOU
          XC2D=XCND
          YC2D=YCND
          ZC2D=ZCND
          XC2U=XCNU
          YC2U=YCNU
          ITMP=0
          LOOP
            DSTO=ABS(XC2U-XC1U)+ABS(YC2U-YC1U)
            XC3D=(XC1D+XC2D)/2.
            YC3D=(YC1D+YC2D)/2.
            ZC3D=(ZC1D+ZC2D)/2.
            CALL HLUCTMXYZ (IMPF,XC3D,YC3D,ZC3D,XC3U,YC3U)
            IF (ICFELL('CTTRCL',2).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 (XC3D.EQ.XC1D.AND.YC3D.EQ.YC1D.AND.ZC3D.EQ.ZC1D)
                XC1D=XC3D
                YC1D=YC3D
                ZC1D=ZC3D
                XC1U=XC3U
                YC1U=YC3U
              ELSE
                EXIT IF (XC3D.EQ.XC2D.AND.YC3D.EQ.YC2D.AND.ZC3D.EQ.ZC2D)
                XC2D=XC3D
                YC2D=YC3D
                ZC2D=ZC3D
                XC2U=XC3U
                YC2U=YC3U
              END IF
              ITMP=ITMP+1
              EXIT IF (ITMP.EQ.64)
            ELSE
              XCVD=XCOD
              YCVD=YCOD
              ZCVD=ZCOD
              XCVU=XCOU
              YCVU=YCOU
              XCID=XC3D
              YCID=YC3D
              ZCID=ZC3D
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              INVOKE (DUMP-POLYLINE-BUFFER)
              XCID=XC3D
              YCID=YC3D
              ZCID=ZC3D
              XCVD=XCND
              YCVD=YCND
              ZCVD=ZCND
              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.)
              XCTD=XC1D
              YCTD=YC1D
              ZCTD=ZC1D
              XCTU=XC1U
              YCTU=YC1U
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
            NPLS=NPLS+1
            RWRK(IR01+NPLS)=XC1U
            RWRK(IR01+MPLS+NPLS)=YC1U
            INVOKE (DUMP-POLYLINE-BUFFER)
            IF (IMPF.NE.0.AND.PITH.GT.0.)
              XCLD=XC2D
              YCLD=YC2D
              ZCLD=ZC2D
              XCLU=XC2U
              YCLU=YC2U
            END IF
            RWRK(IR01+1)=XC2U
            RWRK(IR01+MPLS+1)=YC2U
            NPLS=1
          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
            XCHD=(XCVD+XCID)/2.
            YCHD=(YCVD+YCID)/2.
            ZCHD=(ZCVD+ZCID)/2.
            CALL HLUCTMXYZ (IMPF,XCHD,YCHD,ZCHD,XCHU,YCHU)
            IF (ICFELL('CTTRCL',3).NE.0) GO TO 101
            IF (XCHU.NE.OORV.AND.YCHU.NE.OORV)
              EXIT IF (XCHD.EQ.XCVD.AND.YCHD.EQ.YCVD.AND.ZCHD.EQ.ZCVD)
              XCVD=XCHD
              YCVD=YCHD
              ZCVD=ZCHD
              XCVU=XCHU
              YCVU=YCHU
            ELSE
              EXIT IF (XCHD.EQ.XCID.AND.YCHD.EQ.YCID.AND.ZCHD.EQ.ZCID)
              XCID=XCHD
              YCID=YCHD
              ZCID=ZCHD
            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 (NPLS.EQ.0)
              XCLD=XCVD
              YCLD=YCVD
              ZCLD=ZCVD
              XCLU=XCVU
              YCLU=YCVU
            ELSE
              XCTD=XCVD
              YCTD=YCVD
              ZCTD=ZCVD
              XCTU=XCVU
              YCTU=YCVU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
          END IF
          NPLS=NPLS+1
          RWRK(IR01+NPLS)=XCVU
          RWRK(IR01+MPLS+NPLS)=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
            XCQD=0.
            YCQD=0.
            ZCQD=0.
            RDST=.50
            RSTP=.25
            LOOP
              XCPD=XCLD+RDST*(XCTD-XCLD)
              YCPD=YCLD+RDST*(YCTD-YCLD)
              ZCPD=ZCLD+RDST*(ZCTD-ZCLD)
              CALL HLUCTMXYZ (IMPF,XCPD,YCPD,ZCPD,XCPU,YCPU)
              IF (ICFELL('CTTRCL',4).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
                XCQD=XCPD
                YCQD=YCPD
                ZCQD=ZCPD
                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.(XCQD.NE.XCLD.OR.YCQD.NE.YCLD.OR.
     +                                         ZCQD.NE.ZCLD))
              NPLS=NPLS+1
              RWRK(IR01+NPLS)=XCQU
              RWRK(IR01+MPLS+NPLS)=YCQU
              IF (NPLS.EQ.MPLS)
                XSAV=RWRK(IR01+NPLS)
                YSAV=RWRK(IR01+MPLS+NPLS)
                INVOKE (DUMP-POLYLINE-BUFFER)
                RWRK(IR01+1)=XSAV
                RWRK(IR01+MPLS+1)=YSAV
                NPLS=1
              END IF
              XCLD=XCQD
              YCLD=YCQD
              ZCLD=ZCQD
              XCLU=XCQU
              YCLU=YCQU
            ELSE
              XCLD=XCTD
              YCLD=YCTD
              ZCLD=ZCTD
              XCLU=XCTU
              YCLU=YCTU
            END IF
          END WHILE
          XCLD=XCTD
          YCLD=YCTD
          ZCLD=ZCTD
          XCLU=XCTU
          YCLU=YCTU
        END BLOCK
C
C The following internal procedure is given the data-system coordinates
C of a point (XCND,YCND,ZCND) 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=XCND
            YCNU=YCND
            IVNU=1
          ELSE
            CALL HLUCTMXYZ (IMPF,XCND,YCND,ZCND,XCNU,YCNU)
            IF (ICFELL('CTTRCL',5).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 processes a complete line segment.
C If the 2D smoother is turned on, the routines MSKRV1 and MSKRV2 are
C called to smooth the segment.
C
C
        BLOCK (DUMP-POLYLINE-BUFFER)
C
          I=1
C
          LOOP
            I=I+1
            EXIT IF (I.GT.NPLS)
            IF (ABS(RWRK(IR01+I)-RWRK(IR01+I-1)).LT.EPSX.AND.
     +          ABS(RWRK(IR01+MPLS+I)-RWRK(IR01+MPLS+I-1)).LT.EPSY)
              IF (I.NE.NPLS)
                DO (J=I+1,NPLS)
                  RWRK(IR01+J-1)=RWRK(IR01+J)
                  RWRK(IR01+MPLS+J-1)=RWRK(IR01+MPLS+J)
                END DO
              ELSE
                RWRK(IR01     +NPLS-1)=RWRK(IR01     +NPLS)
                RWRK(IR01+MPLS+NPLS-1)=RWRK(IR01+MPLS+NPLS)
              END IF
              I=I-1
              NPLS=NPLS-1
            END IF
          END LOOP
C
          IF (NPLS.GT.1)
C
            IF (T2DS.EQ.0.)
C
              IJMP=2
              IRW1=IR01
              IRW2=IR01+MPLS
              NRWK=NPLS
              RETURN
C
            ELSE
C
              IF (NPLS.GT.3.AND.
     +            ABS(RWRK(IR01+NPLS)-RWRK(IR01+1)).LT.EPSX.AND.
     +            ABS(RWRK(IR01+MPLS+NPLS)-RWRK(IR01+MPLS+1)).LT.EPSY)
                ISLP=4
              ELSE IF (IFSF.EQ.0.AND.
     +                 ABS(RWRK(IR01+1)-XELS).LT.EPSX.AND.
     +                 ABS(RWRK(IR01+MPLS+1)-YELS).LT.EPSY)
                ISLP=1
                SLP1=SELS
                IF (ABS(RWRK(IR01+NPLS)-XBFS).LT.EPSX.AND.
     +              ABS(RWRK(IR01+MPLS+NPLS)-YBFS).LT.EPSY)
                  ISLP=0
                  SLPN=SBFS
                END IF
              ELSE
                ISLP=3
              END IF
C
              CALL MSKRV1 (NPLS,RWRK(IR01+1),RWRK(IR01+MPLS+1),
     +                     SLP1,SLPN,RWRK(IR01+2*MPLS+1),
     +                     RWRK(IR01+3*MPLS+1),RWRK(IR01+5*MPLS+1),
     +                     RWRK(IR01+4*MPLS+1),ABS(T2DS),ISLP)
              IF (ICFELL('CTTRCL',6).NE.0) GO TO 101
C
              NINT=MAX(3,1+INT(RWRK(IR01+4*MPLS+NPLS)/DBPI))
C
              NOUT=0
              TUDN=0.
C
              FOR (IINT = 0 TO NINT)
C
                IF (IINT.EQ.0)
                  XTMP=RWRK(IR01+1)
                  YTMP=RWRK(IR01+MPLS+1)
                ELSE IF (IINT.NE.NINT)
                  CALL MSKRV2 (REAL(IINT)/REAL(NINT),XTMP,YTMP,NPLS,
     +                         RWRK(IR01+1),RWRK(IR01+MPLS+1),
     +                         RWRK(IR01+2*MPLS+1),RWRK(IR01+3*MPLS+1),
     +                         RWRK(IR01+4*MPLS+1),ABS(T2DS),0,DUMI)
                  IF (ICFELL('CTTRCL',7).NE.0) GO TO 101
                ELSE
                  XTMP=RWRK(IR01+NPLS)
                  YTMP=RWRK(IR01+MPLS+NPLS)
                END IF
C
                NOUT=NOUT+1
                RWRK(IR01+5*MPLS+NOUT)=XTMP
                RWRK(IR01+6*MPLS+NOUT)=YTMP
C
                IF ((IINT.EQ.NINT.OR.NOUT.EQ.MPLS).AND.NOUT.NE.0)
                  XTMP=RWRK(IR01+5*MPLS+NOUT)
                  YTMP=RWRK(IR01+6*MPLS+NOUT)
                  IJMP=1
                  IRW1=IR01+5*MPLS
                  IRW2=IR01+6*MPLS
                  NRWK=NOUT
                  RETURN
  102             RWRK(IR01+5*MPLS+1)=XTMP
                  RWRK(IR01+6*MPLS+1)=YTMP
                  NOUT=1
                END IF
C
              END FOR
C
              IF (IFSF.NE.0)
                IFSF=0
                XBFS=RWRK(IR01+1)
                YBFS=RWRK(IR01+MPLS+1)
                CALL MSKRV2 (0.,XTMP,YTMP,NPLS,RWRK(IR01+1),
     +                       RWRK(IR01+MPLS+1),RWRK(IR01+2*MPLS+1),
     +                       RWRK(IR01+3*MPLS+1),RWRK(IR01+4*MPLS+1),
     +                       ABS(T2DS),1,SBFS)
                IF (ICFELL('CTTRCL',8).NE.0) GO TO 101
              END IF
C
              XELS=RWRK(IR01+NPLS)
              YELS=RWRK(IR01+MPLS+NPLS)
              CALL MSKRV2 (1.,XTMP,YTMP,NPLS,RWRK(IR01+1),
     +                     RWRK(IR01+MPLS+1),RWRK(IR01+2*MPLS+1),
     +                     RWRK(IR01+3*MPLS+1),RWRK(IR01+4*MPLS+1),
     +                     ABS(T2DS),1,SELS)
              IF (ICFELL('CTTRCL',9).NE.0) GO TO 101
C
            END IF
C
          END IF
C
  103     NPLS=0
          RUDN=0.
C
C Done.
C
        END BLOCK
C
      END
.OP   BI=77


.OP   BI=66
      SUBROUTINE CTTREG (RPNT,IEDG,ITRI,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,
     +                                                           NRWK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C This routine traces the edge of the grid.  Control is passed back to
C the caller with each piece of the edge for processing.
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 IJMP is initially set to zero by the caller.  Upon return, it will be
C zero if all segments have been traced and processed, non-zero if the
C caller is expected to process a segment and recall CTTREG.
C
C IAIC is both an input and an output variable.  If it is initially set
C to -9 by the caller, it will not be changed by CTTREG and no attempt
C will be made to determine what area identifier should be used for the
C area on the contoured side of the edge of the grid.  If its initial
C value is 0, it will have been updated, upon every return with IJMP
C non-zero, to the area identifier for the contoured side of the piece
C of the edge defined by IRW1, IRW2, and NRWK.
C
C IRW1 and IRW2 are output variables.  If IJMP is non-zero, they are
C base indices of X and Y coordinate arrays in RWRK.
C
C NRWK is an output variable.  If IJMP is non-zero, NRWK is the number
C of coordinates to be processed by the caller.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/0/
C
C Because of the way this routine is entered and re-entered, we need to
C save every variable it uses.
C
        SAVE
C
C Define an arithmetic statement function for use below.
C
        FRCT(ZDT1,ZDT2)=(CLEV(ICLV)-ZDT1)/(ZDT2-ZDT1)
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 If this is a re-entry after coordinate processing by the caller, jump
C back to the appropriate point in the code.
C
        IF (IJMP.NE.0) GO TO (101,104,105,106,107,108) , IJMP
C
C Extract the values of ITBX and ITBA.
C
        ITBX=IAND(ISHIFT(ITBM,-12),4095)
        ITBA=IAND(       ITBM     ,4095)
C
C Assign space to use for storing the X and Y coordinates of points.
C
        MPLS=LRWC
        CALL CTGRWS (RWRK,1,2*MPLS,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CTTREG',1).NE.0) GO TO 102
C
C Compute quantities used to see if two points are essentially
C different from one another.
C
        SMLX=.01*ABS(XWDR-XWDL)
        SMLY=.01*ABS(YWDT-YWDB)
C
C Compute quantities used in detecting jumps in the mapping.
C
        PITX=PITH*ABS(XWDR-XWDL)
        PITY=PITH*ABS(YWDT-YWDB)
C
C Zero the utility flags in all the edge nodes.  (They will be used to
C mark edges we've already visited.)
C
        DO (IIII=0,NEDG-LOEN,LOEN)
          IEDG(IIII+5)=0
        END DO
C
C Loop through the edge list, searching for starting edges.
C
        FOR (IIII = 0 TO NEDG-LOEN BY LOEN)
C
C Use the edge only if it has not already been used.
C
          IF (IEDG(IIII+5).EQ.0)
C
C Set a flag saying whether or not there is a non-blocked triangle to
C the left of the edge.
C
            IFLL=0
C
            IF (IEDG(IIII+3).GE.0)
              IF (ITBF(ITRI(LOTN*((IEDG(IIII+3)-1)/LOTN)+4))
     +                                                     .EQ.0) IFLL=1
            END IF
C
C Set a flag saying whether or not there is a non-blocked triangle to
C the right of the edge.
C
            IFLR=0
C
            IF (IEDG(IIII+4).GE.0)
              IF (ITBF(ITRI(LOTN*((IEDG(IIII+4)-1)/LOTN)+4))
     +                                                     .EQ.0) IFLR=1
            END IF
C
C Use the edge only if it has a non-blocked triangle on one side of
C it, but not on the other side of it.
C
            IF (IFLL.NE.IFLR)
C
C Trace the portion of the external boundary starting with this edge.
C
              IPTE=IIII
C
C Let the first and second points of the edge be numbered IP12 and
C 3-IP12; initialize IP12 so that the triangle is on the left.
C
              IF (IFLL.NE.0)
                IP12=1
              ELSE
                IP12=2
              END IF
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
C user coordinate system to segment length in the data coordinate
C system.
C
              NPLS=0
              RUDN=0.
C
C Initialize the quantities needed by PROCESS-EDGE-SEGMENT.
C
              XCES=RPNT(IEDG(IPTE+IP12)+1)
              YCES=RPNT(IEDG(IPTE+IP12)+2)
              ZCES=RPNT(IEDG(IPTE+IP12)+3)
              DVES=RPNT(IEDG(IPTE+IP12)+4)
              XCND=XCES
              YCND=YCES
              ZCND=ZCES
              DVND=DVES
              INVOKE (COMPUTE-USER-COORDINATES)
C
C Return here with each new edge found by the algorithm.
C
              LOOP
C
C Mark the edge as used.
C
                IEDG(IPTE+5)=1
C
C Process it.
C
                INVOKE (PROCESS-EDGE-SEGMENT)
C
C Find a continuation edge.
C
                REPEAT
C
C Move to the next edge (in counterclockwise order) in the triangle to
C the left.
C
                  IPTT=LOTN*((IEDG(IPTE+IP12+2)-1)/LOTN)
                  IPTI=MOD(IEDG(IPTE+IP12+2)-IPTT,3)+1
                  IPTX=ITRI(IPTT+IPTI)
C
C Make the end point of the possible new edge match the end point of the
C old one.
C
                  IF (IEDG(IPTX+3-IP12).NE.IEDG(IPTE+3-IP12))
     +                                                       IP12=3-IP12
C
                  IPTE=IPTX
C
C If there's a non-blocked triangle to the left of the possible new edge,
C jump back to try the next edge in that triangle.
C
                  IFLL=0
C
                  IF (IEDG(IPTE+IP12+2).GE.0)
                    IF (ITBF(ITRI(LOTN*((IEDG(IPTE+IP12+2)-1)/LOTN)+4))
     +                                                     .EQ.0) IFLL=1
                  END IF
C
                UNTIL (IFLL.EQ.0)
C
C If the edge found has been used before, quit the loop; otherwise, swap
C its end points and use it as a continuation of the edge being traced.
C
                EXIT IF (IEDG(IPTE+5).NE.0)
C
                IP12=3-IP12
C
              END LOOP
C
C Dump anything left in the buffer.
C
              IF (NPLS.NE.0)
                IJMP=1
                IRW1=IR01
                IRW2=IR01+MPLS
                NRWK=NPLS
                RETURN
              END IF
C
            END IF
C
          END IF
C
  101   END FOR
C
C Release the real workspace and let the caller know we're done.
C
  102   LR01=0
        IJMP=0
C
C Done.
C
        RETURN
C
C The following internal procedure processes a segment along the edge
C of the grid.
C
        BLOCK (PROCESS-EDGE-SEGMENT)
          XCSS=XCES
          YCSS=YCES
          ZCSS=ZCES
          DVSS=DVES
          XCES=RPNT(IEDG(IPTE+3-IP12)+1)
          YCES=RPNT(IEDG(IPTE+3-IP12)+2)
          ZCES=RPNT(IEDG(IPTE+3-IP12)+3)
          DVES=RPNT(IEDG(IPTE+3-IP12)+4)
          FOR (INTP = 1 TO ABS(IPIE)+1 BY 1)
            XCOD=XCND
            YCOD=YCND
            ZCOD=ZCND
            DVOD=DVND
            XCOU=XCNU
            YCOU=YCNU
            IVOU=IVNU
            IF (INTP.NE.ABS(IPIE)+1)
              FINT=REAL(INTP)/REAL(ABS(IPIE)+1)
              XCND=(1.-FINT)*XCSS+FINT*XCES
              YCND=(1.-FINT)*YCSS+FINT*YCES
              ZCND=(1.-FINT)*ZCSS+FINT*ZCES
              DVND=(1.-FINT)*DVSS+FINT*DVES
            ELSE
              XCND=XCES
              YCND=YCES
              ZCND=ZCES
              DVND=DVES
            END IF
            INVOKE (COMPUTE-USER-COORDINATES)
            IF (DVOD.LT.DVND)
              FOR (I = 1 TO NCLV BY 1)
                ICLV=ICLP(I)
                IF (CLEV(ICLV).GT.DVOD.AND.CLEV(ICLV).LT.DVND)
                  INVOKE (INTERPOLATE-TO-CONTOUR-LINE)
                END IF
              END FOR
            ELSE IF (DVND.LT.DVOD)
              FOR (I = NCLV TO 1 BY -1)
                ICLV=ICLP(I)
                IF (CLEV(ICLV).GT.DVND.AND.CLEV(ICLV).LT.DVOD)
                  INVOKE (INTERPOLATE-TO-CONTOUR-LINE)
                END IF
              END FOR
            END IF
            IF (IPIE.LT.0.AND.INTP.NE.ABS(IPIE)+1)
              IFOP=0
            ELSE
              IFOP=1
            END IF
            INVOKE (PROCESS-PIECE-OF-SEGMENT)
          END FOR
        END BLOCK
C
C The following internal procedure interpolates a point where a contour
C line intersects the piece of the edge segment that we're working on.
C We are careful to place these points exactly where they are placed by
C the routine CTTRCL, which makes the code look a little unnecessarily
C complicated.
C
        BLOCK (INTERPOLATE-TO-CONTOUR-LINE)
          XCSD=XCND
          YCSD=YCND
          ZCSD=ZCND
          DVSD=DVND
          XCSU=XCNU
          YCSU=YCNU
          IVSU=IVNU
          IF (DVSS.LT.DVES)
            DFRA=FRCT(DVSS,DVES)
            IF (DFRA.LE..00001.OR.DFRA.GE..99999) GO TO 103
            XCND=XCSS+DFRA*(XCES-XCSS)
            YCND=YCSS+DFRA*(YCES-YCSS)
            ZCND=ZCSS+DFRA*(ZCES-ZCSS)
          ELSE
            DFRA=FRCT(DVES,DVSS)
            IF (DFRA.LE..00001.OR.DFRA.GE..99999) GO TO 103
            XCND=XCES+DFRA*(XCSS-XCES)
            YCND=YCES+DFRA*(YCSS-YCES)
            ZCND=ZCES+DFRA*(ZCSS-ZCES)
          END IF
          DVND=CLEV(ICLV)
          INVOKE (COMPUTE-USER-COORDINATES)
          IFOP=1
          INVOKE (PROCESS-PIECE-OF-SEGMENT)
          XCOD=XCND
          YCOD=YCND
          ZCOD=ZCND
          DVOD=DVND
          XCOU=XCNU
          YCOU=YCNU
          IVOU=IVNU
          XCND=XCSD
          YCND=YCSD
          ZCND=ZCSD
          DVND=DVSD
          XCNU=XCSU
          YCNU=YCSU
          IVNU=IVSU
  103   END BLOCK
C
C The following internal procedure processes a piece of a segment; there
C are several cases, depending on whether both endpoints are visible,
C neither endpoint is visible, or just one of them is visible.
C
        BLOCK (PROCESS-PIECE-OF-SEGMENT)
C
          IAID=IAIC
C
          IF (IAIC.NE.-9)
            IF (NCLV.LE.0)
              IAID=1
            ELSE
              CALL CTGVAI (.5*(DVND+DVOD),IAID)
            END IF
          END IF
C
          IF (NPLS.EQ.0)
            IF (IVOU.NE.0)
              IF (IMPF.NE.0.AND.PITH.GT.0.)
                XCLD=XCOD
                YCLD=YCOD
                ZCLD=ZCOD
                XCLU=XCOU
                YCLU=YCOU
              END IF
              RWRK(IR01+1)=XCOU
              RWRK(IR01+MPLS+1)=YCOU
              NPLS=1
            ELSE IF (IVNU.NE.0)
              XCID=XCOD
              YCID=YCOD
              ZCID=ZCOD
              XCVD=XCND
              YCVD=YCND
              ZCVD=ZCND
              XCVU=XCNU
              YCVU=YCNU
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              XCOD=XCVD
              YCOD=YCVD
              ZCOD=ZCVD
              XCOU=XCVU
              YCOU=YCVU
              IVOU=1
            END IF
          ELSE IF (NPLS.EQ.MPLS.OR.IAID.NE.IAIC)
            XSAV=RWRK(IR01+NPLS)
            YSAV=RWRK(IR01+MPLS+NPLS)
            IJMP=2
            IRW1=IR01
            IRW2=IR01+MPLS
            NRWK=NPLS
            RETURN
  104       RWRK(IR01+1)=XSAV
            RWRK(IR01+MPLS+1)=YSAV
            NPLS=1
          END IF
C
          IAIC=IAID
C
          IF (IVNU.NE.0)
            INVOKE (OUTPUT-NEXT-POINT)
          ELSE IF (IVOU.NE.0)
            XCVD=XCOD
            YCVD=YCOD
            ZCVD=ZCOD
            XCVU=XCOU
            YCVU=YCOU
            XCID=XCND
            YCID=YCND
            ZCID=ZCND
            INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
            XKND=XCND
            YKND=YCND
            ZKND=ZCND
            XKNU=XCNU
            YKNU=YCNU
            XCND=XCVD
            YCND=YCVD
            ZCND=ZCVD
            XCNU=XCVU
            YCNU=YCVU
            IFOP=1
            INVOKE (OUTPUT-NEXT-POINT)
            XCND=XKND
            YCND=YKND
            ZCND=ZKND
            XCNU=XKNU
            YCNU=YKNU
            IJMP=3
            IRW1=IR01
            IRW2=IR01+MPLS
            NRWK=NPLS
            RETURN
  105       NPLS=0
            RUDN=0.
          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.
     +                   (XCND.NE.XCOD.OR.YCND.NE.YCOD.OR.ZCND.NE.ZCOD))
            RUDO=RUDN
            RUDN=(ABS(XCNU-XCOU)+ABS(YCNU-YCOU))/
     +           (ABS(XCND-XCOD)+ABS(YCND-YCOD)+ABS(ZCND-ZCOD))
            IF (RUDN.GT.2.*RUDO)
              IFOP=1
              INVOKE (CHECK-FOR-POSSIBLE-DISCONTINUITY)
            END IF
            IF (PITH.GT.0.)
              XCTD=XCND
              YCTD=YCND
              ZCTD=ZCND
              XCTU=XCNU
              YCTU=YCNU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
          END IF
          IF (IFOP.NE.0)
            NPLS=NPLS+1
            RWRK(IR01+NPLS)=XCNU
            RWRK(IR01+MPLS+NPLS)=YCNU
          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 edge is seen.  It checks
C for a possible discontinuity in the mapping function (as can happen,
C for example, when a cylindrical equidistant projection is being used);
C if there is such a discontinuity, we must generate a final point on
C one side of it, dump the polyline, and then start a new polyline on
C the other side.
C
        BLOCK (CHECK-FOR-POSSIBLE-DISCONTINUITY)
          XC1D=XCOD
          YC1D=YCOD
          ZC1D=ZCOD
          XC1U=XCOU
          YC1U=YCOU
          XC2D=XCND
          YC2D=YCND
          ZC2D=ZCND
          XC2U=XCNU
          YC2U=YCNU
          ITMP=0
          LOOP
            DSTO=ABS(XC2U-XC1U)+ABS(YC2U-YC1U)
            XC3D=(XC1D+XC2D)/2.
            YC3D=(YC1D+YC2D)/2.
            ZC3D=(ZC1D+ZC2D)/2.
            CALL HLUCTMXYZ (IMPF,XC3D,YC3D,ZC3D,XC3U,YC3U)
            IF (ICFELL('CTTREG',2).NE.0) GO TO 102
            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 (XC3D.EQ.XC1D.AND.YC3D.EQ.YC1D.AND.ZC3D.EQ.ZC1D)
                XC1D=XC3D
                YC1D=YC3D
                ZC1D=ZC3D
                XC1U=XC3U
                YC1U=YC3U
              ELSE
                EXIT IF (XC3D.EQ.XC2D.AND.YC3D.EQ.YC2D.AND.ZC3D.EQ.ZC2D)
                XC2D=XC3D
                YC2D=YC3D
                ZC2D=ZC3D
                XC2U=XC3U
                YC2U=YC3U
              END IF
              ITMP=ITMP+1
              EXIT IF (ITMP.EQ.64)
            ELSE
              XCVD=XCOD
              YCVD=YCOD
              ZCVD=ZCOD
              XCVU=XCOU
              YCVU=YCOU
              XCID=XC3D
              YCID=YC3D
              ZCID=ZC3D
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              IJMP=4
              IRW1=IR01
              IRW2=IR01+MPLS
              NRWK=NPLS
              RETURN
  106         NPLS=0
              RUDN=0.
              XCID=XC3D
              YCID=YC3D
              ZCID=ZC3D
              XCVD=XCND
              YCVD=YCND
              ZCVD=ZCND
              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.)
              XCTD=XC1D
              YCTD=YC1D
              ZCTD=ZC1D
              XCTU=XC1U
              YCTU=YC1U
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
            NPLS=NPLS+1
            RWRK(IR01+NPLS)=XC1U
            RWRK(IR01+MPLS+NPLS)=YC1U
            IJMP=5
            IRW1=IR01
            IRW2=IR01+MPLS
            NRWK=NPLS
            RETURN
  107       IF (IMPF.NE.0.AND.PITH.GT.0.)
              XCLD=XC2D
              YCLD=YC2D
              ZCLD=ZC2D
              XCLU=XC2U
              YCLU=YC2U
            END IF
            RWRK(IR01+1)=XC2U
            RWRK(IR01+MPLS+1)=YC2U
            NPLS=1
            RUDN=0.
          END IF
        END BLOCK
C
C Given two points in the data coordinate system, one of which maps to
C a visible point and the other of which maps to an invisible point,
C this internal routine searches the line between them for a point near
C the edge of visibility.
C
        BLOCK (INTERPOLATE-TO-VISIBLE-EDGE)
          ITMP=0
          LOOP
            XCHD=(XCVD+XCID)/2.
            YCHD=(YCVD+YCID)/2.
            ZCHD=(ZCVD+ZCID)/2.
            CALL HLUCTMXYZ (IMPF,XCHD,YCHD,ZCHD,XCHU,YCHU)
            IF (ICFELL('CTTREG',3).NE.0) GO TO 102
            IF (XCHU.NE.OORV.AND.YCHU.NE.OORV)
              EXIT IF (XCHD.EQ.XCVD.AND.YCHD.EQ.YCVD.AND.ZCHD.EQ.ZCVD)
              XCVD=XCHD
              YCVD=YCHD
              ZCVD=ZCHD
              XCVU=XCHU
              YCVU=YCHU
            ELSE
              EXIT IF (XCHD.EQ.XCID.AND.YCHD.EQ.YCID.AND.ZCHD.EQ.ZCID)
              XCID=XCHD
              YCID=YCHD
              ZCID=ZCHD
            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 (NPLS.EQ.0)
              XCLD=XCVD
              YCLD=YCVD
              ZCLD=ZCVD
              XCLU=XCVU
              YCLU=YCVU
            ELSE
              XCTD=XCVD
              YCTD=YCVD
              ZCTD=ZCVD
              XCTU=XCVU
              YCTU=YCVU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING)
            END IF
          END IF
          NPLS=NPLS+1
          RWRK(IR01+NPLS)=XCVU
          RWRK(IR01+MPLS+NPLS)=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 greater than 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
            XCQD=0.
            YCQD=0.
            ZCQD=0.
            RDST=.50
            RSTP=.25
            LOOP
              XCPD=XCLD+RDST*(XCTD-XCLD)
              YCPD=YCLD+RDST*(YCTD-YCLD)
              ZCPD=ZCLD+RDST*(ZCTD-ZCLD)
              CALL HLUCTMXYZ (IMPF,XCPD,YCPD,ZCPD,XCPU,YCPU)
              IF (ICFELL('CTTREG',4).NE.0) GO TO 102
              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
                XCQD=XCPD
                YCQD=YCPD
                ZCQD=ZCPD
                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.(XCQD.NE.XCLD.OR.YCQD.NE.YCLD.OR.
     +                                         ZCQD.NE.ZCLD))
              IFOP=1
              NPLS=NPLS+1
              RWRK(IR01+NPLS)=XCQU
              RWRK(IR01+MPLS+NPLS)=YCQU
              IF (NPLS.EQ.MPLS)
                XSAV=RWRK(IR01+NPLS)
                YSAV=RWRK(IR01+MPLS+NPLS)
                IJMP=6
                IRW1=IR01
                IRW2=IR01+MPLS
                NRWK=NPLS
                RETURN
  108           RWRK(IR01+1)=XSAV
                RWRK(IR01+MPLS+1)=YSAV
                NPLS=1
              END IF
              XCLD=XCQD
              YCLD=YCQD
              ZCLD=ZCQD
              XCLU=XCQU
              YCLU=YCQU
            ELSE
              XCLD=XCTD
              YCLD=YCTD
              ZCLD=ZCTD
              XCLU=XCTU
              YCLU=YCTU
            END IF
          END WHILE
          XCLD=XCTD
          YCLD=YCTD
          ZCLD=ZCTD
          XCLU=XCTU
          YCLU=YCTU
        END BLOCK
C
C The following internal procedure is given the data-system coordinates
C of a point (XCND,YCND,ZCND) 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=XCND
            YCNU=YCND
            IVNU=1
          ELSE
            CALL HLUCTMXYZ (IMPF,XCND,YCND,ZCND,XCNU,YCNU)
            IF (ICFELL('CTTREG',5).NE.0) GO TO 102
            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
      END
.OP   BI=77


.OP   BI=66
      SUBROUTINE CTTRVE (RPNT,IEDG,ITRI,RWRK,IWRK,IJMP,IRW1,IRW2,NRWK)
C
        DIMENSION RPNT(*),IEDG(*),ITRI(*),RWRK(*),IWRK(*)
C
C This routine traces the edge of the area which is visible under the
C current mapping, using the limited inverse mapping capabilities of
C CTMXYZ.
C
C As pieces of the edge are generated, control is passed back to the
C caller for processing of them.
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 IJMP is initially set to zero by the caller.  Upon return, it will be
C zero if all segments have been traced and processed, non-zero if the
C caller is expected to process a segment and recall CTTRVE.
C
C IRW1 and IRW2 are output variables.  If IJMP is non-zero, they are
C base indices of X and Y coordinate arrays in RWRK.
C
C NRWK is an output variable.  If IJMP is non-zero, NRWK is the number
C of coordinates to be processed by the caller.
C
C
C Declare all of the CONPACKT common blocks.
C
.CALL CTCOMN,/$SAVE-COMMON$/0/
C
C Because of the way this routine is entered and re-entered, we need to
C save every variable it uses.
C
        SAVE
C
C If this is a re-entry after coordinate processing by the caller, jump
C back to the appropriate point in the code.
C
        IF (IJMP.NE.0) GO TO (103,104) , IJMP
C
C Assign space to use for storing the X and Y coordinates of points.
C
        MPLS=LRWC
        CALL CTGRWS (RWRK,1,2*MPLS,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CTTRVE',1).NE.0) GO TO 102
C
C Compute required constants.  By default, we work with a grid of
C approximately 2500 boxes in the current viewport; each of the boxes
C is roughly square.  The user may set the value of 'PIE' non-zero to
C increase the number of boxes used.
C
        IIDM=MAX(2,INT(SQRT(2500.*(XVPR-XVPL)/(YVPT-YVPB))))
        IIDN=MAX(2,INT(SQRT(2500.*(YVPT-YVPB)/(XVPR-XVPL))))
C
        IIDM=(IIDM-1)*(ABS(IPIE)+1)+1
        IIDN=(IIDN-1)*(ABS(IPIE)+1)+1
C
        RIDM=(XVPR-XVPL)/REAL(IIDM-1)
        RIDN=(YVPT-YVPB)/REAL(IIDN-1)
C
C Zero the count of horizontal segments seen.
C
        NHSS=0
C
C Define the first search point.
C
        IVBX=1
        IVBY=1
        XDUM=CFUX(XVPL)
        IF (ICFELL('CTTRVE',2).NE.0) GO TO 102
        YDUM=CFUY(YVPB)
        IF (ICFELL('CTTRVE',3).NE.0) GO TO 102
        CALL HLUCTMXYZ (-IMPF,XDUM,YDUM,ZDUM,XPRN,YPRN)
        IF (ICFELL('CTTRVE',4).NE.0) GO TO 102
C
C Search the viewport for pieces of the visible/invisible edge.  We
C first search the edges of the viewport for open-ended pieces and
C then we search the interior of the viewport for pieces that are
C closed loops.  The common variable IOCF is used to indicate which
C type of piece we are dealing with.  Its value will be modified by
C FOLLOW-THE-LIMB to provide the calling routine with even more
C information about the pieces returned (whether or not the first
C point and the last point of the piece is included in the buffer
C load being returned); this information is passed to CTTROE by the
C routine CTCLAM.
C
        WHILE (IVBX.LT.IIDM)
          IVBX=IVBX+1
          XPRP=XPRN
          XDUM=CFUX(XVPL+RIDM*REAL(IVBX-1))
          IF (ICFELL('CTTRVE',5).NE.0) GO TO 102
          YDUM=CFUY(YVPB)
          IF (ICFELL('CTTRVE',6).NE.0) GO TO 102
          CALL HLUCTMXYZ (-IMPF,XDUM,YDUM,ZDUM,XPRN,YPRN)
          IF (ICFELL('CTTRVE',7).NE.0) GO TO 102
          IF (XPRP.EQ.OORV.AND.XPRN.NE.OORV)
            IOCF=0
            INCI=1
            INVOKE (FOLLOW-THE-LIMB)
          END IF
        END WHILE
C
        WHILE (IVBY.LT.IIDN)
          IVBY=IVBY+1
          XPRP=XPRN
          XDUM=CFUX(XVPL+RIDM*REAL(IIDM-1))
          IF (ICFELL('CTTRVE',8).NE.0) GO TO 102
          YDUM=CFUY(YVPB+RIDN*REAL(IVBY-1))
          IF (ICFELL('CTTRVE',9).NE.0) GO TO 102
          CALL HLUCTMXYZ (-IMPF,XDUM,YDUM,ZDUM,XPRN,YPRN)
          IF (ICFELL('CTTRVE',10).NE.0) GO TO 102
          IF (XPRP.EQ.OORV.AND.XPRN.NE.OORV)
            IOCF=0
            INCI=7
            INVOKE (FOLLOW-THE-LIMB)
          END IF
        END WHILE
C
        WHILE (IVBX.GT.1)
          IVBX=IVBX-1
          XPRP=XPRN
          XDUM=CFUX(XVPL+RIDM*REAL(IVBX-1))
          IF (ICFELL('CTTRVE',11).NE.0) GO TO 102
          YDUM=CFUY(YVPB+RIDN*REAL(IIDN-1))
          IF (ICFELL('CTTRVE',12).NE.0) GO TO 102
          CALL HLUCTMXYZ (-IMPF,XDUM,YDUM,ZDUM,XPRN,YPRN)
          IF (ICFELL('CTTRVE',13).NE.0) GO TO 102
          IF (XPRP.EQ.OORV.AND.XPRN.NE.OORV)
            IOCF=0
            INCI=5
            INVOKE (FOLLOW-THE-LIMB)
          END IF
        END WHILE
C
        WHILE (IVBY.GT.1)
          IVBY=IVBY-1
          XPRP=XPRN
          XDUM=CFUX(XVPL)
          IF (ICFELL('CTTRVE',14).NE.0) GO TO 102
          YDUM=CFUY(YVPB+RIDN*REAL(IVBY-1))
          IF (ICFELL('CTTRVE',15).NE.0) GO TO 102
          CALL HLUCTMXYZ (-IMPF,XDUM,YDUM,ZDUM,XPRN,YPRN)
          IF (ICFELL('CTTRVE',16).NE.0) GO TO 102
          IF (XPRP.EQ.OORV.AND.XPRN.NE.OORV)
            IOCF=0
            INCI=3
            INVOKE (FOLLOW-THE-LIMB)
          END IF
        END WHILE
C
        FOR (IVBY = 2 TO IIDN-1)
          XDUM=CFUX(XVPL)
          IF (ICFELL('CTTRVE',17).NE.0) GO TO 102
          RVBY=CFUY(YVPB+RIDN*REAL(IVBY-1))
          IF (ICFELL('CTTRVE',18).NE.0) GO TO 102
          CALL HLUCTMXYZ (-IMPF,XDUM,RVBY,ZDUM,XPRN,YPRN)
          IF (ICFELL('CTTRVE',19).NE.0) GO TO 102
          FOR (IVBX = 2 TO IIDM)
            XPRP=XPRN
            XDUM=CFUX(XVPL+RIDM*REAL(IVBX-1))
            IF (ICFELL('CTTRVE',20).NE.0) GO TO 102
            CALL HLUCTMXYZ (-IMPF,XDUM,RVBY,ZDUM,XPRN,YPRN)
            IF (ICFELL('CTTRVE',21).NE.0) GO TO 102
            IF (XPRP.EQ.OORV.AND.XPRN.NE.OORV)
              IPXY=IIDN*IVBX+IVBY
              DO (I=1,NHSS)
                IF (IPXY.EQ.IWRK(II01+I)) GO TO 101
              END DO
              IF (NHSS.GE.LI01)
                CALL CTGIWS (IWRK,1,LI01+100,IWSE)
                IF (IWSE.NE.0.OR.ICFELL('CTTRVE',22).NE.0) GO TO 102
              END IF
              NHSS=NHSS+1
              IWRK(II01+NHSS)=IPXY
              IOCF=1
              INCI=1
              INVOKE (FOLLOW-THE-LIMB)
  101       END IF
          END FOR
        END FOR
C
C Release the workspaces and let the user know we're done.
C
  102   LI01=0
        LR01=0
        IJMP=0
C
C Done.
C
        RETURN
C
C Limb-following algorithm.  This internal routine moves the limb-
C following vector (defined by the base point (IVBX,IVBY) and the
C components INCX(INCI) and INCY(INCI)) along a limb line.  The
C points defining the limb line are thereby determined.  The process
C stops when either the starting point or the edge of the grid is
C encountered.
C
        BLOCK (FOLLOW-THE-LIMB)
C
          NPLS=0
C
          MVBX=IVBX
          MVBY=IVBY
          MNCI=INCI
C
          IVEX=IVBX+INCX(INCI)
          IVEY=IVBY+INCY(INCI)
C
          INVOKE (GENERATE-POINT-ON-LIMB)
C
          LOOP
C
            INCI=INCI+1
            IF (INCI.GT.8) INCI=INCI-8
            IVEX=IVBX+INCX(INCI)
            IVEY=IVBY+INCY(INCI)
C
            EXIT IF (IVEX.LT.1.OR.IVEX.GT.IIDM.OR.
     +               IVEY.LT.1.OR.IVEY.GT.IIDN)
C
            XDUM=CFUX(XVPL+RIDM*REAL(IVEX-1))
            IF (ICFELL('CTTRVE',23).NE.0) GO TO 102
            YDUM=CFUY(YVPB+RIDN*REAL(IVEY-1))
            IF (ICFELL('CTTRVE',24).NE.0) GO TO 102
            CALL HLUCTMXYZ (-IMPF,XDUM,YDUM,ZDUM,XTMP,YTMP)
            IF (ICFELL('CTTRVE',25).NE.0) GO TO 102
            IF (XTMP.NE.OORV)
C
              IVBX=IVEX
              IVBY=IVEY
              INCI=INCI+4
C
            ELSE IF ((INCI/2)*2.NE.INCI)
C
              INVOKE (GENERATE-POINT-ON-LIMB)
C
              IF (INCI.EQ.1)
                IF (NHSS.GE.LI01)
                  CALL CTGIWS (IWRK,1,LI01+100,IWSE)
                  IF (IWSE.NE.0.OR.ICFELL('CTTRVE',26).NE.0) GO TO 102
                END IF
                NHSS=NHSS+1
                IWRK(II01+NHSS)=IIDN*IVBX+IVBY
              END IF
C
              EXIT IF (IVBX.EQ.MVBX.AND.IVBY.EQ.MVBY.AND.INCI.EQ.MNCI)
C
            END IF
C
          END LOOP
C
C Note: At this point, if NPLS is 1, and the call was from CTCLAM,
C control has to return there so that so that CTTROE can properly
C do its thing.  If the call came from somewhere else, there should
C be no problem - it's just a little inefficient.
C
          IF (NPLS.NE.0)
            IJMP=1
            IRW1=IR01
            IRW2=IR01+MPLS
            NRWK=NPLS
            IOCF=IOR(IOCF,4)
            RETURN
          END IF
C
  103     IVBX=MVBX
          IVBY=MVBY
C
        END BLOCK
C
C The following procedure, given a point on either side of the limb,
C uses a binary-halving technique to determine a point on the limb and
C adds that point to the list.  It also estimates the angle of the
C tangent to the limb; if the angles of the last two tangents indicate
C that the limb is convex as viewed from the visible side, it adds the
C point of intersection of the two tangents to the list before adding
C the new point.
C
        BLOCK (GENERATE-POINT-ON-LIMB)
C
          XCVF=XVPL+RIDM*REAL(IVBX-1)
          YCVF=YVPB+RIDN*REAL(IVBY-1)
          XDUM=CFUX(XCVF)
          IF (ICFELL('CTTRVE',27).NE.0) GO TO 102
          YDUM=CFUY(YCVF)
          IF (ICFELL('CTTRVE',28).NE.0) GO TO 102
          CALL HLUCTMXYZ (-IMPF,XDUM,YDUM,ZDUM,XCVD,YCVD)
          IF (ICFELL('CTTRVE',29).NE.0) GO TO 102
C
          XCIF=XVPL+RIDM*REAL(IVEX-1)
          YCIF=YVPB+RIDN*REAL(IVEY-1)
C
          ITMP=0
C
          LOOP
            XCHF=(XCVF+XCIF)/2.
            YCHF=(YCVF+YCIF)/2.
            XDUM=CFUX(XCHF)
            IF (ICFELL('CTTRVE',30).NE.0) GO TO 102
            YDUM=CFUY(YCHF)
            IF (ICFELL('CTTRVE',31).NE.0) GO TO 102
            CALL HLUCTMXYZ (-IMPF,XDUM,YDUM,ZDUM,XCHD,YCHD)
            IF (ICFELL('CTTRVE',32).NE.0) GO TO 102
            IF (XCHD.NE.OORV)
              EXIT IF (XCHF.EQ.XCVF.AND.YCHF.EQ.YCVF)
              XCVF=XCHF
              YCVF=YCHF
              XCVD=XCHD
              YCVD=YCHD
            ELSE
              EXIT IF (XCHF.EQ.XCIF.AND.YCHF.EQ.YCIF)
              XCIF=XCHF
              YCIF=YCHF
            END IF
            ITMP=ITMP+1
            EXIT IF (ITMP.EQ.64)
          END LOOP
C
          IF (NPLS.NE.0)
            XDUM=CUFX(RWRK(IR01+     NPLS))
            IF (ICFELL('CTTRVE',33).NE.0) GO TO 102
            YDUM=CUFY(RWRK(IR01+MPLS+NPLS))
            IF (ICFELL('CTTRVE',34).NE.0) GO TO 102
            IF (ABS(XCVF-XDUM).LE..0001*ABS(XVPR-XVPL).AND.
     +          ABS(YCVF-YDUM).LE..0001*ABS(YVPT-YVPB))
              IF (NPLS.EQ.1) GO TO 105
              NPLS=NPLS-1
            END IF
          END IF
C
          NPLS=NPLS+1
          RWRK(IR01     +NPLS)=CFUX(XCVF)
          IF (ICFELL('CTTRVE',35).NE.0) GO TO 102
          RWRK(IR01+MPLS+NPLS)=CFUY(YCVF)
          IF (ICFELL('CTTRVE',36).NE.0) GO TO 102
C
          IF (NPLS.GE.MPLS)
            XSAV=RWRK(IR01     +NPLS)
            YSAV=RWRK(IR01+MPLS+NPLS)
            IJMP=2
            IRW1=IR01
            IRW2=IR01+MPLS
            NRWK=NPLS
            RETURN
  104       IOCF=IOR(IOCF,2)
            RWRK(IR01     +1)=XSAV
            RWRK(IR01+MPLS+1)=YSAV
            NPLS=1
          END IF
C
  105   END BLOCK
C
      END
.OP   BI=77


      SUBROUTINE CTTROE (XCRA,YCRA,NCRA,OFFS,RWRK,IOCF,IAMA,IGID,IAIL,
     +                                                           IAIR)
C
        DIMENSION XCRA(*),YCRA(*),RWRK(12),IAMA(*)
C
C The routine CTTROE is given the (fractional) X and Y coordinates of
C points defining a curve C.  It generates a curve C' which is parallel
C to C and separated from it by a small distance.  The points defining
C C' are passed on to the routine CTWLAM, which clips them against a
C rectangular window (defined by the contents of the common block
C WDCOMN) and passes the visible portions on to AREDAM for insertion
C in an area map.
C
C XCRA and YCRA are X and Y coordinate arrays defining NCRA points that
C define part of the curve C.  OFFS is the distance, in the fractional
C coordinate system, from C to C'; if OFFS is positive, C' is to the
C left of C and, if OFFS is negative, C' is to the right of C.  RWRK is
C a workspace array, dimensioned 12, in which required information can
C be saved from call to call.  (It is expected, for a given curve,
C that the last point in one call will be the first point in the next
C call; if the curve is closed, it is expected that the last point in
C the last call will match the first point in the first call.  Still,
C we need to save the next-to-last point from each call for use during
C the next call and, if the curve is closed, we need to save the second
C and third points from the first call for use during the last call.
C We also need to save the last offset curve point generated by each
C call except the last. The saves could be done using local SAVEd
C variables, but that would preclude generating curves for positive
C and negative values of OFFS at the same time.)  IOCF is a flag of
C the form
C
C     4 * R + 2 * S + T
C
C where R, S, and T are one-bit flags giving information about the part
C of C defined by the call.  R = 0 says that (XCRA(NCRA),YCRA(NCRA))
C is not the last point of C and R = 1 says that it is.  S = 0 says that
C (XCRA(1),YCRA(1)) is the first point of the curve and S = 1 says that
C it is not.  T = 0 says that C is open on both ends, in which case its
C ends are to be extended to intersect the edges of the plotter frame,
C and T = 1 says that C is closed on itself.  IAMA is an area map array.
C IGID is the group identifier and IAIL and IAIR are the left and right
C area identifiers to be passed on to CTWLAM and eventually to AREDAM.
C IGID must be the same for all calls defining a given curve, but IAIL
C and IAIR may change from call to call.
C
C Note that, in the sequence of calls to CTTROE for a particular curve,
C IOCF takes on values like the following:
C
C     0  =>  Beginning of an open curve.
C     1  =>  Beginning of a closed curve.
C     2  =>  Part of an open curve, not including either end point.
C     3  =>  Part of a closed curve, not including either end point.
C     4  =>  An entire open curve, including both end points.
C     5  =>  An entire closed curve, including both end points.
C     6  =>  End of an open curve.
C     7  =>  End of a closed curve.
C
C First, extract individual flags from IOCF.  IBEG says whether or not
C the curve begins with this call, IEND says whether or not the curve
C ends with this call, and ICLO says whether or not the curve is closed.
C
        IBEG=1-MOD(IOCF/2,2)
        IEND=IOCF/4
        ICLO=MOD(IOCF,2)
C
C Initialize the flag that tells CTWLAM whether it just got a first
C point or not.
C
        IFST=0
C
C Initialize XNXT and YNXT for one particular case (when the first call
C defining a closed curve defines just the first two points of it).
C
        XNXT=1.E36
        YNXT=1.E36
C
C Initialize the variables that hold local copies of the left and right
C area identifiers.
C
        JAIL=IAIL
        JAIR=IAIR
C
C Do necessary initialization.
C
        IJMP=1
C
        IF (IBEG.NE.0)
          ICRA=1
          XCPB=XCRA(1)
          YCPB=YCRA(1)
          XCPC=XCRA(2)
          YCPC=YCRA(2)
          IF (ICLO.EQ.0)
            DIRE=0.
            GO TO 201
          ELSE
            RWRK(1)=XCRA(2)
            RWRK(2)=YCRA(2)
            RWRK(5)=REAL(IAIL)
            RWRK(6)=REAL(IAIR)
            IF (NCRA.GE.3)
              RWRK(3)=XCRA(3)
              RWRK(4)=YCRA(3)
            ELSE
              RWRK(3)=1.E36
              RWRK(4)=1.E36
            END IF
          END IF
        ELSE
          IF (RWRK(3).EQ.1.E36)
            RWRK(3)=XCRA(2)
            RWRK(4)=YCRA(2)
          END IF
          IF (RWRK(9).NE.1.E36)
            XNXT=RWRK(9)
            YNXT=RWRK(10)
            JAIL=INT(RWRK(11))
            JAIR=INT(RWRK(12))
            CALL CTWLAM (XNXT,YNXT,IFST,IAMA,IGID,JAIL,JAIR)
            IF (ICFELL('CTTROE',1).NE.0) RETURN
            IFST=1
          END IF
          ICRA=0
          XCPB=RWRK(7)
          YCPB=RWRK(8)
          XCPC=XCRA(1)
          YCPC=YCRA(1)
        END IF
C
C Generate offset points near the point with index ICRA until ICRA
C becomes equal to NCRA.
C
  101   ICRA=ICRA+1
        IF (ICRA.LT.NCRA)
          XCPA=XCPB
          YCPA=YCPB
          XCPB=XCPC
          YCPB=YCPC
          XCPC=XCRA(ICRA+1)
          YCPC=YCRA(ICRA+1)
          GO TO 301
        END IF
C
C Do necessary final stuff.
C
        IF (IEND.EQ.0)
          RWRK( 7)=XCRA(NCRA-1)
          RWRK( 8)=YCRA(NCRA-1)
          RWRK( 9)=XNXT
          RWRK(10)=YNXT
          RWRK(11)=REAL(IAIL)
          RWRK(12)=REAL(IAIR)
          GO TO 103
        ELSE
          IF (ICLO.EQ.0)
            DIRE=1.
            IJMP=2
            GO TO 201
          ELSE
            XCPA=XCPB
            YCPA=YCPB
            XCPB=XCPC
            YCPB=YCPC
            XCPC=RWRK(1)
            YCPC=RWRK(2)
            IJMP=2
            GO TO 301
          END IF
        END IF
C
  102   XCPA=XCPB
        YCPA=YCPB
        XCPB=XCPC
        YCPB=YCPC
        XCPC=RWRK(3)
        YCPC=RWRK(4)
        JAIL=INT(RWRK(5))
        JAIR=INT(RWRK(6))
        IJMP=3
        GO TO 301
C
C Done.
C
  103   RETURN
C
C The following internal procedure generates the point of intersection
C of the line offset from BC with the edge of the plotter frame and
C sends that point off to CTWLAM.  DIRE says whether we want the point
C of intersection nearer to B (DIRE = 0.) or nearer to C (DIRE = 1.).
C
  201   XDBC=XCPC-XCPB
        YDBC=YCPC-YCPB
        DFBC=SQRT(XDBC*XDBC+YDBC*YDBC)
        XCPP=XCPB-OFFS*YDBC/DFBC
        YCPP=YCPB+OFFS*XDBC/DFBC
        XCPQ=XCPC-OFFS*YDBC/DFBC
        YCPQ=YCPC+OFFS*XDBC/DFBC
        IF (ABS(XDBC).GT.ABS(YDBC))
          IF (XDBC.GT.0.)
            XNXT=DIRE
          ELSE
            XNXT=1.-DIRE
          END IF
          YNXT=YCPP+(XNXT-XCPP)*(YDBC/XDBC)
        ELSE
          IF (YDBC.GT.0.)
            YNXT=DIRE
          ELSE
            YNXT=1.-DIRE
          END IF
          XNXT=XCPP+(YNXT-YCPP)*(XDBC/YDBC)
        END IF
        CALL CTWLAM (XNXT,YNXT,IFST,IAMA,IGID,IAIL,IAIR)
        IF (ICFELL('CTTROE',2).NE.0) RETURN
        IFST=1
        GO TO (101,103) , IJMP
C
C The following internal procedure generates the point of intersection
C of the line offset from AB with the line offset from BC and sends that
C point off to CTWLAM.
C
  301   XDAB=XCPB-XCPA
        YDAB=YCPB-YCPA
        DFAB=SQRT(XDAB*XDAB+YDAB*YDAB)
        XCPP=XCPA-OFFS*YDAB/DFAB
        YCPP=YCPA+OFFS*XDAB/DFAB
        XCPQ=XCPB-OFFS*YDAB/DFAB
        YCPQ=YCPB+OFFS*XDAB/DFAB
        XDBC=XCPC-XCPB
        YDBC=YCPC-YCPB
        DFBC=SQRT(XDBC*XDBC+YDBC*YDBC)
        XCPR=XCPB-OFFS*YDBC/DFBC
        YCPR=YCPB+OFFS*XDBC/DFBC
        XCPS=XCPC-OFFS*YDBC/DFBC
        YCPS=YCPC+OFFS*XDBC/DFBC
        DNOM=(XCPP-XCPQ)*(YCPR-YCPS)-(XCPR-XCPS)*(YCPP-YCPQ)
        TEMP=((XCPP-XCPQ)**2+(YCPP-YCPQ)**2)*
     +       ((XCPR-XCPS)**2+(YCPR-YCPS)**2)
        IF (DNOM*DNOM.LE..0001*TEMP) THEN
          XNXT=.5*(XCPQ+XCPR)
          YNXT=.5*(YCPQ+YCPR)
        ELSE
          TEMP=((XCPP-XCPR)*(YCPR-YCPS)-(XCPR-XCPS)*(YCPP-YCPR))/DNOM
          XNXT=XCPP+(XCPQ-XCPP)*TEMP
          YNXT=YCPP+(YCPQ-YCPP)*TEMP
        END IF
        CALL CTWLAM (XNXT,YNXT,IFST,IAMA,IGID,JAIL,JAIR)
        IF (ICFELL('CTTROE',3).NE.0) RETURN
        IFST=1
        JAIL=IAIL
        JAIR=IAIR
        GO TO (101,102,103) , IJMP
C
      END


      SUBROUTINE CTWLAM (XNXT,YNXT,IFST,IAMA,IGID,IAIL,IAIR)
C
        DIMENSION IAMA(*)
C
C This is a windowing routine for line draws.  Code using it should
C declare the common block WDCOMN and put into it minimum and maximum
C values of X and Y that together define a window at the edges of which
C lines are to be clipped.  Once that has been done, each call to
C CTWLAM with IFST = 0 declares a point (XNXT,YNXT) at which a line
C is to begin and each call to CTWLAM with IFST = 1 declares a point
C (XNXT,YNXT) at which a line is to continue.
C
C This version of CTWLAM puts the windowed line segments into the area
C map IAMA, using group identifier IGID, left area identifier IAIL, and
C right area identifier IAIR.  Each (XNXT,YNXT) is expected to be a
C point in the fractional coordinate system.  Likewise, the values of
C XWMN, XWMX, YWMN, and YWMX are expected to be in the fractional
C coordinate system.
C
C Declare the common block that holds the clipping window parameters.
C
        COMMON /CTWCMN/ XWMN,XWMX,YWMN,YWMX
C
C Declare some arrays to be used for passing point coordinates to
C AREDAM.
C
        DIMENSION XCRA(2),YCRA(2)
C
C Certain quantities need to be saved from call to call.  LPOW is a
C "last-point-outside-window" flag.  (XLST,YLST) is the last point
C (from the previous call to CTWLAM).
C
        SAVE LPOW,XLST,YLST
C
C Compute a "next-point-outside-window" flag.  The value of this flag
C is between -4 and +4, depending on where the next point is relative
C to the window, as shown in the following diagram:
C
C                      |      |
C                   -2 |  +1  | +4
C            YWMX -----+------+-----
C                   -3 |   0  | +3
C            YWMN -----+------+-----
C                   -4 |  -1  | +2
C                      |      |
C                    XWMN    XWMX
C
C Ultimately, we combine the values of this flag for two consecutive
C points in such a way as to get an integer between 1 and 81, telling
C us what combination of inside/outside we have to deal with.
C
        NPOW=INT(3.*(SIGN(.51,XNXT-XWMN)+SIGN(.51,XNXT-XWMX))+
     +              (SIGN(.51,YNXT-YWMN)+SIGN(.51,YNXT-YWMX)))
C
C If the next point is not the first point of a line, there is work to
C be done.
C
        IF (IFST.NE.0)
C
C The left and right area identifiers passed to AREDAM must be defined
C to be consistent with the user coordinate system, rather than the
C fractional system.
C
          CALL GETSET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
C
          IF ((XWDL.LT.XWDR.AND.YWDB.LT.YWDT).OR.
     +        (XWDL.GT.XWDR.AND.YWDB.GT.YWDT))
            JAIL=IAIL
            JAIR=IAIR
          ELSE
            JAIL=IAIR
            JAIR=IAIL
          END IF
C
C There are various possible cases, depending on whether the last point
C was inside or outside the window and whether the next point is inside
C or outside the window.
C
          IF (LPOW.EQ.0)
            IF (NPOW.NE.0) GO TO 101
            XCRA(1)=CFUX(XLST)
            IF (ICFELL('CTWLAM',1).NE.0) RETURN
            YCRA(1)=CFUY(YLST)
            IF (ICFELL('CTWLAM',2).NE.0) RETURN
            XCRA(2)=CFUX(XNXT)
            IF (ICFELL('CTWLAM',3).NE.0) RETURN
            YCRA(2)=CFUY(YNXT)
            IF (ICFELL('CTWLAM',4).NE.0) RETURN
            CALL AREDAM (IAMA,XCRA,YCRA,2,IGID,JAIL,JAIR)
            IF (ICFELL('CTWLAM',5).NE.0) RETURN
            GO TO 115
          ELSE
            IF (NPOW.EQ.0) GO TO 103
            GO TO 105
          END IF
C
C Last point inside, next point outside.
C
  101     XPEW=XLST
          YPEW=YLST
          XDIF=XNXT-XLST
          YDIF=YNXT-YLST
C
          IF (ABS(XDIF).GT..000001*(XWMX-XWMN))
            XPEW=XWMN
            IF (XDIF.GE.0.) XPEW=XWMX
            YPEW=YLST+(XPEW-XLST)*YDIF/XDIF
            IF (YPEW.GE.YWMN.AND.YPEW.LE.YWMX) GO TO 102
          END IF
C
          IF (ABS(YDIF).GT..000001*(YWMX-YWMN))
            YPEW=YWMN
            IF (YDIF.GE.0.) YPEW=YWMX
            XPEW=XLST+(YPEW-YLST)*XDIF/YDIF
          END IF
C
  102     XCRA(1)=CFUX(XLST)
          IF (ICFELL('CTWLAM',6).NE.0) RETURN
          YCRA(1)=CFUY(YLST)
          IF (ICFELL('CTWLAM',7).NE.0) RETURN
          XCRA(2)=CFUX(XPEW)
          IF (ICFELL('CTWLAM',8).NE.0) RETURN
          YCRA(2)=CFUY(YPEW)
          IF (ICFELL('CTWLAM',9).NE.0) RETURN
          CALL AREDAM (IAMA,XCRA,YCRA,2,IGID,JAIL,JAIR)
          IF (ICFELL('CTWLAM',10).NE.0) RETURN
C
          GO TO 115
C
C Last point outside, next point inside.
C
  103     XPEW=XNXT
          YPEW=YNXT
          XDIF=XLST-XNXT
          YDIF=YLST-YNXT
C
          IF (ABS(XDIF).GT..000001*(XWMX-XWMN))
            XPEW=XWMN
            IF (XDIF.GE.0.) XPEW=XWMX
            YPEW=YNXT+(XPEW-XNXT)*YDIF/XDIF
            IF (YPEW.GE.YWMN.AND.YPEW.LE.YWMX) GO TO 104
          END IF
C
          IF (ABS(YDIF).GT..000001*(YWMX-YWMN))
            YPEW=YWMN
            IF (YDIF.GE.0.) YPEW=YWMX
            XPEW=XNXT+(YPEW-YNXT)*XDIF/YDIF
          END IF
C
  104     XCRA(1)=CFUX(XPEW)
          IF (ICFELL('CTWLAM',11).NE.0) RETURN
          YCRA(1)=CFUY(YPEW)
          IF (ICFELL('CTWLAM',12).NE.0) RETURN
          XCRA(2)=CFUX(XNXT)
          IF (ICFELL('CTWLAM',13).NE.0) RETURN
          YCRA(2)=CFUY(YNXT)
          IF (ICFELL('CTWLAM',14).NE.0) RETURN
          CALL AREDAM (IAMA,XCRA,YCRA,2,IGID,JAIL,JAIR)
          IF (ICFELL('CTWLAM',15).NE.0) RETURN
C
          GO TO 115
C
C Last point outside, next point outside.  Check whether or not part of
C the line joining them lies in the window.
C
  105     MPOW=9*LPOW+NPOW+41
C
          GO TO ( 115,115,115,115,115,106,115,106,106,
     +            115,115,115,107,115,106,107,106,106,
     +            115,115,115,107,115,115,107,107,115,
     +            115,109,109,115,115,106,115,106,106,
     +            115,115,115,115,115,115,115,115,115,
     +            108,108,115,108,115,115,107,107,115,
     +            115,109,109,115,115,109,115,115,115,
     +            108,108,109,108,115,109,115,115,115,
     +            108,108,115,108,115,115,115,115,115 ) , MPOW
C
  106     XPE1=XWMN
          YPT1=YWMN
          XPE2=XWMX
          YPT2=YWMX
          GO TO 110
C
  107     XPE1=XWMN
          YPT1=YWMX
          XPE2=XWMX
          YPT2=YWMN
          GO TO 110
C
  108     XPE1=XWMX
          YPT1=YWMX
          XPE2=XWMN
          YPT2=YWMN
          GO TO 110
C
  109     XPE1=XWMX
          YPT1=YWMN
          XPE2=XWMN
          YPT2=YWMX
C
  110     XDIF=XNXT-XLST
          YDIF=YNXT-YLST
C
          IF (ABS(XDIF).LE..000001*(XWMX-XWMN)) GO TO 112
          YPE1=YLST+(XPE1-XLST)*YDIF/XDIF
          YPE2=YLST+(XPE2-XLST)*YDIF/XDIF
C
          IF (ABS(YDIF).LE..000001*(YWMX-YWMN))
            IF (YPE1.LT.YWMN.OR.YPE1.GT.YWMX) GO TO 115
            IF (YPE2.LT.YWMN.OR.YPE2.GT.YWMX) GO TO 115
            GO TO 114
          END IF
C
          IF (YPE1.GE.YWMN.AND.YPE1.LE.YWMX) GO TO 111
          YPE1=YPT1
          XPE1=XLST+(YPE1-YLST)*XDIF/YDIF
          IF (XPE1.LT.XWMN.OR.XPE1.GT.XWMX) GO TO 115
C
  111     IF (YPE2.GE.YWMN.AND.YPE2.LE.YWMX) GO TO 114
          GO TO 113
C
  112     YPE1=YPT1
          XPE1=XLST+(YPE1-YLST)*XDIF/YDIF
          IF (XPE1.LT.XWMN.OR.XPE1.GT.XWMX) GO TO 115
C
  113     YPE2=YPT2
          XPE2=XLST+(YPE2-YLST)*XDIF/YDIF
          IF (XPE2.LT.XWMN.OR.XPE2.GT.XWMX) GO TO 115
C
  114     XCRA(1)=CFUX(XPE1)
          IF (ICFELL('CTWLAM',16).NE.0) RETURN
          YCRA(1)=CFUY(YPE1)
          IF (ICFELL('CTWLAM',17).NE.0) RETURN
          XCRA(2)=CFUX(XPE2)
          IF (ICFELL('CTWLAM',18).NE.0) RETURN
          YCRA(2)=CFUY(YPE2)
          IF (ICFELL('CTWLAM',19).NE.0) RETURN
          CALL AREDAM (IAMA,XCRA,YCRA,2,IGID,JAIL,JAIR)
          IF (ICFELL('CTWLAM',20).NE.0) RETURN
C
        END IF
C
C Processing of the next point is done.  It becomes the last point and
C we return to the user for a new next point.
C
  115   LPOW=NPOW
        XLST=XNXT
        YLST=YNXT
C
        RETURN
C
      END


      FUNCTION ICAPNT (XCRD,YCRD,ZCRD,DVAL,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 field data value at that point, searches the point list for a point
C having the same coordinates.  If such a point exists, its index is
C returned; if not, such a point is created and its index is returned.
C The search is effected using a tree-sort technique, the pointers for
C 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
            ICAPNT=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 ('ICAPNT - POINT ARRAY IS TOO SMALL',1,1)
          ICAPNT=-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)=DVAL
C
          ICAPNT=NPPP
C
        END IF
C
C Done.
C
        RETURN
C
      END


      FUNCTION ICAPNX (XCRD,YCRD,ZCRD,DVAL,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 field data value at that point, searches the point list for a point
C having nearly the same coordinates (within the epsilon specified by
C the value of EPST).  If such a point exists, its index is returned;
C if not, such a point is created and its index is returned.  The
C search is effected using a tree-sort technique, the pointers for
C which are kept in the array IPPP.  Each node contains three pointers:
C 1) a forward pointer to a list of lesser values; 2) a forward pointer
C to a list of greater values, and 3) a backward 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
            ICAPNX=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)
              ICAPNX=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)
              ICAPNX=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 ('ICAPNX - POINT ARRAY IS TOO SMALL',1,1)
          ICAPNX=-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)=DVAL
C
          ICAPNX=NPPP
C
        END IF
C
C Done.
C
        RETURN
C
      END


      FUNCTION ICAEDG (IPP1,IPP2,IEDG,LOEN,IPPE,MPPE,NPPE,RPNT)
C
      DIMENSION IEDG(LOEN,MPPE),IPPE(2,MPPE),RPNT(*)
      INTEGER *8 IKEY1,IKEY2
c
c      integer totaldepth
c      save maxdepth,itdepth
C
C modified by dbrown to use mangled integer keys. This fixes a problem
C of the edges centers occasionally giving false equalities with 
C different edges. Also improves performances. 11/30/2012
C
C This function, given the base indices, in the point list, of the two
C points defining an edge, searches the edge list for an edge matching
C it.  If such an edge exists, its index is returned; if not, such an
C edge is created and its index is returned.  The search is effected
C using a tree-sort technique, the pointers for which are kept in the
C array IPPE.
C
C If there are any edges in the edge list at all, ...
C
c      if (nppe .eq. 0) then
c         itdepth = 0
c      end if
      IF (NPPE.NE.0) THEN
C
C search it.  First, order the pointers to the points in a consistent
C manner and then find the X, Y, and Z coordinates of the edge's
C midpoint, which we use to determine the order of the edges in the
C list.  (Using the values of ITM1 and ITM2 results in very bad
C behavior by the tree-sort.)
C
        ITM1=MIN(IPP1,IPP2)
        ITM2=MAX(IPP1,IPP2)
C
C
C Instead of finding the edge center and using floating point numbers 
C for comparision, bit-mangle the two point ids into a single int*8
C value that will be unique but distribute in the tree in a semi-
C random manner. The 2 ids always mangle to the same value.
C This eliminates the possible error due to float imprecision
C MANGLE is a C routine in libncarg_c
C
        CALL MANGLE(ITM1,ITM2,IKEY1)
C
C Initialize a search index to point to the first element in the sort
C list.
C
        ITMP=1
C
C Loop.  If the search index now points at the edge we want, return
C its index.
C
c        idepth = 0
  101   IF (ITM1.EQ.IEDG(1,ITMP).AND.ITM2.EQ.IEDG(2,ITMP)) THEN
C
          ICAEDG=ITMP
C
          RETURN
C
        END IF
C
C Find the X, Y, and Z coordinates of this edge's midpoint for
C comparison with the one we seek.
C
c        idepth = idepth + 1
        CALL MANGLE(IEDG(1,ITMP),IEDG(2,ITMP),IKEY2)
C
C If the edge 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
c  this commented out code can be used if integer*8 is not portable
c        if ((ikey1(1) .lt. ikey2(1)) .or. 
c     +      (ikey1(1) .eq. ikey2(1) .and. ikey1(2) .lt. ikey2(2))) then
c
        IF (IKEY1 .LT. IKEY2) THEN
C
          IF (IPPE(1,ITMP).NE.0) THEN
            ITMP=IPPE(1,ITMP)
            GO TO 101
          END IF
C
          IPPE(1,ITMP)=NPPE+1
C
C If the edge 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
c        else if ((ikey1(1) .gt. ikey2(1)) .or. 
c     +       (ikey1(1) .eq. ikey2(1) .and. ikey1(2) .gt. ikey2(2))) then
c
        ELSE IF (IKEY1 .GT. IKEY2) THEN
C
          IF (IPPE(2,ITMP).NE.0) THEN
            ITMP=IPPE(2,ITMP)
            GO TO 101
          END IF
C
          IPPE(2,ITMP)=NPPE+1
C
        ELSE
C
               CALL SETER ('ICAEDG - LOGIC ERROR',1,1)
               ICAEDG=-1
               RETURN
C
        END IF
C
      END IF
c
c      output for monitoring performance of the key method
c
c      itdepth = itdepth + idepth
c      if (idepth .gt. maxdepth) then
c         maxdepth = idepth
c         write(*,*) 'current maxdepth:', maxdepth, 
c     +              ' avg depth: ', itdepth / (nppe + 1),
c     +              'edge count is: ', (nppe + 1) 
c      else if (mod((nppe+1),100) .eq. 0) then
c         write(*,*) ' avg depth: ', itdepth, itdepth / (nppe + 1)
c      end if
C
C Create a new edge in the edge list (if there's room, of course), and
C return its index to the caller.
C
      IF (NPPE.GE.MPPE) THEN
C
        CALL SETER ('ICAEDG - EDGE ARRAY IS TOO SMALL',1,1)
        ICAEDG=-1
        RETURN
C
      ELSE
C
        NPPE=NPPE+1
C
        IPPE(1,NPPE)=0
        IPPE(2,NPPE)=0
C
        IEDG(1,NPPE)=MIN(IPP1,IPP2)
        IEDG(2,NPPE)=MAX(IPP1,IPP2)
        IEDG(3,NPPE)=-1
        IEDG(4,NPPE)=-1
        IEDG(5,NPPE)=0
C
        ICAEDG=NPPE
C
      END IF
C
      RETURN
C
      END

      FUNCTION CTFRAN ()
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)
        CTFRAN=REAL(X)
C
        RETURN
C
      END


      FUNCTION CTABGC (ALAT,ALON,BLAT,BLON,CLAT,CLON)
C
C (CTABGC = ConpackT, 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.)
          CTABGC=ABS(RTOD*ATAN2(CVOZ,CVOY))
        ELSE
          CTABGC=0.
        END IF
C
C Done.
C
        RETURN
C
      END
