.OP LS=10001 LI=1 CB RT ES=< ET=> OC UC=0 BI=77 IF=2
.EL I
I
I $Id: CodeIftran,v 1.11.8.1 2010-03-17 20:51:57 brownrig Exp $
I
I***********************************************************************
I C O N P A C K   -   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 CONPACK.
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   -   I M P L E M E N T A T I O N
I***********************************************************************
I
I The master version of CONPACK 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 CONPACK requires various parts of the NCAR Graphics package to have
I been implemented (in particular, it uses the support routines I1MACH,
I SETER, MSKRV1, MSKRV2, MSBSF1, and MSBSF2, various routines from SPPS,
I and the utility packages DASHCHAR and AREAS).
I
I The distributed FORTRAN version of CONPACK will handle up to 256
I contour levels at a time, which is probably sufficient for most
I purposes.  To increase this number, find all occurrences of the
I strings "256", "257", "258", and "259" and increase them consistently.
I (Array elements 257, 258, and 259 in the "contour level" arrays are
I used to hold parameter values describing the edge of the grid, the
I edge of the special-value area, if any, and the edge of the visible
I area, if any, respectively.)
I
I The distributed FORTRAN version of CONPACK contains two variables
I which are declared to be of type "CHARACTER*500".  This may be too
I large for some compilers.  To change this in the FORTRAN version,
I find all occurrences of the string "500" and change all but one
I (which is part of a comment) to the largest value your compiler will
I accept.
I
I***********************************************************************
I C O N P A C K   -   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$, $NCP2$, and $NCP3$ define the positions, in the extensions of
I the contour-level arrays, of parameters for grid edges, special-value-
I area edges, and visible/invisible edges, respectively.
I
.RE /$NCP1$/<$NCLV$+1>/
.RE /$NCP2$/<$NCP1$+1>/
.RE /$NCP3$/<$NCP2$+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 CONPACK supplies a single integer workspace array.
I When one of the CONPACK routines requires a block of space within the
I array, it calls CPGIWS to request the space.  CPGIWS 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 CONPACK supplies a single real workspace array.
I When one of the CONPACK routines requires a block of space within the
I array, it calls CPGRWS to request the space.  CPGRWS 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 CONPACK common blocks
I --- ------- ------ ------
I
I The following SAVE block contains all of the CONPACK common blocks.
I For descriptions of all of the variables, see the commenting in the
I block data routine CPBLDA, below.
I
.SAVE CPCOMN
C
C CPCOM1 contains integer and real variables.
C
        COMMON /CPCOM1/ ANCF,ANHL,ANIL,ANLL,CDMX,CHWM,CINS,CINT(10)
        COMMON /CPCOM1/ CINU,CLDB($NCLV$),CLDL($NCLV$),CLDR($NCLV$)
        COMMON /CPCOM1/ CLDT($NCLV$),CLEV($NCLV$),CLWA($NCP3$),CXCF
        COMMON /CPCOM1/ CXIL,CYCF,CYIL,DBLF,DBLM,DBLN,DBLV,DFLD,DOPT
        COMMON /CPCOM1/ EPSI,FNCM,GRAV,GRSD,GSDM,HCHL,HCHS,IAIA($NCP3$)
        COMMON /CPCOM1/ IAIB($NCLV$),IBCF,IBHL,IBIL,IBLL,ICAF,ICCF
        COMMON /CPCOM1/ ICCL($NCP3$),ICFF,ICHI,ICHL,ICIL,ICLL($NCLV$)
        COMMON /CPCOM1/ ICLO,ICLP($NCLV$),ICLS,ICLU($NCP3$),ICLV,ICLW
        COMMON /CPCOM1/ IDUF,IGCL,IGLB,IGRM,IGRN,IGVS,IHCF,IHLE,IHLX
        COMMON /CPCOM1/ IHLY,IIWS($NBIW$),IIWU,ILBC,IMPF,INCX(8),INCY(8)
        COMMON /CPCOM1/ INHL,INIL,INIT,INLL,IOCF,IOHL,IOLL,IPAI,IPCF
        COMMON /CPCOM1/ IPIC,IPIE,IPIL,IPLL,IRWS($NBRW$),IRWU,ISET,IWSO
        COMMON /CPCOM1/ IZD1,IZDM,IZDN,IZDS,JODP,JOMA,JOTZ,LCTM,LEA1
        COMMON /CPCOM1/ LEA2,LEA3,LEE1,LEE2,LEE3,LINS,LINT(10),LINU
        COMMON /CPCOM1/ LIWK,LIWM,LIWS($NBIW$),LNLG,LRWC,LRWG,LRWK
        COMMON /CPCOM1/ LRWM,LRWS($NBRW$),LSDD,LSDL,LSDM,LTCF,LTHI
        COMMON /CPCOM1/ LTIL,LTLO,MIRO,NCLB($NCLV$),NCLV,NDGL,NEXL
        COMMON /CPCOM1/ NEXT,NEXU,NLBS,NLSD,NLZF,NOMF,NOVS,NR04,NSDL
        COMMON /CPCOM1/ NSDR,OORV,PITH,SCFS,SCFU,SEGL,SVAL,T2DS,T3DS
        COMMON /CPCOM1/ UCMN,UCMX,UVPB,UVPL,UVPR,UVPS,UVPT,UWDB,UWDL
        COMMON /CPCOM1/ UWDR,UWDT,UXA1,UXAM,UYA1,UYAN,WCCF,WCHL,WCIL
        COMMON /CPCOM1/ WCLL,WLCF,WLHL,WLIL,WLLL,WOCH,WODA,WTCD,WTGR
        COMMON /CPCOM1/ WTNC,WTOD,WWCF,WWHL,WWIL,WWLL,XAT1,XATM,XLBC
        COMMON /CPCOM1/ XVPL,XVPR,XWDL,XWDR,YAT1,YATN,YLBC,YVPB,YVPT
        COMMON /CPCOM1/ YWDB,YWDT,ZDVL,ZMAX,ZMIN
.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   /CPCOM1/
.ENDIF
C
C CPCOM2 holds character parameters.
C
        COMMON /CPCOM2/ CHEX,CLBL($NCLV$),CLDP($NCP3$),CTMA,CTMB,FRMT
        COMMON /CPCOM2/ 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   /CPCOM2/
.ENDIF
.END


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


      SUBROUTINE CPBLDA
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 CPBLDAX
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$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 three elements of this
C array give the dash patterns for the edge of the grid, the edge of the
C special value area, and the edge of the visible area, respectively.
C
        DATA CLDP / $NCP3$*'$$$$$$$$$$$$$$$$' /
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 three elements of this array give the line width for the edge of the
C grid, the edge of the special value area, and the edge of the visible
C area, respectively.
C
        DATA CLWA / $NCP3$*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 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 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 CPNUMB.  It is constructed
C as needed by the routine CPINRC.
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 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 three elements,
C which are used for the edge of the grid, the edge of the special value
C area, and the edge of the visible area, respectively - in these cases,
C the value is for the area on the other side of the edge from the area
C which has contour lines in it).
C
        DATA IAIA / $NCLV$*0,0,2*-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 CPCICA
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 three elements, which are used for the edge of the grid,
C the edge of the special value area, and the edge of the visible area,
C respectively).
C
        DATA ICCL / $NCLV$*0,3*-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 CONPACK 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 CONPACK in
C such a way as to give approximately "n" contour lines.  The value "0"
C 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 three elements, which are used for the edge of the grid, the edge of
C the special value area, and the edge of the visible area,
C respectively).
C
        DATA ICLU / $NCP3$*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 CPPKLP and used in CPPLPS; 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 CONPACK to search for highs and lows involving more than
C one adjacent equal value in the field.
C
        DATA IHLE / 0 /
C
C IHLX and IHLY are the parameters 'HLX' and 'HLY', which specify the
C dimensions of the neighborhood to be used in looking for highs and
C lows.
C
        DATA IHLX,IHLY / 0,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 CPTRCL 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 CPTRVE,
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 CONPACK is to
C call SET.
C
        DATA ISET / 1 /
C
C IWSO is the parameter 'WSO', which says what to do when workspace
C overflow occurs.
C
        DATA IWSO / 1 /
C
C IZD1 is the parameter 'ZD1', which specifies the first dimension of
C the FORTRAN array in which the user's data is stored.
C
        DATA IZD1 / 1 /
C
C IZDM and IZDN are the parameters 'ZDM' and 'ZDN', which specify the
C first and second dimensions of the data array to be contoured.
C
        DATA IZDM,IZDN / 1,1 /
C
C IZDS is a ZDAT dimension-selector flag.  If its value is non-zero,
C the routines CPRAND, CPSPS1, and CPSPS2 will choose values for IZD1,
C IZDM, and IZDN.
C
        DATA IZDS / 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 CONPACK 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 LIWK is the length of the user's integer workspace array, as declared
C in the last call to CPRAND, CPRECT, CPSPS1, or CPSPS2.
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 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 / 100 /
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 CPRAND, CPRECT, CPSPS1, or CPSPS2.
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 CPINIT to indicate the position of the leftmost
C significant digit in ABS(ZMAX-ZMIN).  This information is needed
C in CPPKLB.
C
C LSDL is used for the leftmost-significant-digit argument of CPNUMB,
C which is based on, but not identical with, the leftmost-significant-
C digit parameter 'NLS'.
C
C LSDM is set by CPINIT to indicate the position of the leftmost
C significant digit in MAX(ABS(ZMIN),ABS(ZMAX)).  This information
C is needed in CPPKLB.
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 CPNUMB,
C which is based on, but not identical with, the number-of-significant-
C digits parameter 'NSD'.
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 OORV is the parameter 'ORV', an out-of-range value to be returned by
C CPMPXY 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 CPMPXY, 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 SVAL is the parameter 'SPV'.  If non-zero, this is a value to be used
C as a "missing-data" flag.
C
        DATA SVAL / 0. /
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 T3DS is the desired tension for the 3D splines used by CPSPS1/2.
C
        DATA T3DS / 1. /
C
C TXCF is the parameter 'CFT', the text of the constant-field label.
C
        DATA TXCF / 'CONSTANT FIELD - VALUE IS $ZDV$' /
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:$ZDV$: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:$ZDV$: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 CONPACK is asked to do the call to SET; they become arguments 5
C through 8 in the call.  If UWDL is equal to UWDR, the values implied
C by UXA1 and UXAM are used.  Similarly, if UWDB is equal to UWDT, the
C values implied by UYA1 and UYAN are used.
C
        DATA UWDL,UWDR,UWDB,UWDT / 0.,0.,0.,0. /
C
C UXA1, UXAM, UYA1, and UYAN are the parameters 'XC1', 'XCM', 'YC1',
C and 'YCN', specifying the X and Y coordinates corresponding to extreme
C values of the first and second indices of the array ZDAT (before
C mapping).  If UXA1 is equal to UXAM, X coordinates will vary from 1.
C to REAL(IZDM),  If UYA1 is equal to UYAN, Y coordinates will vary
C from 1. to REAL(IZDN).
C
        DATA UXA1,UXAM,UYA1,UYAN / 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 XAT1 and XATM specify the range of X-coordinate values to be used.
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 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 YAT1 and YATN specify the range of Y-coordinate values to be used.
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 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 ZDVL is the parameter 'ZDV', which holds a value from the ZDAT array,
C either the value at a high or low or the value of a constant field.
C
        DATA ZDVL / 0. /
C
C ZMAX and ZMIN are the parameters 'ZMX' and 'ZMN', the maximum and
C minimum values in the user's array of data.
C
        DATA ZMAX,ZMIN / 0.,0. /
C
      END


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


      SUBROUTINE CPBACK (ZDAT,RWRK,IWRK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPBACK - 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 ('CPBACK - 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('CPBACK',3).NE.0) RETURN
C
C If the mapping flag is off, do a simple call to PERIM.
C
        IF (IMPF.EQ.0)
          CALL PERIM (IZDM-1,0,IZDN-1,0)
          IF (ICFELL('CPBACK',4).NE.0) RETURN
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPCICA (ZDAT,RWRK,IWRK,ICRA,ICA1,ICAM,ICAN,XCPF,YCPF,
     +                                                      XCQF,YCQF)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*),ICRA(ICA1,*)
C
C This routine adds color indices to a user's cell array.
C
C ZDAT is the user's data array.
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 (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 Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPCICA - 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 ('CPCICA - INITIALIZATION CALL NOT DONE',2,1)
          RETURN
        END IF
C
C If the mapping flag is turned on and CPMPXY is not capable of doing
C the inverse transformations, log an error and quit.
C
        IF (IMPF.NE.0)
C
          TST1=REAL(IMPF)
          TST2=0.
C
          CALL HLUCPMPXY (0,TST1,TST2,TST3,TST4)
          IF (ICFELL('CPCICA',3).NE.0) RETURN
C
          IF (TST2.NE.2..AND.TST2.NE.3.)
            CALL SETER ('CPCICA - CANNOT CONTINUE - CPMPXY DOES NOT DO I
     +NVERSE MAPPINGS',4,1)
            RETURN
          END IF
        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 ('CPCICA - THE DIMENSIONS OF THE CELL ARRAY ARE INC
     +ORRECT',5,1)
          RETURN
        END IF
C
        IF (XCPF.LT.0..OR.XCPF.GT.1..OR.
     +      YCPF.LT.0..OR.YCPF.GT.1..OR.
     +      XCQF.LT.0..OR.XCQF.GT.1..OR.
     +      YCQF.LT.0..OR.YCQF.GT.1.)
          CALL SETER ('CPCICA - ONE OF THE CORNER POINTS OF THE CELL ARR
     +AY IS INCORRECT',6,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('CPCICA',7).NE.0) RETURN
C
C If no contour levels are defined, try to pick a set of levels.
C
        IF (NCLV.LE.0)
          CALL CPPKCL (ZDAT,RWRK,IWRK)
          IF (ICFELL('CPCICA',8).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 CPSORT (CLEV,NCLV,ICLP)
C
C Compute the minimum and maximum values that user X and Y coordinates
C can have.
C
        XUMN=MIN(XAT1,XATM)
        XUMX=MAX(XAT1,XATM)
        YUMN=MIN(YAT1,YATN)
        YUMX=MAX(YAT1,YATN)
C
C Loop through each cell in the cell array.  Find the center point of
C each cell in the fractional system (coordinates XCFS and YCFS) and
C then in the user system (coordinates XCUS and YCUS).
C
        DO (I=1,ICAM)
C
          XCCF=XCPF+(REAL(I)-.5)*((XCQF-XCPF)/REAL(ICAM))
          XCCU=CFUX(XCCF)
          IF (ICFELL('CPCICA',9).NE.0) RETURN
C
          DO (J=1,ICAN)
C
            YCCF=YCPF+(REAL(J)-.5)*((YCQF-YCPF)/REAL(ICAN))
            YCCU=CFUY(YCCF)
            IF (ICFELL('CPCICA',10).NE.0) RETURN
C
C Find the center point of each cell in the data index system.  The flag
C IOOR is set non-zero if, in the process, the point is found to be
C invisible under the current mapping or outside the coordinate ranges
C associated with the data grid; at the same time, the area identifier
C for the cell is set to the appropriate value for an area which is
C invisible or outside the grid.
C
            IOOR=0
C
            IF (IMPF.EQ.0)
              XCCI=1.+((XCCU-XAT1)/(XATM-XAT1))*REAL(IZDM-1)
              YCCI=1.+((YCCU-YAT1)/(YATN-YAT1))*REAL(IZDN-1)
            ELSE
              CALL HLUCPMPXY (-IMPF,XCCU,YCCU,XCCD,YCCD)
              IF (ICFELL('CPCICA',11).NE.0) RETURN
              IF (OORV.NE.0..AND.XCCD.EQ.OORV)
                IOOR=1
                IAID=IAIA($NCP3$)
              ELSE IF (XCCD.LT.XUMN.OR.XCCD.GT.XUMX.OR.
     +                 YCCD.LT.YUMN.OR.YCCD.GT.YUMX)
                IOOR=1
                IAID=IAIA($NCP1$)
              ELSE
                XCCI=1.+((XCCD-XAT1)/(XATM-XAT1))*REAL(IZDM-1)
                YCCI=1.+((YCCD-YAT1)/(YATN-YAT1))*REAL(IZDN-1)
              END IF
            END IF
C
C If the cell is positioned over a point that corresponds to a point in
C the data array, compute the appropriate indices into the data array.
C
            IF (IOOR.EQ.0)
C
              INDX=INT(XCCI)
              INDY=INT(YCCI)
C
C If the indices are out of range, use the area identifier specified for
C areas outside the grid.
C
              IF (INDX.LT.1.OR.INDX.GE.IZDM.OR.
     +            INDY.LT.1.OR.INDY.GE.IZDN)
C
                IAID=IAIA($NCP1$)
C
C Otherwise, if the special-value feature is turned on and any of the
C corner points is a special value, use the area identifier specified
C for special-value areas.
C
              ELSE IF (SVAL.NE.0..AND.
     +                 (ZDAT(INDX  ,INDY  ).EQ.SVAL.OR.
     +                  ZDAT(INDX  ,INDY+1).EQ.SVAL.OR.
     +                  ZDAT(INDX+1,INDY  ).EQ.SVAL.OR.
     +                  ZDAT(INDX+1,INDY+1).EQ.SVAL    ))
C
                IAID=IAIA($NCP2$)
C
C Otherwise, interpolate to find a data value.
C
              ELSE
C
                ZVAL= (REAL(INDY+1)-YCCI)*
     +               ((REAL(INDX+1)-XCCI)*ZDAT(INDX  ,INDY  )+
     +                (XCCI-REAL(INDX  ))*ZDAT(INDX+1,INDY  ))+
     +                (YCCI-REAL(INDY  ))*
     +               ((REAL(INDX+1)-XCCI)*ZDAT(INDX  ,INDY+1)+
     +                (XCCI-REAL(INDX  ))*ZDAT(INDX+1,INDY+1))
C
C Given the data value, find an area identifier associated with it.
C
                CALL CPGVAI (ZVAL,IAID)
C
              END IF
C
            END IF
C
C Modify the current cell array element as directed by the value of
C the internal parameter 'CAF'.
C
            IF (ICAF.GE.0)
              IF (ICAF+IAID.GT.0) ICRA(I,J)=ICAF+IAID
            ELSE
              CALL HLUCPSCAE (ICRA,ICA1,ICAM,ICAN,XCPF,YCPF,XCQF,YCQF,
     +                                                  I,J,ICAF,IAID)
              IF (ICFELL('CPCICA',12).NE.0) RETURN
            END IF
C
          END DO
C
        END DO
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPCLAM (ZDAT,RWRK,IWRK,IAMA)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*),IAMA(*)
C
C This routine adds contour lines to an area map.
C
C ZDAT is the user's data array.
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 CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Declare the common block that holds the clipping-window parameters
C for the routine CPWLAM.
C
        COMMON /CPWCMN/ XMIN,XMAX,YMIN,YMAX
C
C Define a couple of little workspace arrays required by CPTROE.
C
        DIMENSION RWKL(12),RWKR(12)
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPCLAM - 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 ('CPCLAM - 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('CPCLAM',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 CPPKCL (ZDAT,RWRK,IWRK)
          IF (ICFELL('CPCLAM',4).NE.0) RETURN
        END IF
C
C Get indices for the contour levels in ascending order.
C
        IF (NCLV.GT.0) CALL CPSORT (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 CPGRWS (RWRK,1,10,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CPCLAM',5).NE.0) RETURN
        CALL SET (XVPL,XVPR,YVPB,YVPT,XVPL,XVPR,YVPB,YVPT,1)
        IF (ICFELL('CPCLAM',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.  Also, as of
C 06/04/91, the area identifier on the inside of the viewport is set
C to zero, rather than to a value associated with a contour level.
C (And, as of 8/24/04, I'm pinching in 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('CPCLAM',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('CPCLAM',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('CPCLAM',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('CPCLAM',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
C There are two ways to trace these edges, depending on whether the
C user-supplied CPMPXY will do the inverse transformation or not.  By
C convention, if CPMPXY is called with its first argument equal to zero
C and its second argument equal to the real equivalent of a particular
C mapping index, the third argument will be returned as a 0. if neither
C mapping is defined, as a 1. if only the forward mapping is defined,
C as a 2. if only the inverse mapping is defined, and as a 3. if both
C the forward and the inverse mappings are defined.  Find out if the
C inverse mapping is available.
C
          TST1=REAL(IMPF)
          TST2=0.
C
          CALL HLUCPMPXY (0,TST1,TST2,TST3,TST4)
          IF (ICFELL('CPCLAM',11).NE.0) RETURN
C
          IF (TST2.NE.2..AND.TST2.NE.3.)
C
C CPMPXY will not do the inverse transformation.  We do the best we can.
C
            IJMP=0
            IAIC=0
C
            LOOP
              CALL CPTREV (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK)
              IF (ICFELL('CPCLAM',12).NE.0) RETURN
              EXIT IF (IJMP.EQ.0)
              IF (MIRO.EQ.0)
                CALL AREDAM (IAMA,RWRK(IRW1+1),RWRK(IRW2+1),NRWK,IGCL,
     +                                                IAIA($NCP3$),IAIC)
                IF (ICFELL('CPCLAM',13).NE.0) RETURN
              ELSE
                CALL AREDAM (IAMA,RWRK(IRW1+1),RWRK(IRW2+1),NRWK,IGCL,
     +                                                IAIC,IAIA($NCP3$))
                IF (ICFELL('CPCLAM',14).NE.0) RETURN
              END IF
            END LOOP
C
C CPMPXY will do the inverse transformation.  We use it to generate the
C desired edges.  Note that mirror imaging, which can affect the use of
C coordinates returned by all of the other edge-tracing routines, does
C not affect the use of coordinates returned by CPTRVE.
C
          ELSE
C
            XMIN=XVPL
            XMAX=XVPR
            YMIN=YVPB
            YMAX=YVPT
C
            IJMP=0
            IAIC=0
C
            LOOP
              CALL CPTRVE (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK)
              IF (ICFELL('CPCLAM',15).NE.0) RETURN
              EXIT IF (IJMP.EQ.0)
              DO (I=1,NRWK)
                RWRK(IRW1+I)=CUFX(RWRK(IRW1+I))
                IF (ICFELL('CPCLAM',16).NE.0) RETURN
                RWRK(IRW2+I)=CUFY(RWRK(IRW2+I))
                IF (ICFELL('CPCLAM',17).NE.0) RETURN
              END DO
              CALL CPTROE (RWRK(IRW1+1),RWRK(IRW2+1),NRWK,+.0005,RWKL,
     +                               IOCF,IAMA,IGCL,IAIA($NCP3$),IAIC)
              IF (ICFELL('CPCLAM',18).NE.0) RETURN
              CALL CPTROE (RWRK(IRW1+1),RWRK(IRW2+1),NRWK,-.0005,RWKR,
     +                               IOCF,IAMA,IGCL,IAIA($NCP3$),IAIC)
              IF (ICFELL('CPCLAM',19).NE.0) RETURN
            END LOOP
C
          END IF
C
        END IF
C
C Add the edge of the grid.
C
        IJMP=0
        IAIC=0
C
        LOOP
          CALL CPTREG (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK)
          IF (ICFELL('CPCLAM',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('CPCLAM',21).NE.0) RETURN
          ELSE
            CALL AREDAM (IAMA,RWRK(IRW1+1),RWRK(IRW2+1),NRWK,IGCL,
     +                                                IAIA($NCP1$),IAIC)
            IF (ICFELL('CPCLAM',22).NE.0) RETURN
          END IF
        END LOOP
C
C Add edges of areas filled with special values.
C
        IJMP=0
        IAIC=0
C
        LOOP
          CALL CPTRES (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK,0)
          IF (ICFELL('CPCLAM',23).NE.0) RETURN
          EXIT IF (IJMP.EQ.0)
          IF (MIRO.EQ.0)
            CALL AREDAM (IAMA,RWRK(IRW1+1),RWRK(IRW2+1),NRWK,IGCL,
     +                                                IAIA($NCP2$),IAIC)
            IF (ICFELL('CPCLAM',24).NE.0) RETURN
          ELSE
            CALL AREDAM (IAMA,RWRK(IRW1+1),RWRK(IRW2+1),NRWK,IGCL,
     +                                                IAIC,IAIA($NCP2$))
            IF (ICFELL('CPCLAM',25).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.ZMIN.AND.CLEV(ICLV).LT.ZMAX)
C
                JAIA=IAIA(ICLV)
                JAIB=IAIB(ICLV)
C
                DO (J=I+1,NCLV)
                  JCLV=ICLP(J)
                  IF (CLEV(JCLV).NE.CLEV(ICLV)) GO TO 105
                  IF (IAIA(JCLV).NE.0)
                    IF (JAIA.NE.0.AND.JAIA.NE.IAIA(JCLV))
                      CALL SETER ('CPCLAM - 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 ('CPCLAM - CONTRADICTORY AREA-IDENTIFIE
     +R INFORMATION',27,1)
                      RETURN
                    END IF
                    JAIB=IAIB(JCLV)
                  END IF
                END DO
C
  105           IF (JAIA.NE.0.OR.JAIB.NE.0)
C
                  IJMP=0
C
                  LOOP
                    CALL CPTRCL (ZDAT,RWRK,IWRK,CLEV(ICLV),IJMP,
     +                                           IRW1,IRW2,NRWK)
                    IF (ICFELL('CPCLAM',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('CPCLAM',29).NE.0) RETURN
                    ELSE
                      CALL AREDAM (IAMA,RWRK(IRW1+1),RWRK(IRW2+1),NRWK,
     +                                                   IGCL,JAIA,JAIB)
                      IF (ICFELL('CPCLAM',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 CPCLDM (ZDAT,RWRK,IWRK,IAMA,RTPL)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*),IAMA(*)
C
C This routine draws contour lines masked by an existing area map.
C
C ZDAT is the user's data array.
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 CONPACK common blocks.
C
.CALL CPCOMN,/$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('CPCLDM - 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 ('CPCLDM - 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('CPCLDM',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 CPPKCL (ZDAT,RWRK,IWRK)
          IF (ICFELL('CPCLDM',4).NE.0) RETURN
        END IF
C
C Get indices for the contour levels in ascending order.
C
        IF (NCLV.GT.0) CALL CPSORT (CLEV,NCLV,ICLP)
C
C Get real and integer workspaces to use in the calls to ARDRLN.
C
        CALL CPGRWS (RWRK,2,2*LRWM,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CPCLDM',5).NE.0) RETURN
C
        CALL CPGIWS (IWRK,2,2*LIWM,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CPCLDM',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('CPCLDM',7).NE.0) RETURN
          CALL DPGETC ('CRG',CHRG)
          IF (ICFELL('CPCLDM',8).NE.0) RETURN
          CALL DPGETC ('CRS',CHRS)
          IF (ICFELL('CPCLDM',9).NE.0) RETURN
          CALL DPGETI ('DPL',IDPL)
          IF (ICFELL('CPCLDM',10).NE.0) RETURN
          CALL DPGETI ('DPS',IDPS)
          IF (ICFELL('CPCLDM',11).NE.0) RETURN
          CALL DPGETC ('DPT',CHDP)
          IF (ICFELL('CPCLDM',12).NE.0) RETURN
          CALL DPGETR ('TCS',RTCS)
          IF (ICFELL('CPCLDM',13).NE.0) RETURN
          CALL DPGETR ('WOC',RWOC)
          IF (ICFELL('CPCLDM',14).NE.0) RETURN
          CALL DPGETR ('WOG',RWOG)
          IF (ICFELL('CPCLDM',15).NE.0) RETURN
          CALL DPGETR ('WOS',RWOS)
          IF (ICFELL('CPCLDM',16).NE.0) RETURN
C
          CALL DPSETI ('DPS',0)
          IF (ICFELL('CPCLDM',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('CPCLDM',18).NE.0) RETURN
          CALL DPSETR ('TCS',-1.)
          IF (ICFELL('CPCLDM',19).NE.0) RETURN
          CALL DPSETR ('WOC',CHWM*WOCH*(XVPR-XVPL))
          IF (ICFELL('CPCLDM',20).NE.0) RETURN
          CALL DPSETR ('WOG',CHWM*WODA*(XVPR-XVPL))
          IF (ICFELL('CPCLDM',21).NE.0) RETURN
          CALL DPSETR ('WOS',CHWM*WODA*(XVPR-XVPL))
          IF (ICFELL('CPCLDM',22).NE.0) RETURN
C
        ELSE IF (IDUF.GT.0)
C
          CALL GETSI (IP2X,IP2Y)
          IF (ICFELL('CPCLDM',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('CPCLDM',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 CPCFLB (1,RWRK,IWRK)
          IF (ICFELL('CPCLDM',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 CPPKLB (ZDAT,RWRK,IWRK)
            IF (ICFELL('CPCLDM',26).NE.0) RETURN
            CALL CPSTLS (ZDAT,RWRK,IWRK)
            IF (ICFELL('CPCLDM',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.ZMIN.AND.CLEV(ICLV).LT.ZMAX)
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('CPCLDM',28).NE.0) RETURN
                ELSE IF (IDUF.GT.0)
                  CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
                  IF (ICFELL('CPCLDM',29).NE.0) RETURN
                END IF
C
                INVOKE (CALL-CPTRCL)
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('CPCLDM',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('CPCLDM',31).NE.0) RETURN
                  END IF
                  INVOKE (CALL-CPTRCL)
                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('CPCLDM',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('CPCLDM',33).NE.0) RETURN
                    END IF
                  ELSE
                    IF (IDUF.LT.0)
                      CALL DPSETC ('DPT',CLDP(ICLV)(1:LCLD))
                      IF (ICFELL('CPCLDM',34).NE.0) RETURN
                    ELSE
                      CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
                      IF (ICFELL('CPCLDM',35).NE.0) RETURN
                    END IF
                  END IF
                END IF
C
                INVOKE (CALL-CPTRCL)
C
              END IF
C
            END IF
C
          END FOR
C
        END IF
C
C Draw boundaries for areas filled with special values.
C
        IF (ICLU($NCP2$).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('CPCLDM',36).NE.0) RETURN
            ELSE
              CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
              IF (ICFELL('CPCLDM',37).NE.0) RETURN
            END IF
          END IF
          INVOKE (SET-LINE-COLOR-AND-WIDTH)
          IJMP=0
          IAIC=-9
          LOOP
            CALL CPTRES (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK,
     +                                            ICLU($NCP2$)/2)
            IF (ICFELL('CPCLDM',38).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('CPCLDM',39).NE.0) RETURN
          END LOOP
          INVOKE (RESET-LINE-COLOR-AND-WIDTH)
        END IF
C
C Draw boundaries for areas which are invisible.
C
        IF (ICLU($NCP3$).NE.0.AND.IMPF.NE.0.AND.OORV.NE.0.)
          TST1=REAL(IMPF)
          TST2=0.
          CALL HLUCPMPXY (0,TST1,TST2,TST3,TST4)
          IF (ICFELL('CPCLDM',40).NE.0) RETURN
          ICLV=$NCP3$
          IF (IDUF.NE.0)
            INVOKE (FIND-LENGTH-OF-DASH-PATTERN)
            IF (IDUF.LT.0)
              CALL DPSETC ('DPT',CLDP(ICLV)(1:LCLD))
              IF (ICFELL('CPCLDM',41).NE.0) RETURN
            ELSE
              CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
              IF (ICFELL('CPCLDM',42).NE.0) RETURN
            END IF
          END IF
          INVOKE (SET-LINE-COLOR-AND-WIDTH)
          IJMP=0
          IAIC=-9
          LOOP
            IF (TST2.NE.2..AND.TST2.NE.3.)
              CALL CPTREV (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK)
              IF (ICFELL('CPCLDM',43).NE.0) RETURN
            ELSE
              CALL CPTRVE (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK)
              IF (ICFELL('CPCLDM',44).NE.0) RETURN
            END IF
            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('CPCLDM',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('CPCLDM',46).NE.0) RETURN
            ELSE
              CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
              IF (ICFELL('CPCLDM',47).NE.0) RETURN
            END IF
          END IF
          INVOKE (SET-LINE-COLOR-AND-WIDTH)
          IJMP=0
          IAIC=-9
          LOOP
            CALL CPTREG (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK)
            IF (ICFELL('CPCLDM',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('CPCLDM',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('CPCLDM',50).NE.0) RETURN
          CALL DPSETC ('DPT',CHDP(1:IDPL))
          IF (ICFELL('CPCLDM',51).NE.0) RETURN
          CALL DPSETR ('TCS',RTCS)
          IF (ICFELL('CPCLDM',52).NE.0) RETURN
          CALL DPSETR ('WOC',RWOC)
          IF (ICFELL('CPCLDM',53).NE.0) RETURN
          CALL DPSETR ('WOG',RWOG)
          IF (ICFELL('CPCLDM',54).NE.0) RETURN
          CALL DPSETR ('WOS',RWOS)
          IF (ICFELL('CPCLDM',55).NE.0) RETURN
C
        ELSE IF (IDUF.GT.0)
C
          CALL DASHDC ('$$$$$$$$$$$$$$$$',ILDA,ILCH)
          IF (ICFELL('CPCLDM',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 CPTRCL to draw the contour
C line at a given level.  The user-change routine is called before
C and after the calls to CPTRCL.
C
        BLOCK (CALL-CPTRCL)
          INVOKE (SET-LINE-COLOR-AND-WIDTH)
          IJMP=0
          LOOP
            CALL CPTRCL (ZDAT,RWRK,IWRK,CLEV(ICLV),IJMP,IRW1,IRW2,NRWK)
            IF (ICFELL('CPCLDM',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('CPCLDM',58).NE.0) RETURN
            IF (IHCF.NE.0)
              CALL CPHCHM (RWRK,IRW1,IRW2,NRWK,IAMA,IWRK,RTPL)
              IF (ICFELL('CPCLDM',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('CPCLDM',60).NE.0) RETURN
          JCCL=ICCL(ICLV)
          IF (JCCL.GE.0)
            CALL GQPLCI (IGER,ISLC)
            IF (IGER.NE.0)
              CALL SETER ('CPCLDM - ERROR EXIT FROM GQPLCI',61,1)
              RETURN
            END IF
            CALL GQTXCI (IGER,ISTC)
            IF (IGER.NE.0)
              CALL SETER ('CPCLDM - 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 ('CPCLDM - ERROR EXIT FROM GQLWSC',63,1)
              RETURN
            END IF
            CALL GSLWSC (CLWS)
          END IF
          IPAI=ICLV
          IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
          CALL HLUCPCHCL (+1)
          IF (ICFELL('CPCLDM',64).NE.0) RETURN
        END BLOCK
C
        BLOCK (RESET-LINE-COLOR-AND-WIDTH)
          CALL PLOTIF (0.,0.,2)
          IF (ICFELL('CPCLDM',65).NE.0) RETURN
          IPAI=ICLV
          IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
          CALL HLUCPCHCL (-1)
          IF (ICFELL('CPCLDM',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 CPCLDR (ZDAT,RWRK,IWRK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C This routine draws contour lines.
C
C ZDAT is the user's data array.
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 CONPACK common blocks.
C
.CALL CPCOMN,/$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('CPCLDR - 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 ('CPCLDR - 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('CPCLDR',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 CPPKCL (ZDAT,RWRK,IWRK)
          IF (ICFELL('CPCLDR',4).NE.0) RETURN
        END IF
C
C Get indices for the contour levels in ascending order.
C
        IF (NCLV.GT.0) CALL CPSORT (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('CPCLDR',5).NE.0) RETURN
          CALL DPGETC ('CRG',CHRG)
          IF (ICFELL('CPCLDR',6).NE.0) RETURN
          CALL DPGETC ('CRS',CHRS)
          IF (ICFELL('CPCLDR',7).NE.0) RETURN
          CALL DPGETI ('DPL',IDPL)
          IF (ICFELL('CPCLDR',8).NE.0) RETURN
          CALL DPGETI ('DPS',IDPS)
          IF (ICFELL('CPCLDR',9).NE.0) RETURN
          CALL DPGETC ('DPT',CHDP)
          IF (ICFELL('CPCLDR',10).NE.0) RETURN
          CALL DPGETR ('TCS',RTCS)
          IF (ICFELL('CPCLDR',11).NE.0) RETURN
          CALL DPGETR ('WOC',RWOC)
          IF (ICFELL('CPCLDR',12).NE.0) RETURN
          CALL DPGETR ('WOG',RWOG)
          IF (ICFELL('CPCLDR',13).NE.0) RETURN
          CALL DPGETR ('WOS',RWOS)
          IF (ICFELL('CPCLDR',14).NE.0) RETURN
C
          CALL DPSETI ('DPS',0)
          IF (ICFELL('CPCLDR',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('CPCLDR',16).NE.0) RETURN
          CALL DPSETR ('TCS',-1.)
          IF (ICFELL('CPCLDR',17).NE.0) RETURN
          CALL DPSETR ('WOC',CHWM*WOCH*(XVPR-XVPL))
          IF (ICFELL('CPCLDR',18).NE.0) RETURN
          CALL DPSETR ('WOG',CHWM*WODA*(XVPR-XVPL))
          IF (ICFELL('CPCLDR',19).NE.0) RETURN
          CALL DPSETR ('WOS',CHWM*WODA*(XVPR-XVPL))
          IF (ICFELL('CPCLDR',20).NE.0) RETURN
C
        ELSE IF (IDUF.GT.0)
C
          CALL GETSI (IP2X,IP2Y)
          IF (ICFELL('CPCLDR',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('CPCLDR',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 CPCFLB (1,RWRK,IWRK)
          IF (ICFELL('CPCLDR',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 CPPKLB (ZDAT,RWRK,IWRK)
            IF (ICFELL('CPCLDR',24).NE.0) RETURN
            CALL CPSTLS (ZDAT,RWRK,IWRK)
            IF (ICFELL('CPCLDR',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.ZMIN.AND.CLEV(ICLV).LT.ZMAX)
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('CPCLDR',26).NE.0) RETURN
                ELSE IF (IDUF.GT.0)
                  CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
                  IF (ICFELL('CPCLDR',27).NE.0) RETURN
                END IF
C
                INVOKE (CALL-CPTRCL)
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('CPCLDR',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('CPCLDR',29).NE.0) RETURN
                  END IF
                  INVOKE (CALL-CPTRCL)
                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('CPCLDR',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('CPCLDR',31).NE.0) RETURN
                    END IF
                  ELSE
                    IF (IDUF.LT.0)
                      CALL DPSETC ('DPT',CLDP(ICLV)(1:LCLD))
                      IF (ICFELL('CPCLDR',32).NE.0) RETURN
                    ELSE
                      CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
                      IF (ICFELL('CPCLDR',33).NE.0) RETURN
                    END IF
                  END IF
                END IF
C
                INVOKE (CALL-CPTRCL)
C
              END IF
C
            END IF
C
          END FOR
C
        END IF
C
C Draw boundaries for areas filled with special values.
C
        IF (ICLU($NCP2$).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('CPCLDR',34).NE.0) RETURN
            ELSE
              CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
              IF (ICFELL('CPCLDR',35).NE.0) RETURN
            END IF
          END IF
          INVOKE (SET-LINE-COLOR-AND-WIDTH)
          IJMP=0
          IAIC=-9
          LOOP
            CALL CPTRES (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK,
     +                                            ICLU($NCP2$)/2)
            IF (ICFELL('CPCLDR',36).NE.0) RETURN
            EXIT IF (IJMP.EQ.0)
            CALL CPDRSG (RWRK,IRW1,IRW2,NRWK)
            IF (ICFELL('CPCLDR',37).NE.0) RETURN
          END LOOP
          INVOKE (RESET-LINE-COLOR-AND-WIDTH)
        END IF
C
C Draw boundaries for areas which are invisible.
C
        IF (ICLU($NCP3$).NE.0.AND.IMPF.NE.0.AND.OORV.NE.0.)
          TST1=REAL(IMPF)
          TST2=0.
          CALL HLUCPMPXY (0,TST1,TST2,TST3,TST4)
          IF (ICFELL('CPCLDR',38).NE.0) RETURN
          ICLV=$NCP3$
          IF (IDUF.NE.0)
            INVOKE (FIND-LENGTH-OF-DASH-PATTERN)
            IF (IDUF.LT.0)
              CALL DPSETC ('DPT',CLDP(ICLV)(1:LCLD))
              IF (ICFELL('CPCLDR',39).NE.0) RETURN
            ELSE
              CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
              IF (ICFELL('CPCLDR',40).NE.0) RETURN
            END IF
          END IF
          INVOKE (SET-LINE-COLOR-AND-WIDTH)
          IJMP=0
          IAIC=-9
          LOOP
            IF (TST2.NE.2..AND.TST2.NE.3.)
              CALL CPTREV (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK)
              IF (ICFELL('CPCLDR',41).NE.0) RETURN
            ELSE
              CALL CPTRVE (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK)
              IF (ICFELL('CPCLDR',42).NE.0) RETURN
            END IF
            EXIT IF (IJMP.EQ.0)
            CALL CPDRSG (RWRK,IRW1,IRW2,NRWK)
            IF (ICFELL('CPCLDR',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('CPCLDR',44).NE.0) RETURN
            ELSE
              CALL DASHDC (CLDP(ICLV)(1:LCLD),ILDA,ILCH)
              IF (ICFELL('CPCLDR',45).NE.0) RETURN
            END IF
          END IF
          INVOKE (SET-LINE-COLOR-AND-WIDTH)
          IJMP=0
          IAIC=-9
          LOOP
            CALL CPTREG (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK)
            IF (ICFELL('CPCLDR',46).NE.0) RETURN
            EXIT IF (IJMP.EQ.0)
            CALL CPDRSG (RWRK,IRW1,IRW2,NRWK)
            IF (ICFELL('CPCLDR',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('CPCLDR',48).NE.0) RETURN
          CALL DPSETC ('DPT',CHDP(1:IDPL))
          IF (ICFELL('CPCLDR',49).NE.0) RETURN
          CALL DPSETR ('TCS',RTCS)
          IF (ICFELL('CPCLDR',50).NE.0) RETURN
          CALL DPSETR ('WOC',RWOC)
          IF (ICFELL('CPCLDR',51).NE.0) RETURN
          CALL DPSETR ('WOG',RWOG)
          IF (ICFELL('CPCLDR',52).NE.0) RETURN
          CALL DPSETR ('WOS',RWOS)
          IF (ICFELL('CPCLDR',53).NE.0) RETURN
C
        ELSE IF (IDUF.GT.0)
C
          CALL DASHDC ('$$$$$$$$$$$$$$$$',ILDA,ILCH)
          IF (ICFELL('CPCLDR',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 CPTRCL to draw the contour
C line at a given level.  The user-change routine is called before
C and after the calls to CPTRCL.
C
        BLOCK (CALL-CPTRCL)
          INVOKE (SET-LINE-COLOR-AND-WIDTH)
          IJMP=0
          LOOP
            CALL CPTRCL (ZDAT,RWRK,IWRK,CLEV(ICLV),IJMP,IRW1,IRW2,NRWK)
            IF (ICFELL('CPCLDR',55).NE.0) RETURN
            EXIT IF (IJMP.EQ.0)
            CALL CPDRSG (RWRK,IRW1,IRW2,NRWK)
            IF (ICFELL('CPCLDR',56).NE.0) RETURN
            IF (IHCF.NE.0)
              CALL CPHCHR (RWRK,IRW1,IRW2,NRWK)
              IF (ICFELL('CPCLDR',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('CPCLDR',58).NE.0) RETURN
          JCCL=ICCL(ICLV)
          IF (JCCL.GE.0)
            CALL GQPLCI (IGER,ISLC)
            IF (IGER.NE.0)
              CALL SETER ('CPCLDR - ERROR EXIT FROM GQPLCI',59,1)
              RETURN
            END IF
            CALL GQTXCI (IGER,ISTC)
            IF (IGER.NE.0)
              CALL SETER ('CPCLDR - 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 ('CPCLDR - ERROR EXIT FROM GQLWSC',61,1)
              RETURN
            END IF
            CALL GSLWSC (CLWS)
          END IF
          IPAI=ICLV
          IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
          CALL HLUCPCHCL (+1)
          IF (ICFELL('CPCLDR',62).NE.0) RETURN
        END BLOCK
C
        BLOCK (RESET-LINE-COLOR-AND-WIDTH)
          CALL PLOTIF (0.,0.,2)
          IF (ICFELL('CPCLDR',63).NE.0) RETURN
          IPAI=ICLV
          IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
          CALL HLUCPCHCL (-1)
          IF (ICFELL('CPCLDR',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 CPCLTR (ZDAT,RWRK,IWRK,CLVL,IJMP,IRW1,IRW2,NRWK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C This routine just provides a user interface to the internal routine
C CPTRCL, which traces the contour lines at a specified level.
C
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPCLTR - 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 ('CPCLTR - 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('CPCLTR',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 CPTRCL (ZDAT,RWRK,IWRK,CLVL,IJMP,IRW1,IRW2,NRWK)
        IF (ICFELL('CPCLTR',4).NE.0) RETURN
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPCNRC (ZDAT,KZDT,MZDT,NZDT,FLOW,FHGH,FINC,KSET,NHGH,
     +                   NDSH)
C
        DIMENSION ZDAT(KZDT,*)
C
C This routine simulates the old routine CONREC.
C
C Define some needed dimensions.
C
        PARAMETER (LRWK=5000,LIWK=2000,LAMA=12000,LOCV=10)
C
C Define required workspace arrays.
C
        DIMENSION RWRK(LRWK),IWRK(LIWK),IAMA(LAMA)
C
C Define a character variable to use for point-value labelling.
C
        CHARACTER*(LOCV) CROZ
C
C Declare the contour-line drawing routine.
C
        EXTERNAL CPDRPL
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPCNRC - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Copy the argument KSET to an internal variable NSET, limiting it to
C the range from -1 to +1.  Note: if the absolute value of KSET is
C greater than 1, saving and restoring of the SET call is not done.
C
        NSET=MOD(MOD(KSET+1,3)+3,3)-1
C
C If the absolute value of KSET is less than or equal to 1, save the
C current SET call.
C
        IF (ABS(KSET).LE.1)
          CALL GETSET (SVPL,SVPR,SVPB,SVPT,SWDL,SWDR,SWDB,SWDT,LLFS)
          IF (ICFELL('CPCNRC',2).NE.0) RETURN
        END IF
C
C Arrange for the selection of contour levels as desired by the user.
C
        CALL CPSETR ('CMN - CONTOUR MINIMUM',1.)
        IF (ICFELL('CPCNRC',3).NE.0) RETURN
        CALL CPSETR ('CMX - CONTOUR MAXIMUM',0.)
        IF (ICFELL('CPCNRC',4).NE.0) RETURN
C
        IF (FINC.LT.0.)
          CALL CPSETI ('CLS - CONTOUR LEVEL SELECTOR',MAX(1,INT(-FINC)))
          IF (ICFELL('CPCNRC',5).NE.0) RETURN
          CALL CPSETR ('CIS - CONTOUR INTERVAL SPECIFIER',0.)
          IF (ICFELL('CPCNRC',6).NE.0) RETURN
        ELSE IF (FINC.EQ.0.)
          CALL CPSETI ('CLS - CONTOUR LEVEL SELECTOR',16)
          IF (ICFELL('CPCNRC',7).NE.0) RETURN
          CALL CPSETR ('CIS - CONTOUR INTERVAL SPECIFIER',0.)
          IF (ICFELL('CPCNRC',8).NE.0) RETURN
        ELSE
          CALL CPSETI ('CLS - CONTOUR LEVEL SELECTOR',1)
          IF (ICFELL('CPCNRC',9).NE.0) RETURN
          CALL CPSETR ('CIS - CONTOUR INTERVAL SPECIFIER',FINC)
          IF (ICFELL('CPCNRC',10).NE.0) RETURN
          IF (FLOW.LT.FHGH)
            CALL CPSETR ('CMN - CONTOUR MINIMUM',FLOW)
            IF (ICFELL('CPCNRC',11).NE.0) RETURN
            CALL CPSETR ('CMX - CONTOUR MAXIMUM',FHGH)
            IF (ICFELL('CPCNRC',12).NE.0) RETURN
          END IF
        END IF
C
C Set up the desired mapping of output onto the plotter frame.
C
        IF (NSET.LT.0)
          CALL CPSETI ('SET - DO-SET-CALL FLAG',1)
          IF (ICFELL('CPCNRC',13).NE.0) RETURN
          CALL GETSET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
          IF (ICFELL('CPCNRC',14).NE.0) RETURN
          CALL CPSETR ('VPL - VIEWPORT LEFT EDGE',XVPL)
          IF (ICFELL('CPCNRC',15).NE.0) RETURN
          CALL CPSETR ('VPR - VIEWPORT RIGHT EDGE',XVPR)
          IF (ICFELL('CPCNRC',16).NE.0) RETURN
          CALL CPSETR ('VPB - VIEWPORT BOTTOM EDGE',YVPB)
          IF (ICFELL('CPCNRC',17).NE.0) RETURN
          CALL CPSETR ('VPT - VIEWPORT TOP EDGE',YVPT)
          IF (ICFELL('CPCNRC',18).NE.0) RETURN
          CALL CPSETI ('VPS - VIEWPORT SHAPE',0)
          IF (ICFELL('CPCNRC',19).NE.0) RETURN
        ELSE IF (NSET.EQ.0)
          CALL CPSETI ('SET - DO-SET-CALL FLAG',1)
          IF (ICFELL('CPCNRC',20).NE.0) RETURN
          CALL CPSETR ('VPL - VIEWPORT LEFT EDGE',.05)
          IF (ICFELL('CPCNRC',21).NE.0) RETURN
          CALL CPSETR ('VPR - VIEWPORT RIGHT EDGE',.95)
          IF (ICFELL('CPCNRC',22).NE.0) RETURN
          CALL CPSETR ('VPB - VIEWPORT BOTTOM EDGE',.05)
          IF (ICFELL('CPCNRC',23).NE.0) RETURN
          CALL CPSETR ('VPT - VIEWPORT TOP EDGE',.95)
          IF (ICFELL('CPCNRC',24).NE.0) RETURN
          CALL CPSETI ('VPS - VIEWPORT SHAPE',4)
          IF (ICFELL('CPCNRC',25).NE.0) RETURN
        ELSE
          CALL CPSETI ('SET - DO-SET-CALL FLAG',0)
          IF (ICFELL('CPCNRC',26).NE.0) RETURN
        END IF
C
C Decide what dash pattern to use.
C
        IDSH=ABS(NDSH)
        IF (IDSH.EQ.0.OR.IDSH.EQ.1.OR.IDSH.EQ.1023)
          IDSH=IOR(ISHIFT(32767,1),1)
        ELSE
          IDSH=IOR(ISHIFT(IDSH,6),IAND(ISHIFT(IDSH,-4),63))
        END IF
C
C Decide whether to label highs and lows or not.
C
        IF (NHGH.EQ.0)
          CALL CPSETC ('HLT - HIGH/LOW LABEL TEXT',
     +                 'H:B:$ZDV$:E:''L:B:$ZDV$:E:')
          IF (ICFELL('CPCNRC',27).NE.0) RETURN
        ELSE
          CALL CPSETC ('HLT - HIGH/LOW LABEL TEXT',' ')
          IF (ICFELL('CPCNRC',28).NE.0) RETURN
        END IF
C
C Initialize CONPACK and give it all array dimensions.
C
        CALL CPRECT (ZDAT,KZDT,MZDT,NZDT,RWRK,LRWK,IWRK,LIWK)
        IF (ICFELL('CPCNRC',29).NE.0) RETURN
C
C If the field was constant, skip some of the following code.
C
        CALL CPGETI ('CFF - CONSTANT FIELD FLAG',ICFF)
        IF (ICFELL('CPCNRC',30).NE.0) RETURN
C
        IF (ICFF.EQ.0)
C
C Pick contour levels.
C
          CALL CPPKCL (ZDAT,RWRK,IWRK)
          IF (ICFELL('CPCNRC',31).NE.0) RETURN
C
C Retrieve the contour levels selected, one at a time.  Discard levels
C which are outside the range, if any, specified by the user-supplied
C values of FLOW and FHGH, and move the parameters for all remaining
C levels to the beginning of the parameter arrays.  Set dash patterns
C for all levels.  The value of 'CIU' must be saved for possible
C restoration if it gets clobbered as a side effect of setting contour
C level 1.
C
          CALL CPGETR ('CIU - CONTOUR INTERVAL USED',CINU)
          IF (ICFELL('CPCNRC',32).NE.0) RETURN
C
          CALL CPGETI ('NCL - NUMBER OF CONTOUR LEVELS',NCLO)
          IF (ICFELL('CPCNRC',33).NE.0) RETURN
          NCLN=0
C
          DO (ICLO=1,NCLO)
            CALL CPSETI ('PAI - PARAMETER ARRAY INDEX',ICLO)
            IF (ICFELL('CPCNRC',34).NE.0) RETURN
            CALL CPGETR ('CLV - CONTOUR LEVEL',CLEV)
            IF (ICFELL('CPCNRC',35).NE.0) RETURN
            IF (FLOW.GE.FHGH.OR.(CLEV.GE.FLOW-.001*CINU.AND.
     +                           CLEV.LE.FHGH+.001*CINU))
              NCLN=NCLN+1
              IF (NCLN.NE.ICLO)
                CALL CPGETI ('CLU - CONTOUR LEVEL USE FLAG',ICLU)
                IF (ICFELL('CPCNRC',36).NE.0) RETURN
                CALL CPSETI ('PAI - PARAMETER ARRAY INDEX',NCLN)
                IF (ICFELL('CPCNRC',37).NE.0) RETURN
                CALL CPSETR ('CLV - CONTOUR LEVEL',CLEV)
                IF (ICFELL('CPCNRC',38).NE.0) RETURN
                CALL CPSETI ('CLU - CONTOUR LEVEL USE FLAG',ICLU)
                IF (ICFELL('CPCNRC',39).NE.0) RETURN
                CALL CPSETI ('AIA - AREA IDENTIFIER ABOVE LEVEL',NCLN+1)
                IF (ICFELL('CPCNRC',40).NE.0) RETURN
                CALL CPSETI ('AIB - AREA IDENTIFIER BELOW LEVEL',NCLN)
                IF (ICFELL('CPCNRC',41).NE.0) RETURN
                CALL CPSETI ('CLC - CONTOUR LINE COLOR INDEX',-1)
                IF (ICFELL('CPCNRC',42).NE.0) RETURN
                CALL CPSETC ('CLD - CONTOUR LINE DASH PATTERN',
     +                                               '$$$$$$$$$$$$$$$$')
                IF (ICFELL('CPCNRC',43).NE.0) RETURN
                CALL CPSETI ('CLL - CONTOUR LINE LINE WIDTH',-1)
                IF (ICFELL('CPCNRC',44).NE.0) RETURN
                CALL CPSETI ('LLC - LINE LABEL COLOR INDEX',-1)
                IF (ICFELL('CPCNRC',45).NE.0) RETURN
                CALL CPSETC ('LLT - LINE LABEL TEXT',' ')
                IF (ICFELL('CPCNRC',46).NE.0) RETURN
              END IF
            END IF
            IF (NDSH.GT.0.OR.(NDSH.LT.0..AND.CLEV.LT.0.))
              CALL CPSETI ('CLD - CONTOUR LINE DASH PATTERN',IDSH)
              IF (ICFELL('CPCNRC',47).NE.0) RETURN
            END IF
          END DO
C
C If the number of contour levels decreased, reset parameters affected.
C
          IF (NCLN.LT.NCLO)
            CALL CPSETI ('NCL - NUMBER OF CONTOUR LEVELS',NCLN)
            IF (ICFELL('CPCNRC',48).NE.0) RETURN
            CALL CPSETR ('CIU - CONTOUR INTERVAL USED',CINU)
            IF (ICFELL('CPCNRC',49).NE.0) RETURN
          END IF
C
        END IF
C
C If requested, put out a simple background.
C
        IF (NSET.EQ.0)
          CALL CPBACK (ZDAT,RWRK,IWRK)
          IF (ICFELL('CPCNRC',50).NE.0) RETURN
        END IF
C
C See how the user has chosen to position contour levels.
C
        CALL CPGETI ('LLP - LINE LABEL POSITIONING FLAG',LLPF)
        IF (ICFELL('CPCNRC',51).NE.0) RETURN
C
C Draw the contour lines, masking them if necessary.
C
        IF (LLPF.LE.1)
          CALL CPCLDR (ZDAT,RWRK,IWRK)
          IF (ICFELL('CPCNRC',52).NE.0) RETURN
        ELSE
          CALL ARINAM (IAMA,LAMA)
          IF (ICFELL('CPCNRC',53).NE.0) RETURN
          CALL CPLBAM (ZDAT,RWRK,IWRK,IAMA)
          IF (ICFELL('CPCNRC',54).NE.0) RETURN
          CALL CPCLDM (ZDAT,RWRK,IWRK,IAMA,CPDRPL)
          IF (ICFELL('CPCNRC',55).NE.0) RETURN
        END IF
C
C Plot labels.
C
        CALL CPLBDR (ZDAT,RWRK,IWRK)
        IF (ICFELL('CPCNRC',56).NE.0) RETURN
C
C If requested, label every point on the grid.
C
        IF (NHGH.GT.0)
          CALL GETSET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
          IF (ICFELL('CPCNRC',57).NE.0) RETURN
          CALL CPGETR ('CWM - CHARACTER WIDTH MULTIPLIER',CHWM)
          IF (ICFELL('CPCNRC',58).NE.0) RETURN
          CALL CPGETR ('HLA - HIGH/LOW LABEL ANGLE',ANGD)
          IF (ICFELL('CPCNRC',59).NE.0) RETURN
          CALL CPGETR ('HLS - HIGH/LOW LABEL SIZE',SIZE)
          IF (ICFELL('CPCNRC',60).NE.0) RETURN
          CALL CPGETI ('MAP - MAPPING FLAG',IMAP)
          IF (ICFELL('CPCNRC',61).NE.0) RETURN
          CALL CPGETR ('ORV - OUT-OF-RANGE VALUE',ORVA)
          IF (ICFELL('CPCNRC',62).NE.0) RETURN
          CALL CPGETR ('SPV - SPECIAL VALUE',SPVA)
          IF (ICFELL('CPCNRC',63).NE.0) RETURN
          CALL CPGETR ('XC1 - X COORDINATE AT I = 1',XCA1)
          IF (ICFELL('CPCNRC',64).NE.0) RETURN
          CALL CPGETR ('XCM - X COORDINATE AT I = M',XCAM)
          IF (ICFELL('CPCNRC',65).NE.0) RETURN
          CALL CPGETR ('YC1 - Y COORDINATE AT J = 1',YCA1)
          IF (ICFELL('CPCNRC',66).NE.0) RETURN
          CALL CPGETR ('YCN - Y COORDINATE AT J = N',YCAN)
          IF (ICFELL('CPCNRC',67).NE.0) RETURN
          SIZE=(XVPR-XVPL)*CHWM*SIZE
          IF (XCA1.EQ.XCAM)
            XCA1=1.
            XCAM=REAL(MZDT)
          END IF
          IF (YCA1.EQ.YCAN)
            YCA1=1.
            YCAN=REAL(NZDT)
          END IF
          DO (J=1,NZDT)
            YPOS=YCA1+REAL(J-1)*(YCAN-YCA1)/REAL(NZDT-1)
            DO (I=1,MZDT)
              XPOS=XCA1+REAL(I-1)*(XCAM-XCA1)/REAL(MZDT-1)
              IF (SPVA.EQ.0..OR.ZDAT(I,J).NE.SPVA)
                CALL CPSETR ('ZDV - Z DATA VALUE',ZDAT(I,J))
                IF (ICFELL('CPCNRC',68).NE.0) RETURN
                CALL CPGETC ('ZDV - Z DATA VALUE',CROZ)
                IF (ICFELL('CPCNRC',69).NE.0) RETURN
                DO (K=LOCV,2,-1)
                  IF (CROZ(K:K).NE.' ')
                    LCRZ=K
                    GO TO 101
                  END IF
                END DO
                LCRZ=1
  101           IF (IMAP.EQ.0)
                  CALL PLCHHQ (XPOS,YPOS,CROZ(1:LCRZ),SIZE,ANGD,0.)
                  IF (ICFELL('CPCNRC',70).NE.0) RETURN
                ELSE
                  CALL HLUCPMPXY (IMAP,XPOS,YPOS,XMPD,YMPD)
                  IF (ICFELL('CPCNRC',71).NE.0) RETURN
                  IF (ORVA.EQ.0..OR.XMPD.NE.ORVA)
                    CALL PLCHHQ (XMPD,YMPD,CROZ(1:LCRZ),SIZE,ANGD,0.)
                    IF (ICFELL('CPCNRC',72).NE.0) RETURN
                  END IF
                END IF
              END IF
            END DO
          END DO
        END IF
C
C Done.  Restore the original SET call and return to the caller.
C
        IF (ABS(KSET).LE.1)
          CALL SET (SVPL,SVPR,SVPB,SVPT,SWDL,SWDR,SWDB,SWDT,LLFS)
          IF (ICFELL('CPCNRC',73).NE.0) RETURN
        END IF
C
        RETURN
C
      END


      SUBROUTINE CPDRPL (XCS,YCS,NCS,IAI,IAG,NAI)
C
        DIMENSION XCS(*),YCS(*),IAI(*),IAG(*)
C
C This version of CPDRPL 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 CONPACK common blocks.
C
.CALL CPCOMN,/$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('CPDRPL',1).NE.0) RETURN
          ELSE IF (IDUF.LT.0)
            CALL DPCURV (XCS,YCS,NCS)
            IF (ICFELL('CPDRPL',2).NE.0) RETURN
          ELSE
            CALL CURVED (XCS,YCS,NCS)
            IF (ICFELL('CPDRPL',3).NE.0) RETURN
          END IF
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPEZCT (ZDAT,MZDT,NZDT)
C
        DIMENSION ZDAT(MZDT,NZDT)
C
C This routine simulates the old routine EZCNTR.
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPEZCT - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Call CPCNRC to do the job.
C
        CALL CPCNRC (ZDAT,MZDT,MZDT,NZDT,0.,0.,0.,0,0,-682)
        IF (ICFELL('CPEZCT',2).NE.0) RETURN
C
C Advance the frame.
C
        CALL FRAME
        IF (ICFELL('CPEZCT',3).NE.0) RETURN
C
        RETURN
C
      END


      SUBROUTINE CPGETC (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 CPGETC.
C
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPGETC - 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)='CPGETC - 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)='CPGETC - 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.'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 IF (WHCH(1:3).EQ.'ZDU'.OR.WHCH(1:3).EQ.'zdu')
          CALL CPSBST ('$ZDVU$',CVAL,LCVL)
        ELSE IF (WHCH(1:3).EQ.'ZDV'.OR.WHCH(1:3).EQ.'zdv')
          CALL CPSBST ('$ZDV$',CVAL,LCVL)
        ELSE
          CTMB(1:36)='CPGETC - 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 CPGETI (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 CPGETI.
C
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPGETI - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Use CPGETR to retrieve the real value, fix it, and return it to the
C user.
C
        CALL CPGETR (WHCH,RVAL)
        IF (ICFELL('CPGETI',2).NE.0) RETURN
        IVAL=INT(RVAL)
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPGETR (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 CPGETR.
C
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPGETR - 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)='CPGETR - 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)='CPGETR - 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.'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.'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.'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.'HLX'.OR.WHCH(1:3).EQ.'hlx')
          RVAL=REAL(IHLX)
        ELSE IF (WHCH(1:3).EQ.'HLY'.OR.WHCH(1:3).EQ.'hly')
          RVAL=REAL(IHLY)
        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.'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.'SPV'.OR.WHCH(1:3).EQ.'spv')
          RVAL=SVAL
        ELSE IF (WHCH(1:3).EQ.'SSL'.OR.WHCH(1:3).EQ.'ssl')
          RVAL=SEGL
        ELSE IF (WHCH(1:3).EQ.'T2D'.OR.WHCH(1:3).EQ.'t2d')
          RVAL=T2DS
        ELSE IF (WHCH(1:3).EQ.'T3D'.OR.WHCH(1:3).EQ.'t3d')
          RVAL=T3DS
        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.'XC1'.OR.WHCH(1:3).EQ.'xc1')
          RVAL=UXA1
        ELSE IF (WHCH(1:3).EQ.'XCM'.OR.WHCH(1:3).EQ.'xcm')
          RVAL=UXAM
        ELSE IF (WHCH(1:3).EQ.'YC1'.OR.WHCH(1:3).EQ.'yc1')
          RVAL=UYA1
        ELSE IF (WHCH(1:3).EQ.'YCN'.OR.WHCH(1:3).EQ.'ycn')
          RVAL=UYAN
        ELSE IF (WHCH(1:3).EQ.'ZD1'.OR.WHCH(1:3).EQ.'zd1')
          RVAL=REAL(IZD1)
        ELSE IF (WHCH(1:3).EQ.'ZDM'.OR.WHCH(1:3).EQ.'zdm')
          RVAL=REAL(IZDM)
        ELSE IF (WHCH(1:3).EQ.'ZDN'.OR.WHCH(1:3).EQ.'zdn')
          RVAL=REAL(IZDN)
        ELSE IF (WHCH(1:3).EQ.'ZDS'.OR.WHCH(1:3).EQ.'zds')
          RVAL=REAL(IZDS)
        ELSE IF (WHCH(1:3).EQ.'ZDV'.OR.WHCH(1:3).EQ.'zdv')
          RVAL=ZDVL
        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)='CPGETR - 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 CPLBAM (ZDAT,RWRK,IWRK,IAMA)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*),IAMA(*)
C
C The function of the routine CPLBAM is to add to an area map boxes
C surrounding all of the labels.
C
C ZDAT is the user's data array.
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 CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPLBAM - 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 ('CPLBAM - 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('CPLBAM',3).NE.0) RETURN
C
C Make sure we have space for 10 coordinate values in real workspace 1.
C
        CALL CPGRWS (RWRK,1,10,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CPLBAM',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 CPCFLB (2,RWRK,IAMA)
          IF (ICFELL('CPLBAM',5).NE.0) RETURN
          GO TO 101
        END IF
C
C Make sure label positions have been chosen.
C
        CALL CPPKLP (ZDAT,RWRK,IWRK)
        IF (ICFELL('CPLBAM',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('CPLBAM',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('CPLBAM',8).NE.0) RETURN
        END DO
C
        CALL SET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
        IF (ICFELL('CPLBAM',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('CPLBAM',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('CPLBAM',11).NE.0) RETURN
          CALL SET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
          IF (ICFELL('CPLBAM',12).NE.0) RETURN
        END IF
C
C Release real workspace 1.
C
  102   LR01=0
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPLBDR (ZDAT,RWRK,IWRK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C The function of the routine CPLBDR is to draw all of the labels.
C
C ZDAT is the user's data array.
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 CONPACK common blocks.
C
.CALL CPCOMN,/$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('CPLBDR - 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 ('CPLBDR - 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('CPLBDR',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 CPCFLB (1,RWRK,IWRK)
          IF (ICFELL('CPLBDR',4).NE.0) RETURN
          RETURN
        END IF
C
C Make sure label positions have been chosen.
C
        CALL CPPKLP (ZDAT,RWRK,IWRK)
        IF (ICFELL('CPLBDR',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('CPLBDR',6).NE.0) RETURN
C
C Set up color-index controls.
C
        CALL GQPLCI (IGER,ISLC)
        IF (IGER.NE.0)
          CALL SETER ('CPLBDR - ERROR EXIT FROM GQPLCI',7,1)
          RETURN
        END IF
        CALL GQTXCI (IGER,ISTC)
        IF (IGER.NE.0)
          CALL SETER ('CPLBDR - ERROR EXIT FROM GQTXCI',8,1)
          RETURN
        END IF
        CALL GQFACI (IGER,ISFC)
        IF (IGER.NE.0)
          CALL SETER ('CPLBDR - 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
              ZDVL=0.
              CALL CPSBST (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
              ZDVL=RWRK(IR04-ICLB+2)
              CALL CPSBST (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
              ZDVL=RWRK(IR04-ICLB+2)
              CALL CPSBST (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
              ZDVL=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
            ZDVL=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 ('CPLBDR - ERROR EXIT FROM GQCLIP',10,1)
              RETURN
            END IF
            IF (IGCF.NE.0)
              CALL PLOTIF (0.,0.,2)
              IF (ICFELL('CPLBDR',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 HLUCPCHIL (+2)
              IF (ICFELL('CPLBDR',12).NE.0) RETURN
            ELSE IF (ITYP.EQ.2)
              CALL HLUCPCHHL (+2)
              IF (ICFELL('CPLBDR',13).NE.0) RETURN
            ELSE IF (ITYP.EQ.3)
              CALL HLUCPCHHL (+6)
              IF (ICFELL('CPLBDR',14).NE.0) RETURN
            ELSE
              IPAI=ICLB
              IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
              CALL HLUCPCHLL (+2)
              IF (ICFELL('CPLBDR',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 HLUCPCHIL (-2)
              IF (ICFELL('CPLBDR',16).NE.0) RETURN
            ELSE IF (ITYP.EQ.2)
              CALL HLUCPCHHL (-2)
              IF (ICFELL('CPLBDR',17).NE.0) RETURN
            ELSE IF (ITYP.EQ.3)
              CALL HLUCPCHHL (-6)
              IF (ICFELL('CPLBDR',18).NE.0) RETURN
            ELSE
              IPAI=ICLB
              IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
              CALL HLUCPCHLL (-2)
              IF (ICFELL('CPLBDR',19).NE.0) RETURN
            END IF
          END IF
C
          IF (JSLC.NE.JCOL)
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('CPLBDR',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 HLUCPCHIL (+3)
            IF (ICFELL('CPLBDR',21).NE.0) RETURN
          ELSE IF (ITYP.EQ.2)
            CALL HLUCPCHHL (+3)
            IF (ICFELL('CPLBDR',22).NE.0) RETURN
          ELSE IF (ITYP.EQ.3)
            CALL HLUCPCHHL (+7)
            IF (ICFELL('CPLBDR',23).NE.0) RETURN
          ELSE
            IPAI=ICLB
            IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
            CALL HLUCPCHLL (+3)
            IF (ICFELL('CPLBDR',24).NE.0) RETURN
          END IF
          CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCHR,ANGD,0.)
          IF (ICFELL('CPLBDR',25).NE.0) RETURN
          IF (ITYP.EQ.1)
            CALL HLUCPCHIL (-3)
            IF (ICFELL('CPLBDR',26).NE.0) RETURN
          ELSE IF (ITYP.EQ.2)
            CALL HLUCPCHHL (-3)
            IF (ICFELL('CPLBDR',27).NE.0) RETURN
          ELSE IF (ITYP.EQ.3)
            CALL HLUCPCHHL (-7)
            IF (ICFELL('CPLBDR',28).NE.0) RETURN
          ELSE
            IPAI=ICLB
            IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
            CALL HLUCPCHLL (-3)
            IF (ICFELL('CPLBDR',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 ('CPLBDR - ERROR EXIT FROM GQLWSC',30,1)
                RETURN
              END IF
              CALL PLOTIF (0.,0.,2)
              IF (ICFELL('CPLBDR',31).NE.0) RETURN
              CALL GSLWSC (WDTH)
            END IF
            IF (ITYP.EQ.1)
              CALL HLUCPCHIL (+4)
              IF (ICFELL('CPLBDR',32).NE.0) RETURN
            ELSE IF (ITYP.EQ.2)
              CALL HLUCPCHHL (+4)
              IF (ICFELL('CPLBDR',33).NE.0) RETURN
            ELSE IF (ITYP.EQ.3)
              CALL HLUCPCHHL (+8)
              IF (ICFELL('CPLBDR',34).NE.0) RETURN
            ELSE
              IPAI=ICLB
              IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
              CALL HLUCPCHLL (+4)
              IF (ICFELL('CPLBDR',35).NE.0) RETURN
            END IF
            CALL PLOTIF (XCLB-DLLB*CALB+DBLB*SALB,
     +                   YCLB-DLLB*SALB-DBLB*CALB,0)
            IF (ICFELL('CPLBDR',36).NE.0) RETURN
            CALL PLOTIF (XCLB+DRLB*CALB+DBLB*SALB,
     +                   YCLB+DRLB*SALB-DBLB*CALB,1)
            IF (ICFELL('CPLBDR',37).NE.0) RETURN
            CALL PLOTIF (XCLB+DRLB*CALB-DTLB*SALB,
     +                   YCLB+DRLB*SALB+DTLB*CALB,1)
            IF (ICFELL('CPLBDR',38).NE.0) RETURN
            CALL PLOTIF (XCLB-DLLB*CALB-DTLB*SALB,
     +                   YCLB-DLLB*SALB+DTLB*CALB,1)
            IF (ICFELL('CPLBDR',39).NE.0) RETURN
            CALL PLOTIF (XCLB-DLLB*CALB+DBLB*SALB,
     +                   YCLB-DLLB*SALB-DBLB*CALB,1)
            IF (ICFELL('CPLBDR',40).NE.0) RETURN
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('CPLBDR',41).NE.0) RETURN
            IF (ITYP.EQ.1)
              CALL HLUCPCHIL (-4)
              IF (ICFELL('CPLBDR',42).NE.0) RETURN
            ELSE IF (ITYP.EQ.2)
              CALL HLUCPCHHL (-4)
              IF (ICFELL('CPLBDR',43).NE.0) RETURN
            ELSE IF (ITYP.EQ.3)
              CALL HLUCPCHHL (-8)
              IF (ICFELL('CPLBDR',44).NE.0) RETURN
            ELSE
              IPAI=ICLB
              IF (IPAI.GT.$NCLV$) IPAI=$NCLV$-IPAI
              CALL HLUCPCHLL (-4)
              IF (ICFELL('CPLBDR',45).NE.0) RETURN
            END IF
            IF (WDTH.GT.0.)
              CALL PLOTIF (0.,0.,2)
              IF (ICFELL('CPLBDR',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('CPLBDR',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('CPLBDR',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('CPLBDR',49).NE.0) RETURN
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPMVIW (IWKO,IWKN,LWKN)
C
        DIMENSION IWKO(LIWK),IWKN(LWKN)
C
C This subroutine is called to move what CONPACK 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 CONPACK common blocks.
C
.CALL CPCOMN,/$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('CPMVIW - 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 ('CPMVIW - 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 CPMVRW (RWKO,RWKN,LWKN)
C
        DIMENSION RWKO(LRWK),RWKN(LWKN)
C
C This subroutine is called to move what CONPACK 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 CONPACK common blocks.
C
.CALL CPCOMN,/$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('CPMVRW - 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 ('CPMVRW - 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 CPPKCL (ZDAT,RWRK,IWRK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C The routine CPPKCL is called to pick a set of contour levels.
C
C ZDAT is the user's data array.
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 CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPPKCL - 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 ('CPPKCL - 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 ('CPPKCL - TOO MANY CONTOUR LEVELS',3,1)
            RETURN
          END IF
C
          NCLV=MIN(-ICLS,$NCLV$)
          CINU=(ZMAX-ZMIN)/REAL(NCLV+1)
          LINU=0
C
          DO (I=1,NCLV)
            CLEV(I)=ZMIN+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=(ZMAX-ZMIN)/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=ZMIN+.001*(ZMAX-ZMIN)
          IF (RTM2.LT.0.)
            RTM1=-REAL(INT(-RTM2/CINU))
          ELSE
            RTM1=1.+REAL(INT(RTM2/CINU))
          END IF
          RTM2=ZMAX-.001*(ZMAX-ZMIN)
          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 CPPKLB (ZDAT,RWRK,IWRK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C The routine CPPKLB is called to pick the labels to be associated with
C the contour levels.
C
C ZDAT is the user's data array.
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 CONPACK common blocks.
C
.CALL CPCOMN,/$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('CPPKLB - 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 ('CPPKLB - 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 CPPKCL (ZDAT,RWRK,IWRK)
          IF (ICFELL('CPPKLB',3).NE.0) RETURN
        END IF
C
C Get indices for the contour levels in ascending order.
C
        IF (NCLV.GT.0) CALL CPSORT (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 CPNUMB (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.  CPPKLB 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 CPNUMB (MAX(ABS(ZMIN),ABS(ZMAX))/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 CPNUMB (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 CPPKLP (ZDAT,RWRK,IWRK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C The routine CPPKLP is called to pick the label positions.
C
C ZDAT is the user's data array.
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 CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPPKLP - 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 ('CPPKLP - 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('CPPKLP',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 CPPKLB (ZDAT,RWRK,IWRK)
        IF (ICFELL('CPPKLP',4).NE.0) RETURN
        CALL CPSTLS (ZDAT,RWRK,IWRK)
        IF (ICFELL('CPPKLP',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 CPINLB (ZDAT,RWRK,IWRK)
        IF (ICFELL('CPPKLP',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 CPHLLB (ZDAT,RWRK,IWRK)
        IF (ICFELL('CPPKLP',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 CPGRWS (RWRK,2,IGRM*IGRN,IWSE)
          IF (IWSE.NE.0.OR.ICFELL('CPPKLP',8).NE.0) RETURN
          CALL CPCPAG (ZDAT,RWRK)
          IF (ICFELL('CPPKLP',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.ZMIN.AND.CLEV(ICLW).LT.ZMAX)
            ICLV=ICLP(ICLW)
            IF (MOD(ICLU(ICLV)/2,2).NE.0)
              IJMP=0
              LOOP
                CALL CPTRCL (ZDAT,RWRK,IWRK,CLEV(ICLV),IJMP,IRW1,IRW2,
     +                                                             NRWK)
                IF (ICFELL('CPPKLP',10).NE.0) RETURN
                EXIT IF (IJMP.EQ.0)
                IF (ABS(IPLL).EQ.2)
                  CALL CPPLAR (RWRK,IRW1,IRW2,NRWK)
                  IF (ICFELL('CPPKLP',11).NE.0) RETURN
                ELSE
                  CALL CPPLPS (RWRK,IRW1,IRW2,NRWK)
                  IF (ICFELL('CPPKLP',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 CPRECT (ZDAT,KZDT,MZDT,NZDT,RWRK,KRWK,IWRK,KIWK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C The routine CPRECT is called to start the process of drawing a
C contour plot, given a rectangular array of data.
C
C ZDAT is a two-dimensional array containing the data to be contoured.
C
C KZDT is the first dimension of the array ZDAT.
C
C MZDT specifies the number of elements in each row of the array to be
C contoured.
C
C NZDT specifies the number of elements in each column of the array to
C be contoured.
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 CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPRECT - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C If no CONPACK routine has been called before, initialize required
C constants.
C
        IF (INIT.EQ.0)
          CALL CPINRC
          IF (ICFELL('CPRECT',2).NE.0) RETURN
        END IF
C
C Transfer the array dimensions to variables in COMMON.
C
        IZD1=KZDT
        IZDM=MZDT
        IZDN=NZDT
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 CPINIT does the rest.
C
        CALL CPINIT (ZDAT,RWRK,IWRK)
        IF (ICFELL('CPRECT',3).NE.0) RETURN
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPRSET
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 CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPRSET - 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
        DOPT=.05
        FNCM=5.
        GSDM=1.
        HCHL=.004
        HCHS=.010
        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
        IHLX=0
        IHLY=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
        IWSO=1
        IZD1=1
        IZDM=1
        IZDN=1
        IZDS=1
        LCTM=1
        LINS=5
        LINU=0
        LIWM=10
        LRWC=100
        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
        SVAL=0.
        T2DS=0.
        T3DS=1.
        TXCF='CONSTANT FIELD - VALUE IS $ZDV$'
        TXHI='H:B:$ZDV$:E:'
        TXIL='CONTOUR FROM $CMN$ TO $CMX$ BY $CIU$'
        TXLO='L:B:$ZDV$:E:'
        UCMN=1.
        UCMX=0.
        UVPL=.05
        UVPR=.95
        UVPB=.05
        UVPT=.95
        UVPS=.25
        UWDL=0.
        UWDR=0.
        UWDB=0.
        UWDT=0.
        UXA1=0.
        UXAM=0.
        UYA1=0.
        UYAN=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.
        YLBC=0.
        ZDVL=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
        IAIA($NCP3$)=-1
        ICCL($NCP1$)=-1
        ICCL($NCP2$)=-1
        ICCL($NCP3$)=-1
        DO (I=1,$NCP3$)
          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 CPSETC (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 CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPSETC - 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)='CPSETC - 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)='CPSETC - 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)='CPSETC - 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 CPSETI (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 CONPACK common blocks.
C
.CALL CPCOMN,/$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 CPSETR. This provided a sort
C   of "automatic type conversion", allowing the user to set a real
C   parameter using either cpseti() or cpsetr(), as in:
C        CALL CPSETI ('xxx',-9999)
C     or
C        CALL CPSETR ('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 CPSETR.
C -------------------------------------------------------
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPSETI - 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)='CPSETI - 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.'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.'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.'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)='CPSETI - 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.'HLX'.OR.WHCH(1:3).EQ.'hlx')
          IHLX=IVAL
        ELSE IF (WHCH(1:3).EQ.'HLY'.OR.WHCH(1:3).EQ.'hly')
          IHLY=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.'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 ('CPSETI - 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.'WSO'.OR.WHCH(1:3).EQ.'wso')
          IWSO=MAX(0,MIN(3,IVAL))
        ELSE IF (WHCH(1:3).EQ.'ZD1'.OR.WHCH(1:3).EQ.'zd1')
          IZD1=MAX(1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'ZDM'.OR.WHCH(1:3).EQ.'zdm')
          IZDM=MAX(1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'ZDN'.OR.WHCH(1:3).EQ.'zdn')
          IZDN=MAX(1,IVAL)
        ELSE IF (WHCH(1:3).EQ.'ZDS'.OR.WHCH(1:3).EQ.'zds')
          IZDS=MAX(0,MIN(1,IVAL))
        ELSE
C         Float the integer value and pass it on to CPSETR.
          RVAL=REAL(IVAL)
          CALL CPSETR (WHCH,RVAL)
          IF (ICFELL('CPSETI',2).NE.0) RETURN
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPSETR (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 CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPSETR - 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)='CPSETR - 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)='CPSETR - 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.'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.'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.'HLX'.OR.WHCH(1:3).EQ.'hlx')
          IHLX=INT(RVAL)
        ELSE IF (WHCH(1:3).EQ.'HLY'.OR.WHCH(1:3).EQ.'hly')
          IHLY=INT(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.'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 ('CPSETR - 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.'SPV'.OR.WHCH(1:3).EQ.'spv')
          SVAL=RVAL
        ELSE IF (WHCH(1:3).EQ.'SSL'.OR.WHCH(1:3).EQ.'ssl')
          SEGL=MAX(.0001,RVAL)
        ELSE IF (WHCH(1:3).EQ.'T2D'.OR.WHCH(1:3).EQ.'t2d')
          T2DS=RVAL
        ELSE IF (WHCH(1:3).EQ.'T3D'.OR.WHCH(1:3).EQ.'t3d')
          T3DS=MAX(0.,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 IF (WHCH(1:3).EQ.'XC1'.OR.WHCH(1:3).EQ.'xc1')
          UXA1=RVAL
        ELSE IF (WHCH(1:3).EQ.'XCM'.OR.WHCH(1:3).EQ.'xcm')
          UXAM=RVAL
        ELSE IF (WHCH(1:3).EQ.'YC1'.OR.WHCH(1:3).EQ.'yc1')
          UYA1=RVAL
        ELSE IF (WHCH(1:3).EQ.'YCN'.OR.WHCH(1:3).EQ.'ycn')
          UYAN=RVAL
        ELSE IF (WHCH(1:3).EQ.'ZD1'.OR.WHCH(1:3).EQ.'zd1')
          IZD1=MAX(1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'ZDM'.OR.WHCH(1:3).EQ.'zdm')
          IZDM=MAX(1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'ZDN'.OR.WHCH(1:3).EQ.'zdn')
          IZDN=MAX(1,INT(RVAL))
        ELSE IF (WHCH(1:3).EQ.'ZDS'.OR.WHCH(1:3).EQ.'zds')
          IZDS=MAX(0,MIN(1,INT(RVAL)))
        ELSE IF (WHCH(1:3).EQ.'ZDV'.OR.WHCH(1:3).EQ.'zdv')
          ZDVL=RVAL
        ELSE
          CTMB(1:36)='CPSETR - 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 CPSPRS (ZSPS,KSPS,MSPS,NSPS,RWRK,KRWK,IWRK,KIWK,ZDAT,
     +                   KZDT)
C
        DIMENSION ZSPS(KSPS,*),RWRK(*),IWRK(*),ZDAT(IZD1,*)
C
C This routine just provides an alternate name for CPSPS1.
C
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPSPRS - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Pass the buck.
C
        CALL CPSPS1 (ZSPS,KSPS,MSPS,NSPS,RWRK,KRWK,IWRK,KIWK,ZDAT,KZDT)
        IF (ICFELL('CPSPRS',2).NE.0) RETURN
C
        RETURN
C
      END


      SUBROUTINE CPSPS1 (ZSPS,KSPS,MSPS,NSPS,RWRK,KRWK,IWRK,KIWK,ZDAT,
     +                   KZDT)
C
        DIMENSION ZSPS(KSPS,*),RWRK(*),IWRK(*),ZDAT(IZD1,*)
C
C The routine CPSPS1 is called to start the process of drawing a
C contour plot, given a sparse rectangular array of data.
C
C ZSPS is a two-dimensional array containing the data to be contoured.
C
C KSPS is the first dimension of the array ZSPS.
C
C MSPS specifies the number of elements in each row of the array to be
C contoured.
C
C NSPS specifies the number of elements in each column of the array to
C be contoured.
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 ZDAT is an array in which an interpolated dense array is to be
C generated.
C
C KZDT is the length of the array ZDAT.
C
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPSPS1 - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C If no CONPACK routine has been called before, initialize required
C constants.
C
        IF (INIT.EQ.0)
          CALL CPINRC
          IF (ICFELL('CPSPS1',2).NE.0) RETURN
        END IF
C
C If the user has not provided the dimensions of the dense array,
C compute them; otherwise, check the supplied values for errors.
C
        IF (IZDS.NE.0)
          RTIO=(1.+EPSI)*SQRT(REAL(KZDT)/REAL(MSPS*NSPS))
          IZDM=INT(RTIO*REAL(MSPS))
          IZDN=INT(RTIO*REAL(NSPS))
          IZD1=IZDM
        ELSE
          IF (IZD1.LT.IZDM.OR.IZDM.LT.2.OR.IZDN.LT.2.OR.
     +        IZDM*IZDN.GT.KZDT)
            CALL SETER ('CPSPS1 - IZD1, IZDM, OR IZDN SET INCORRECTLY',
     +                                                              3,1)
            RETURN
          END IF
        END IF
C
C Transfer the dimensions of the work arrays to COMMON.
C
        LRWK=KRWK
        LIWK=KIWK
C
C Transfer to a subroutine.  This is necessary so that the change in
C dimensioning of ZDAT should take effect.
C
        CALL CPSP1A (ZSPS,KSPS,MSPS,NSPS,RWRK,IWRK,ZDAT)
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPSP1A (ZSPS,KSPS,MSPS,NSPS,RWRK,IWRK,ZDAT)
C
        DIMENSION ZSPS(KSPS,*),RWRK(*),IWRK(*),ZDAT(IZD1,*)
C
C The routine CPSP1A is really just a part of CPSPS1.  It has to be
C made separate so that the change in dimension of ZDAT will actually
C take effect.
C
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
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 If the special-value flag is set, record the positions of the special
C values in the sparse array and replace them with reasonable values so
C that the interpolation routines can be called.
C
        IF (SVAL.NE.0.)
C
          NSVS=0
C
          DO (ISPS=1,MSPS)
            DO (JSPS=1,NSPS)
              IF (ZSPS(ISPS,JSPS).EQ.SVAL)
                IF (NSVS.GE.LI01)
                  CALL CPGIWS (IWRK,1,LI01+100,IWSE)
                  IF (IWSE.NE.0)
                    INVOKE (NOT-ENOUGH-WORKSPACE,NR)
                  END IF
                  IF (ICFELL('CPSPS1',4).NE.0) RETURN
                END IF
                IF (NSVS.GE.LR01)
                  CALL CPGRWS (RWRK,1,LR01+100,IWSE)
                  IF (IWSE.NE.0)
                    INVOKE (NOT-ENOUGH-WORKSPACE,NR)
                  END IF
                  IF (ICFELL('CPSPS1',5).NE.0) RETURN
                END IF
                NSVS=NSVS+1
                IWRK(II01+NSVS)=NSPS*(ISPS-1)+(JSPS-1)
                RWRK(IR01+NSVS)=SVAL
              END IF
            END DO
          END DO
C
          NSVR=NSVS
          MEST=4
C
          WHILE (NSVR.NE.0)
C
            NREP=0
C
            DO (I=1,NSVR)
              ISPS=IWRK(II01+I)/NSPS+1
              JSPS=MOD(IWRK(II01+I),NSPS)+1
              NEST=0
              REST=0.
              IF (ISPS.GE.3)
                IF (ZSPS(ISPS-1,JSPS).NE.SVAL.AND.
     +              ZSPS(ISPS-2,JSPS).NE.SVAL)
                  NEST=NEST+1
                  REST=REST+1.5*ZSPS(ISPS-1,JSPS)-.5*ZSPS(ISPS-2,JSPS)
                END IF
              END IF
              IF (ISPS.LE.MSPS-2)
                IF (ZSPS(ISPS+1,JSPS).NE.SVAL.AND.
     +              ZSPS(ISPS+2,JSPS).NE.SVAL)
                  NEST=NEST+1
                  REST=REST+1.5*ZSPS(ISPS+1,JSPS)-.5*ZSPS(ISPS+2,JSPS)
                END IF
              END IF
              IF (JSPS.GE.3)
                IF (ZSPS(ISPS,JSPS-1).NE.SVAL.AND.
     +              ZSPS(ISPS,JSPS-2).NE.SVAL)
                  NEST=NEST+1
                  REST=REST+1.5*ZSPS(ISPS,JSPS-1)-.5*ZSPS(ISPS,JSPS-2)
                END IF
              END IF
              IF (JSPS.LE.NSPS-2)
                IF (ZSPS(ISPS,JSPS+1).NE.SVAL.AND.
     +              ZSPS(ISPS,JSPS+2).NE.SVAL)
                  NEST=NEST+1
                  REST=REST+1.5*ZSPS(ISPS,JSPS+1)-.5*ZSPS(ISPS,JSPS+2)
                END IF
              END IF
              IF (NEST.GE.MEST)
                NREP=NREP+1
                RWRK(IR01+I)=REST/REAL(NEST)
              END IF
            END DO
C
            IF (NREP.EQ.0)
C
              MEST=MEST-1
C
              IF (MEST.LE.0)
                CALL SETER ('CPSPS1 - SPECIAL-VALUE REPLACEMENT FAILURE'
     +                                                             ,6,1)
                RETURN
              END IF
C
            ELSE
C
              NSVT=NSVR
C
              DO (I=NSVT,1,-1)
                IF (RWRK(IR01+I).NE.SVAL)
                  ISPS=IWRK(II01+I)/NSPS+1
                  JSPS=MOD(IWRK(II01+I),NSPS)+1
                  ZSPS(ISPS,JSPS)=RWRK(IR01+I)
                  IF (I.NE.NSVR)
                    ITMP=IWRK(II01+I)
                    IWRK(II01+I)=IWRK(II01+NSVR)
                    IWRK(II01+NSVR)=ITMP
                    RWRK(IR01+I)=SVAL
                  END IF
                  NSVR=NSVR-1
                END IF
              END DO
C
              MEST=4
C
            END IF
C
          END WHILE
C
        END IF
C
C Do the interpolation from the sparse array to the dense array.
C
        CALL CPGRWS (RWRK,1,3*MSPS*NSPS+MAX(MSPS+NSPS+NSPS,4*IZDM),IWSE)
C
        IF (IWSE.NE.0)
          INVOKE (NOT-ENOUGH-WORKSPACE,NR)
        END IF
        IF (ICFELL('CPSPS1',7).NE.0) RETURN
C
        CALL MSBSF1 (MSPS,NSPS,1.,REAL(MSPS),1.,REAL(NSPS),ZSPS,KSPS,
     +               RWRK(IR01+1),RWRK(IR01+1+3*MSPS*NSPS),T3DS)
        IF (ICFELL('CPSPS1',8).NE.0) RETURN
C
        CALL MSBSF2 (1.,REAL(MSPS),IZDM,1.,REAL(NSPS),IZDN,ZDAT,IZD1,
     +               MSPS,NSPS,1.,REAL(MSPS),1.,REAL(NSPS),ZSPS,KSPS,
     +               RWRK(IR01+1),RWRK(IR01+1+3*MSPS*NSPS),T3DS)
        IF (ICFELL('CPSPS1',9).NE.0) RETURN
C
        LR01=0
C
C If the special-value flag is set, restore the special values to the
C sparse array and fill in the corresponding values in the dense array.
C
        IF (SVAL.NE.0.)
C
          DO (I=1,NSVS)
            ISPS=IWRK(II01+I)/NSPS+1
            JSPS=MOD(IWRK(II01+I),NSPS)+1
            ZSPS(ISPS,JSPS)=SVAL
            IF (ISPS.EQ.1)
              JBEG=1
              JEND=1
            ELSE IF (ISPS.EQ.MSPS)
              JBEG=IZDM
              JEND=IZDM
            ELSE
              JBEG=MAX(1,MIN(IZDM,INT((REAL(ISPS-2)/
     +                                 REAL(MSPS-1)+.000001)*
     +                                      REAL(IZDM-1))+2))
              JEND=MAX(1,MIN(IZDM,INT((REAL(ISPS  )/
     +                                 REAL(MSPS-1)-.000001)*
     +                                      REAL(IZDM-1))+1))
            END IF
            IF (JSPS.EQ.1)
              KBEG=1
              KEND=1
            ELSE IF (JSPS.EQ.NSPS)
              KBEG=IZDN
              KEND=IZDN
            ELSE
              KBEG=MAX(1,MIN(IZDN,INT((REAL(JSPS-2)/
     +                                 REAL(NSPS-1)+.000001)*
     +                                      REAL(IZDN-1))+2))
              KEND=MAX(1,MIN(IZDN,INT((REAL(JSPS  )/
     +                                 REAL(NSPS-1)-.000001)*
     +                                      REAL(IZDN-1))+1))
            END IF
            DO (J=JBEG,JEND)
              DO (K=KBEG,KEND)
                ZDAT(J,K)=SVAL
              END DO
            END DO
          END DO
C
          LI01=0
C
        END IF
C
C CPINIT does the rest.
C
        CALL CPINIT (ZDAT,RWRK,IWRK)
        IF (ICFELL('CPSPS1',10).NE.0) RETURN
C
C Done.
C
        RETURN
C
C Error exit.
C
          BLOCK (NOT-ENOUGH-WORKSPACE,NR)
            CALL SETER ('CPSPS1 - CANNOT CONTINUE WITHOUT WORKSPACE',11,
     +                                                                1)
            RETURN
          END BLOCK
C
      END


      SUBROUTINE CPSPS2 (XSPS,YSPS,ZSPS,KSPS,MSPS,NSPS,RWRK,KRWK,IWRK,
     +                   KIWK,ZDAT,KZDT)
C
        DIMENSION XSPS(*),YSPS(*),ZSPS(KSPS,*),RWRK(*),IWRK(*),
     +            ZDAT(IZD1,*)
C
C The routine CPSPS2 is called to start the process of drawing a
C contour plot, given a rectangular array of data which is sparse and
C irregularly spaced in X and Y.
C
C XSPS is a one-dimensional array containing the MSPS X coordinates.
C
C YSPS is a one-dimensional array containing the NSPS Y coordinates.
C
C ZSPS is a two-dimensional array containing the data to be contoured.
C
C KSPS is the first dimension of the array ZSPS.
C
C MSPS specifies the number of elements in each row of the array to be
C contoured.
C
C NSPS specifies the number of elements in each column of the array to
C be contoured.
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 ZDAT is an array in which an interpolated dense array is to be
C generated.
C
C KZDT is the length of the array ZDAT.
C
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('CPSPS2 - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C If no CONPACK routine has been called before, initialize required
C constants.
C
        IF (INIT.EQ.0)
          CALL CPINRC
          IF (ICFELL('CPSPS2',2).NE.0) RETURN
        END IF
C
C If the user has not provided the dimensions of the dense array,
C compute them; otherwise, check the supplied values for errors.
C
        IF (IZDS.NE.0)
          XDIF=XSPS(MSPS)-XSPS(1)
          YDIF=YSPS(NSPS)-YSPS(1)
          IZDM=INT((1.+EPSI)*SQRT(REAL(KZDT)*(XDIF/YDIF)))
          IZDN=INT((1.+EPSI)*SQRT(REAL(KZDT)*(YDIF/XDIF)))
          IZD1=IZDM
        ELSE
          IF (IZD1.LT.IZDM.OR.IZDM.LT.2.OR.IZDN.LT.2.OR.
     +        IZDM*IZDN.GT.KZDT)
            CALL SETER ('CPSPS2 - IZD1, IZDM, OR IZDN SET INCORRECTLY',
     +                                                              3,1)
            RETURN
          END IF
        END IF
C
C Transfer the dimensions of the work arrays to COMMON.
C
        LRWK=KRWK
        LIWK=KIWK
C
C Transfer to a subroutine.  This is necessary so that the change in
C dimensioning of ZDAT should take effect.
C
        CALL CPSP2A (XSPS,YSPS,ZSPS,KSPS,MSPS,NSPS,RWRK,IWRK,ZDAT)
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPSP2A (XSPS,YSPS,ZSPS,KSPS,MSPS,NSPS,RWRK,IWRK,ZDAT)
C
        DIMENSION XSPS(*),YSPS(*),ZSPS(KSPS,*),RWRK(*),IWRK(*),
     +            ZDAT(IZD1,*)
C
C The routine CPSP2A is really just a part of CPSPS2.  It has to be
C made separate so that the change in dimension of ZDAT will actually
C take effect.
C
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Declare the type of the FITPACK function MSSRF2.
C
        REAL MSSRF2
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 If the special-value flag is set, record the positions of the special
C values in the sparse array and replace them with reasonable values so
C that the interpolation routines can be called.
C
        IF (SVAL.NE.0.)
C
          NSVS=0
C
          DO (ISPS=1,MSPS)
            DO (JSPS=1,NSPS)
              IF (ZSPS(ISPS,JSPS).EQ.SVAL)
                IF (NSVS.GE.LI01)
                  CALL CPGIWS (IWRK,1,LI01+100,IWSE)
                  IF (IWSE.NE.0)
                    CALL SETER ('CPSPS2 - CANNOT CONTINUE WITHOUT WORKSP
     +ACE',4,1)
                    RETURN
                  ELSE IF (ICFELL('CPSPS2',5).NE.0)
                    RETURN
                  END IF
                END IF
                IF (NSVS.GE.LR01)
                  CALL CPGRWS (RWRK,1,LR01+100,IWSE)
                  IF (IWSE.NE.0)
                    CALL SETER ('CPSPS2 - CANNOT CONTINUE WITHOUT WORKSP
     +ACE',6,1)
                    RETURN
                  ELSE IF (ICFELL('CPSPS2',7).NE.0)
                    RETURN
                  END IF
                END IF
                NSVS=NSVS+1
                IWRK(II01+NSVS)=NSPS*(ISPS-1)+(JSPS-1)
                RWRK(IR01+NSVS)=SVAL
              END IF
            END DO
          END DO
C
          NSVR=NSVS
          MEST=4
C
          WHILE (NSVR.NE.0)
C
            NREP=0
C
            DO (I=1,NSVR)
              ISPS=IWRK(II01+I)/NSPS+1
              JSPS=MOD(IWRK(II01+I),NSPS)+1
              NEST=0
              REST=0.
              IF (ISPS.GE.3)
                IF (ZSPS(ISPS-1,JSPS).NE.SVAL.AND.
     +              ZSPS(ISPS-2,JSPS).NE.SVAL)
                  NEST=NEST+1
                  REST=REST+ZSPS(ISPS-1,JSPS)+.5*
     +                      (ZSPS(ISPS-2,JSPS)-ZSPS(ISPS-1,JSPS))*
     +                      ((XSPS(ISPS  )-XSPS(ISPS-1))/
     +                       (XSPS(ISPS-2)-XSPS(ISPS-1)))
                END IF
              END IF
              IF (ISPS.LE.MSPS-2)
                IF (ZSPS(ISPS+1,JSPS).NE.SVAL.AND.
     +              ZSPS(ISPS+2,JSPS).NE.SVAL)
                  NEST=NEST+1
                  REST=REST+ZSPS(ISPS+1,JSPS)+.5*
     +                      (ZSPS(ISPS+2,JSPS)-ZSPS(ISPS+1,JSPS))*
     +                      ((XSPS(ISPS  )-XSPS(ISPS+1))/
     +                       (XSPS(ISPS+2)-XSPS(ISPS+1)))
                END IF
              END IF
              IF (JSPS.GE.3)
                IF (ZSPS(ISPS,JSPS-1).NE.SVAL.AND.
     +              ZSPS(ISPS,JSPS-2).NE.SVAL)
                  NEST=NEST+1
                  REST=REST+ZSPS(ISPS,JSPS-1)+.5*
     +                      (ZSPS(ISPS,JSPS-2)-ZSPS(ISPS,JSPS-1))*
     +                      ((YSPS(JSPS  )-YSPS(JSPS-1))/
     +                       (YSPS(JSPS-2)-YSPS(JSPS-1)))
                END IF
              END IF
              IF (JSPS.LE.NSPS-2)
                IF (ZSPS(ISPS,JSPS+1).NE.SVAL.AND.
     +              ZSPS(ISPS,JSPS+2).NE.SVAL)
                  NEST=NEST+1
                  REST=REST+ZSPS(ISPS,JSPS+1)+.5*
     +                      (ZSPS(ISPS,JSPS+2)-ZSPS(ISPS,JSPS+1))*
     +                      ((YSPS(JSPS  )-YSPS(JSPS+1))/
     +                       (YSPS(JSPS+2)-YSPS(JSPS+1)))
                END IF
              END IF
              IF (NEST.GE.MEST)
                NREP=NREP+1
                RWRK(IR01+I)=REST/REAL(NEST)
              END IF
            END DO
C
            IF (NREP.EQ.0)
C
              MEST=MEST-1
C
              IF (MEST.LE.0)
                CALL SETER ('CPSPS2 - SPECIAL-VALUE REPLACEMENT FAILURE'
     +                                                             ,8,1)
                RETURN
              END IF
C
            ELSE
C
              NSVT=NSVR
C
              DO (I=NSVT,1,-1)
                IF (RWRK(IR01+I).NE.SVAL)
                  ISPS=IWRK(II01+I)/NSPS+1
                  JSPS=MOD(IWRK(II01+I),NSPS)+1
                  ZSPS(ISPS,JSPS)=RWRK(IR01+I)
                  IF (I.NE.NSVR)
                    ITMP=IWRK(II01+I)
                    IWRK(II01+I)=IWRK(II01+NSVR)
                    IWRK(II01+NSVR)=ITMP
                    RWRK(IR01+I)=SVAL
                  END IF
                  NSVR=NSVR-1
                END IF
              END DO
C
              MEST=4
C
            END IF
C
          END WHILE
C
        END IF
C
C Do the interpolation from the sparse array to the dense array.
C
        CALL CPGRWS (RWRK,1,3*MSPS*NSPS+MSPS+NSPS+NSPS,IWSE)
C
        IF (IWSE.NE.0)
          CALL SETER ('CPSPS2 - CANNOT CONTINUE WITHOUT WORKSPACE',9,1)
          RETURN
        ELSE IF (ICFELL('CPSPS2',10).NE.0)
          RETURN
        END IF
C
        CALL MSSRF1 (MSPS,NSPS,XSPS,YSPS,ZSPS,KSPS,RWRK,RWRK,RWRK,RWRK,
     +               RWRK(1),RWRK(1),RWRK(1),RWRK(1),255,RWRK(IR01+1),
     +               RWRK(IR01+1+3*MSPS*NSPS),T3DS,IERR)
C
        IF (IERR.NE.0)
          CALL SETER ('CPSPS2 - ERROR IN CALL TO MSSRF1',11,1)
          RETURN
        END IF
C
        DO (I=1,IZDM)
          XCPT=XSPS(1)+(REAL(I-1)/REAL(IZDM-1))*(XSPS(MSPS)-XSPS(1))
          DO (J=1,IZDN)
            YCPT=YSPS(1)+(REAL(J-1)/REAL(IZDN-1))*(YSPS(NSPS)-YSPS(1))
            ZDAT(I,J)=MSSRF2 (XCPT,YCPT,MSPS,NSPS,XSPS,YSPS,ZSPS,KSPS,
     +                       RWRK(IR01+1),T3DS)
            IF (ICFELL('CPSPS2',12).NE.0) RETURN
          END DO
        END DO
C
        LR01=0
C
C If the special-value flag is set, restore the special values to the
C sparse array and fill in the corresponding values in the dense array.
C
        IF (SVAL.NE.0.)
C
          DO (I=1,NSVS)
C
            ISPS=IWRK(II01+I)/NSPS+1
            JSPS=MOD(IWRK(II01+I),NSPS)+1
            ZSPS(ISPS,JSPS)=SVAL
            IF (ISPS.EQ.1)
              JBEG=1
              JEND=1
            ELSE IF (ISPS.EQ.MSPS)
              JBEG=IZDM
              JEND=IZDM
            ELSE
              JBEG=MAX(1,MIN(IZDM,INT(((XSPS(ISPS-1)-XSPS(1))/
     +                                 (XSPS(MSPS  )-XSPS(1))+.000001)*
     +                                  REAL(IZDM-1))+2))
              JEND=MAX(1,MIN(IZDM,INT(((XSPS(ISPS+1)-XSPS(1))/
     +                                 (XSPS(MSPS  )-XSPS(1))-.000001)*
     +                                  REAL(IZDM-1))+1))
            END IF
            IF (JSPS.EQ.1)
              KBEG=1
              KEND=1
            ELSE IF (JSPS.EQ.NSPS)
              KBEG=IZDN
              KEND=IZDN
            ELSE
              KBEG=MAX(1,MIN(IZDN,INT(((YSPS(JSPS-1)-YSPS(1))/
     +                                 (YSPS(NSPS  )-YSPS(1))+.000001)*
     +                                                REAL(IZDN-1))+2))
              KEND=MAX(1,MIN(IZDN,INT(((YSPS(JSPS+1)-YSPS(1))/
     +                                 (YSPS(NSPS  )-YSPS(1))-.000001)*
     +                                                REAL(IZDN-1))+1))
            END IF
            DO (J=JBEG,JEND)
              DO (K=KBEG,KEND)
                ZDAT(J,K)=SVAL
              END DO
            END DO
C
          END DO
C
          LI01=0
C
        END IF
C
C CPINIT does the rest.
C
        CALL CPINIT (ZDAT,RWRK,IWRK)
        IF (ICFELL('CPSPS2',13).NE.0) RETURN
C
C Done.
C
        RETURN
C
      END


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


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


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


      SUBROUTINE CPCHCL (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 CPCHCL 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 CPGETx.
C
        RETURN
C
      END


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


      SUBROUTINE CPCHHL (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 CPCHHL may retrieve the value of the internal parameter 'ZDV', which
C is the value associated with the high or low being labelled.
C
C CPCHHL 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, CPCHHL 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 CONPACK 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, CPCHHL 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 HLUCPCHIL (IFLG)
C
C This routine stands between CONPACK and the user call-back routine
C CPCHIL.  When HLUs are not in use, this version of the routine gets
C loaded, so that CPCHIL 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 CPCHIL.
C
        CALL CPCHIL (IFLG)
C
        RETURN
C
      END


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


      SUBROUTINE CPCHLL (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 CPCHLL 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 CPGETx.
C
C CPCHLL may retrieve the value of the internal parameter 'ZDV', which
C is the contour level associated with the contour line being labelled.
C
C CPCHLL 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, CPCHLL 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 CONPACK 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, CPCHLL 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 HLUCPMPXY (IMAP,XINP,YINP,XOTP,YOTP)
C
C This routine stands between CONPACK and the user call-back routine
C CPMPXY.  When HLUs are not in use, this version of the routine gets
C loaded, so that CPMPXY 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 CPMPXY.
C
        CALL CPMPXY (IMAP,XINP,YINP,XOTP,YOTP)
C
        RETURN
C
      END


      SUBROUTINE CPMPXY (IMAP,XINP,YINP,XOTP,YOTP)
C
C By default, CONPACK draws contour lines using X coordinates in the
C range from XAT1 to XATM and Y coordinates in the range from YAT1 to
C YATN.  Setting the flag 'MAP' non-zero causes those coordinates to be
C transformed by calling the subroutine CPMPXY.  By default, 'MAP' = 1
C selects the EZMAP transformations and 'MAP' = 2 selects the polar
C coordinate transformations.  The user of CONPACK may replace this
C subroutine as desired to transform the final coordinates and thus to
C transform the objects drawn.
C
C NOTE:  As of 4/25/91, the default CPMPXY calls the new EZMAP routine
C MAPTRA instead of MAPTRN.  The new routine returns 1.E12 for points
C which project outside the EZMAP perimeter.
C
C NOTE:  As of 1/14/92, the default CPMPXY has been changed so that,
C when IMAP is negated, the inverse mapping is requested:  (XINP,YINP)
C is a point in the current user coordinate system; (XOTP,YOTP) is
C returned and is the point which would be carried into (XINP,YINP) by
C the mapping numbered ABS(IMAP).
C
C An additional convention has been adopted which will allow CONPACK to
C find out whether a given inverse transformation is available.  A call
C of the form
C
C       CALL CPMPXY (0,REAL(IMAP),RFLG,DUM1,DUM2)
C
C will return information in RFLG about the mapping numbered IMAP, as
C follows:
C
C   RFLG       forward mapping defined      inverse mapping defined
C   ----       -----------------------      -----------------------
C    0.                 no                            no
C    1.                yes                            no
C    2.                 no                           yes
C    3.                yes                           yes
C
C Versions of CPMPXY that have not been updated to include these new
C features should continue to work for a period of time, but ought to
C be updated eventually.
C
C ---------------------------------------------------------------------
C
C Handle a request by the caller for information about the capabilities
C of this version of CPMPXY.  Note that, if you modify CPMPXY to do
C other mappings, you should update the following code to correctly
C reflect the capabilities of the modified routine.
C
      IF (IMAP.EQ.0)
        IF ((INT(XINP).GE.1.AND.INT(XINP).LE.2).OR.INT(XINP).GE.3)
          YINP=3.
        ELSE
          YINP=0.
        END IF
C
C Handle the EZMAP case ...
C
      ELSE IF (ABS(IMAP).EQ.1)
        IF (IMAP.GT.0)
          CALL MAPTRA (YINP,XINP,XOTP,YOTP)
          IF (ICFELL('CPMPXY',1).NE.0) RETURN
        ELSE
          CALL MAPTRI (XINP,YINP,YOTP,XOTP)
          IF (ICFELL('CPMPXY',2).NE.0) RETURN
        END IF
C
C ... the polar coordinate case ...
C
      ELSE IF (ABS(IMAP).EQ.2)
        IF (IMAP.GT.0)
          XOTP=XINP*COS(.017453292519943*YINP)
          YOTP=XINP*SIN(.017453292519943*YINP)
        ELSE
          XOTP=SQRT(XINP*XINP+YINP*YINP)
          YOTP=57.2957795130823*ATAN2(YINP,XINP)
        END IF
C
C ... and everything else.
C
      ELSE
        XOTP=XINP
        YOTP=YINP
      END IF
C
C Done.
C
      RETURN
C
      END


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


      SUBROUTINE CPSCAE (ICRA,ICA1,ICAM,ICAN,XCPF,YCPF,XCQF,YCQF,
     +                                       IND1,IND2,ICAF,IAID)
        DIMENSION ICRA(ICA1,*)
C
C This routine is called by CPCICA when the internal parameter 'CAF' is
C given a negative value.  Each call is intended to update 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 a special-value 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 a special-value
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
C if the cell falls on the data grid, but no contour level below the
C cell 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 CPSCAE 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, the cell array is simply not changed.  The user may supply
C a version of CPSCAE 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
        IF (IAID.GE.0) ICRA(IND1,IND2)=IAID
C
        RETURN
C
      END


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


      SUBROUTINE CPCFLB (IACT,RWRK,IAMA)
C
        DIMENSION RWRK(*),IAMA(*)
C
C CPCFLB 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 CONPACK common blocks.
C
.CALL CPCOMN,/$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 ('CPCFLB - ERROR EXIT FROM GQCNTN',1,1)
          RETURN
        END IF
C
        CALL GQNT (NCNT,IGER,WIND,VPRT)
C
        IF (IGER.NE.0)
          CALL SETER ('CPCFLB - 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
        ZDVL=ZMIN
        CALL CPSBST (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('CPCFLB',3).NE.0) RETURN
        YLBC=CFUY(YPFS)
        IF (ICFELL('CPCFLB',4).NE.0) RETURN
        WCFS=CHWM*WCCF*(XVPR-XVPL)
        WWFS=CHWM*WWCF*(XVPR-XVPL)
C
        CALL PCGETI ('TE',ITMP)
        IF (ICFELL('CPCFLB',5).NE.0) RETURN
        CALL PCSETI ('TE',1)
        IF (ICFELL('CPCFLB',6).NE.0) RETURN
        CALL HLUCPCHCF (+1)
        IF (ICFELL('CPCFLB',7).NE.0) RETURN
        CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,360.,0.)
        IF (ICFELL('CPCFLB',8).NE.0) RETURN
        CALL HLUCPCHCF (-1)
        IF (ICFELL('CPCFLB',9).NE.0) RETURN
        CALL PCGETR ('DL',DSTL)
        IF (ICFELL('CPCFLB',10).NE.0) RETURN
        CALL PCGETR ('DR',DSTR)
        IF (ICFELL('CPCFLB',11).NE.0) RETURN
        CALL PCGETR ('DB',DSTB)
        IF (ICFELL('CPCFLB',12).NE.0) RETURN
        CALL PCGETR ('DT',DSTT)
        IF (ICFELL('CPCFLB',13).NE.0) RETURN
        CALL PCSETI ('TE',ITMP)
        IF (ICFELL('CPCFLB',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('CPCFLB',15).NE.0) RETURN
        YLBC=CFUY(YPFS)
        IF (ICFELL('CPCFLB',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 ('CPCFLB - ERROR EXIT FROM GQFACI',17,1)
                RETURN
              END IF
              IF (ISFC.NE.JLBC) CALL GSFACI (JLBC)
            END IF
            CALL HLUCPCHCF (+2)
            IF (ICFELL('CPCFLB',18).NE.0) RETURN
            BFXC(1)=CFWX(XPFS-DSTL*COSA+DSTB*SINA)
            IF (ICFELL('CPCFLB',19).NE.0) RETURN
            BFYC(1)=CFWY(YPFS-DSTL*SINA-DSTB*COSA)
            IF (ICFELL('CPCFLB',20).NE.0) RETURN
            BFXC(2)=CFWX(XPFS+DSTR*COSA+DSTB*SINA)
            IF (ICFELL('CPCFLB',21).NE.0) RETURN
            BFYC(2)=CFWY(YPFS+DSTR*SINA-DSTB*COSA)
            IF (ICFELL('CPCFLB',22).NE.0) RETURN
            BFXC(3)=CFWX(XPFS+DSTR*COSA-DSTT*SINA)
            IF (ICFELL('CPCFLB',23).NE.0) RETURN
            BFYC(3)=CFWY(YPFS+DSTR*SINA+DSTT*COSA)
            IF (ICFELL('CPCFLB',24).NE.0) RETURN
            BFXC(4)=CFWX(XPFS-DSTL*COSA-DSTT*SINA)
            IF (ICFELL('CPCFLB',25).NE.0) RETURN
            BFYC(4)=CFWY(YPFS-DSTL*SINA+DSTT*COSA)
            IF (ICFELL('CPCFLB',26).NE.0) RETURN
            CALL GFA (4,BFXC,BFYC)
            CALL HLUCPCHCF (-2)
            IF (ICFELL('CPCFLB',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 ('CPCFLB - ERROR EXIT FROM GQPLCI',28,1)
            RETURN
          END IF
          CALL GQTXCI (IGER,ISTC)
          IF (IGER.NE.0)
            CALL SETER ('CPCFLB - 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('CPCFLB',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 ('CPCFLB - ERROR EXIT FROM GQCLIP',31,1)
            RETURN
          END IF
          IF (IGCF.NE.0)
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('CPCFLB',32).NE.0) RETURN
            CALL GSCLIP (0)
          END IF
          CALL HLUCPCHCF (+3)
          IF (ICFELL('CPCFLB',33).NE.0) RETURN
          CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,ANCF,0.)
          IF (ICFELL('CPCFLB',34).NE.0) RETURN
          CALL HLUCPCHCF (-3)
          IF (ICFELL('CPCFLB',35).NE.0) RETURN
          IF (IGCF.NE.0)
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('CPCFLB',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 ('CPCFLB - ERROR EXIT FROM GQLWSC',37,1)
                RETURN
              END IF
              CALL PLOTIF (0.,0.,2)
              IF (ICFELL('CPCFLB',38).NE.0) RETURN
              CALL GSLWSC (WDTH)
            END IF
            CALL HLUCPCHCF (+4)
            IF (ICFELL('CPCFLB',39).NE.0) RETURN
            CALL PLOTIF (XPFS-DSTL*COSA+DSTB*SINA,
     +                   YPFS-DSTL*SINA-DSTB*COSA,0)
            IF (ICFELL('CPCFLB',40).NE.0) RETURN
            CALL PLOTIF (XPFS+DSTR*COSA+DSTB*SINA,
     +                   YPFS+DSTR*SINA-DSTB*COSA,1)
            IF (ICFELL('CPCFLB',41).NE.0) RETURN
            CALL PLOTIF (XPFS+DSTR*COSA-DSTT*SINA,
     +                   YPFS+DSTR*SINA+DSTT*COSA,1)
            IF (ICFELL('CPCFLB',42).NE.0) RETURN
            CALL PLOTIF (XPFS-DSTL*COSA-DSTT*SINA,
     +                   YPFS-DSTL*SINA+DSTT*COSA,1)
            IF (ICFELL('CPCFLB',43).NE.0) RETURN
            CALL PLOTIF (XPFS-DSTL*COSA+DSTB*SINA,
     +                   YPFS-DSTL*SINA-DSTB*COSA,1)
            IF (ICFELL('CPCFLB',44).NE.0) RETURN
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('CPCFLB',45).NE.0) RETURN
            CALL HLUCPCHCF (-4)
            IF (ICFELL('CPCFLB',46).NE.0) RETURN
            IF (WDTH.GT.0.)
              CALL PLOTIF (0.,0.,2)
              IF (ICFELL('CPCFLB',47).NE.0) RETURN
              CALL GSLWSC (SFLW)
            END IF
          END IF
          IF (ISLC.NE.JSLC)
            CALL PLOTIF (0.,0.,2)
            IF (ICFELL('CPCFLB',48).NE.0) RETURN
            CALL GSPLCI (ISLC)
          END IF
          IF (ISTC.NE.JSTC) CALL GSTXCI (ISTC)
        ELSE
          CALL CPGRWS (RWRK,1,10,IWSE)
          IF (IWSE.NE.0.OR.ICFELL('CPCFLB',49).NE.0) RETURN
          ANLB=.017453292519943*ANCF
          SALB=SIN(ANLB)
          CALB=COS(ANLB)
          RWRK(IR01+ 1)=CFUX(XPFS-DSTL*CALB+DSTB*SALB)
          IF (ICFELL('CPCFLB',50).NE.0) RETURN
          RWRK(IR01+ 2)=CFUX(XPFS+DSTR*CALB+DSTB*SALB)
          IF (ICFELL('CPCFLB',51).NE.0) RETURN
          RWRK(IR01+ 3)=CFUX(XPFS+DSTR*CALB-DSTT*SALB)
          IF (ICFELL('CPCFLB',52).NE.0) RETURN
          RWRK(IR01+ 4)=CFUX(XPFS-DSTL*CALB-DSTT*SALB)
          IF (ICFELL('CPCFLB',53).NE.0) RETURN
          RWRK(IR01+ 5)=RWRK(IR01+1)
          RWRK(IR01+ 6)=CFUY(YPFS-DSTL*SALB-DSTB*CALB)
          IF (ICFELL('CPCFLB',54).NE.0) RETURN
          RWRK(IR01+ 7)=CFUY(YPFS+DSTR*SALB-DSTB*CALB)
          IF (ICFELL('CPCFLB',55).NE.0) RETURN
          RWRK(IR01+ 8)=CFUY(YPFS+DSTR*SALB+DSTT*CALB)
          IF (ICFELL('CPCFLB',56).NE.0) RETURN
          RWRK(IR01+ 9)=CFUY(YPFS-DSTL*SALB+DSTT*CALB)
          IF (ICFELL('CPCFLB',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('CPCFLB',58).NE.0) RETURN
          ELSE
            CALL AREDAM (IAMA,RWRK(IR01+1),RWRK(IR01+6),5,IGLB,0,-1)
            IF (ICFELL('CPCFLB',59).NE.0) RETURN
          END IF
          LR01=0
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPCPAG (ZDAT,RWRK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*)
C
C Given an array of data to be contoured, the routine CPCPAG computes
C an array of IGRM*IGRN gradients to be used in positioning labels.
C
C ZDAT is the user's data array.
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 (because of special values and
C peculiarities of the mapping functions, NGRV may not equal IGRM*IGRN),
C GRAV, which is the average gradient found, and GRSD, which is the
C standard deviation of the gradient distribution.
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Compute some needed conversion constants.
C
        RZDM=(XATM-XAT1)/REAL(IZDM-1)
        RZDN=(YATN-YAT1)/REAL(IZDN-1)
C
C Initialize the gradient array.
C
        DO (I=1,IGRM*IGRN)
          RWRK(IR02+I)=-1.
        END DO
C
C Run through all the right triangles with hypotenuses in the first
C quadrant ...
C
        FOR (I=1 TO IZDM-1)
          FOR (J=1 TO IZDN-1)
            XCD1=REAL(I)
            YCD1=REAL(J)
            ZCD1=ZDAT(I,J)
            XCD2=REAL(I+1)
            YCD2=REAL(J)
            ZCD2=ZDAT(I+1,J)
            XCD3=REAL(I)
            YCD3=REAL(J+1)
            ZCD3=ZDAT(I,J+1)
            INVOKE (UPDATE-THE-GRADIENT-ARRAY)
          END FOR
        END FOR
C
C ... the second quadrant, ...
C
        FOR (I=2 TO IZDM)
          FOR (J=1 TO IZDN-1)
            XCD1=REAL(I)
            YCD1=REAL(J)
            ZCD1=ZDAT(I,J)
            XCD2=REAL(I)
            YCD2=REAL(J+1)
            ZCD2=ZDAT(I,J+1)
            XCD3=REAL(I-1)
            YCD3=REAL(J)
            ZCD3=ZDAT(I-1,J)
            INVOKE (UPDATE-THE-GRADIENT-ARRAY)
          END FOR
        END FOR
C
C ... the third quadrant, ...
C
        FOR (I=2 TO IZDM)
          FOR (J=2 TO IZDN)
            XCD1=REAL(I)
            YCD1=REAL(J)
            ZCD1=ZDAT(I,J)
            XCD2=REAL(I-1)
            YCD2=REAL(J)
            ZCD2=ZDAT(I-1,J)
            XCD3=REAL(I)
            YCD3=REAL(J-1)
            ZCD3=ZDAT(I,J-1)
            INVOKE (UPDATE-THE-GRADIENT-ARRAY)
          END FOR
        END FOR
C
C ... and the fourth quadrant.
C
        FOR (I=1 TO IZDM-1)
          FOR (J=2 TO IZDN)
            XCD1=REAL(I)
            YCD1=REAL(J)
            ZCD1=ZDAT(I,J)
            XCD2=REAL(I)
            YCD2=REAL(J-1)
            ZCD2=ZDAT(I,J-1)
            XCD3=REAL(I+1)
            YCD3=REAL(J)
            ZCD3=ZDAT(I+1,J)
            INVOKE (UPDATE-THE-GRADIENT-ARRAY)
          END FOR
        END FOR
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
C The following "internal procedure", given a triangle in three-space,
C computes the gradient of that triangle and updates relevant portions
C of the gradient array.
C
        BLOCK (UPDATE-THE-GRADIENT-ARRAY)
C
          IF (SVAL.NE.0..AND.ZCD1.EQ.SVAL)
            IVI1=0
          ELSE
            XGD1=XAT1+RZDM*(XCD1-1.)
            YGD1=YAT1+RZDN*(YCD1-1.)
            IVI1=1
            IF (IMPF.NE.0)
              XTMP=XGD1
              YTMP=YGD1
              CALL HLUCPMPXY (IMPF,XTMP,YTMP,XGD1,YGD1)
              IF (ICFELL('CPCPAG',1).NE.0) RETURN
              IF (OORV.NE.0..AND.(XGD1.EQ.OORV.OR.YGD1.EQ.OORV)) IVI1=0
            END IF
            XGD1=CUFX(XGD1)
            IF (ICFELL('CPCPAG',2).NE.0) RETURN
            YGD1=CUFY(YGD1)
            IF (ICFELL('CPCPAG',3).NE.0) RETURN
            ZGD1=ZCD1
          END IF
C
          IF (SVAL.NE.0..AND.ZCD2.EQ.SVAL)
            IVI2=0
          ELSE
            XGD2=XAT1+RZDM*(XCD2-1.)
            YGD2=YAT1+RZDN*(YCD2-1.)
            IVI2=1
            IF (IMPF.NE.0)
              XTMP=XGD2
              YTMP=YGD2
              CALL HLUCPMPXY (IMPF,XTMP,YTMP,XGD2,YGD2)
              IF (ICFELL('CPCPAG',4).NE.0) RETURN
              IF (OORV.NE.0..AND.(XGD2.EQ.OORV.OR.YGD2.EQ.OORV)) IVI2=0
            END IF
            XGD2=CUFX(XGD2)
            IF (ICFELL('CPCPAG',5).NE.0) RETURN
            YGD2=CUFY(YGD2)
            IF (ICFELL('CPCPAG',6).NE.0) RETURN
            ZGD2=ZCD2
          END IF
C
          IF (SVAL.NE.0..AND.ZCD3.EQ.SVAL)
            IVI3=0
          ELSE
            XGD3=XAT1+RZDM*(XCD3-1.)
            YGD3=YAT1+RZDN*(YCD3-1.)
            IVI3=1
            IF (IMPF.NE.0)
              XTMP=XGD3
              YTMP=YGD3
              CALL HLUCPMPXY (IMPF,XTMP,YTMP,XGD3,YGD3)
              IF (ICFELL('CPCPAG',7).NE.0) RETURN
              IF (OORV.NE.0..AND.(XGD3.EQ.OORV.OR.YGD3.EQ.OORV)) IVI3=0
            END IF
            XGD3=CUFX(XGD3)
            IF (ICFELL('CPCPAG',8).NE.0) RETURN
            YGD3=CUFY(YGD3)
            IF (ICFELL('CPCPAG',9).NE.0) RETURN
            ZGD3=ZCD3
          END IF
C
          IF (IVI1.NE.0.AND.IVI2.NE.0.AND.IVI3.NE.0)
            XD12=XGD2-XGD1
            YD12=YGD2-YGD1
            XD23=XGD3-XGD2
            YD23=YGD3-YGD2
            XD31=XGD1-XGD3
            YD31=YGD1-YGD3
            IF ((XD12.NE.0..OR.YD12.NE.0.).AND.
     +          (XD23.NE.0..OR.YD23.NE.0.).AND.
     +          (XD31.NE.0..OR.YD31.NE.0.))
              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
            END IF
          END IF
        END BLOCK
C
      END


      SUBROUTINE CPDRSG (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 CPDRSG is to draw the segment.
C
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$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('CPDRSG',1).NE.0) RETURN
        ELSE IF (IDUF.LT.0)
          CALL DPCURV (RWRK(IPTX+1),RWRK(IPTY+1),NXYC)
          IF (ICFELL('CPDRSG',2).NE.0) RETURN
        ELSE
          CALL CURVED (RWRK(IPTX+1),RWRK(IPTY+1),NXYC)
          IF (ICFELL('CPDRSG',3).NE.0) RETURN
        END IF
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPGIWS (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 CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for argument error.
C
        IF (IOWS.LT.1.OR.IOWS.GT.$NBIW$.OR.LOWS.LT.0)
          CALL SETER ('CPGIWS - 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),'('' CPGIWS'',
     +                         I8,'' WORDS REQUESTED'',
     +                         I8,'' WORDS AVAILABLE'')') LOWS,NLFT
          IF (IWSO.LE.0)
            CALL SETER ('CPGIWS - INTEGER WORKSPACE OVERFLOW',2,2)
            STOP
          ELSE IF (IWSO.GE.3)
            CALL SETER ('CPGIWS - 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 CPGRWS (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 CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Check for argument error.
C
        IF (IOWS.LT.1.OR.IOWS.GT.$NBRW$.OR.LOWS.LT.0)
          CALL SETER ('CPGRWS - 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),'('' CPGRWS'',
     +                         I8,'' WORDS REQUESTED'',
     +                         I8,'' WORDS AVAILABLE'')') LOWS,NLFT
          IF (IWSO.LE.0)
            CALL SETER ('CPGRWS - REAL WORKSPACE OVERFLOW',2,2)
            STOP
          ELSE IF (IWSO.GE.3)
            CALL SETER ('CPGRWS - 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 CPGVAI (ZVAL,IAID)
C
C Given a field value ZVAL, CPGVAI searches the current contour list to
C determine the area identifier IAID to be associated with that value.
C It is called by CPCICA, CPTREG, CPTRES, CPTREV, and CPTRVE.
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$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 CPHCHM (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 CPHCHM 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 CONPACK common blocks.
C
.CALL CPCOMN,/$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('CPHCHM',1).NE.0) RETURN
          RWRK(IPTY+I)=CUFY(RWRK(IPTY+I))
          IF (ICFELL('CPHCHM',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('CPHCHM',3).NE.0) RETURN
            YCPT(1)=CFUY(YCPT(1))
            IF (ICFELL('CPHCHM',4).NE.0) RETURN
            XCPT(2)=CFUX(XCPT(2))
            IF (ICFELL('CPHCHM',5).NE.0) RETURN
            YCPT(2)=CFUY(YCPT(2))
            IF (ICFELL('CPHCHM',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('CPHCHM',7).NE.0) RETURN
            PNHM=PNHM+DBHM
          END WHILE
          CLEN=CLEN+SLEN
        END WHILE
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPHCHR (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 CPHCHR is to hachure the segment, if appropriate.
C
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$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('CPHCHR',1).NE.0) RETURN
          RWRK(IPTY+I)=CUFY(RWRK(IPTY+I))
          IF (ICFELL('CPHCHR',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('CPHCHR',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('CPHCHR',4).NE.0) RETURN
            PNHM=PNHM+DBHM
          END WHILE
          CLEN=CLEN+SLEN
        END WHILE
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPHLLB (ZDAT,RWRK,IWRK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C CPHLLB 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 A point (I,J) is defined to be a high (low) if ZDAT(I,J) is greater
C than (less than) every other field value within a certain neighborhood
C of (I,J).  The neighborhood is defined by the values of the parameters
C 'HLX' and 'HLY'.
C
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C ZVAL is an arithmetic statement function which, given an integer
C index I between 1 and IZDM*IZDN, has as its value the Ith element
C (in column-wise order) of the array ZDAT.
C
        ZVAL(I)=ZDAT(MOD(I,IZDM)+1,I/IZDM+1)
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 Zero the value of a flag that is incremented whenever a problematic
C pair of near-by equal values is seen in the field.
C
        IFLG=0
C
C Compute constants needed to get from data-index coordinates to user
C coordinates.
C
        RZDM=(XATM-XAT1)/REAL(IZDM-1)
        RZDN=(YATN-YAT1)/REAL(IZDN-1)
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 Determine the values of IRNG and JRNG, which specify the size of the
C neighborhood used in testing for highs and lows.
C
        IF (IHLX.GT.0)
          IRNG=IHLX
        ELSE
          IRNG=MAX(2,MIN(15,IZDM/8))
        END IF
C
        IF (IHLY.GT.0)
          JRNG=IHLY
        ELSE
          JRNG=MAX(2,MIN(15,IZDN/8))
        END IF
C
C Make PLOTCHAR compute text-extent quantities.
C
        CALL PCGETI ('TE',ITMP)
        IF (ICFELL('CPHLLB',1).NE.0) RETURN
        CALL PCSETI ('TE',1)
        IF (ICFELL('CPHLLB',2).NE.0) RETURN
C
C Line loop follows.  The complete two-dimensional test for a minimum or
C maximum of the field is only performed for points which are minima or
C maxima along some line.  Finding these candidates is made efficient by
C using a count of consecutive increases or decreases of the function
C along the line.
C
C Tell IFTRAN to use the FORTRAN-66 implementation of BLOCK invocations.
C
.OP     BI=66
C
        FOR (JPNT = 2 TO IZDN-1)
C
          ICON=IRNG-1
          IPNT=-1
          GO TO 106
C
C Loop as long as the function is increasing along the line; we seek a
C possible maximum.
C
  101     LOOP
            IPNT=IPNT+1
            IF (IPNT.GE.IZDM) GO TO 107
            ZNOW=ZNXT
            ZNXT=ZDAT(IPNT+1,JPNT)
            IF (SVAL.NE.0..AND.ZNXT.EQ.SVAL) GO TO 105
            IF (ZNXT.LT.ZNOW)
              EXIT
            ELSE IF (ZNXT.EQ.ZNOW)
              IFLG=IFLG+1
              ICON=0
            ELSE
              ICON=ICON+1
            END IF
          END LOOP
C
C Function decreases at next point.  Test for maximum on line.
C
          IF (ICON.LT.IRNG)
C
            IBEG=MAX(1,IPNT-IRNG)
            IEND=IPNT-ICON-1
C
            DO (I=IBEG,IEND)
              IF (ZNOW.EQ.ZDAT(I,JPNT)) IFLG=IFLG+1
              IF (ZNOW.LE.ZDAT(I,JPNT)) GO TO 102
            END DO
C
          END IF
C
          IBEG=IPNT+2
          IEND=MIN(IZDM,IPNT+IRNG)
C
          DO (I=IBEG,IEND)
            IF (ZNOW.EQ.ZDAT(I,JPNT)) IFLG=IFLG+1
            IF (ZNOW.LE.ZDAT(I,JPNT)) GO TO 102
          END DO
C
C We have a maximum on the line.  Do a two-dimensional test for a
C maximum in the field.
C
          JBEG=MAX(1,JPNT-JRNG)
          JEND=MIN(IZDN,JPNT+JRNG)
          IBEG=MAX(1,IPNT-IRNG)
          IEND=MIN(IZDM,IPNT+IRNG)
C
          DO (J=JBEG,JEND)
            IF (J.NE.JPNT)
              DO (I=IBEG,IEND)
                IF (SVAL.EQ.0..OR.ZDAT(I,J).NE.SVAL)
                  IF (ZDAT(I,J).EQ.ZNOW) IFLG=IFLG+1
                  IF (ZDAT(I,J).GE.ZNOW) GO TO 102
                ELSE
                  IF (ABS(I-IPNT).LT.2.AND.ABS(J-JPNT).LT.2) GO TO 102
                END IF
              END DO
            END IF
          END DO
C
C We have a maximum in the field.  Process it.
C
          IF (TXHI(1:LTHI).NE.' ')
            IHOL=0
            XLBC=XAT1+RZDM*(REAL(IPNT)-1.)
            YLBC=YAT1+RZDN*(REAL(JPNT)-1.)
            INVOKE (WRITE-A-LABEL)
          END IF
C
C Start searching for a minimum.
C
  102     ICON=1
C
C Loop as long as the function is decreasing along the line.  We seek a
C possible minimum.
C
  103     LOOP
            IPNT=IPNT+1
            IF (IPNT.GE.IZDM) GO TO 107
            ZNOW=ZNXT
            ZNXT=ZDAT(IPNT+1,JPNT)
            IF (SVAL.NE.0..AND.ZNXT.EQ.SVAL) GO TO 105
            IF (ZNXT.GT.ZNOW)
              EXIT
            ELSE IF (ZNXT.EQ.ZNOW)
              IFLG=IFLG+1
              ICON=0
            ELSE
              ICON=ICON+1
            END IF
          END LOOP
C
C Function increases at next point.  Test for a minimum on the line.
C
          IF (ICON.LT.IRNG)
C
            IBEG=MAX(1,IPNT-IRNG)
            IEND=IPNT-ICON-1
C
            DO (I=IBEG,IEND)
              IF (ZNOW.EQ.ZDAT(I,JPNT)) IFLG=IFLG+1
              IF (ZNOW.GE.ZDAT(I,JPNT)) GO TO 104
            END DO
C
          END IF
C
          IBEG=IPNT+2
          IEND=MIN(IZDM,IPNT+IRNG)
C
          DO (I=IBEG,IEND)
            IF (ZNOW.EQ.ZDAT(I,JPNT)) IFLG=IFLG+1
            IF (ZNOW.GE.ZDAT(I,JPNT)) GO TO 104
          END DO
C
C We have a minimum on the line.  Do a two-dimensional test for a
C minimum of the field.
C
          JBEG=MAX(1,JPNT-JRNG)
          JEND=MIN(IZDN,JPNT+JRNG)
          IBEG=MAX(1,IPNT-IRNG)
          IEND=MIN(IZDM,IPNT+IRNG)
C
          DO (J=JBEG,JEND)
            IF (J.NE.JPNT)
              DO (I=IBEG,IEND)
                IF (SVAL.EQ.0..OR.ZDAT(I,J).NE.SVAL)
                  IF (ZDAT(I,J).EQ.ZNOW) IFLG=IFLG+1
                  IF (ZDAT(I,J).LE.ZNOW) GO TO 104
                ELSE
                  IF (ABS(I-IPNT).LT.2.AND.ABS(J-JPNT).LT.2) GO TO 104
                END IF
              END DO
            END IF
          END DO
C
C We have a minimum in the field.  Process it.
C
          IF (TXLO(1:LTLO).NE.' ')
            IHOL=1
            XLBC=XAT1+RZDM*(REAL(IPNT)-1.)
            YLBC=YAT1+RZDN*(REAL(JPNT)-1.)
            INVOKE (WRITE-A-LABEL)
          END IF
C
C Start searching for a maximum.
C
  104     ICON=1
          GO TO 101
C
C Skip special values on the line.
C
  105     ICON=0
  106     IPNT=IPNT+1
          IF (IPNT.GE.IZDM-1) GO TO 107
          IF (SVAL.NE.0..AND.ZDAT(IPNT+1,JPNT).EQ.SVAL) GO TO 105
          ICON=ICON+1
          IF (ICON.LE.IRNG) GO TO 106
C
          ICON=1
          ZNXT=ZDAT(IPNT+1,JPNT)
          IF (ZDAT(IPNT,JPNT).EQ.ZNXT) ICON=0
          IF (ZDAT(IPNT,JPNT).LE.ZNXT) GO TO 101
          GO TO 103
C
  107   END FOR
C
C If there is evidence that the straightforward search for highs and
C lows may have missed some because of equal field values at neighboring
C locations within the search neighborhood and if the user has enabled
C an additional search for the highs and lows that were missed, do it.
C
        IF (IFLG.NE.0.AND.IHLE.NE.0)
C
C Grab a portion of the integer workspace of length IZDM*IZDN.
C
          CALL CPGIWS (IWRK,1,IZDM*IZDN,IWSE)
          IF (IWSE.NE.0.OR.ICFELL('CPHLLB',3).NE.0) GO TO 110
C
C Form an index array for the contents of ZDAT.  Each element of the
C index array is of the form (J-1)*IZDM+(I-1), where I and J are indices
C of an element of ZDAT.  The elements of the index array are sorted
C in order of increasing value of the associated elements of ZDAT.
C
          CALL CPHLSO (ZDAT,IZD1,IZDM,IZDN,IWRK(II01+1))
C
C Initialize a scan of the index array to look for elements of ZDAT
C that are equal to each other.  ZNXT is the larger element of ZDAT.
C NEQU keeps track of the number of equal values found in a row.
C
          ZNXT=ZVAL(IWRK(II01+1))
          NEQU=0
C
C Loop through the elements of the index array.
C
          FOR (INDX = 1 TO IZDM*IZDN)
C
C ZNOW is the element of ZDAT pointed at by element INDX of the index
C array.
C
            ZNOW=ZNXT
C
C ZNXT is the element of ZDAT pointed at by element INDX+1 of the index
C array.  If element INDX is the last element of the array, ZNXT is just
C set to a value different from ZNOW (the smallest element of ZDAT).
C
            IF (INDX.LT.IZDM*IZDN)
              ZNXT=ZVAL(IWRK(II01+INDX+1))
            ELSE
              ZNXT=ZVAL(IWRK(II01+1))
            END IF
C
C If ZNXT is equal to ZNOW, bump the value of NEQU, which keeps track
C of the number of consecutive elements of the index array that have
C pointed to the same value in the ZDAT array.
C
            IF (ZNXT.EQ.ZNOW)
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) and if it's not a group of special
C values, ...
C
              IF (NEQU.GT.0..AND.NEQU.LT.64.AND.
     +            (SVAL.EQ.0..OR.ZNOW.NE.SVAL))
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 point to elements of ZDAT that
C are within one grid unit of each other in both X and Y.)  NEQU is the
C number of equalities seen and is therefore one less than the number of
C equal values in the group.  INDX points to the element of the index
C array defining the last element of the group.  JNDX points to the
C element of the index array defining the first element of the group.
C KNDX points to the element of the index array defining the last
C element of the subgroup currently being worked 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
  108             DO (LNDX=KNDX+1,INDX)
                    LIM1=MOD(IWRK(II01+LNDX),IZDM)
                    LJM1=(IWRK(II01+LNDX))/IZDM
                    DO (MNDX=JNDX,KNDX)
                      MIM1=MOD(IWRK(II01+MNDX),IZDM)
                      MJM1=(IWRK(II01+MNDX))/IZDM
                      IF (ABS(LIM1-MIM1).LE.1.AND.ABS(LJM1-MJM1).LE.1)
                        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 108
                      END IF
                    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 elements of ZDAT pointed at by members of the subgroup
C to see whether the subgroup can be considered a high or a low.  IHLC
C is set positive to indicate that the subgroup is a high, negative to
C indicate that it is a low.  XLBC, YLBC, and NLBC are used to compute a
C mean position for the high or the low.
C
                    IHLC=0
                    XLBC=0.
                    YLBC=0.
                    NLBC=0
C
C Loop through the elements of the subgroup.
C
                    DO (LNDX=JNDX,KNDX)
                      IPNT=MOD(IWRK(LNDX),IZDM)+1
                      JPNT=(IWRK(LNDX))/IZDM+1
                      IBEG=MAX(1,IPNT-IRNG)
                      IEND=MIN(IZDM,IPNT+IRNG)
                      JBEG=MAX(1,JPNT-JRNG)
                      JEND=MIN(IZDN,JPNT+JRNG)
                      XLBC=XLBC+XAT1+RZDM*(REAL(IPNT)-1.)
                      YLBC=YLBC+YAT1+RZDN*(REAL(JPNT)-1.)
                      NLBC=NLBC+1
                      DO (I=IBEG,IEND)
                        DO (J=JBEG,JEND)
                          IF (I.NE.IPNT.OR.J.NE.JPNT)
                            IF (SVAL.EQ.0..OR.ZDAT(I,J).NE.SVAL)
                              IF (ZNOW.GT.ZDAT(I,J))
                                IF (IHLC.LT.0) GO TO 109
                                IHLC=+1
                              ELSE IF (ZNOW.LT.ZDAT(I,J))
                                IF (IHLC.GT.0) GO TO 109
                                IHLC=-1
                              END IF
                            ELSE
                              IF (ABS(I-IPNT).LT.2.AND.
     +                            ABS(J-JPNT).LT.2) GO TO 109
                            END IF
                          END IF
                        END DO
                      END DO
                    END DO
C
C Finish computing the location of the "high" or "low" and, ...
C
                    XLBC=XLBC/REAL(NLBC)
                    IF (XLBC.LE.XAT1.OR.XLBC.GE.XATM) GO TO 109
                    YLBC=YLBC/REAL(NLBC)
                    IF (YLBC.LE.YAT1.OR.YLBC.GE.YATN) GO TO 109
C
C ... if all comparisons indicate that a high has been found, ...
C
                    IF (IHLC.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 (IHLC.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
  109             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
C All highs and lows that were missed by the normal algorithm have been
C found and labeled.
C
        END IF
C
C Tell IFTRAN to use the FORTRAN-77 implementation of BLOCK invocations.
C
.OP     BI=77
C
C Discard any integer workspace that may have been used above.
C
  110   LI01=0
C
C Return PLOTCHAR to its default state.
C
        CALL PCSETI ('TE',ITMP)
        IF (ICFELL('CPHLLB',4).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 subscript coordinates are
C IPNT and JPNT.
C
        BLOCK (WRITE-A-LABEL)
C
          IVIS=1
C
          IF (IMPF.NE.0)
            XTMP=XLBC
            YTMP=YLBC
            CALL HLUCPMPXY (IMPF,XTMP,YTMP,XLBC,YLBC)
            IF (ICFELL('CPHLLB',5).NE.0) RETURN
            IF ((OORV.NE.0.).AND.(XLBC.EQ.OORV.OR.YLBC.EQ.OORV)) IVIS=0
          END IF
C
          IF (IVIS.NE.0)
            XCLB=CUFX(XLBC)
            IF (ICFELL('CPHLLB',6).NE.0) RETURN
            YCLB=CUFY(YLBC)
            IF (ICFELL('CPHLLB',7).NE.0) RETURN
            ZDVL=ZDAT(IPNT,JPNT)
            IF (IHOL.EQ.0)
              CALL CPSBST(TXHI(1:LTHI),CTMA,LCTM)
            ELSE
              CALL CPSBST(TXLO(1:LTLO),CTMA,LCTM)
            END IF
            CALL HLUCPCHHL (+1+4*IHOL)
            IF (ICFELL('CPHLLB',8).NE.0) RETURN
            IF (CTMA(1:LCTM).EQ.' ') GO TO 111
            CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,360.,0.)
            IF (ICFELL('CPHLLB',9).NE.0) RETURN
            CALL HLUCPCHHL (-1-4*IHOL)
            IF (ICFELL('CPHLLB',10).NE.0) RETURN
            CALL PCGETR ('DL',DTOL)
            IF (ICFELL('CPHLLB',11).NE.0) RETURN
            CALL PCGETR ('DR',DTOR)
            IF (ICFELL('CPHLLB',12).NE.0) RETURN
            CALL PCGETR ('DB',DTOB)
            IF (ICFELL('CPHLLB',13).NE.0) RETURN
            CALL PCGETR ('DT',DTOT)
            IF (ICFELL('CPHLLB',14).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 111
              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 111
                  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 111
                  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('CPHLLB',15).NE.0) RETURN
                YLBC=CFUY(YCLB)
                IF (ICFELL('CPHLLB',16).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 111
C
              END FOR
C
            END IF
C
            NLBS=NLBS+1
            IF (4*NLBS.GT.LR03)
              CALL CPGRWS (RWRK,3,MAX(4*NLBS,LR03+100),IWSE)
              IF (IWSE.NE.0)
                NLBS=NLBS-1
                GO TO 110
              ELSE IF (ICFELL('CPHLLB',17).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 CPGRWS (RWRK,4,MAX(NR04,LR04+100),IWSE)
              IF (IWSE.NE.0)
                NLBS=NLBS-1
                GO TO 110
              ELSE IF (ICFELL('CPHLLB',18).NE.0)
                NLBS=NLBS-1
                RETURN
              END IF
            END IF
            RWRK(IR04+NR04-5)=REAL(IHOL+1)
            RWRK(IR04+NR04-4)=ZDAT(IPNT,JPNT)
            RWRK(IR04+NR04-3)=DTOL
            RWRK(IR04+NR04-2)=DTOR
            RWRK(IR04+NR04-1)=DTOB
            RWRK(IR04+NR04  )=DTOT
C
          END IF
C
  111   END BLOCK
C
      END


      SUBROUTINE CPHLSO (RWRK,IDRW,MRWK,NRWK,IWRK)
C
        DIMENSION RWRK(IDRW,*),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 MRWK*NRWK reals in an array RWRK (whose first dimension is IDRW)
C and an integer array IWRK of length MRWK*NRWK, CPHLSO returns in IWRK
C an array of indices of the elements of RWRK such that, if M and N are
C in [1,MRWK*NRWK] and M.LE.N, then the element of RWRK indexed by the
C Mth element of IWRK is less than or equal to the one indexed by the
C Nth element of IWRK.
C
C RVAL is an arithmetic statement function which, given an integer
C index I between 0 and MRWK*NRWK-1, has as its value the Ith element
C (in column-wise order) of the array RWRK.
C
        RVAL(I)=RWRK(MOD(I,MRWK)+1,I/MRWK+1)
C
C If the first dimension of the array of data to be sorted is equal to
C the first dimension of the FORTRAN array in which it is stored, use
C a simpler, faster version of the code to process it.
C
        IF (IDRW.EQ.MRWK)
          CALL CPHLS2 (RWRK,MRWK*NRWK,IWRK)
C
C Otherwise ...
C
        ELSE
C
C ... generate indices 0 through MRWK*NRWK-1 in the array IWRK and ...
C
          DO 101 I=1,MRWK*NRWK
            IWRK(I)=I-1
  101     CONTINUE
C
C ... sort them.
C                                                                       
          K=0
C
  102     IF (3*K+1.LT.MRWK*NRWK)
            K=3*K+1
            GO TO 102
          END IF
C
  103     IF (K.GT.0)
C
            DO 105 I=1,MRWK*NRWK-K
C
              J=I
C
  104         IF (RVAL(IWRK(J)).LE.RVAL(IWRK(J+K))) GO TO 105
              ITMP=IWRK(J)
              IWRK(J)=IWRK(J+K)
              IWRK(J+K)=ITMP
              J=J-K
              IF (J.LT.1) GO TO 105
              GO TO 104
C
  105       CONTINUE
C
            K=(K-1)/3
C
            GO TO 103
C
          END IF
C
        END IF
C
C Done.
C
        RETURN
C
      END                                                               


      SUBROUTINE CPHLS2 (RWRK,NRWK,IWRK)
C
        DIMENSION RWRK(NRWK),IWRK(NRWK)
C
C This is a modified version of a sort routine from TDPACK.  I think the
C original came from Fred Clare.
C
C Given an array of NRWK reals in an array RWRK, this routine returns
C a permutation vector IWRK such that, for every I and J such that
C 1.LE.I.LE.J.LE.NRWK, then RWRK(IWRK(I)).LE.RWRK(IWRK(J)).
C
        DO 101 I=1,NRWK
          IWRK(I)=I-1
  101   CONTINUE
C                                                                       
        K=0
C
  102   IF (3*K+1.LT.NRWK)
          K=3*K+1
          GO TO 102
        END IF
C
  103   IF (K.GT.0)
C
          DO 105 I=1,NRWK-K
C
            J=I
C
  104       IF (RWRK(IWRK(J)+1).LE.RWRK(IWRK(J+K)+1)) GO TO 105
            ITMP=IWRK(J)
            IWRK(J)=IWRK(J+K)
            IWRK(J+K)=ITMP
            J=J-K
            IF (J.LT.1) GO TO 105
            GO TO 104
C
  105     CONTINUE
C
          K=(K-1)/3
C
          GO TO 103
C
        END IF
C
C Done.
C
        RETURN
C
      END                                                               


      SUBROUTINE CPINIT (ZDAT,RWRK,IWRK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Define a variable which will hold a single character.
C
        CHARACTER*1 SCHR
C
C Decide what the range of values in X and Y should be.
C
        IF (UXA1.EQ.UXAM)
          XAT1=1.
          XATM=REAL(IZDM)
        ELSE
          XAT1=UXA1
          XATM=UXAM
        END IF
C
        IF (UYA1.EQ.UYAN)
          YAT1=1.
          YATN=REAL(IZDN)
        ELSE
          YAT1=UYA1
          YATN=UYAN
        END IF
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('CPINIT',1).NE.0) RETURN
C
        ELSE
C
          LNLG=1
C
          IF (UWDL.EQ.UWDR)
            XWDL=XAT1
            XWDR=XATM
          ELSE
            XWDL=UWDL
            XWDR=UWDR
          END IF
C
          IF (UWDB.EQ.UWDT)
            YWDB=YAT1
            YWDT=YATN
          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('CPINIT',2).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.
C
        MIRO=0
C
        RZDM=(XATM-XAT1)/REAL(IZDM-1)
        RZDN=(YATN-YAT1)/REAL(IZDN-1)
C
        DO (I=1,IZDM-1)
          DO (J=1,IZDN-1)
            XCFP=XAT1+RZDM*(REAL(I  )-1.)
            YCFP=YAT1+RZDN*(REAL(J  )-1.)
            XCLP=XAT1+RZDM*(REAL(I+1)-1.)
            YCLP=YAT1+RZDN*(REAL(J+1)-1.)
            XCPR=XAT1+RZDM*(REAL(I+1)-1.)
            YCPR=YAT1+RZDN*(REAL(J  )-1.)
            IF (IMPF.NE.0)
              XTMP=XCFP
              YTMP=YCFP
              CALL HLUCPMPXY (IMPF,XTMP,YTMP,XCFP,YCFP)
              IF (ICFELL('CPINIT',3).NE.0) RETURN
              IF ((OORV.NE.0.).AND.(XCFP.EQ.OORV.OR.YCFP.EQ.OORV))
     +                                                         GO TO 101
              XTMP=XCLP
              YTMP=YCLP
              CALL HLUCPMPXY (IMPF,XTMP,YTMP,XCLP,YCLP)
              IF (ICFELL('CPINIT',4).NE.0) RETURN
              IF ((OORV.NE.0.).AND.(XCLP.EQ.OORV.OR.YCLP.EQ.OORV))
     +                                                         GO TO 101
              XTMP=XCPR
              YTMP=YCPR
              CALL HLUCPMPXY (IMPF,XTMP,YTMP,XCPR,YCPR)
              IF (ICFELL('CPINIT',5).NE.0) RETURN
              IF ((OORV.NE.0.).AND.(XCPR.EQ.OORV.OR.YCPR.EQ.OORV))
     +                                                         GO TO 101
              IF (ABS(XCLP-XCFP).LT..0001*ABS(XWDR-XWDL).AND.
     +            ABS(YCLP-YCFP).LT..0001*ABS(YWDT-YWDB)) GO TO 101
              IF (ABS(XCPR-XCFP).LT..0001*ABS(XWDR-XWDL).AND.
     +            ABS(YCPR-YCFP).LT..0001*ABS(YWDT-YWDB)) GO TO 101
              IF (ABS(XCLP-XCPR).LT..0001*ABS(XWDR-XWDL).AND.
     +            ABS(YCLP-YCPR).LT..0001*ABS(YWDT-YWDB)) GO TO 101
              IF (ABS(XCLP-XCFP).GT..5*ABS(XWDR-XWDL).OR.
     +            ABS(YCLP-YCFP).GT..5*ABS(YWDT-YWDB)) GO TO 101
              IF (ABS(XCPR-XCFP).GT..5*ABS(XWDR-XWDL).OR.
     +            ABS(YCPR-YCFP).GT..5*ABS(YWDT-YWDB)) GO TO 101
              IF (ABS(XCLP-XCPR).GT..5*ABS(XWDR-XWDL).OR.
     +            ABS(YCLP-YCPR).GT..5*ABS(YWDT-YWDB)) GO TO 101
            END IF
            IF (XCLP.EQ.XCFP.AND.YCLP.EQ.YCFP) GO TO 101
            IF (ABS(XCLP-XCFP).LT.ABS(YCLP-YCFP))
              IF (XCPR.LT.XCFP+((XCLP-XCFP)/(YCLP-YCFP))*(YCPR-YCFP))
                IF (YCFP.LT.YCLP) MIRO=1
                GO TO 102
              ELSE
                IF (YCFP.GT.YCLP) MIRO=1
                GO TO 102
              END IF
            ELSE
              IF (YCPR.LT.YCFP+((YCLP-YCFP)/(XCLP-XCFP))*(XCPR-XCFP))
                IF (XCFP.GT.XCLP) MIRO=1
                GO TO 102
              ELSE
                IF (XCFP.LT.XCLP) MIRO=1
                GO TO 102
              END IF
            END IF
  101       CONTINUE
          END DO
        END DO
C
  102   CONTINUE
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
        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 CONPACK, 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 Find the minimum and maximum values in the field.
C
        ITMP=0
        ZMIN=0.
        ZMAX=0.
C
        DO (I=1,IZDM)
          DO (J=1,IZDN)
            IF (SVAL.EQ.0..OR.ZDAT(I,J).NE.SVAL)
              IF (ITMP.EQ.0)
                ITMP=1
                ZMIN=ZDAT(I,J)
                ZMAX=ZDAT(I,J)
              ELSE
                ZMIN=MIN(ZMIN,ZDAT(I,J))
                ZMAX=MAX(ZMAX,ZDAT(I,J))
              END IF
            END IF
          END DO
        END DO
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 (ZMAX-ZMIN.LE.10.*EPSI*ABS((ZMIN+ZMAX)/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 CPNUMB (MAX(ABS(ZMIN/SCFU),ABS(ZMAX/SCFU)),1,-10000,-1,-1,
     +                      ' ',' ',' ',0,0,0,0,0,0,SCHR,NCHS,NDGS,IEVA)
        LSDM=IEVA-1
C
        IF (ICFF.EQ.0)
          CALL CPNUMB ((ZMAX-ZMIN)/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('CPINIT',6).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 CPINLB (ZDAT,RWRK,IWRK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C CPINLB 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 CONPACK common blocks.
C
.CALL CPCOMN,/$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 CPSBST (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('CPINLB',1).NE.0) RETURN
        YLBC=CFUY(YPFS)
        IF (ICFELL('CPINLB',2).NE.0) RETURN
        WCFS=CHWM*WCIL*(XVPR-XVPL)
        WWFS=CHWM*WWIL*(XVPR-XVPL)
C
        CALL PCGETI ('TE',ITMP)
        IF (ICFELL('CPINLB',3).NE.0) RETURN
        CALL PCSETI ('TE',1)
        IF (ICFELL('CPINLB',4).NE.0) RETURN
        CALL HLUCPCHIL (+1)
        IF (ICFELL('CPINLB',5).NE.0) RETURN
        IF (CTMA(1:LCTM).EQ.' ') GO TO 101
        CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,360.,0.)
        IF (ICFELL('CPINLB',6).NE.0) RETURN
        CALL HLUCPCHIL (-1)
        IF (ICFELL('CPINLB',7).NE.0) RETURN
        CALL PCGETR ('DL',DSTL)
        IF (ICFELL('CPINLB',8).NE.0) RETURN
        CALL PCGETR ('DR',DSTR)
        IF (ICFELL('CPINLB',9).NE.0) RETURN
        CALL PCGETR ('DB',DSTB)
        IF (ICFELL('CPINLB',10).NE.0) RETURN
        CALL PCGETR ('DT',DSTT)
        IF (ICFELL('CPINLB',11).NE.0) RETURN
        CALL PCSETI ('TE',ITMP)
        IF (ICFELL('CPINLB',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('CPINLB',13).NE.0) RETURN
        YLBC=CFUY(YPFS)
        IF (ICFELL('CPINLB',14).NE.0) RETURN
C
        NLBS=NLBS+1
        IF (4*NLBS.GT.LR03)
          CALL CPGRWS (RWRK,3,MAX(4*NLBS,LR03+100),IWSE)
          IF (IWSE.NE.0.OR.ICFELL('CPINLB',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 CPGRWS (RWRK,4,MAX(NR04,LR04+100),IWSE)
          IF (IWSE.NE.0.OR.ICFELL('CPINLB',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 CPINRC
C
C CPINRC sets constants that are required by CONPACK 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 CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/1/
C
C Do a call forcing a BLOCKDATA to be loaded from a binary library.
C
        CALL CPBLDA
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 CPNUMB.
C
        NSDR=0
C
        REPEAT
          NSDR=NSDR+1
          CALL CPINRK (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 CPINRK (NSDR,TMP1,TMP2,TMP3)
C
C This routine computes some quantities needed by CPINRC; 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 CPNUMB (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 CONPACK common blocks.
C
.CALL CPCOMN,/$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 CPPLAR (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 CPPLAR is to position one or more labels at regular intervals along
C that portion.
C
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$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('CPPLAR',1).NE.0) RETURN
          RWRK(IPTY+I)=CUFY(RWRK(IPTY+I))
          IF (ICFELL('CPPLAR',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.*(CPRANF()-.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('CPPLAR',3).NE.0) RETURN
            YLBC=CFUY(YCLB)
            IF (ICFELL('CPPLAR',4).NE.0) RETURN
C
            ZDVL=CLEV(ICLV)
C
            LCTM=NCLB(ICLV)
            CTMA(1:LCTM)=CLBL(ICLV)(1:LCTM)
            CTMB(1:LCTM)=CTMA(1:LCTM)
C
            CALL HLUCPCHLL (+1)
            IF (ICFELL('CPPLAR',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',ITMP)
              IF (ICFELL('CPPLAR',6).NE.0) RETURN
              CALL PCSETI ('TE',1)
              IF (ICFELL('CPPLAR',7).NE.0) RETURN
              CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,360.,0.)
              IF (ICFELL('CPPLAR',8).NE.0) RETURN
              CALL PCGETR ('DL',DTOL)
              IF (ICFELL('CPPLAR',9).NE.0) RETURN
              CALL PCGETR ('DR',DTOR)
              IF (ICFELL('CPPLAR',10).NE.0) RETURN
              CALL PCGETR ('DB',DTOB)
              IF (ICFELL('CPPLAR',11).NE.0) RETURN
              CALL PCGETR ('DT',DTOT)
              IF (ICFELL('CPPLAR',12).NE.0) RETURN
              CALL PCSETI ('TE',ITMP)
              IF (ICFELL('CPPLAR',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 CPGRWS (RWRK,3,MAX(4*NLBS,LR03+100),IWSE)
              IPTX=IPTX-IS01+IR01
              IPTY=IPTY-IS01+IR01
              IF (IWSE.NE.0.OR.ICFELL('CPPLAR',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 CPGRWS (RWRK,4,MAX(NR04,LR04+100),IWSE)
                IPTX=IPTX-IS01+IR01
                IPTY=IPTY-IS01+IR01
                IF (IWSE.NE.0.OR.ICFELL('CPPLAR',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.*(CPRANF()-.5)*DBLV
C
          END IF
C
  101   END DO
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE CPPLPS (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 CPPLPS 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 CONPACK common blocks.
C
.CALL CPCOMN,/$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('CPPLPS',1).NE.0) RETURN
          RWRK(IPTY+I)=CUFY(RWRK(IPTY+I))
          IF (ICFELL('CPPLPS',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 IMIN will hold the index of the point at which the penalty function
C is minimized and PMIN will hold the value of the penalty function
C there.  Give them initial values which indicate nothing found so far.
C
          IMIN=0
          PMIN=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('CPPLPS',3).NE.0) RETURN
            YLBC=CFUY(YCLB)
            IF (ICFELL('CPPLPS',4).NE.0) RETURN
C
            ZDVL=CLEV(ICLV)
C
            LCTM=NCLB(ICLV)
            CTMA(1:LCTM)=CLBL(ICLV)(1:LCTM)
            CTMB(1:LCTM)=CTMA(1:LCTM)
C
            CALL HLUCPCHLL (+1)
            IF (ICFELL('CPPLPS',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',ITMP)
              IF (ICFELL('CPPLPS',6).NE.0) RETURN
              CALL PCSETI ('TE',1)
              IF (ICFELL('CPPLPS',7).NE.0) RETURN
              CALL PLCHHQ (XLBC,YLBC,CTMA(1:LCTM),WCFS,360.,0.)
              IF (ICFELL('CPPLPS',8).NE.0) RETURN
              CALL PCGETR ('DL',DTOL)
              IF (ICFELL('CPPLPS',9).NE.0) RETURN
              CALL PCGETR ('DR',DTOR)
              IF (ICFELL('CPPLPS',10).NE.0) RETURN
              CALL PCGETR ('DB',DTOB)
              IF (ICFELL('CPPLPS',11).NE.0) RETURN
              CALL PCGETR ('DT',DTOT)
              IF (ICFELL('CPPLPS',12).NE.0) RETURN
              CALL PCSETI ('TE',ITMP)
              IF (ICFELL('CPPLPS',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 (IMIN.EQ.0.OR.PNAL.LT.PMIN)
              IMIN=I
              PMIN=PNAL
              XMIN=XCLB
              YMIN=YCLB
              AMIN=ANLB
              ISCF=ICHF
              SDTL=DTOL
              SDTR=DTOR
              SDTB=DTOB
              SDTT=DTOT
            END IF
C
  102     END DO
C
          IF (IMIN.NE.0)
            NLBS=NLBS+1
            IF (4*NLBS.GT.LR03)
              IS01=IR01
              CALL CPGRWS (RWRK,3,MAX(4*NLBS,LR03+100),IWSE)
              IPTX=IPTX-IS01+IR01
              IPTY=IPTY-IS01+IR01
              IF (IWSE.NE.0.OR.ICFELL('CPPLPS',14).NE.0)
                NLBS=NLBS-1
                RETURN
              END IF
            END IF
            RWRK(IR03+4*(NLBS-1)+1)=XMIN
            RWRK(IR03+4*(NLBS-1)+2)=YMIN
            RWRK(IR03+4*(NLBS-1)+3)=AMIN
            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 CPGRWS (RWRK,4,MAX(NR04,LR04+100),IWSE)
                IPTX=IPTX-IS01+IR01
                IPTY=IPTY-IS01+IR01
                IF (IWSE.NE.0.OR.ICFELL('CPPLPS',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 (IMIN.EQ.0)
C
C Done.
C
        RETURN
C
      END


      FUNCTION CPRANF ()
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
        CPRANF=RSEQ(ISEQ)
        RETURN
      END


      SUBROUTINE CPSBST (CHSI,CHSO,NCHO)
C
        CHARACTER*(*) CHSI,CHSO
C
C The routine CPSBST 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, '$ZDV$' is
C replaced by a string representing the numeric value of ZDVL.  The
C length of the resulting string is returned as the value of NCHO.
C
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$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.'ZDV')
                VALU=ZDVL
                INVOKE (TRANSLATE-UNROUNDED-NUMBER)
              ELSE IF (CHSI(KCHI+1:KCHI+3).EQ.'ZMN')
                VALU=ZMIN
                INVOKE (TRANSLATE-UNROUNDED-NUMBER)
              ELSE IF (CHSI(KCHI+1:KCHI+3).EQ.'ZMX')
                VALU=ZMAX
                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 CPNUMB (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 CPSORT (RVAL,NVAL,IPER)
C
        DIMENSION RVAL(NVAL),IPER(NVAL)
C
C Given an array of NVAL reals in an array RVAL, this routine returns a
C permutation vector IPER such that, given I and J, 1.LE.I.LE.J.LE.NVAL,
C RVAL(IPER(I)).LE.RVAL(IPER(J)).
C
C A Shell sort is used.  Details of the algorithm may be found in the
C book "Algorithms" by Robert Sedgewick.
C                                                                       
C Note:  Fred Clare wrote the original version of this routine.  I have
C adapted it for use in CONPACK; among other things, the error checking
C has been been removed because the calling routine does it.  (DJK)
C                                                                       
        DO (I=1,NVAL)
          IPER(I)=I
        END DO
C                                                                       
        K=0
C
        WHILE (3*K+1.LT.NVAL)
          K=3*K+1
        END WHILE
C                                                                       
        WHILE (K.GT.0)
C
          DO (I=1,NVAL-K)
C
            J=I
C
            LOOP
              EXIT IF (RVAL(IPER(J)).LE.RVAL(IPER(J+K)))
              ITMP=IPER(J)
              IPER(J)=IPER(J+K)
              IPER(J+K)=ITMP
              J=J-K
              EXIT IF (J.LT.1)
            END LOOP
C
          END DO
C                                                                       
          K=(K-1)/3
C
        END WHILE
C
C Done.
C
        RETURN
C
      END                                                               


      SUBROUTINE CPSTLS (ZDAT,RWRK,IWRK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C The routine CPSTLS is called to set the label-size parameters.
C
C ZDAT is the user's data array.
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 CONPACK common blocks.
C
.CALL CPCOMN,/$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',ITMP)
            IF (ICFELL('CPSTLS',1).NE.0) RETURN
            CALL PCSETI ('TE',1)
            IF (ICFELL('CPSTLS',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('CPSTLS',3).NE.0) RETURN
            CALL PCGETR ('DB',DSTB)
            IF (ICFELL('CPSTLS',4).NE.0) RETURN
            CALL PCGETR ('DL',DSTL)
            IF (ICFELL('CPSTLS',5).NE.0) RETURN
            CALL PCGETR ('DR',DSTR)
            IF (ICFELL('CPSTLS',6).NE.0) RETURN
            CALL PCGETR ('DT',DSTT)
            IF (ICFELL('CPSTLS',7).NE.0) RETURN
            CALL PCSETI ('TE',ITMP)
            IF (ICFELL('CPSTLS',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 CPTRCL (ZDAT,RWRK,IWRK,CLVL,IJMP,IRW1,IRW2,NRWK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C Given ZDAT (an array of data), RWRK (a real workspace), IWRK (an
C integer workspace), and CLVL (a particular contour level), CPTRCL
C finds the beginning of each contour line at the level CLVL and then
C traces it.  Control is passed back to the caller to process the
C line segments generated.
C
C ZDAT is the doubly-dimensioned array of data being contoured.
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 CPTRCL.
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 CONPACK common blocks.
C
.CALL CPCOMN,/$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 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 (105,103,104,106,107,108) , IJMP
C
C Otherwise, compute some needed conversion constants.
C
        RZDM=(XATM-XAT1)/REAL(IZDM-1)
        RZDN=(YATN-YAT1)/REAL(IZDN-1)
C
C Assign space to use for storing the coordinates of points on contour
C lines.
C
        IF (T2DS.EQ.0.)
          CALL CPGRWS (RWRK,1,2*LRWC,IWSE)
        ELSE
          CALL CPGRWS (RWRK,1,7*LRWC,IWSE)
        END IF
C
        IF (IWSE.NE.0.OR.ICFELL('CPTRCL',1).NE.0) GO TO 102
C
C Set the offset from one portion of the real workspace to the next.
C
        MPLS=LRWC
C
C Set some tolerances.
C
        IF (T2DS.LT.0.)
          DBPI=ABS(XATM-XAT1)*SEGL
          EPSX=ABS(XATM-XAT1)*EPSI
          EPSY=ABS(YATN-YAT1)*EPSI
        ELSE
          DBPI=ABS(XWDR-XWDL)*SEGL
          EPSX=ABS(XWDR-XWDL)*EPSI
          EPSY=ABS(YWDT-YWDB)*EPSI
        END IF
C
        SMLX=.01*ABS(XWDR-XWDL)
        SMLY=.01*ABS(YWDT-YWDB)
C
        PITX=PITH*ABS(XWDR-XWDL)
        PITY=PITH*ABS(YWDT-YWDB)
C
C Zero the count of horizontal segments seen so far.
C
        NHSS=0
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 Set IOCF to indicate that we are looking for open contours.
C
        IOCF=0
C
C Search the bottom edge of the grid.
C
        IVBY=1
        FOR (IVBX = 2 TO IZDM)
          IF (ZDAT(IVBX-1,1).LT.CLVL.AND.ZDAT(IVBX,1).GE.CLVL)
            INCI=1
            INVOKE (FOLLOW-THE-LINE)
          END IF
        END FOR
C
C Search the right edge of the grid.
C
        IVBX=IZDM
        FOR (IVBY = 2 TO IZDN)
          IF (ZDAT(IZDM,IVBY-1).LT.CLVL.AND.ZDAT(IZDM,IVBY).GE.CLVL)
            INCI=7
            INVOKE (FOLLOW-THE-LINE)
          END IF
        END FOR
C
C Search the top edge of the grid.
C
        IVBY=IZDN
        FOR (IVBX = IZDM-1 TO 1 BY -1)
          IF (ZDAT(IVBX+1,IZDN).LT.CLVL.AND.ZDAT(IVBX,IZDN).GE.CLVL)
            INCI=5
            INVOKE (FOLLOW-THE-LINE)
          END IF
        END FOR
C
C Search the left edge of the grid.
C
        IVBX=1
        FOR (IVBY = IZDN-1 TO 1 BY -1)
          IF (ZDAT(1,IVBY+1).LT.CLVL.AND.ZDAT(1,IVBY).GE.CLVL)
            INCI=3
            INVOKE (FOLLOW-THE-LINE)
          END IF
        END FOR
C
C Set IOCF to indicate that we are looking for closed contours.
C
        IOCF=1
C
C Search the interior of the grid.
C
        FOR (IVBY = 2 TO IZDN-1)
          FOR (IVBX = 2 TO IZDM)
            IF (ZDAT(IVBX-1,IVBY).LT.CLVL.AND.ZDAT(IVBX,IVBY).GE.CLVL)
              IPXY=IZDN*IVBX+IVBY
              DO (I=1,NHSS)
                IF (IPXY.EQ.IWRK(II01+I)) GO TO 101
              END DO
              IF (NHSS.GE.LI01)
                CALL CPGIWS (IWRK,1,LI01+100,IWSE)
                IF (IWSE.NE.0.OR.ICFELL('CPTRCL',2).NE.0) GO TO 102
              END IF
              NHSS=NHSS+1
              IWRK(II01+NHSS)=IPXY
              INCI=1
              INVOKE (FOLLOW-THE-LINE)
  101       END IF
          END FOR
        END FOR
C
C Done.
C
  102   LI01=0
        LR01=0
        IJMP=0
        RETURN
C
C Line-following algorithm.  This internal routine moves the line-
C following vector (defined by the base point (IVBX,IVBY) and the
C components INCX(INCI) and INCY(INCI)) along a contour line.  The
C points defining the contour line are thereby determined.  The
C process stops when either the starting point or the edge of the
C grid is encountered.
C
        BLOCK (FOLLOW-THE-LINE)
C
C Save the variables defining the original position of the line-
C following vector.
C
          MVBX=IVBX
          MVBY=IVBY
          MNCI=INCI
C
C Set variables defining the position of the end of the vector.
C
          IVEX=IVBX+INCX(INCI)
          IVEY=IVBY+INCY(INCI)
C
C Compute the coordinates, in the data-index coordinate system, of the
C starting position of the contour line.  If the point is very close to
C a grid intersection, put it at the intersection; this avoids problems
C caused by very short line segments.  Also, be careful to compute the
C value of XFRA using code exactly like that in CPTREG and CPTRES, thus
C ensuring that points they interpolate where contour lines intersect
C the edge of the grid or the edges of special-value areas will match
C the points generated here.
C
          IF (IVEX.GT.IVBX)
            XFRA=FRCT(ZDAT(IVBX,IVBY),ZDAT(IVEX,IVEY))
            IF (XFRA.LE..00001) XFRA=0.
            IF (XFRA.GE..99999) XFRA=1.
            XCND=REAL(IVBX)+XFRA
            YCND=REAL(IVBY)
          ELSE IF (IVEX.LT.IVBX)
            XFRA=FRCT(ZDAT(IVEX,IVEY),ZDAT(IVBX,IVBY))
            IF (XFRA.LE..00001) XFRA=0.
            IF (XFRA.GE..99999) XFRA=1.
            XCND=REAL(IVEX)+XFRA
            YCND=REAL(IVEY)
          ELSE IF (IVEY.GT.IVBY)
            XCND=REAL(IVBX)
            YFRA=FRCT(ZDAT(IVBX,IVBY),ZDAT(IVEX,IVEY))
            IF (YFRA.LE..00001) YFRA=0.
            IF (YFRA.GE..99999) YFRA=1.
            YCND=REAL(IVBY)+YFRA
          ELSE
            XCND=REAL(IVEX)
            YFRA=FRCT(ZDAT(IVEX,IVEY),ZDAT(IVBX,IVBY))
            IF (YFRA.LE..00001) YFRA=0.
            IF (YFRA.GE..99999) YFRA=1.
            YCND=REAL(IVEY)+YFRA
          END IF
C
C Map the coordinates (XCND,YCND) into user coordinates (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 system to segment length in the data-index system.
C
          NPLS=0
          IFSF=1
          RUDN=0.
C
C Loop, moving the line-following vector as dictated by the positions
C of its end points.
C
          LOOP
C
C At this point, we know that the base of the line-following vector is
C on the high side of the contour and that the end of it is on the other
C side.  Move the vector clockwise and see what the situation is then.
C
            INCI=INCI+1
            IF (INCI.GT.8) INCI=INCI-8
            IVEX=IVBX+INCX(INCI)
            IVEY=IVBY+INCY(INCI)
C
C Exit the loop if we've hit the edge.
C
            EXIT IF (IVEX.LT.1.OR.IVEX.GT.IZDM.OR.
     +               IVEY.LT.1.OR.IVEY.GT.IZDN)
C
C If the end of the line-following vector is now on the same side of
C the contour line as its base ...
C
            IF (ZDAT(IVEX,IVEY).GE.CLVL)
C
C flip it end-for-end and continue the loop.
C
              IVBX=IVEX
              IVBY=IVEY
              INCI=INCI+4
C
C Otherwise, if the line-following vector is currently horizontal or
C vertical, we have another point to add to the contour line ...
C
            ELSE IF ((INCI/2)*2.NE.INCI)
C
C so save the coordinates of the old point and compute the coordinates
C of the new one.
C
              XCOD=XCND
              YCOD=YCND
              XCOU=XCNU
              YCOU=YCNU
              IVOU=IVNU
C
              IF (IVEX.GT.IVBX)
                XFRA=FRCT(ZDAT(IVBX,IVBY),ZDAT(IVEX,IVEY))
                IF (XFRA.LE..00001) XFRA=0.
                IF (XFRA.GE..99999) XFRA=1.
                XCND=REAL(IVBX)+XFRA
                YCND=REAL(IVBY)
              ELSE IF (IVEX.LT.IVBX)
                XFRA=FRCT(ZDAT(IVEX,IVEY),ZDAT(IVBX,IVBY))
                IF (XFRA.LE..00001) XFRA=0.
                IF (XFRA.GE..99999) XFRA=1.
                XCND=REAL(IVEX)+XFRA
                YCND=REAL(IVEY)
              ELSE IF (IVEY.GT.IVBY)
                XCND=REAL(IVBX)
                YFRA=FRCT(ZDAT(IVBX,IVBY),ZDAT(IVEX,IVEY))
                IF (YFRA.LE..00001) YFRA=0.
                IF (YFRA.GE..99999) YFRA=1.
                YCND=REAL(IVBY)+YFRA
              ELSE
                XCND=REAL(IVEX)
                YFRA=FRCT(ZDAT(IVEX,IVEY),ZDAT(IVBX,IVBY))
                IF (YFRA.LE..00001) YFRA=0.
                IF (YFRA.GE..99999) YFRA=1.
                YCND=REAL(IVEY)+YFRA
              END IF
C
C Map the coordinates (XCND,YCND) into user coordinates (XCNU,YCNU).
C
              INVOKE (COMPUTE-USER-COORDINATES)
C
C Save the coordinates of the point.  Special values complicate things.
C
              IF (SVAL.EQ.0.)
                INVOKE (INTERPOLATE-POINTS-ALONG-SEGMENT)
              ELSE
                IF (INCI.EQ.1)
                  INCP=9
                ELSE
                  INCP=INCI
                END IF
                IVCX=IVBX+INCX(INCP-1)
                IVCY=IVBY+INCY(INCP-1)
                IVDX=IVBX+INCX(INCP-2)
                IVDY=IVBY+INCY(INCP-2)
                IF (ZDAT(IVBX,IVBY).EQ.SVAL.OR.
     +              ZDAT(IVCX,IVCY).EQ.SVAL.OR.
     +              ZDAT(IVDX,IVDY).EQ.SVAL.OR.
     +              ZDAT(IVEX,IVEY).EQ.SVAL)
                  IF (NPLS.GT.1)
                    INVOKE (DUMP-POLYLINE-BUFFER)
                  END IF
                ELSE
                  INVOKE (INTERPOLATE-POINTS-ALONG-SEGMENT)
                END IF
              END IF
C
C If we just crossed a horizontal grid line in the upwards direction,
C save that information.
C
              IF (INCI.EQ.1)
                IF (NHSS.GE.LI01)
                  CALL CPGIWS (IWRK,1,LI01+100,IWSE)
                  IF (IWSE.NE.0.OR.ICFELL('CPTRCL',3).NE.0) GO TO 102
                END IF
                NHSS=NHSS+1
                IWRK(II01+NHSS)=IZDN*IVBX+IVBY
              END IF
C
C If we just arrived at our starting point, quit the loop.
C
              EXIT IF (IVBX.EQ.MVBX.AND.IVBY.EQ.MVBY.AND.INCI.EQ.MNCI)
C
            END IF
C
          END LOOP
C
C Process any remaining portion of the contour line.
C
          IF (NPLS.GT.1)
            INVOKE (DUMP-POLYLINE-BUFFER)
          END IF
C
C Reset the vector base to its original position.
C
          IVBX=MVBX
          IVBY=MVBY
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
            XSND=XCND
            YSND=YCND
            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)
              INVOKE (COMPUTE-USER-COORDINATES)
              IF (IPIC.GT.0.OR.IVNU.NE.IVOU)
                INVOKE (ADD-POINTS-TO-POLYLINE)
                XCOD=XCND
                YCOD=YCND
                XCOU=XCNU
                YCOU=YCNU
                IVOU=IVNU
              END IF
            END FOR
            XCND=XSND
            YCND=YSND
            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),
C which projects into (XCOU,YCOU), and (XCND,YCND), which projects into
C (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)
C
            IF (NPLS.EQ.0)
              IF (IVOU.NE.0)
                IF (IMPF.NE.0.AND.T2DS.GE.0..AND.PITH.GT.0.)
                  XCLD=XCOD
                  YCLD=YCOD
                  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
                XCVD=XCND
                YCVD=YCND
                XCVU=XCNU
                YCVU=YCNU
                INVOKE (INTERPOLATE-TO-VISIBLE-EDGE-1)
                INVOKE (OUTPUT-VISIBLE-EDGE-POINT-1)
                XCOD=XCVD
                YCOD=YCVD
                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-1)
            ELSE IF (IVOU.NE.0)
              XCVD=XCOD
              YCVD=YCOD
              XCVU=XCOU
              YCVU=YCOU
              XCID=XCND
              YCID=YCND
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE-1)
              XKND=XCND
              YKND=YCND
              XKNU=XCNU
              YKNU=YCNU
              XCND=XCVD
              YCND=YCVD
              XCNU=XCVU
              YCNU=YCVU
              INVOKE (OUTPUT-NEXT-POINT-1)
              XCND=XKND
              YCND=YKND
              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-1)
          IF (IMPF.NE.0.AND.T2DS.GE.0..AND.
     +                                   (XCND.NE.XCOD.OR.YCND.NE.YCOD))
            RUDO=RUDN
            RUDN=(ABS(XCNU-XCOU)+ABS(YCNU-YCOU))/
     +           (ABS(XCND-XCOD)+ABS(YCND-YCOD))
            IF (RUDN.GT.2.*RUDO)
              INVOKE (CHECK-FOR-POSSIBLE-DISCONTINUITY-1)
            END IF
            IF (PITH.GT.0.)
              XCTD=XCND
              YCTD=YCND
              XCTU=XCNU
              YCTU=YCNU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING-1)
            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-1)
          XC1D=XCOD
          YC1D=YCOD
          XC1U=XCOU
          YC1U=YCOU
          XC2D=XCND
          YC2D=YCND
          XC2U=XCNU
          YC2U=YCNU
          ITMP=0
          LOOP
            DSTO=ABS(XC2U-XC1U)+ABS(YC2U-YC1U)
            XC3D=(XC1D+XC2D)/2.
            YC3D=(YC1D+YC2D)/2.
            CALL HLUCPMPXY (IMPF,XAT1+RZDM*(XC3D-1.),
     +                           YAT1+RZDN*(YC3D-1.),
     +                                     XC3U,YC3U)
            IF (ICFELL('CPTRCL',4).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)
                XC1D=XC3D
                YC1D=YC3D
                XC1U=XC3U
                YC1U=YC3U
              ELSE
                EXIT IF (XC3D.EQ.XC2D.AND.YC3D.EQ.YC2D)
                XC2D=XC3D
                YC2D=YC3D
                XC2U=XC3U
                YC2U=YC3U
              END IF
              ITMP=ITMP+1
              EXIT IF (ITMP.EQ.64)
            ELSE
              XCVD=XCOD
              YCVD=YCOD
              XCVU=XCOU
              YCVU=YCOU
              XCID=XC3D
              YCID=YC3D
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE-1)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT-1)
              INVOKE (DUMP-POLYLINE-BUFFER)
              XCID=XC3D
              YCID=YC3D
              XCVD=XCND
              YCVD=YCND
              XCVU=XCNU
              YCVU=YCNU
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE-1)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT-1)
              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.T2DS.GE.0..AND.PITH.GT.0.)
              XCTD=XC1D
              YCTD=YC1D
              XCTU=XC1U
              YCTU=YC1U
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING-1)
            END IF
            NPLS=NPLS+1
            RWRK(IR01+NPLS)=XC1U
            RWRK(IR01+MPLS+NPLS)=YC1U
            INVOKE (DUMP-POLYLINE-BUFFER)
            IF (IMPF.NE.0.AND.T2DS.GE.0..AND.PITH.GT.0.)
              XCLD=XC2D
              YCLD=YC2D
              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-1)
          ITMP=0
          LOOP
            XCHD=(XCVD+XCID)/2.
            YCHD=(YCVD+YCID)/2.
            CALL HLUCPMPXY (IMPF,XAT1+RZDM*(XCHD-1.),
     +                           YAT1+RZDN*(YCHD-1.),
     +                                     XCHU,YCHU)
            IF (ICFELL('CPTRCL',5).NE.0) GO TO 102
            IF (XCHU.NE.OORV.AND.YCHU.NE.OORV)
              EXIT IF (XCHD.EQ.XCVD.AND.YCHD.EQ.YCVD)
              XCVD=XCHD
              YCVD=YCHD
              XCVU=XCHU
              YCVU=YCHU
            ELSE
              EXIT IF (XCHD.EQ.XCID.AND.YCHD.EQ.YCID)
              XCID=XCHD
              YCID=YCHD
            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-1)
          IF (IMPF.NE.0.AND.T2DS.GE.0..AND.PITH.GT.0.)
            IF (NPLS.EQ.0)
              XCLD=XCVD
              YCLD=YCVD
              XCLU=XCVU
              YCLU=YCVU
            ELSE
              XCTD=XCVD
              YCTD=YCVD
              XCTU=XCVU
              YCTU=YCVU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING-1)
            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-1)
          WHILE (ABS(XCTU-XCLU).GT.PITX.OR.ABS(YCTU-YCLU).GT.PITY)
            IFND=0
            XCQD=0.
            YCQD=0.
            RDST=.50
            RSTP=.25
            LOOP
              XCPD=XCLD+RDST*(XCTD-XCLD)
              YCPD=YCLD+RDST*(YCTD-YCLD)
              CALL HLUCPMPXY (IMPF,XAT1+RZDM*(XCPD-1.),
     +                             YAT1+RZDN*(YCPD-1.),
     +                                       XCPU,YCPU)
              IF (ICFELL('CPTRCL',6).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
                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))
              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
              XCLU=XCQU
              YCLU=YCQU
            ELSE
              XCLD=XCTD
              YCLD=YCTD
              XCLU=XCTU
              YCLU=YCTU
            END IF
          END WHILE
          XCLD=XCTD
          YCLD=YCTD
          XCLU=XCTU
          YCLU=YCTU
        END BLOCK
C
C The following internal procedure is given the data-system coordinates
C of a point (XCND,YCND) and computes the user-system coordinates of
C 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
          XCNU=XAT1+RZDM*(XCND-1.)
          YCNU=YAT1+RZDN*(YCND-1.)
          IVNU=1
C
          IF (IMPF.NE.0.AND.T2DS.GE.0.)
            XTMP=XCNU
            YTMP=YCNU
            CALL HLUCPMPXY (IMPF,XTMP,YTMP,XCNU,YCNU)
            IF (ICFELL('CPTRCL',7).NE.0) GO TO 102
            IF ((OORV.NE.0.).AND.(XCNU.EQ.OORV.OR.YCNU.EQ.OORV)) IVNU=0
          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=1
              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('CPTRCL',8).NE.0) GO TO 102
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('CPTRCL',9).NE.0) GO TO 102
                ELSE
                  XTMP=RWRK(IR01+NPLS)
                  YTMP=RWRK(IR01+MPLS+NPLS)
                END IF
C
                IF (IMPF.EQ.0.OR.T2DS.GT.0.)
                  NOUT=NOUT+1
                  RWRK(IR01+5*MPLS+NOUT)=XTMP
                  RWRK(IR01+6*MPLS+NOUT)=YTMP
                ELSE
                  IF (IINT.NE.0)
                    XTOD=XTND
                    YTOD=YTND
                    XTOU=XTNU
                    YTOU=YTNU
                    IVSO=IVSN
                  END IF
                  XTND=XTMP
                  YTND=YTMP
                  CALL HLUCPMPXY (IMPF,XTND,YTND,XTNU,YTNU)
                  IF (ICFELL('CPTRCL',10).NE.0) GO TO 102
                  IVSN=1
                  IF (OORV.NE.0..AND.
     +                (XTNU.EQ.OORV.OR.YTNU.EQ.OORV)) IVSN=0
                  IF (NOUT.EQ.0)
                    IF (IVSN.NE.0)
                      IF (IINT.NE.0)
                        XTID=XTOD
                        YTID=YTOD
                        XTVD=XTND
                        YTVD=YTND
                        XTVU=XTNU
                        YTVU=YTNU
                        INVOKE (INTERPOLATE-TO-VISIBLE-EDGE-2)
                        INVOKE (OUTPUT-VISIBLE-EDGE-POINT-2)
                        XTOD=XTVD
                        YTOD=YTVD
                        XTOU=XTVU
                        YTOU=YTVU
                        IVSO=1
                      END IF
                      IF (PITH.GT.0.)
                        IF (NOUT.EQ.0)
                          XTLD=XTND
                          YTLD=YTND
                          XTLU=XTNU
                          YTLU=YTNU
                        ELSE
                          XTTD=XTND
                          YTTD=YTND
                          XTTU=XTNU
                          YTTU=YTNU
                          INVOKE (CHECK-FOR-JUMP-IN-MAPPING-2)
                        END IF
                      END IF
                      NOUT=NOUT+1
                      RWRK(IR01+5*MPLS+NOUT)=XTNU
                      RWRK(IR01+6*MPLS+NOUT)=YTNU
                    END IF
                  ELSE IF (IVSN.NE.0)
                    INVOKE (OUTPUT-NEXT-POINT-2)
                  ELSE
                    XTVD=XTOD
                    YTVD=YTOD
                    XTVU=XTOU
                    YTVU=YTOU
                    XTID=XTND
                    YTID=YTND
                    INVOKE (INTERPOLATE-TO-VISIBLE-EDGE-2)
                    XQND=XTND
                    YQND=YTND
                    XQNU=XTNU
                    YQNU=YTNU
                    XTND=XTVD
                    YTND=YTVD
                    XTNU=XTVU
                    YTNU=YTVU
                    INVOKE (OUTPUT-NEXT-POINT-2)
                    XTND=XQND
                    YTND=YQND
                    XTNU=XQNU
                    YTNU=YQNU
                    IJMP=2
                    IRW1=IR01+5*MPLS
                    IRW2=IR01+6*MPLS
                    NRWK=NOUT
                    RETURN
  103               NOUT=0
                    TUDN=0.
                  END IF
                END IF
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=3
                  IRW1=IR01+5*MPLS
                  IRW2=IR01+6*MPLS
                  NRWK=NOUT
                  RETURN
  104             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('CPTRCL',11).NE.0) GO TO 102
              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('CPTRCL',12).NE.0) GO TO 102
C
            END IF
C
          END IF
C
  105     NPLS=0
          RUDN=0.
C
C Done.
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 is activated, we check for a large enough jump in the mapped position
C to justify interpolating points.
C
        BLOCK (OUTPUT-NEXT-POINT-2)
          IF (IMPF.NE.0.AND.(XTND.NE.XTOD.OR.YTND.NE.YTOD))
            TUDO=TUDN
            TUDN=(ABS(XTNU-XTOU)+ABS(YTNU-YTOU))/
     +           (ABS(XTND-XTOD)+ABS(YTND-YTOD))
            IF (TUDN.GT.2.*TUDO)
              INVOKE (CHECK-FOR-POSSIBLE-DISCONTINUITY-2)
            END IF
          END IF
          IF (PITH.GT.0.)
            XTTD=XTND
            YTTD=YTND
            XTTU=XTNU
            YTTU=YTNU
            INVOKE (CHECK-FOR-JUMP-IN-MAPPING-2)
          END IF
          NOUT=NOUT+1
          RWRK(IR01+5*MPLS+NOUT)=XTNU
          RWRK(IR01+6*MPLS+NOUT)=YTNU
        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-2)
          XT1D=XTOD
          YT1D=YTOD
          XT1U=XTOU
          YT1U=YTOU
          XT2D=XTND
          YT2D=YTND
          XT2U=XTNU
          YT2U=YTNU
          ITMP=0
          LOOP
            DSTO=ABS(XT2U-XT1U)+ABS(YT2U-YT1U)
            XT3D=(XT1D+XT2D)/2.
            YT3D=(YT1D+YT2D)/2.
            CALL HLUCPMPXY (IMPF,XT3D,YT3D,XT3U,YT3U)
            IF (ICFELL('CPTRCL',13).NE.0) GO TO 102
            IF (OORV.EQ.0..OR.(XT3U.NE.OORV.AND.YT3U.NE.OORV))
              DST1=ABS(XT3U-XT1U)+ABS(YT3U-YT1U)
              DST2=ABS(XT3U-XT2U)+ABS(YT3U-YT2U)
              IF (MIN(DST1,DST2).GT.DSTO)
                ITMP=1000
                EXIT
              ELSE IF (DST1.LT.DST2)
                EXIT IF (XT3D.EQ.XT1D.AND.YT3D.EQ.YT1D)
                XT1D=XT3D
                YT1D=YT3D
                XT1U=XT3U
                YT1U=YT3U
              ELSE
                EXIT IF (XT3D.EQ.XT2D.AND.YT3D.EQ.YT2D)
                XT2D=XT3D
                YT2D=YT3D
                XT2U=XT3U
                YT2U=YT3U
              END IF
              ITMP=ITMP+1
              EXIT IF (ITMP.EQ.64)
            ELSE
              XTVD=XTOD
              YTVD=YTOD
              XTVU=XTOU
              YTVU=YTOU
              XTID=XT3D
              YTID=YT3D
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE-2)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT-2)
              IJMP=4
              IRW1=IR01+5*MPLS
              IRW2=IR01+6*MPLS
              NRWK=NOUT
              RETURN
  106         NOUT=0
              TUDN=0.
              XTID=XT3D
              YTID=YT3D
              XTVD=XTND
              YTVD=YTND
              XTVU=XTNU
              YTVU=YTNU
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE-2)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT-2)
              ITMP=1000
              EXIT
            END IF
          END LOOP
          IF (ITMP.NE.1000.AND.
     +               (ABS(XT1U-XT2U).GT.SMLX.OR.ABS(YT1U-YT2U).GT.SMLY))
            IF (PITH.GT.0.)
              XTTD=XT1D
              YTTD=YT1D
              XTTU=XT1U
              YTTU=YT1U
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING-2)
            END IF
            NOUT=NOUT+1
            RWRK(IR01+5*MPLS+NOUT)=XT1U
            RWRK(IR01+6*MPLS+NOUT)=YT1U
            IJMP=5
            IRW1=IR01+5*MPLS
            IRW2=IR01+6*MPLS
            NRWK=NOUT
            RETURN
  107       RWRK(IR01+5*MPLS+1)=XT2U
            RWRK(IR01+6*MPLS+1)=YT2U
            NOUT=1
            IF (PITH.GT.0.)
              XTLD=XT2D
              YTLD=YT2D
              XTLU=XT2U
              YTLU=YT2U
            END IF
            TUDN=0.
          END IF
        END BLOCK
C
C Given two points in the unmapped user 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-2)
        ITMP=0
          LOOP
            XTHD=(XTVD+XTID)/2.
            YTHD=(YTVD+YTID)/2.
            CALL HLUCPMPXY (IMPF,XTHD,YTHD,XTHU,YTHU)
            IF (ICFELL('CPTRCL',14).NE.0) GO TO 102
            IF (XTHU.NE.OORV.AND.YTHU.NE.OORV)
              EXIT IF (XTHD.EQ.XTVD.AND.YTHD.EQ.YTVD)
              XTVD=XTHD
              YTVD=YTHD
              XTVU=XTHU
              YTVU=YTHU
            ELSE
              EXIT IF (XTHD.EQ.XTID.AND.YTHD.EQ.YTID)
              XTID=XTHD
              YTID=YTHD
            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-2)
          IF (PITH.GT.0.)
            IF (NOUT.EQ.0)
              XTLD=XTVD
              YTLD=YTVD
              XTLU=XTVU
              YTLU=YTVU
            ELSE
              XTTD=XTVD
              YTTD=YTVD
              XTTU=XTVU
              YTTU=YTVU
              INVOKE (CHECK-FOR-JUMP-IN-MAPPING-2)
            END IF
          END IF
          NOUT=NOUT+1
          RWRK(IR01+5*MPLS+NOUT)=XTVU
          RWRK(IR01+6*MPLS+NOUT)=YTVU
        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-2)
          WHILE (ABS(XTTU-XTLU).GT.PITX.OR.ABS(YTTU-YTLU).GT.PITY)
            IFND=0
            XTQD=0.
            YTQD=0.
            RDST=.50
            RSTP=.25
            LOOP
              XTPD=XTLD+RDST*(XTTD-XTLD)
              YTPD=YTLD+RDST*(YTTD-YTLD)
              CALL HLUCPMPXY (IMPF,XTPD,YTPD,XTPU,YTPU)
              IF (ICFELL('CPTRCL',15).NE.0) GO TO 102
              EXIT IF (OORV.NE.0..AND.(XTPU.EQ.OORV.OR.YTPU.EQ.OORV))
              IF (ABS(XTPU-XTLU).LT.PITX.AND.ABS(YTPU-YTLU).LT.PITY)
                IFND=1
                XTQD=XTPD
                YTQD=YTPD
                XTQU=XTPU
                YTQU=YTPU
                EXIT IF (ABS(XTQU-XTLU).GT..5*PITX.OR.
     +                   ABS(YTQU-YTLU).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.(XTQD.NE.XTLD.OR.YTQD.NE.YTLD))
              NOUT=NOUT+1
              RWRK(IR01+5*MPLS+NOUT)=XTQU
              RWRK(IR01+6*MPLS+NOUT)=YTQU
              IF (NOUT.EQ.MPLS)
                XTMP=RWRK(IR01+5*MPLS+NOUT)
                YTMP=RWRK(IR01+6*MPLS+NOUT)
                IJMP=6
                IRW1=IR01+5*MPLS
                IRW2=IR01+6*MPLS
                NRWK=NOUT
                RETURN
  108           RWRK(IR01+5*MPLS+1)=XTMP
                RWRK(IR01+6*MPLS+1)=YTMP
                NOUT=1
              END IF
              XTLD=XTQD
              YTLD=YTQD
              XTLU=XTQU
              YTLU=YTQU
            ELSE
              XTLD=XTTD
              YTLD=YTTD
              XTLU=XTTU
              YTLU=YTTU
            END IF
          END WHILE
          XTLD=XTTD
          YTLD=YTTD
          XTLU=XTTU
          YTLU=YTTU
        END BLOCK
C
      END
.OP   BI=77


.OP   BI=66
      SUBROUTINE CPTREG (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK)
C
        DIMENSION ZDAT(IZD1,*),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 ZDAT is the user's data array.
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 CPTREG.
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 CPTREG 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 CONPACK common blocks.
C
.CALL CPCOMN,/$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 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,102,103,104,105,106) , IJMP
C
C Assign space to use for storing the X and Y coordinates of points.
C
        MPLS=LRWC
        CALL CPGRWS (RWRK,1,2*MPLS,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CPTREG',1).NE.0) GO TO 101
C
C Compute constants required to get from indices to X and Y coordinates.
C
        RZDM=(XATM-XAT1)/REAL(IZDM-1)
        RZDN=(YATN-YAT1)/REAL(IZDN-1)
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 If the mapping flag is off and no area identifiers are to be returned,
C the boundary can be defined as a simple rectangle.
C
        IF (IMPF.EQ.0.AND.IAIC.EQ.-9)
C
          RWRK(IR01     +1)=XAT1
          RWRK(IR01+MPLS+1)=YAT1
          RWRK(IR01     +2)=XATM
          RWRK(IR01+MPLS+2)=YAT1
          RWRK(IR01     +3)=XATM
          RWRK(IR01+MPLS+3)=YATN
          RWRK(IR01     +4)=XAT1
          RWRK(IR01+MPLS+4)=YATN
          RWRK(IR01     +5)=XAT1
          RWRK(IR01+MPLS+5)=YAT1
C
          IJMP=1
          IRW1=IR01
          IRW2=IR01+MPLS
          NRWK=5
          RETURN
C
C Otherwise, more points must be used.  In particular, all points of
C intersection of contour lines with the boundary must be included.
C Also, the possibility of invisible areas must be provided for.
C
        ELSE
C
          NPLS=0
          RUDN=0.
C
          INDX=1
          INDY=1
          XCES=1.
          YCES=1.
          ZCES=ZDAT(1,1)
          IF (SVAL.NE.0..AND.ZDAT(1,2).EQ.SVAL) ZCES=SVAL
          XCND=XCES
          YCND=YCES
          ZCND=ZCES
          INVOKE (COMPUTE-USER-COORDINATES)
C
          IADX=0
          IADY=1
          WHILE (INDX.LT.IZDM)
            INDX=INDX+1
            INVOKE (PROCESS-EDGE-SEGMENT)
          END WHILE
C
          IADX=-1
          IADY=0
          WHILE (INDY.LT.IZDN)
            INDY=INDY+1
            INVOKE (PROCESS-EDGE-SEGMENT)
          END WHILE
C
          IADX=0
          IADY=-1
          WHILE (INDX.GT.1)
            INDX=INDX-1
            INVOKE (PROCESS-EDGE-SEGMENT)
          END WHILE
C
          IADX=1
          IADY=0
          WHILE (INDY.GT.1)
            INDY=INDY-1
            INVOKE (PROCESS-EDGE-SEGMENT)
          END WHILE
C
          IF (NPLS.NE.0)
            IJMP=1
            IRW1=IR01
            IRW2=IR01+MPLS
            NRWK=NPLS
            RETURN
          END IF
C
        END IF
C
C Release the real workspace and let the caller know we're done.
C
  101   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
          XCES=REAL(INDX)
          YCES=REAL(INDY)
          ZCES=ZDAT(INDX,INDY)
          IF (SVAL.NE.0..AND.ZDAT(INDX+IADX,INDY+IADY).EQ.SVAL)ZCES=SVAL
          FOR (INTP = 1 TO ABS(IPIE)+1 BY 1)
            FINT=REAL(INTP)/REAL(ABS(IPIE)+1)
            XCOD=XCND
            YCOD=YCND
            ZCOD=ZCND
            XCOU=XCNU
            YCOU=YCNU
            IVOU=IVNU
            XCND=(1.-FINT)*XCSS+FINT*XCES
            YCND=(1.-FINT)*YCSS+FINT*YCES
            IF (INTP.NE.ABS(IPIE)+1)
              IF (SVAL.EQ.0..OR.(ZCSS.NE.SVAL.AND.ZCES.NE.SVAL))
                ZCND=(1.-FINT)*ZCSS+FINT*ZCES
              ELSE
                ZCND=SVAL
              END IF
            ELSE
              ZCND=ZCES
            END IF
            INVOKE (COMPUTE-USER-COORDINATES)
            IF (SVAL.EQ.0..OR.(ZCOD.NE.SVAL.AND.ZCND.NE.SVAL))
              IF (ZCOD.LT.ZCND)
                FOR (I = 1 TO NCLV BY 1)
                  ICLV=ICLP(I)
                  IF (CLEV(ICLV).GT.ZCOD.AND.CLEV(ICLV).LT.ZCND)
                    INVOKE (INTERPOLATE-TO-CONTOUR-LINE)
                  END IF
                END FOR
              ELSE IF (ZCND.LT.ZCOD)
                FOR (I = NCLV TO 1 BY -1)
                  ICLV=ICLP(I)
                  IF (CLEV(ICLV).GT.ZCND.AND.CLEV(ICLV).LT.ZCOD)
                    INVOKE (INTERPOLATE-TO-CONTOUR-LINE)
                  END IF
                END FOR
              END IF
            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 CPTRCL, which makes the code look a little unnecessarily
C complicated.
C
        BLOCK (INTERPOLATE-TO-CONTOUR-LINE)
          XCSD=XCND
          YCSD=YCND
          ZCSD=ZCND
          XCSU=XCNU
          YCSU=YCNU
          IVSU=IVNU
          IF (XCES.GT.XCSS)
            XFRA=FRCT(ZCSS,ZCES)
            IF (XFRA.LE..00001.OR.XFRA.GE..99999) GO TO 999
            XCND=XCSS+XFRA
          ELSE IF (XCES.LT.XCSS)
            XFRA=FRCT(ZCES,ZCSS)
            IF (XFRA.LE..00001.OR.XFRA.GE..99999) GO TO 999
            XCND=XCES+XFRA
          ELSE IF (YCES.GT.YCSS)
            YFRA=FRCT(ZCSS,ZCES)
            IF (YFRA.LE..00001.OR.YFRA.GE..99999) GO TO 999
            YCND=YCSS+YFRA
          ELSE
            YFRA=FRCT(ZCES,ZCSS)
            IF (YFRA.LE..00001.OR.YFRA.GE..99999) GO TO 999
            YCND=YCES+YFRA
          END IF
          ZCND=CLEV(ICLV)
          INVOKE (COMPUTE-USER-COORDINATES)
          IFOP=1
          INVOKE (PROCESS-PIECE-OF-SEGMENT)
          XCOD=XCND
          YCOD=YCND
          ZCOD=ZCND
          XCOU=XCNU
          YCOU=YCNU
          IVOU=IVNU
          XCND=XCSD
          YCND=YCSD
          ZCND=ZCSD
          XCNU=XCSU
          YCNU=YCSU
          IVNU=IVSU
  999   END BLOCK
C
C The following internal procedure processes a piece of a segment.
C There are several cases, depending on whether both endpoints are
C visible, 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 (SVAL.NE.0..AND.(ZCND.EQ.SVAL.OR.ZCOD.EQ.SVAL))
              IAID=IAIA($NCP2$)
            ELSE
              IF (NCLV.LE.0)
                IAID=1
              ELSE
                ZAVG=.5*(ZCND+ZCOD)
                CALL CPGVAI (ZAVG,IAID)
              END IF
            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
                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
              XCVD=XCND
              YCVD=YCND
              XCVU=XCNU
              YCVU=YCNU
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              XCOD=XCVD
              YCOD=YCVD
              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
  102       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
            XCVU=XCOU
            YCVU=YCOU
            XCID=XCND
            YCID=YCND
            INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
            XKND=XCND
            YKND=YCND
            XKNU=XCNU
            YKNU=YCNU
            XCND=XCVD
            YCND=YCVD
            XCNU=XCVU
            YCNU=YCVU
            IFOP=1
            INVOKE (OUTPUT-NEXT-POINT)
            XCND=XKND
            YCND=YKND
            XCNU=XKNU
            YCNU=YKNU
            IJMP=3
            IRW1=IR01
            IRW2=IR01+MPLS
            NRWK=NPLS
            RETURN
  103       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))
            RUDO=RUDN
            RUDN=(ABS(XCNU-XCOU)+ABS(YCNU-YCOU))/
     +           (ABS(XCND-XCOD)+ABS(YCND-YCOD))
            IF (RUDN.GT.2.*RUDO)
              IFOP=1
              INVOKE (CHECK-FOR-POSSIBLE-DISCONTINUITY)
            END IF
            IF (PITH.GT.0.)
              XCTD=XCND
              YCTD=YCND
              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
          XC1U=XCOU
          YC1U=YCOU
          XC2D=XCND
          YC2D=YCND
          XC2U=XCNU
          YC2U=YCNU
          ITMP=0
          LOOP
            DSTO=ABS(XC2U-XC1U)+ABS(YC2U-YC1U)
            XC3D=(XC1D+XC2D)/2.
            YC3D=(YC1D+YC2D)/2.
            CALL HLUCPMPXY (IMPF,XAT1+RZDM*(XC3D-1.),
     +                           YAT1+RZDN*(YC3D-1.),
     +                                     XC3U,YC3U)
            IF (ICFELL('CPTREG',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)
                XC1D=XC3D
                YC1D=YC3D
                XC1U=XC3U
                YC1U=YC3U
              ELSE
                EXIT IF (XC3D.EQ.XC2D.AND.YC3D.EQ.YC2D)
                XC2D=XC3D
                YC2D=YC3D
                XC2U=XC3U
                YC2U=YC3U
              END IF
              ITMP=ITMP+1
              EXIT IF (ITMP.EQ.64)
            ELSE
              XCVD=XCOD
              YCVD=YCOD
              XCVU=XCOU
              YCVU=YCOU
              XCID=XC3D
              YCID=YC3D
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              IJMP=4
              IRW1=IR01
              IRW2=IR01+MPLS
              NRWK=NPLS
              RETURN
  104         NPLS=0
              RUDN=0.
              XCID=XC3D
              YCID=YC3D
              XCVD=XCND
              YCVD=YCND
              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
              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
  105       IF (IMPF.NE.0.AND.PITH.GT.0.)
              XCLD=XC2D
              YCLD=YC2D
              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-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.
            CALL HLUCPMPXY (IMPF,XAT1+RZDM*(XCHD-1.),
     +                           YAT1+RZDN*(YCHD-1.),
     +                                     XCHU,YCHU)
            IF (ICFELL('CPTREG',3).NE.0) GO TO 101
            IF (XCHU.NE.OORV.AND.YCHU.NE.OORV)
              EXIT IF (XCHD.EQ.XCVD.AND.YCHD.EQ.YCVD)
              XCVD=XCHD
              YCVD=YCHD
              XCVU=XCHU
              YCVU=YCHU
            ELSE
              EXIT IF (XCHD.EQ.XCID.AND.YCHD.EQ.YCID)
              XCID=XCHD
              YCID=YCHD
            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 (IMPF.NE.0.AND.PITH.GT.0.)
            IF (NPLS.EQ.0)
              XCLD=XCVD
              YCLD=YCVD
              XCLU=XCVU
              YCLU=YCVU
            ELSE
              XCTD=XCVD
              YCTD=YCVD
              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.
            RDST=.50
            RSTP=.25
            LOOP
              XCPD=XCLD+RDST*(XCTD-XCLD)
              YCPD=YCLD+RDST*(YCTD-YCLD)
              CALL HLUCPMPXY (IMPF,XAT1+RZDM*(XCPD-1.),
     +                             YAT1+RZDN*(YCPD-1.),
     +                                       XCPU,YCPU)
              IF (ICFELL('CPTREG',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
                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))
              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
  106           RWRK(IR01+1)=XSAV
                RWRK(IR01+MPLS+1)=YSAV
                NPLS=1
              END IF
              XCLD=XCQD
              YCLD=YCQD
              XCLU=XCQU
              YCLU=YCQU
            ELSE
              XCLD=XCTD
              YCLD=YCTD
              XCLU=XCTU
              YCLU=YCTU
            END IF
          END WHILE
          XCLD=XCTD
          YCLD=YCTD
          XCLU=XCTU
          YCLU=YCTU
        END BLOCK
C
C The following internal procedure is given the data-system coordinates
C of a point (XCND,YCND) and computes the user-system coordinates of
C 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
          XCNU=XAT1+RZDM*(XCND-1.)
          YCNU=YAT1+RZDN*(YCND-1.)
          IVNU=1
C
          IF (IMPF.NE.0)
            XTMP=XCNU
            YTMP=YCNU
            CALL HLUCPMPXY (IMPF,XTMP,YTMP,XCNU,YCNU)
            IF (ICFELL('CPTREG',5).NE.0) GO TO 101
            IF ((OORV.NE.0.).AND.(XCNU.EQ.OORV.OR.YCNU.EQ.OORV)) IVNU=0
          END IF
C
        END BLOCK
C
      END
.OP   BI=77


.OP   BI=66
      SUBROUTINE CPTRES (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK,IFWB)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C This routine traces the edge of the special-value area.  Control is
C passed back to the caller with each piece of the edge for processing.
C
C ZDAT is the user's data array.
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 CPTRES.
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 CPTRES 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 special-value area.  If
C its initial value is 0, it will have been updated, upon every return
C with IJMP non-zero, to the area identifier for the contoured side of
C the piece 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 IFWB is a new variable added to the calling sequence on 09/21/2000; it
C is set non-zero if and only CPTRES is to generate the entire boundary
C of each special-value area; if its value is zero, the parts of the
C boundary on the edge of the grid are not drawn.
C
C
C Declare all of the CONPACK common blocks.
C
.CALL CPCOMN,/$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 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,102,106,107,108,109,110) , IJMP
C
C If there are no special values in the field, do nothing.
C
        IF (SVAL.EQ.0.) RETURN
C
C Assign space to use for storing the X and Y coordinates of points.
C
        MPLS=LRWC
        CALL CPGRWS (RWRK,1,2*MPLS,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CPTRES',1).NE.0) GO TO 105
C
C Compute constants required to get from indices to X and Y coordinates.
C
        RZDM=(XATM-XAT1)/REAL(IZDM-1)
        RZDN=(YATN-YAT1)/REAL(IZDN-1)
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 count of horizontal segments seen.
C
        NHSS=0
C
C Search.
C
        FOR (I = 1 TO IZDM-1)
          FOR (J = 1 TO IZDN-1)
            IF (J.EQ.1)
              IF (ZDAT(I  ,J  ).EQ.SVAL.OR.
     +            ZDAT(I+1,J  ).EQ.SVAL.OR.
     +            ZDAT(I  ,J+1).EQ.SVAL.OR.
     +            ZDAT(I+1,J+1).EQ.SVAL)
                INVOKE (TRACE-SPECIAL-VALUE-BOUNDARY,NR)
              END IF
            ELSE
              IF (ZDAT(I  ,J-1).NE.SVAL.AND.
     +            ZDAT(I+1,J-1).NE.SVAL.AND.
     +            ZDAT(I  ,J  ).NE.SVAL.AND.
     +            ZDAT(I+1,J  ).NE.SVAL.AND.
     +           (ZDAT(I  ,J+1).EQ.SVAL.OR.
     +            ZDAT(I+1,J+1).EQ.SVAL))
                INVOKE (TRACE-SPECIAL-VALUE-BOUNDARY,NR)
              END IF
            END IF
            BLOCK (TRACE-SPECIAL-VALUE-BOUNDARY,NR)
              NPLS=0
              RUDN=0.
              IPXY=IZDN*I+J
              DO (K=1,NHSS)
                IF (IPXY.EQ.IWRK(II01+K)) GO TO 104
              END DO
              IF (NHSS.GE.LI01)
                CALL CPGIWS (IWRK,1,LI01+100,IWSE)
                IF (IWSE.NE.0.OR.ICFELL('CPTRES',2).NE.0) GO TO 105
              END IF
              NHSS=NHSS+1
              IWRK(II01+NHSS)=IPXY
              XCES=REAL(I)
              YCES=REAL(J)
              ZCES=ZDAT(I,J)
              XCND=XCES
              YCND=YCES
              ZCND=ZCES
              INVOKE (COMPUTE-USER-COORDINATES)
              INSX=I
              INSY=J
              INOX=I
              INOY=J
              INDX=I+1
              INDY=J
              IDIR=5
              LOOP
                IF (IFWB.EQ.0.AND.(
     +             (INDX.EQ.INOX.AND.(INDX.EQ.1.OR.INDX.EQ.IZDM)).OR.
     +             (INDY.EQ.INOY.AND.(INDY.EQ.1.OR.INDY.EQ.IZDN))))
                  IF (NPLS.NE.0)
                    IJMP=1
                    IRW1=IR01
                    IRW2=IR01+MPLS
                    NRWK=NPLS
                    RETURN
  101               NPLS=0
                    RUDN=0.
                  END IF
                  XCES=REAL(INDX)
                  YCES=REAL(INDY)
                  ZCES=ZDAT(INDX,INDY)
                  XCND=XCES
                  YCND=YCES
                  ZCND=ZCES
                  INVOKE (COMPUTE-USER-COORDINATES)
                ELSE
                  INVOKE (PROCESS-EDGE-SEGMENT)
                END IF
                IF (INDX.EQ.INSX.AND.INDY.EQ.INSY)
                  IF (NPLS.NE.0)
                    IJMP=2
                    IRW1=IR01
                    IRW2=IR01+MPLS
                    NRWK=NPLS
                    RETURN
                  END IF
  102             EXIT
                END IF
                INOX=INDX
                INOY=INDY
                IDIR=MOD(IDIR+1,8)+1
                DO (K=1,3)
                  IF (IDIR.EQ.5)
                    IF (INOX.NE.IZDM.AND.INOY.NE.IZDN)
                      IF (INOY.EQ.1)
                        IF (ZDAT(INOX  ,INOY  ).EQ.SVAL.OR.
     +                      ZDAT(INOX+1,INOY  ).EQ.SVAL.OR.
     +                      ZDAT(INOX  ,INOY+1).EQ.SVAL.OR.
     +                      ZDAT(INOX+1,INOY+1).EQ.SVAL)
     +                                                         GO TO 103
                      ELSE
                        IF (ZDAT(INOX  ,INOY-1).NE.SVAL.AND.
     +                      ZDAT(INOX+1,INOY-1).NE.SVAL.AND.
     +                      ZDAT(INOX  ,INOY  ).NE.SVAL.AND.
     +                      ZDAT(INOX+1,INOY  ).NE.SVAL.AND.
     +                     (ZDAT(INOX  ,INOY+1).EQ.SVAL.OR.
     +                      ZDAT(INOX+1,INOY+1).EQ.SVAL))
     +                                                         GO TO 103
                      END IF
                    END IF
                  ELSE IF (IDIR.EQ.3)
                    IF (INOX.NE.1.AND.INOY.NE.IZDN)
                      IF (INOX.EQ.IZDM)
                        IF (ZDAT(INOX  ,INOY  ).EQ.SVAL.OR.
     +                      ZDAT(INOX  ,INOY+1).EQ.SVAL.OR.
     +                      ZDAT(INOX-1,INOY  ).EQ.SVAL.OR.
     +                      ZDAT(INOX-1,INOY+1).EQ.SVAL)
     +                                                         GO TO 103
                      ELSE
                        IF (ZDAT(INOX+1,INOY  ).NE.SVAL.AND.
     +                      ZDAT(INOX+1,INOY+1).NE.SVAL.AND.
     +                      ZDAT(INOX  ,INOY  ).NE.SVAL.AND.
     +                      ZDAT(INOX  ,INOY+1).NE.SVAL.AND.
     +                     (ZDAT(INOX-1,INOY  ).EQ.SVAL.OR.
     +                      ZDAT(INOX-1,INOY+1).EQ.SVAL))
     +                                                         GO TO 103
                      END IF
                    END IF
                  ELSE IF (IDIR.EQ.1)
                    IF (INOX.NE.1.AND.INOY.NE.1)
                      IF (INOY.EQ.IZDN)
                        IF (ZDAT(INOX  ,INOY  ).EQ.SVAL.OR.
     +                      ZDAT(INOX-1,INOY  ).EQ.SVAL.OR.
     +                      ZDAT(INOX  ,INOY-1).EQ.SVAL.OR.
     +                      ZDAT(INOX-1,INOY-1).EQ.SVAL)
     +                                                         GO TO 103
                      ELSE
                        IF (ZDAT(INOX  ,INOY+1).NE.SVAL.AND.
     +                      ZDAT(INOX-1,INOY+1).NE.SVAL.AND.
     +                      ZDAT(INOX  ,INOY  ).NE.SVAL.AND.
     +                      ZDAT(INOX-1,INOY  ).NE.SVAL.AND.
     +                     (ZDAT(INOX  ,INOY-1).EQ.SVAL.OR.
     +                      ZDAT(INOX-1,INOY-1).EQ.SVAL))
     +                                                         GO TO 103
                      END IF
                    END IF
                  ELSE
                    IF (INOX.NE.IZDM.AND.INOY.NE.1)
                      IF (INOX.EQ.1)
                        IF (ZDAT(INOX  ,INOY  ).EQ.SVAL.OR.
     +                      ZDAT(INOX  ,INOY-1).EQ.SVAL.OR.
     +                      ZDAT(INOX+1,INOY  ).EQ.SVAL.OR.
     +                      ZDAT(INOX+1,INOY-1).EQ.SVAL)
     +                                                         GO TO 103
                      ELSE
                        IF (ZDAT(INOX-1,INOY  ).NE.SVAL.AND.
     +                      ZDAT(INOX-1,INOY-1).NE.SVAL.AND.
     +                      ZDAT(INOX  ,INOY  ).NE.SVAL.AND.
     +                      ZDAT(INOX  ,INOY-1).NE.SVAL.AND.
     +                     (ZDAT(INOX+1,INOY  ).EQ.SVAL.OR.
     +                      ZDAT(INOX+1,INOY-1).EQ.SVAL))
     +                                                         GO TO 103
                      END IF
                    END IF
                  END IF
                  IDIR=MOD(IDIR+5,8)+1
                END DO
                CALL SETER ('CPTRES - ALGORITHM FAILURE - SEE SPECIALIST
     +'                                                            ,3,1)
                GO TO 105
  103           INDX=INOX+INCX(IDIR)
                INDY=INOY+INCY(IDIR)
                IF (IDIR.EQ.5)
                  IF (NHSS.GE.LI01)
                    CALL CPGIWS (IWRK,1,LI01+100,IWSE)
                    IF (IWSE.NE.0.OR.ICFELL('CPTRES',4).NE.0) GO TO 105
                  END IF
                  NHSS=NHSS+1
                  IWRK(II01+NHSS)=IZDN*INOX+INOY
                END IF
              END LOOP
            END BLOCK
  104     END FOR
        END FOR
C
C Release the workspaces and let the caller know we're done.
C
  105   LI01=0
        LR01=0
        IJMP=0
C
C Done.
C
        RETURN
C
C The following internal procedure processes a segment along the edge
C of the special-value area.
C
        BLOCK (PROCESS-EDGE-SEGMENT)
          XCSS=XCES
          YCSS=YCES
          ZCSS=ZCES
          XCES=REAL(INDX)
          YCES=REAL(INDY)
          ZCES=ZDAT(INDX,INDY)
          FOR (INTP = 1 TO ABS(IPIE)+1 BY 1)
            FINT=REAL(INTP)/REAL(ABS(IPIE)+1)
            XCOD=XCND
            YCOD=YCND
            ZCOD=ZCND
            XCOU=XCNU
            YCOU=YCNU
            IVOU=IVNU
            XCND=(1.-FINT)*XCSS+FINT*XCES
            YCND=(1.-FINT)*YCSS+FINT*YCES
            IF (SVAL.EQ.0..OR.(ZCSS.NE.SVAL.AND.ZCES.NE.SVAL))
              ZCND=(1.-FINT)*ZCSS+FINT*ZCES
            ELSE
              ZCND=SVAL
            END IF
            INVOKE (COMPUTE-USER-COORDINATES)
            IF (SVAL.EQ.0..OR.(ZCOD.NE.SVAL.AND.ZCND.NE.SVAL))
              IF (ZCOD.LT.ZCND)
                FOR (K = 1 TO NCLV BY 1)
                  ICLV=ICLP(K)
                  IF (CLEV(ICLV).GT.ZCOD.AND.CLEV(ICLV).LT.ZCND)
                    INVOKE (INTERPOLATE-TO-CONTOUR-LINE)
                  END IF
                END FOR
              ELSE IF (ZCND.LT.ZCOD)
                FOR (K = NCLV TO 1 BY -1)
                  ICLV=ICLP(K)
                  IF (CLEV(ICLV).GT.ZCND.AND.CLEV(ICLV).LT.ZCOD)
                    INVOKE (INTERPOLATE-TO-CONTOUR-LINE)
                  END IF
                END FOR
              END IF
            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 CPTRCL, which makes the code look a little unnecessarily
C complicated.
C
        BLOCK (INTERPOLATE-TO-CONTOUR-LINE)
          XCSD=XCND
          YCSD=YCND
          ZCSD=ZCND
          XCSU=XCNU
          YCSU=YCNU
          IVSU=IVNU
          IF (XCES.GT.XCSS)
            XFRA=FRCT(ZCSS,ZCES)
            IF (XFRA.LE..00001.OR.XFRA.GE..99999) GO TO 999
            XCND=XCSS+XFRA
          ELSE IF (XCES.LT.XCSS)
            XFRA=FRCT(ZCES,ZCSS)
            IF (XFRA.LE..00001.OR.XFRA.GE..99999) GO TO 999
            XCND=XCES+XFRA
          ELSE IF (YCES.GT.YCSS)
            YFRA=FRCT(ZCSS,ZCES)
            IF (YFRA.LE..00001.OR.YFRA.GE..99999) GO TO 999
            YCND=YCSS+YFRA
          ELSE
            YFRA=FRCT(ZCES,ZCSS)
            IF (YFRA.LE..00001.OR.YFRA.GE..99999) GO TO 999
            YCND=YCES+YFRA
          END IF
          ZCND=CLEV(ICLV)
          INVOKE (COMPUTE-USER-COORDINATES)
          IFOP=1
          INVOKE (PROCESS-PIECE-OF-SEGMENT)
          XCOD=XCND
          YCOD=YCND
          ZCOD=ZCND
          XCOU=XCNU
          YCOU=YCNU
          IVOU=IVNU
          XCND=XCSD
          YCND=YCSD
          ZCND=ZCSD
          XCNU=XCSU
          YCNU=YCSU
          IVNU=IVSU
  999   END BLOCK
C
C The following internal procedure processes a piece of a segment.
C There are several cases, depending on whether both endpoints are
C visible, 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 (SVAL.NE.0..AND.(ZCND.EQ.SVAL.OR.ZCOD.EQ.SVAL))
              IAID=IAIA($NCP2$)
            ELSE
              IF (NCLV.LE.0)
                IAID=1
              ELSE
                ZAVG=.5*(ZCND+ZCOD)
                CALL CPGVAI (ZAVG,IAID)
              END IF
            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
                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
              XCVD=XCND
              YCVD=YCND
              XCVU=XCNU
              YCVU=YCNU
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              XCOD=XCVD
              YCOD=YCVD
              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=3
            IRW1=IR01
            IRW2=IR01+MPLS
            NRWK=NPLS
            RETURN
  106       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
            XCVU=XCOU
            YCVU=YCOU
            XCID=XCND
            YCID=YCND
            INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
            XKND=XCND
            YKND=YCND
            XKNU=XCNU
            YKNU=YCNU
            XCND=XCVD
            YCND=YCVD
            XCNU=XCVU
            YCNU=YCVU
            IFOP=1
            INVOKE (OUTPUT-NEXT-POINT)
            XCND=XKND
            YCND=YKND
            XCNU=XKNU
            YCNU=YKNU
            IJMP=4
            IRW1=IR01
            IRW2=IR01+MPLS
            NRWK=NPLS
            RETURN
  107       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))
            RUDO=RUDN
            RUDN=(ABS(XCNU-XCOU)+ABS(YCNU-YCOU))/
     +           (ABS(XCND-XCOD)+ABS(YCND-YCOD))
            IF (RUDN.GT.2.*RUDO)
              IFOP=1
              INVOKE (CHECK-FOR-POSSIBLE-DISCONTINUITY)
            END IF
            IF (PITH.GT.0.)
              XCTD=XCND
              YCTD=YCND
              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
          XC1U=XCOU
          YC1U=YCOU
          XC2D=XCND
          YC2D=YCND
          XC2U=XCNU
          YC2U=YCNU
          ITMP=0
          LOOP
            DSTO=ABS(XC2U-XC1U)+ABS(YC2U-YC1U)
            XC3D=(XC1D+XC2D)/2.
            YC3D=(YC1D+YC2D)/2.
            CALL HLUCPMPXY (IMPF,XAT1+RZDM*(XC3D-1.),
     +                           YAT1+RZDN*(YC3D-1.),
     +                                     XC3U,YC3U)
            IF (ICFELL('CPTRES',5).NE.0) GO TO 105
            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)
                XC1D=XC3D
                YC1D=YC3D
                XC1U=XC3U
                YC1U=YC3U
              ELSE
                EXIT IF (XC3D.EQ.XC2D.AND.YC3D.EQ.YC2D)
                XC2D=XC3D
                YC2D=YC3D
                XC2U=XC3U
                YC2U=YC3U
              END IF
              ITMP=ITMP+1
              EXIT IF (ITMP.EQ.64)
            ELSE
              XCVD=XCOD
              YCVD=YCOD
              XCVU=XCOU
              YCVU=YCOU
              XCID=XC3D
              YCID=YC3D
              INVOKE (INTERPOLATE-TO-VISIBLE-EDGE)
              INVOKE (OUTPUT-VISIBLE-EDGE-POINT)
              IJMP=5
              IRW1=IR01
              IRW2=IR01+MPLS
              NRWK=NPLS
              RETURN
  108         NPLS=0
              RUDN=0.
              XCID=XC3D
              YCID=YC3D
              XCVD=XCND
              YCVD=YCND
              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
              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=6
            IRW1=IR01
            IRW2=IR01+MPLS
            NRWK=NPLS
            RETURN
  109       IF (IMPF.NE.0.AND.PITH.GT.0.)
              XCLD=XC2D
              YCLD=YC2D
              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-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.
            CALL HLUCPMPXY (IMPF,XAT1+RZDM*(XCHD-1.),
     +                           YAT1+RZDN*(YCHD-1.),
     +                                     XCHU,YCHU)
            IF (ICFELL('CPTRES',6).NE.0) GO TO 105
            IF (XCHU.NE.OORV.AND.YCHU.NE.OORV)
              EXIT IF (XCHD.EQ.XCVD.AND.YCHD.EQ.YCVD)
              XCVD=XCHD
              YCVD=YCHD
              XCVU=XCHU
              YCVU=YCHU
            ELSE
              EXIT IF (XCHD.EQ.XCID.AND.YCHD.EQ.YCID)
              XCID=XCHD
              YCID=YCHD
            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 (IMPF.NE.0.AND.PITH.GT.0.)
            IF (NPLS.EQ.0)
              XCLD=XCVD
              YCLD=YCVD
              XCLU=XCVU
              YCLU=YCVU
            ELSE
              XCTD=XCVD
              YCTD=YCVD
              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.
            RDST=.50
            RSTP=.25
            LOOP
              XCPD=XCLD+RDST*(XCTD-XCLD)
              YCPD=YCLD+RDST*(YCTD-YCLD)
              CALL HLUCPMPXY (IMPF,XAT1+RZDM*(XCPD-1.),
     +                             YAT1+RZDN*(YCPD-1.),
     +                                       XCPU,YCPU)
              IF (ICFELL('CPTRES',7).NE.0) GO TO 105
              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
                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))
              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=7
                IRW1=IR01
                IRW2=IR01+MPLS
                NRWK=NPLS
                RETURN
  110           RWRK(IR01+1)=XSAV
                RWRK(IR01+MPLS+1)=YSAV
                NPLS=1
              END IF
              XCLD=XCQD
              YCLD=YCQD
              XCLU=XCQU
              YCLU=YCQU
            ELSE
              XCLD=XCTD
              YCLD=YCTD
              XCLU=XCTU
              YCLU=YCTU
            END IF
          END WHILE
          XCLD=XCTD
          YCLD=YCTD
          XCLU=XCTU
          YCLU=YCTU
        END BLOCK
C
C The following internal procedure is given the data-system coordinates
C of a point (XCND,YCND) and computes the user-system coordinates of
C 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
          XCNU=XAT1+RZDM*(XCND-1.)
          YCNU=YAT1+RZDN*(YCND-1.)
          IVNU=1
C
          IF (IMPF.NE.0)
            XTMP=XCNU
            YTMP=YCNU
            CALL HLUCPMPXY (IMPF,XTMP,YTMP,XCNU,YCNU)
            IF (ICFELL('CPTRES',8).NE.0) GO TO 105
            IF ((OORV.NE.0.).AND.(XCNU.EQ.OORV.OR.YCNU.EQ.OORV)) IVNU=0
          END IF
C
        END BLOCK
C
      END
.OP   BI=77


.OP   BI=66
      SUBROUTINE CPTREV (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C This routine traces the edge of the area which is visible under the
C current mapping, using only forward mapping capabilities of CPMPXY
C (which doesn't work all that well for many mappings of interest).
C
C As pieces of the edge are generated, control is passed back to the
C caller for processing of them.
C
C ZDAT is the user's data array.
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 CPTREV.
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 CPTREV 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 visible area.  If its
C initial value is 0, it will have been updated, upon every return
C with IJMP non-zero, to the area identifier for the contoured side of
C the piece 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 CONPACK common blocks.
C
.CALL CPCOMN,/$SAVE-COMMON$/0/
C
C Define arrays to hold coordinates used in finding the slope of the
C tangent to a limb line at a given point.
C
        DIMENSION XCUV(3),YCUV(3)
C
C Define arrays to hold the coordinates of eight points around a unit
C circle, spaced 45 degrees apart and starting at the 45-degree mark.
C
        DIMENSION XOUC(8),YOUC(8)
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 the unit-circle data.
C
        DATA XOUC / .70711,0.,-.70711,-1.,-.70711, 0., .70711,1. /
        DATA YOUC / .70711,1., .70711, 0.,-.70711,-1.,-.70711,0. /
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,105,107) , IJMP
C
C Save the initial value of IAIC.
C
        IAID=IAIC
C
C Assign space to use for storing the X and Y coordinates of points.
C
        MPLS=LRWC
        CALL CPGRWS (RWRK,1,2*MPLS,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CPTREV',1).NE.0) GO TO 102
C
C Compute required constants.
C
        IIDM=(IZDM-1)*(ABS(IPIE)+1)+1
        IIDN=(IZDN-1)*(ABS(IPIE)+1)+1
C
        RIDM=(XATM-XAT1)/REAL(IIDM-1)
        RIDN=(YATN-YAT1)/REAL(IIDN-1)
C
        DELX=.0001*ABS(XATM-XAT1)
        DELY=.0001*ABS(YATN-YAT1)
C
C Zero the count of horizontal segments seen.
C
        NHSS=0
C
C Define the first search point.
C
        IVBX=1
        IVBY=1
        CALL HLUCPMPXY (IMPF,XAT1,YAT1,XPRN,YPRN)
        IF (ICFELL('CPTREV',2).NE.0) GO TO 102
C
C Search.
C
        WHILE (IVBX.LT.IIDM)
          IVBX=IVBX+1
          XPRP=XPRN
          CALL HLUCPMPXY (IMPF,XAT1+RIDM*REAL(IVBX-1),YAT1,XPRN,YPRN)
          IF (ICFELL('CPTREV',3).NE.0) GO TO 102
          IF (XPRP.EQ.OORV.AND.XPRN.NE.OORV)
            INCI=1
            INVOKE (FOLLOW-THE-LIMB)
          END IF
        END WHILE
C
        WHILE (IVBY.LT.IIDN)
          IVBY=IVBY+1
          XPRP=XPRN
          CALL HLUCPMPXY (IMPF,XAT1+RIDM*REAL(IIDM-1),
     +                         YAT1+RIDN*REAL(IVBY-1),
     +                                      XPRN,YPRN)
          IF (ICFELL('CPTREV',4).NE.0) GO TO 102
          IF (XPRP.EQ.OORV.AND.XPRN.NE.OORV)
            INCI=7
            INVOKE (FOLLOW-THE-LIMB)
          END IF
        END WHILE
C
        WHILE (IVBX.GT.1)
          IVBX=IVBX-1
          XPRP=XPRN
          CALL HLUCPMPXY (IMPF,XAT1+RIDM*REAL(IVBX-1),
     +                         YAT1+RIDN*REAL(IIDN-1),
     +                                      XPRN,YPRN)
          IF (ICFELL('CPTREV',5).NE.0) GO TO 102
          IF (XPRP.EQ.OORV.AND.XPRN.NE.OORV)
            INCI=5
            INVOKE (FOLLOW-THE-LIMB)
          END IF
        END WHILE
C
        WHILE (IVBY.GT.1)
          IVBY=IVBY-1
          XPRP=XPRN
          CALL HLUCPMPXY (IMPF,XAT1,YAT1+RIDN*REAL(IVBY-1),XPRN,YPRN)
          IF (ICFELL('CPTREV',6).NE.0) GO TO 102
          IF (XPRP.EQ.OORV.AND.XPRN.NE.OORV)
            INCI=3
            INVOKE (FOLLOW-THE-LIMB)
          END IF
        END WHILE
C
        FOR (IVBY = 2 TO IIDN-1)
          RVBY=YAT1+RIDN*REAL(IVBY-1)
          CALL HLUCPMPXY (IMPF,XAT1,RVBY,XPRN,YPRN)
          IF (ICFELL('CPTREV',7).NE.0) GO TO 102
          FOR (IVBX = 2 TO IIDM)
            XPRP=XPRN
            CALL HLUCPMPXY (IMPF,XAT1+RIDM*REAL(IVBX-1),RVBY,XPRN,YPRN)
            IF (ICFELL('CPTREV',8).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 CPGIWS (IWRK,1,LI01+100,IWSE)
                IF (IWSE.NE.0.OR.ICFELL('CPTREV',9).NE.0) GO TO 102
              END IF
              NHSS=NHSS+1
              IWRK(II01+NHSS)=IPXY
              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
            CALL HLUCPMPXY (IMPF,XAT1+RIDM*REAL(IVEX-1),
     +                           YAT1+RIDN*REAL(IVEY-1),
     +                                        XTMP,YTMP)
            IF (ICFELL('CPTREV',10).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 CPGIWS (IWRK,1,LI01+100,IWSE)
                  IF (IWSE.NE.0.OR.ICFELL('CPTREV',11).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 CPCLAM,
C control need not return there, because CPTROE is not going to be
C called.  (This is different from the situation in CPTRVE.)
C
          IF (NPLS.GT.1)
            IJMP=1
            IRW1=IR01
            IRW2=IR01+MPLS
            NRWK=NPLS
            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
          XCVD=XAT1+RIDM*REAL(IVBX-1)
          YCVD=YAT1+RIDN*REAL(IVBY-1)
          CALL HLUCPMPXY (IMPF,XCVD,YCVD,XCVU,YCVU)
          IF (ICFELL('CPTREV',12).NE.0) GO TO 102
C
          XCID=XAT1+RIDM*REAL(IVEX-1)
          YCID=YAT1+RIDN*REAL(IVEY-1)
C
          ITMP=0
C
          LOOP
            XCHD=(XCVD+XCID)/2.
            YCHD=(YCVD+YCID)/2.
            CALL HLUCPMPXY (IMPF,XCHD,YCHD,XCHU,YCHU)
            IF (ICFELL('CPTREV',13).NE.0) GO TO 102
            IF (XCHU.NE.OORV)
              EXIT IF (XCHD.EQ.XCVD.AND.YCHD.EQ.YCVD)
              XCVD=XCHD
              YCVD=YCHD
              XCVU=XCHU
              YCVU=YCHU
            ELSE
              EXIT IF (XCHD.EQ.XCID.AND.YCHD.EQ.YCID)
              XCID=XCHD
              YCID=YCHD
            END IF
            ITMP=ITMP+1
            EXIT IF (ITMP.EQ.64)
          END LOOP
C
          IF (IAID.NE.-9)
            XTMP=1.+((XCVD-XAT1)/(XATM-XAT1))*REAL(IZDM-1)
            YTMP=1.+((YCVD-YAT1)/(YATN-YAT1))*REAL(IZDN-1)
            ITMP=INT(XTMP)
            JTMP=INT(YTMP)
            ITP1=MIN(ITMP+1,IZDM)
            JTP1=MIN(JTMP+1,IZDN)
            IF (SVAL.NE.0..AND.(ZDAT(ITMP,JTMP).EQ.SVAL.OR.
     +                          ZDAT(ITMP,JTP1).EQ.SVAL.OR.
     +                          ZDAT(ITP1,JTMP).EQ.SVAL.OR.
     +                          ZDAT(ITP1,JTP1).EQ.SVAL))
              IAID=IAIA($NCP2$)
            ELSE
              IF (NCLV.LE.0)
                IAID=1
              ELSE
                XDEL=XTMP-REAL(ITMP)
                YDEL=YTMP-REAL(JTMP)
                ZINT=(1.-YDEL)*
     +               ((1.-XDEL)*ZDAT(ITMP,JTMP)+XDEL*ZDAT(ITP1,JTMP))+
     +               YDEL*
     +               ((1.-XDEL)*ZDAT(ITMP,JTP1)+XDEL*ZDAT(ITP1,JTP1))
                CALL CPGVAI (ZINT,IAID)
              END IF
            END IF
          END IF
C
          IF (IAID.NE.IAIC)
            IF (NPLS.GT.1)
              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
            IAIC=0
          END IF
C
          NINT=0
C
          XCDN=MAX(MIN(XAT1,XATM),MIN(MAX(XAT1,XATM),
     +                                    XCVD+DELX))
          YCDN=MAX(MIN(YAT1,YATN),MIN(MAX(YAT1,YATN),
     +                                         YCVD))
          CALL HLUCPMPXY (IMPF,XCDN,YCDN,OORN,YTMP)
          IF (ICFELL('CPTREV',14).NE.0) GO TO 102
C
          DO (I=1,8)
            XCDP=XCDN
            YCDP=YCDN
            OORP=OORN
            XCDN=MAX(MIN(XAT1,XATM),MIN(MAX(XAT1,XATM),
     +                              XCVD+DELX*XOUC(I)))
            YCDN=MAX(MIN(YAT1,YATN),MIN(MAX(YAT1,YATN),
     +                              YCVD+DELY*YOUC(I)))
            CALL HLUCPMPXY (IMPF,XCDN,YCDN,OORN,YTMP)
            IF (ICFELL('CPTREV',15).NE.0) GO TO 102
            IF (OORP.EQ.OORV.AND.OORN.NE.OORV)
              XCDI=XCDP
              YCDI=YCDP
              XCDV=XCDN
              YCDV=YCDN
              INVOKE (REFINE-THE-COORDINATES,NR)
            ELSE IF (OORP.NE.OORV.AND.OORN.EQ.OORV)
              XCDV=XCDP
              YCDV=YCDP
              XCDI=XCDN
              YCDI=YCDN
              INVOKE (REFINE-THE-COORDINATES,NR)
            END IF
            BLOCK (REFINE-THE-COORDINATES,NR)
              IF (NINT.LT.3)
                NINT=NINT+1
                CALL HLUCPMPXY (IMPF,XCDV,YCDV,XCUV(NINT),YCUV(NINT))
                IF (ICFELL('CPTREV',16).NE.0) GO TO 102
                ITMP=0
                LOOP
                  XCDH=(XCDV+XCDI)/2.
                  YCDH=(YCDV+YCDI)/2.
                  CALL HLUCPMPXY (IMPF,XCDH,YCDH,XCUH,YCUH)
                  IF (ICFELL('CPTREV',17).NE.0) GO TO 102
                  IF (XCUH.NE.OORV)
                    EXIT IF (XCDH.EQ.XCDV.AND.YCDH.EQ.YCDV)
                    XCDV=XCDH
                    YCDV=YCDH
                    XCUV(NINT)=XCUH
                    YCUV(NINT)=YCUH
                  ELSE
                    EXIT IF (XCDH.EQ.XCDI.AND.YCDH.EQ.YCDI)
                    XCDI=XCDH
                    YCDI=YCDH
                  END IF
                  ITMP=ITMP+1
                  EXIT IF (ITMP.EQ.64)
                END LOOP
              END IF
            END BLOCK
          END DO
C
          IF (NINT.EQ.2)
C
            SINP=SINN
            COSP=COSN
            ANGP=ANGN
            SINN=YCUV(2)-YCUV(1)
            COSN=XCUV(2)-XCUV(1)
            ANGN=57.2957795130823*ATAN2(SINN,COSN)
C
            IF (NPLS.NE.0)
C
              IF (ABS(XCVU-RWRK(IR01+     NPLS)).LE..001*ABS(XWDR-XWDL)
     +           .AND.
     +            ABS(YCVU-RWRK(IR01+MPLS+NPLS)).LE..001*ABS(YWDT-YWDB))
                IF (XCVU.NE.RWRK(IR01     +NPLS).OR.
     +              YCVU.NE.RWRK(IR01+MPLS+NPLS))
                  GO TO 106
                ELSE
                  GO TO 108
                END IF
              END IF
C
              ANGC=57.2957795130823*ATAN2(YCVU-RWRK(IR01+MPLS+NPLS),
     +                                    XCVU-RWRK(IR01     +NPLS))
              ANGP=ANGP-180.*SIGN(REAL(INT((ABS(ANGP-ANGC)+90.)/180.)),
     +                                                        ANGP-ANGC)
              ANGN=ANGN-180.*SIGN(REAL(INT((ABS(ANGN-ANGC)+90.)/180.)),
     +                                                        ANGN-ANGC)
              IF ((MIRO.EQ.0.AND.ANGP.LT.ANGC.AND.ANGC.LT.ANGN).OR.
     +            (MIRO.NE.0.AND.ANGP.GT.ANGC.AND.ANGC.GT.ANGN))
                DNOM=COSN*SINP-SINN*COSP
                IF (DNOM.NE.0.)
                  XINT=(COSN*(SINP*RWRK(IR01     +NPLS)-
     +                        COSP*RWRK(IR01+MPLS+NPLS))-
     +                  COSP*(SINN*XCVU-COSN*YCVU))/DNOM
                  YINT=(SINN*(SINP*RWRK(IR01     +NPLS)-
     +                        COSP*RWRK(IR01+MPLS+NPLS))-
     +                  SINP*(SINN*XCVU-COSN*YCVU))/DNOM
                  IF (NPLS.GE.MPLS-1)
                    XSAV=RWRK(IR01     +NPLS)
                    YSAV=RWRK(IR01+MPLS+NPLS)
                    IJMP=3
                    IRW1=IR01
                    IRW2=IR01+MPLS
                    NRWK=NPLS
                    RETURN
  105               RWRK(IR01     +1)=XSAV
                    RWRK(IR01+MPLS+1)=YSAV
                    NPLS=1
                  END IF
                  NPLS=NPLS+1
                  RWRK(IR01     +NPLS)=XINT
                  RWRK(IR01+MPLS+NPLS)=YINT
                END IF
              END IF
C
            END IF
C
          END IF
C
  106     NPLS=NPLS+1
          RWRK(IR01     +NPLS)=XCVU
          RWRK(IR01+MPLS+NPLS)=YCVU
C
          IF (NPLS.GE.MPLS.OR.(NPLS.GT.1.AND.IAID.NE.IAIC))
            XSAV=RWRK(IR01     +NPLS)
            YSAV=RWRK(IR01+MPLS+NPLS)
            IJMP=4
            IRW1=IR01
            IRW2=IR01+MPLS
            NRWK=NPLS
            RETURN
  107       RWRK(IR01     +1)=XSAV
            RWRK(IR01+MPLS+1)=YSAV
            NPLS=1
          END IF
C
  108     IAIC=IAID
C
        END BLOCK
C
      END
.OP   BI=77


.OP   BI=66
      SUBROUTINE CPTRVE (ZDAT,RWRK,IWRK,IJMP,IAIC,IRW1,IRW2,NRWK)
C
        DIMENSION ZDAT(IZD1,*),RWRK(*),IWRK(*)
C
C This routine traces the edge of the area which is visible under the
C current mapping, using the inverse mapping capabilities of CPMPXY.
C This routine works better than CPTREV for many mappings of interest
C (but, of course, it depends on the inverse mapping being available).
C
C As pieces of the edge are generated, control is passed back to the
C caller for processing of them.
C
C ZDAT is the user's data array.
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 CPTRVE.
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 CPTRVE 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 visible area.  If its
C initial value is 0, it will have been updated, upon every return
C with IJMP non-zero, to the area identifier for the contoured side of
C the piece 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 CONPACK common blocks.
C
.CALL CPCOMN,/$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,105) , IJMP
C
C Save the initial value of IAIC.
C
        IAID=IAIC
C
C Assign space to use for storing the X and Y coordinates of points.
C
        MPLS=LRWC
        CALL CPGRWS (RWRK,1,2*MPLS,IWSE)
        IF (IWSE.NE.0.OR.ICFELL('CPTRVE',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('CPTRVE',2).NE.0) GO TO 102
        YDUM=CFUY(YVPB)
        IF (ICFELL('CPTRVE',3).NE.0) GO TO 102
        CALL HLUCPMPXY (-IMPF,XDUM,YDUM,XPRN,YPRN)
        IF (ICFELL('CPTRVE',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 CPTROE by the
C routine CPCLAM.
C
        WHILE (IVBX.LT.IIDM)
          IVBX=IVBX+1
          XPRP=XPRN
          XDUM=CFUX(XVPL+RIDM*REAL(IVBX-1))
          IF (ICFELL('CPTRVE',5).NE.0) GO TO 102
          YDUM=CFUY(YVPB)
          IF (ICFELL('CPTRVE',6).NE.0) GO TO 102
          CALL HLUCPMPXY (-IMPF,XDUM,YDUM,XPRN,YPRN)
          IF (ICFELL('CPTRVE',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('CPTRVE',8).NE.0) GO TO 102
          YDUM=CFUY(YVPB+RIDN*REAL(IVBY-1))
          IF (ICFELL('CPTRVE',9).NE.0) GO TO 102
          CALL HLUCPMPXY (-IMPF,XDUM,YDUM,XPRN,YPRN)
          IF (ICFELL('CPTRVE',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('CPTRVE',11).NE.0) GO TO 102
          YDUM=CFUY(YVPB+RIDN*REAL(IIDN-1))
          IF (ICFELL('CPTRVE',12).NE.0) GO TO 102
          CALL HLUCPMPXY (-IMPF,XDUM,YDUM,XPRN,YPRN)
          IF (ICFELL('CPTRVE',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('CPTRVE',14).NE.0) GO TO 102
          YDUM=CFUY(YVPB+RIDN*REAL(IVBY-1))
          IF (ICFELL('CPTRVE',15).NE.0) GO TO 102
          CALL HLUCPMPXY (-IMPF,XDUM,YDUM,XPRN,YPRN)
          IF (ICFELL('CPTRVE',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('CPTRVE',17).NE.0) GO TO 102
          RVBY=CFUY(YVPB+RIDN*REAL(IVBY-1))
          IF (ICFELL('CPTRVE',18).NE.0) GO TO 102
          CALL HLUCPMPXY (-IMPF,XDUM,RVBY,XPRN,YPRN)
          IF (ICFELL('CPTRVE',19).NE.0) GO TO 102
          FOR (IVBX = 2 TO IIDM)
            XPRP=XPRN
            XDUM=CFUX(XVPL+RIDM*REAL(IVBX-1))
            IF (ICFELL('CPTRVE',20).NE.0) GO TO 102
            CALL HLUCPMPXY (-IMPF,XDUM,RVBY,XPRN,YPRN)
            IF (ICFELL('CPTRVE',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 CPGIWS (IWRK,1,LI01+100,IWSE)
                IF (IWSE.NE.0.OR.ICFELL('CPTRVE',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('CPTRVE',23).NE.0) GO TO 102
            YDUM=CFUY(YVPB+RIDN*REAL(IVEY-1))
            IF (ICFELL('CPTRVE',24).NE.0) GO TO 102
            CALL HLUCPMPXY (-IMPF,XDUM,YDUM,XTMP,YTMP)
            IF (ICFELL('CPTRVE',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 CPGIWS (IWRK,1,LI01+100,IWSE)
                  IF (IWSE.NE.0.OR.ICFELL('CPTRVE',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 CPCLAM,
C control has to return there so that so that CPTROE 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('CPTRVE',27).NE.0) GO TO 102
          YDUM=CFUY(YCVF)
          IF (ICFELL('CPTRVE',28).NE.0) GO TO 102
          CALL HLUCPMPXY (-IMPF,XDUM,YDUM,XCVD,YCVD)
          IF (ICFELL('CPTRVE',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('CPTRVE',30).NE.0) GO TO 102
            YDUM=CFUY(YCHF)
            IF (ICFELL('CPTRVE',31).NE.0) GO TO 102
            CALL HLUCPMPXY (-IMPF,XDUM,YDUM,XCHD,YCHD)
            IF (ICFELL('CPTRVE',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 (IAID.NE.-9)
            XTMP=1.+((XCVD-XAT1)/(XATM-XAT1))*REAL(IZDM-1)
            YTMP=1.+((YCVD-YAT1)/(YATN-YAT1))*REAL(IZDN-1)
            ITMP=INT(XTMP)
            JTMP=INT(YTMP)
            IF (ITMP.LT.1.OR.ITMP.GE.IZDM.OR.
     +          JTMP.LT.1.OR.JTMP.GE.IZDN)
              IAID=IAIA($NCP1$)
            ELSE
              ITP1=ITMP+1
              JTP1=JTMP+1
              IF (SVAL.NE.0..AND.(ZDAT(ITMP,JTMP).EQ.SVAL.OR.
     +                            ZDAT(ITMP,JTP1).EQ.SVAL.OR.
     +                            ZDAT(ITP1,JTMP).EQ.SVAL.OR.
     +                            ZDAT(ITP1,JTP1).EQ.SVAL))
                IAID=IAIA($NCP2$)
              ELSE
                IF (NCLV.LE.0)
                  IAID=1
                ELSE
                  XDEL=XTMP-REAL(ITMP)
                  YDEL=YTMP-REAL(JTMP)
                  ZINT=(1.-YDEL)*
     +                 ((1.-XDEL)*ZDAT(ITMP,JTMP)+XDEL*ZDAT(ITP1,JTMP))+
     +                 YDEL*
     +                 ((1.-XDEL)*ZDAT(ITMP,JTP1)+XDEL*ZDAT(ITP1,JTP1))
                  CALL CPGVAI (ZINT,IAID)
                END IF
              END IF
            END IF
          END IF
C
          IF (IAID.NE.IAIC)
            IF (NPLS.GT.1)
              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
            IAIC=0
          END IF
C
          IF (NPLS.NE.0)
            XDUM=CUFX(RWRK(IR01+     NPLS))
            IF (ICFELL('CPTRVE',33).NE.0) GO TO 102
            YDUM=CUFY(RWRK(IR01+MPLS+NPLS))
            IF (ICFELL('CPTRVE',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 106
              NPLS=NPLS-1
            END IF
          END IF
C
          NPLS=NPLS+1
          RWRK(IR01     +NPLS)=CFUX(XCVF)
          IF (ICFELL('CPTRVE',35).NE.0) GO TO 102
          RWRK(IR01+MPLS+NPLS)=CFUY(YCVF)
          IF (ICFELL('CPTRVE',36).NE.0) GO TO 102
C
          IF (NPLS.GE.MPLS.OR.(NPLS.GT.1.AND.IAID.NE.IAIC))
            XSAV=RWRK(IR01     +NPLS)
            YSAV=RWRK(IR01+MPLS+NPLS)
            IJMP=3
            IRW1=IR01
            IRW2=IR01+MPLS
            NRWK=NPLS
            RETURN
  105       IOCF=IOR(IOCF,2)
            RWRK(IR01     +1)=XSAV
            RWRK(IR01+MPLS+1)=YSAV
            NPLS=1
          END IF
C
          IAIC=IAID
C
  106   END BLOCK
C
      END
.OP   BI=77


      SUBROUTINE CPTROE (XCRA,YCRA,NCRA,OFFS,RWRK,IOCF,IAMA,IGID,IAIL,
     +                                                           IAIR)
C
        DIMENSION XCRA(*),YCRA(*),RWRK(12),IAMA(*)
C
C The routine CPTROE 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 CPWLAM, 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 CPWLAM 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 CPTROE 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 CPWLAM 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 CPWLAM (XNXT,YNXT,IFST,IAMA,IGID,JAIL,JAIR)
            IF (ICFELL('CPTROE',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 CPWLAM.  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 CPWLAM (XNXT,YNXT,IFST,IAMA,IGID,IAIL,IAIR)
        IF (ICFELL('CPTROE',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 CPWLAM.
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 CPWLAM (XNXT,YNXT,IFST,IAMA,IGID,JAIL,JAIR)
        IF (ICFELL('CPTROE',3).NE.0) RETURN
        IFST=1
        JAIL=IAIL
        JAIR=IAIR
        GO TO (101,102,103) , IJMP
C
      END


      SUBROUTINE CPWLAM (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 CPWLAM with IFST = 0 declares a point (XNXT,YNXT) at which a line
C is to begin and each call to CPWLAM with IFST = 1 declares a point
C (XNXT,YNXT) at which a line is to continue.
C
C This version of CPWLAM 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 XMIN, XMAX, YMIN, and YMAX are expected to be in the fractional
C coordinate system.
C
C Declare the common block that holds the clipping window parameters.
C
        COMMON /CPWCMN/ XMIN,XMAX,YMIN,YMAX
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 CPWLAM).
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            YMAX -----+------+-----
C                   -3 |   0  | +3
C            YMIN -----+------+-----
C                   -4 |  -1  | +2
C                      |      |
C                    XMIN    XMAX
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-XMIN)+SIGN(.51,XNXT-XMAX))+
     +              (SIGN(.51,YNXT-YMIN)+SIGN(.51,YNXT-YMAX)))
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('CPWLAM',1).NE.0) RETURN
            YCRA(1)=CFUY(YLST)
            IF (ICFELL('CPWLAM',2).NE.0) RETURN
            XCRA(2)=CFUX(XNXT)
            IF (ICFELL('CPWLAM',3).NE.0) RETURN
            YCRA(2)=CFUY(YNXT)
            IF (ICFELL('CPWLAM',4).NE.0) RETURN
            CALL AREDAM (IAMA,XCRA,YCRA,2,IGID,JAIL,JAIR)
            IF (ICFELL('CPWLAM',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*(XMAX-XMIN))
            XPEW=XMIN
            IF (XDIF.GE.0.) XPEW=XMAX
            YPEW=YLST+(XPEW-XLST)*YDIF/XDIF
            IF (YPEW.GE.YMIN.AND.YPEW.LE.YMAX) GO TO 102
          END IF
C
          IF (ABS(YDIF).GT..000001*(YMAX-YMIN))
            YPEW=YMIN
            IF (YDIF.GE.0.) YPEW=YMAX
            XPEW=XLST+(YPEW-YLST)*XDIF/YDIF
          END IF
C
  102     XCRA(1)=CFUX(XLST)
          IF (ICFELL('CPWLAM',6).NE.0) RETURN
          YCRA(1)=CFUY(YLST)
          IF (ICFELL('CPWLAM',7).NE.0) RETURN
          XCRA(2)=CFUX(XPEW)
          IF (ICFELL('CPWLAM',8).NE.0) RETURN
          YCRA(2)=CFUY(YPEW)
          IF (ICFELL('CPWLAM',9).NE.0) RETURN
          CALL AREDAM (IAMA,XCRA,YCRA,2,IGID,JAIL,JAIR)
          IF (ICFELL('CPWLAM',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*(XMAX-XMIN))
            XPEW=XMIN
            IF (XDIF.GE.0.) XPEW=XMAX
            YPEW=YNXT+(XPEW-XNXT)*YDIF/XDIF
            IF (YPEW.GE.YMIN.AND.YPEW.LE.YMAX) GO TO 104
          END IF
C
          IF (ABS(YDIF).GT..000001*(YMAX-YMIN))
            YPEW=YMIN
            IF (YDIF.GE.0.) YPEW=YMAX
            XPEW=XNXT+(YPEW-YNXT)*XDIF/YDIF
          END IF
C
  104     XCRA(1)=CFUX(XPEW)
          IF (ICFELL('CPWLAM',11).NE.0) RETURN
          YCRA(1)=CFUY(YPEW)
          IF (ICFELL('CPWLAM',12).NE.0) RETURN
          XCRA(2)=CFUX(XNXT)
          IF (ICFELL('CPWLAM',13).NE.0) RETURN
          YCRA(2)=CFUY(YNXT)
          IF (ICFELL('CPWLAM',14).NE.0) RETURN
          CALL AREDAM (IAMA,XCRA,YCRA,2,IGID,JAIL,JAIR)
          IF (ICFELL('CPWLAM',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=XMIN
          YPT1=YMIN
          XPE2=XMAX
          YPT2=YMAX
          GO TO 110
C
  107     XPE1=XMIN
          YPT1=YMAX
          XPE2=XMAX
          YPT2=YMIN
          GO TO 110
C
  108     XPE1=XMAX
          YPT1=YMAX
          XPE2=XMIN
          YPT2=YMIN
          GO TO 110
C
  109     XPE1=XMAX
          YPT1=YMIN
          XPE2=XMIN
          YPT2=YMAX
C
  110     XDIF=XNXT-XLST
          YDIF=YNXT-YLST
C
          IF (ABS(XDIF).LE..000001*(XMAX-XMIN)) GO TO 112
          YPE1=YLST+(XPE1-XLST)*YDIF/XDIF
          YPE2=YLST+(XPE2-XLST)*YDIF/XDIF
C
          IF (ABS(YDIF).LE..000001*(YMAX-YMIN))
            IF (YPE1.LT.YMIN.OR.YPE1.GT.YMAX) GO TO 115
            IF (YPE2.LT.YMIN.OR.YPE2.GT.YMAX) GO TO 115
            GO TO 114
          END IF
C
          IF (YPE1.GE.YMIN.AND.YPE1.LE.YMAX) GO TO 111
          YPE1=YPT1
          XPE1=XLST+(YPE1-YLST)*XDIF/YDIF
          IF (XPE1.LT.XMIN.OR.XPE1.GT.XMAX) GO TO 115
C
  111     IF (YPE2.GE.YMIN.AND.YPE2.LE.YMAX) GO TO 114
          GO TO 113
C
  112     YPE1=YPT1
          XPE1=XLST+(YPE1-YLST)*XDIF/YDIF
          IF (XPE1.LT.XMIN.OR.XPE1.GT.XMAX) GO TO 115
C
  113     YPE2=YPT2
          XPE2=XLST+(YPE2-YLST)*XDIF/YDIF
          IF (XPE2.LT.XMIN.OR.XPE2.GT.XMAX) GO TO 115
C
  114     XCRA(1)=CFUX(XPE1)
          IF (ICFELL('CPWLAM',16).NE.0) RETURN
          YCRA(1)=CFUY(YPE1)
          IF (ICFELL('CPWLAM',17).NE.0) RETURN
          XCRA(2)=CFUX(XPE2)
          IF (ICFELL('CPWLAM',18).NE.0) RETURN
          YCRA(2)=CFUY(YPE2)
          IF (ICFELL('CPWLAM',19).NE.0) RETURN
          CALL AREDAM (IAMA,XCRA,YCRA,2,IGID,JAIL,JAIR)
          IF (ICFELL('CPWLAM',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
