C Copyright(C) 2009-2017 National Technology & Engineering Solutions of
C Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C     * Neither the name of NTESS nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

C=======================================================================
      SUBROUTINE UGRCOL (INDX, BLKCOL)
C=======================================================================

C   --*** UGRCOL *** (BLOT) Set color (PLT)
C   --   Written by John Glick - 11/29/88
C   --
C   --UGRCOL is similar to the GRCOLR routine of GRPLIB in that it
C   --sets the color of lines depending on the passed index.
C   --The colors are chosen differently than GRCOLR, however.
C   --If appropriate, the BLKCOL array is used to select the color.
C   --
C   --
C   --Parameters:
C   --   INDX - IN - the color index or block id:
C   --      If = -1, black is chosen as the color.
C   --      If = 0, the foreground color is chosen as the color.
C   --              If the foreground color is not available on
C   --              the current device, white is chosen.
C   --      If > 0, it is assumed to be an element block identifier.
C   --              If BLKCOL(INDX) > -2, then BLKCOL(INDX) is the
C   --              color index chosen (if it is a supported color on
C   --              the current device).
C   --   BLKCOL - IN - the user selected colors of the element blocks.
C   --                    BLKCOL(0) = 1 if the user defined material
C   --                                colors should be used in mesh plots.
C   --                              = -1 if program selected colors should
C   --                                not be used.
C   --                    BLKCOL(i) = the user selected color of element
C   --                               block i:
C   --                                  -2 - no color selected by user.
C   --                                  -1 - black
C   --                                   0 - white
C   --                                   1 - red
C   --                                   2 - green
C   --                                   3 - yellow
C   --                                   4 - blue
C   --                                   5 - cyan
C   --                                   6 - magenta
C   --
C   --Common Variables:
C   --   Uses ICURDV, MAXCOL, NUMCOL, MAPUSE of /GRPCOM/

C   --Routines Called:
C   --   PLTICL - (PLTLIB) Get color index from name
C   --   PLTSTD - (PLTLIB) Set device parameter
C   --      1 = (KCOLOR) set color
C   --   PLTSTG - (PLTLIB) Set graph parameter
C   --      6 = (KCOLIN) set line color for PLTGRH lines
C   --      44 = (KCOSYM) set symbol color for PLTGRH lines

      PARAMETER (KCOLOR=1)
      PARAMETER (KCOLIN=6, KCOSYM=44)

      COMMON /GRPCOC/ DEVNAM(2), DEVCOD(2)
      CHARACTER*3 DEVNAM
      CHARACTER*8 DEVCOD
      COMMON /GRPCOM/ ICURDV, ISHARD, DEVOK(2), TALKOK(2),
     &   NSNAP(2), IFONT(2), SOFTCH(2), AUTOPL(2),
     &   MAXCOL(2), NUMCOL(0:1,2), MAPALT(2), MAPUSE(2)
      LOGICAL ISHARD, DEVOK, TALKOK, SOFTCH, AUTOPL
      include 'dbnums.blk'
      include 'grcol.blk'

      COMMON /BCOLR/ BCOLCH
      LOGICAL BCOLCH

      include 'plcol2.blk'
      include 'params.blk'
      include 'cmap-lst.blk'
      INTEGER LSTD2
      SAVE LSTD2

      INTEGER INDX
      INTEGER BLKCOL(0:NELBLK)

      LOGICAL LDUM, PLTSTG, PLTSTD, PLTICL

      LOGICAL COLSPC(NCOLOR)
      INTEGER NUMFRE, FRECOL(NCOLOR)
      SAVE COLSPC, NUMFRE, FRECOL

      CHARACTER*8 BLCOLR, WHCOLR
      SAVE BLCOLR, WHCOLR

      DATA LSTD2 / 0 /
      DATA BLCOLR, WHCOLR / 'BLACK   ', 'WHITE   ' /

      IF (ICURDV .NE. LSTDEV) THEN
         LSTDEV = ICURDV
         LSTMAP = 0

C      --Reset last color
         LSTCOL = -999

C      --Set device black and white
         IF (MAXCOL(ICURDV) .GT. 0) THEN
            LDUM = PLTICL (WHCOLR, RWHITE)
            IWHITE = INT(RWHITE)
            LDUM = PLTICL (BLCOLR, RBLACK)
            IBLACK = INT(RBLACK)
         ELSE
            IBLACK = 0
            IWHITE = 1
         END IF

      ELSE IF (MAPUSE(ICURDV) .NE. LSTMAP) THEN

C      --Reset last color
         LSTCOL = -999
         LSTMAP = MAPUSE(ICURDV)

      ENDIF

      IF (ICURDV .NE. LSTD2) THEN
C           Get mapping of colors
         DO 100 I = 1, NCOLOR
            IF (PLTICL (COLLST(I+2), RCOLOR)) THEN
               COLMAP(I) = RCOLOR
            ELSE
               COLMAP(I) = -1
            ENDIF
  100    CONTINUE
      ENDIF

      IF (BCOLCH  .OR.  (ICURDV .NE. LSTD2)) THEN
         BCOLCH = .FALSE.
         DO 110 I = 1, NCOLOR
            COLSPC(I) = .FALSE.
  110    CONTINUE
         IF (BLKCOL(0) .EQ. 1) THEN
            DO 120 I = 1, NELBLK
               IF ((BLKCOL(I) .GT. 0)  .AND.
     &            (COLMAP(BLKCOL(I)) .NE. -1))
     &            COLSPC(BLKCOL(I)) = .TRUE.
  120       CONTINUE
         ENDIF
         NUMFRE = 0
         DO 130 I = 1, NCOLOR
            IF ((.NOT. COLSPC(I))  .AND.  (COLMAP(I) .NE. -1)) THEN
               NUMFRE = NUMFRE + 1
               FRECOL(NUMFRE) = I
            ENDIF
  130    CONTINUE
      ENDIF

      IF (ICURDV .NE. LSTD2) LSTD2 = ICURDV

      NCOL = NUMCOL(MAPUSE(ICURDV),ICURDV)

      IF (BLKCOL(0) .EQ. 1) THEN
         IF (INDX .EQ. -1) THEN
            ICOLOR = IBLACK
         ELSE IF (INDX .EQ. 0) THEN
            IDFORT = IDFOR
            IF (IDFOR .EQ. 1) THEN
               ICOLOR = IBLACK
            ELSE IF (IDFOR .EQ. 2) THEN
               ICOLOR = IWHITE
            ELSE IF (COLMAP(IDFOR-2) .GE. 0.0) THEN
               ICOLOR = INT(COLMAP(IDFOR-2))
            ELSE
               ICOLOR = IWHITE
               IDFORT = 2
            ENDIF
            COLFOR = REAL (ICOLOR)
         ELSE IF ((BLKCOL(INDX) .GT. 0)  .AND.
     &      (COLMAP(BLKCOL(INDX)) .NE. -1)) THEN
            ICOLOR = INT(COLMAP(BLKCOL(INDX)))
         ELSE IF (BLKCOL(INDX) .EQ. 0) THEN
            ICOLOR = IWHITE
         ELSE IF (BLKCOL(INDX) .EQ. -1) THEN
            ICOLOR = IBLACK
         ELSE
            IF (NUMFRE .GT. 0) THEN
               NBLNSP = 0
               DO 140 I = 1, INDX
                  IF (BLKCOL(I) .EQ. -2) THEN
                     NBLNSP = NBLNSP + 1
                  ELSE IF (BLKCOL(I) .GT. 0) THEN
                     IF (COLMAP(BLKCOL(I)) .EQ. -1) THEN
                        NBLNSP = NBLNSP + 1
                     ENDIF
                  ENDIF
  140          CONTINUE
               ICOLOR = INT(COLMAP (FRECOL(MOD (NBLNSP-1, NUMFRE)+1)))
            ELSE
               IDFORT = IDFOR
               IF (IDFOR .EQ. 1) THEN
                  ICOLOR = IBLACK
               ELSE IF (IDFOR .EQ. 2) THEN
                  ICOLOR = IWHITE
               ELSE IF (COLMAP(IDFOR-2) .GE. 0.0) THEN
                  ICOLOR = INT(COLMAP(IDFOR-2))
               ELSE
                  ICOLOR = IWHITE
                  IDFORT = 2
               ENDIF
               COLFOR = REAL (ICOLOR)
            ENDIF
         ENDIF

      ELSE
         IF ((INDX .GT. 0) .AND. (NCOL .GT. 0)) THEN
C ... This is a temporary kludge by GDS for Ultrix -
            ICOLOR = MOD (INDX-1, NCOL) +1
C            ICOLOR = MOD (INDX-1, NCOL)
            IF (MAPUSE(ICURDV) .EQ. 0) THEN
               IF (ICOLOR .GE. IBLACK) ICOLOR = ICOLOR + 1
               IF (ICOLOR .GE. IWHITE) ICOLOR = ICOLOR + 1
               IF (ICOLOR .GT. IBLACK .AND.
     &             ICOLOR .LT. IWHITE) ICOLOR = INT(COLMAP(ICOLOR))
            ELSE
               ICOLOR = ICOLOR + (6 + 2)
            END IF
         ELSE IF (INDX .EQ. -1) THEN
            ICOLOR = IBLACK
         ELSE
            IDFORT = IDFOR
            IF (IDFOR .EQ. 1) THEN
               ICOLOR = IBLACK
            ELSE IF (IDFOR .EQ. 2) THEN
               ICOLOR = IWHITE
            ELSE IF (COLMAP(IDFOR-2) .GE. 0.0) THEN
               ICOLOR = INT(COLMAP(IDFOR-2))
            ELSE
               ICOLOR = IWHITE
               IDFORT = 2
            ENDIF
            COLFOR = REAL (ICOLOR)
         END IF
      ENDIF

      IF (ICOLOR .NE. LSTCOL) THEN
         LDUM = PLTSTD (KCOLOR, REAL (ICOLOR))
         LDUM = PLTSTG (KCOLIN, REAL (ICOLOR))
         LDUM = PLTSTG (KCOSYM, REAL (ICOLOR))
         LSTCOL = ICOLOR
      END IF
      RETURN
      END


