C Copyright(C) 1999-2020, 2024 National Technology & Engineering Solutions
C of 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 See packages/seacas/LICENSE for details

C---5---10---15---20---25---30---35---40---45---50---55---60---65---70--
C=======================================================================
      SUBROUTINE GRCOLT
C=======================================================================

C   --*** GRCOLT *** (GRPLIB) Set alternate color table (PLT)
C   --   Written by Amy Gilkey - revised 04/11/88
C   --
C   --GRCOLT sets the alternate color table (colors 8..) to a specified
C   --color table map.  The following maps are defined:
C   --       spectrum colors blue to red
C   --       rainbow colors violet to red
C   --
C   --Common Variables:
C   --   Uses DEVOK, ICURDV, NUMCOL, MAPALT of /GRPCOM/
C   --   Sets MAPUSE of /GRPCOM/

C   --Routines Called:
C   --   PLTCOL - (PLTLIB) Set color table color
C   --   PLTIQC - (PLTLIB) Get color table color

      EXTERNAL BLKDAT

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

      include 'grpcom.blk'

C  Flag for rainbow spectrum
      include 'icrnbw.blk'

      REAL SRED(0:4), SGREEN(0:4), SBLUE(0:4)
      SAVE SRED, SGREEN, SBLUE
C      --SRED, SGREEN, SBLUE - color ratios for RGB settings; spectrum is
C      --   divided in 4 parts

      REAL RRED(32:255), RGREEN(32:255), RBLUE(32:255)
      SAVE RRED, RGREEN, RBLUE
C  RRED, RGREEN, RBLUE - color ratios for RGB settings; rainbow is
C  from TOOPLOT color table; numbering 32-255 has been retained
C  in order to use original coding to generate table.
C  The original routineS used 0-255 for color definition values.
C  These are scaled to the range 0.-1. here.

      INTEGER LSTALT(2), LSTNUM(2)
      SAVE LSTALT, LSTNUM, SATLST, IRNBWL
C      --LSTALT - the color type last set for the device
C      --LSTNUM - the number of colors last set for the device

      DATA SRED   / 0.20, 0.50, 0.80, 0.85, 1.00 /
      DATA SGREEN / 0.60, 0.70, 0.80, 0.60, 0.10 /
      DATA SBLUE  / 1.00, 0.50, 0.25, 0.10, 0.10 /

C  INITIALIZE ALL RAINBOW COLORS TO ZERO - COLOR TABLE HAS NOT BEEN CREATED
      DATA RRED   / 224*0. /
      DATA RGREEN / 224*0. /
      DATA RBLUE  / 224*0. /

      DATA LSTALT / 0, 0 /
      DATA LSTNUM / 0, 0 /
      DATA SATLST / 0.0  /
      DATA IRNBWL / -1 /

      IF (MAPALT(ICURDV) .LE. 0) THEN
         CONTINUE

      ELSE IF ((MAPALT(ICURDV) .NE. LSTALT(ICURDV))
     &   .OR. (NUMCOL(MAPALT(ICURDV),ICURDV) .NE. LSTNUM(ICURDV))
     &   .OR.  IRNBWL.NE.IRAINB  .OR.  SATUR .NE. SATLST) THEN

        IF (MAPALT(ICURDV) .EQ. 1) THEN

C         --Set up a spectrum of colors in colors 8+

          IF(IRAINB.EQ.0 .AND. ISPEC .EQ. 0)THEN
C  Blue-brown-red spectrum (DEFAULT)

            IF (NUMCOL(1,ICURDV) .EQ. 1) THEN
               CALL PLTCOL (8+0, 0.0, 0.0, 1.0)

            ELSE IF (NUMCOL(1,ICURDV) .EQ. 2) THEN
              if (isinv .eq. 0) then
                CALL PLTCOL (8+0, 0.0, 0.0, 1.0)
                CALL PLTCOL (8+1, 1.0, 0.0, 0.0)
              else
                CALL PLTCOL (8+1, 0.0, 0.0, 1.0)
                CALL PLTCOL (8+0, 1.0, 0.0, 0.0)
              end if
            ELSE IF (NUMCOL(1,ICURDV) .EQ. 3) THEN
              if (isinv .eq. 0) then
                CALL PLTCOL (8+0, 0.0, 0.0, 1.0)
                CALL PLTCOL (8+1, 0.0, 1.0, 0.0)
                CALL PLTCOL (8+2, 1.0, 0.0, 0.0)
              else
                CALL PLTCOL (8+2, 0.0, 0.0, 1.0)
                CALL PLTCOL (8+1, 0.0, 1.0, 0.0)
                CALL PLTCOL (8+0, 1.0, 0.0, 0.0)
              end if
            ELSE IF (NUMCOL(1,ICURDV) .EQ. 5) THEN
              if (isinv .eq. 0) then
                CALL PLTCOL (8+0, 0.0, 0.0, 1.0)
                CALL PLTCOL (8+1, 0.0, 1.0, 1.0)
                CALL PLTCOL (8+2, 0.0, 1.0, 0.0)
                CALL PLTCOL (8+3, 1.0, 1.0, 0.0)
                CALL PLTCOL (8+4, 1.0, 0.0, 0.0)
              else
                CALL PLTCOL (8+4, 0.0, 0.0, 1.0)
                CALL PLTCOL (8+3, 0.0, 1.0, 1.0)
                CALL PLTCOL (8+2, 0.0, 1.0, 0.0)
                CALL PLTCOL (8+1, 1.0, 1.0, 0.0)
                CALL PLTCOL (8+0, 1.0, 0.0, 0.0)
              end if
            ELSE
              NEWCOL = NUMCOL(1,ICURDV) - 1
              DO 10 I = 0, NEWCOL
                FRAC = DBLE(I) / DBLE(NEWCOL)
                ISEG = INT (FRAC * 4)
                REM = FRAC * 4 - ISEG
                if (iseg .lt. 4) then
                   XRED   = SRED(ISEG)
     &                  - REM * (SRED(ISEG) - SRED(ISEG+1))
                   XGREEN = SGREEN(ISEG)
     &                  - REM * (SGREEN(ISEG) - SGREEN(ISEG+1))
                   XBLUE  = SBLUE(ISEG)
     &                  - REM * (SBLUE(ISEG) - SBLUE(ISEG+1))
                else
                   XRED   = SRED(ISEG)
                   XGREEN = SGREEN(ISEG)
                   XBLUE  = SBLUE(ISEG)
                end if
                if (isinv .eq. 0) then
                  CALL PLTCOL (8+I, XRED, XGREEN, XBLUE)
                else
                  CALL PLTCOL (8+NEWCOL-I, XRED, XGREEN, XBLUE)
                end if
 10           CONTINUE
            END IF

          ELSE IF(IRAINB.EQ.0 .AND. ISPEC .GE. 1)THEN
            NEWCOL = NUMCOL(1,ICURDV) - 1
            call textur (SATUR, NUMCOL(1,ICURDV), ISPEC, ISINV,
     *        RMULT, GMULT, BMULT)
            SATLST = SATUR
          ELSE
C  Rainbow spectrum
           IF(RRED(32).EQ.0.)THEN

C  Color table has not been created. Generate it

C     Define colors 32-56 to be a linear variation from red to orange
C     Red    = 255,0,0    (R,G,B)
C     Orange = 255,168,0  (R,G,B)

             XIPCOL=168.0/24.0
             DO 50 I=32,56
              RRED(I)=1.
              RGREEN(I)=(I-32)*XIPCOL/255.
              RBLUE(I)=0.
   50        CONTINUE

C     Define colors 57-106 to be a linear variation from orange to yellow
C     Orange = 255,168,0  (R,G,B)
C     Yellow = 255,255,0  (R,G,B)

             XIPCOL=87.0/50.0
             DO 60 I=57,106
              RRED(I)=1.
              RGREEN(I)=(168.0+(I-56)*XIPCOL)/255.
              RBLUE(I)=0.
   60        CONTINUE

C     Define colors 107-166 to be a linear variation from yellow to green
C     Yellow = 255,255,0  (R,G,B)
C     Green  = 0,255,0    (R,G,B)

             XIPCOL=255.0/60.0
             DO 70 I=107,166
              RRED(I)=(255.0-(I-106)*XIPCOL)/255.
              RGREEN(I)=1.
              RBLUE(I)=0.
   70        CONTINUE

C     Define colors 167-210 to be a linear variation from green to blue
C     Green = 0,255,0  (R,G,B)
C     Blue  = 0,0,255  (R,G,B)

             XIPCOL=255.0/44.0
             DO 80 I=167,210
              RRED(I)=0.
              RGREEN(I)=(255.0-(I-166)*XIPCOL)/255.
              RBLUE(I)=(I-166)*XIPCOL/255.
   80        CONTINUE

C    Define colors 211-255 to be a linear variation from blue to violet
C    Blue   = 0,0,255    (R,G,B)
C    Purple = 180,0,180  (R,G,B)

             XICOLB = 75.0/45.0
             XICOLR = 180.0/45.0
             DO 90 I=211,255
              RRED(I)=(I-210)*XICOLR/255.
              RGREEN(I)=0.
              RBLUE(I)=(255.0-(I-210)*XICOLB)/255.
   90        CONTINUE

            ENDIF

            IF (NUMCOL(1,ICURDV) .EQ. 1) THEN
               CALL PLTCOL (8+0, 0.7059, 0.0, 0.7059)

            ELSE
               NEWCOL = NUMCOL(1,ICURDV) - 1
               DO 100 I = 0, NEWCOL
C  Interpolate on color number, not color values.
C  For a spectrum with less than 224 colors, choose
C  equally-spaced color numbers from the range 255-32
                  FRAC = DBLE(I) / DBLE(NEWCOL)
                  NC=NINT(255.-FRAC*223.)
                  CALL PLTCOL (8+I, RRED(NC), RGREEN(NC), RBLUE(NC))
  100          CONTINUE
            END IF

          ENDIF

         END IF

C      --Change old alternate colors to black

         IF (LSTALT(ICURDV) .GT. 0) THEN
            DO 110 I = NEWCOL+1, LSTNUM(ICURDV)-1
               CALL PLTCOL (8+I, 0.0, 0.0, 0.0)
  110       CONTINUE
         END IF
         CALL PLTFLU

         LSTALT(ICURDV) = MAPALT(ICURDV)
         LSTNUM(ICURDV) = NUMCOL(LSTALT(ICURDV),ICURDV)
      END IF

      MAPUSE(ICURDV) = MAPALT(ICURDV)

      IRNBWL=IRAINB

      RETURN
      END
