C 
C Program PALLET to interpolate colour tables.
C
C Version: 5.40
C Date: 2000, January 24
C
C Coded by: Ludek Klimes
C     Department of Geophysics, Charles University Prague,
C     Ke Karlovu 3, 121 16 Praha 2, Czech Republic,
C     E-mail: klimes@seis.karlov.mff.cuni.cz
C
C.......................................................................
C                                                    
C Description of data files:
C
C Input data read from the standard input device (*):
C     The data are read by the list directed input (free format) and
C     consist of a single string 'SEP':
C     'SEP'...String in apostrophes containing the name of the input
C             SEP parameter or history file with the input data.
C     No default, 'SEP' must be specified and cannot be blank.
C
C                                                     
C Input data file 'SEP':
C     File 'SEP' has the form of the SEP
C     parameter file.  The parameters, which do not differ from their
C     defaults, need not be specified in file 'SEP'.
C Names of input and output files:
C     KRGB='string'... Name of the input data file containing
C             the table assigning RGB colours to several integers.
C             Description of file KRGB
C             No default, KRGB must be specified and cannot be blank.
C     KRGBNEW='string'... Name of the output data file containing
C             the table assigning RGB colours to all integers within the
C             range corresponding to the input.
C             Description of file KRGBNEW
C             No default, KRGBNEW must be specified and cannot be blank.
C Brightness factor:
C     FACTOR=real ... Brightness factor.  Intensities of the input RGB
C             colours are multiplied by FACTOR.
C             Default: FACTOR=1.
C
C                                                    
C Input file KRGB and output file KRGBNEW with the RGB colour tables:
C     Each line contains four numbers:
C K,R,G,B
C     K...    Index of the colour.  Non-negative integer.
C     R...    Content of the red colour.  Real between 0 and 1.
C     G...    Content of the green colour.  Real between 0 and 1.
C     B...    Content of the blue colour.  Real between 0 and 1.
C
C.......................................................................
C
C This Fortran77 file consists of the following external procedures:
C     PALLET..Main program to interpolate colour tables.
C             PALLET
C     RGBHSV..Subroutine to convert the RGB colour representation into
C             the HSV colour representation.
C             RGBHSV
C     HSVRGB..Subroutine to convert the HSV colour representation into
C             the RGB colour representation.
C             HSVRGB
C
C=======================================================================
C
C     
C
C     Filenames:
      CHARACTER*80 FILE1,FILE2
      CHARACTER*80 FILSEP
      INTEGER LU0
      PARAMETER (LU0=1)
C
      INTEGER K1,K2,K
      REAL  FACTOR,A1,H1,S1,V1,A2,H2,S2,V2,R2,G2,B2,H,S,V,R,G,B
C
C.......................................................................
C
C     Reading name of SEP file with input data:
      WRITE(*,'(A)') '+PALLET: Enter input filename: '
      FILSEP=' '
      READ(*,*) FILSEP
      WRITE(*,'(A)') '+PALLET: Working ...           '
C
C     Reading all data from the SEP file into the memory:
      IF (FILSEP.NE.' ') THEN
        CALL RSEP1(LU0,FILSEP)
      ELSE
C       PALLET-07
        CALL ERROR('PALLET-07: SEP file not given')
C       Input file in the form of the SEP (Stanford Exploration Project)
C       parameter or history file must be specified.
C       There is no default filename.
      ENDIF
C
C     Reading input parameters from the SEP file:
      CALL RSEP3T('KRGB',FILE1,' ')
      IF (FILE1.EQ.' ') THEN
C       PALLET-08
        CALL ERROR('PALLET-08: Input file KRGB not given')
C       Input file KRGB must be specified.
C       There is no default filename.
      ENDIF
      CALL RSEP3T('KRGBNEW',FILE2,' ')
      IF (FILE2.EQ.' ') THEN
C       PALLET-09
        CALL ERROR('PALLET-09: Output file KRGBNEW not given')
C       Output file KRGBNEW must be specified.
C       There is no default filename.
      ENDIF
      CALL RSEP3R('FACTOR',FACTOR,1.)
C
      OPEN(1,FILE=FILE1,STATUS='OLD')
      OPEN(2,FILE=FILE2)
      READ(1,*,END=90) K2,R2,G2,B2
      IF(K2.EQ.0) THEN
        WRITE(2,'(I3,3F5.2)') K2,R2,G2,B2
      ELSE
        WRITE(2,'(I3,3F5.2)') K2,R2*FACTOR,G2*FACTOR,B2*FACTOR
      END IF
      CALL RGBHSV(R2,G2,B2,H2,S2,V2)
   10 CONTINUE
        K1=K2
        H1=H2
        S1=S2
        V1=V2
        READ(1,*,END=90) K2,R2,G2,B2
        CALL RGBHSV(R2,G2,B2,H2,S2,V2)
        DO 20 K=K1+1,K2
          A2=FLOAT(K-K1)/FLOAT(K2-K1)
          A1=1.-A2
          H=H1*A1+H2*A2
          S=S1*A1+S2*A2
          V=V1*A1+V2*A2
          IF(ABS(H1-H2).GT.0.5) THEN
            IF(H1+H2.LT.1.) THEN
              IF(H1.LT.H2) THEN
                H=H+A1
              ELSE
                H=H+A2
              END IF
            ELSE
              IF(H1.GE.H2) THEN
                H=H-A1
              ELSE
                H=H-A2
              END IF
            END IF
          END IF
          S=S*FACTOR
          V=V*FACTOR
          CALL HSVRGB(H,S,V,R,G,B)
          WRITE(2,'(I3,3F5.2)') K,R,G,B
   20   CONTINUE
      GO TO 10
C
   90 CONTINUE
      CLOSE(1)
      CLOSE(2)
      WRITE(*,'(A)') '+PALLET: Done.                 '
      STOP
      END
C
C=======================================================================
C
C     
C
      SUBROUTINE RGBHSV(R,G,B,H,S,V)
      REAL R,G,B,H,S,V
C
C Subroutine to convert the RGB colour representation into the HSV
C colour representation.
C
C Input:
C     R...    Red.
C     G...    Green.
C     B...    Blue.
C
C Output:
C     H...    Hue: red=0., green=1/3, blue=2/3.
C     S...    Saturation or chroma: saturation*value=chroma=pure colour.
C     V...    Value = pure colour + white.
C
C No subroutines and external functions referred.
C
C Date: 1999, February 26
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
*     REAL  PI
*     PARAMETER (PI=3.141593)
C
C.......................................................................
C
      H=0.
      IF(R.GE.G.AND.R.GE.B) THEN
        V=R
        IF(B.GE.G) THEN
          S=(V-G)
          IF(S.GT.0.) THEN
*           H=11./12.-ASIN((B-G)/S-0.5)/2./PI
            H=(6.-(B-G)/S)/6.
          END IF
        ELSE
          S=(V-B)
          IF(S.GT.0.) THEN
*           H= 1./12.+ASIN((G-B)/S-0.5)/2./PI
            H=(0.+(G-B)/S)/6.
          END IF
        END IF
      ELSE IF(G.GE.B) THEN
        V=G
        IF(R.GE.B) THEN
          S=(V-B)
          IF(S.GT.0.) THEN
*           H= 3./12.-ASIN((R-B)/S-0.5)/2./PI
            H=(2.-(R-B)/S)/6.
          END IF
        ELSE
          S=(V-R)
          IF(S.GT.0.) THEN
*           H= 5./12.+ASIN((B-R)/S-0.5)/2./PI
            H=(2.+(B-R)/S)/6.
          END IF
        END IF
      ELSE
        V=B
        IF(G.GE.R) THEN
          S=(V-R)
          IF(S.GT.0.) THEN
*           H= 7./12.-ASIN((G-R)/S-0.5)/2./PI
            H=(4.-(G-R)/S)/6.
          END IF
        ELSE
          S=(V-G)
          IF(S.GT.0.) THEN
*           H= 9./12.+ASIN((R-G)/S-0.5)/2./PI
            H=(4.+(R-G)/S)/6.
          END IF
        END IF
      END IF
      IF(H.LT.0.) THEN
        H=H+1.
      END IF
      IF(H.GT.1.) THEN
        H=H-1.
      END IF
C     If V is saturation (comment if V is chroma):
*     IF(V.GT.0.) THEN
*       S=S/V
*     END IF
C
      RETURN
      END
C
C=======================================================================
C
C     
C
      SUBROUTINE HSVRGB(H,S,V,R,G,B)
      REAL H,S,V,R,G,B
C
C Subroutine to convert the HSV colour representation into the RGB
C colour representation.
C
C Input:
C     H...    Hue: red=0., green=1/3, blue=2/3.
C     S...    Saturation or chroma: saturation*value=chroma=pure colour.
C     V...    Value = pure colour + white.
C
C Output:
C     R...    Red.
C     G...    Green.
C     B...    Blue.
C
C No subroutines and external functions referred.
C
C Date: 1999, February 26
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
*     REAL  PI
*     PARAMETER (PI=3.141593)
C
C.......................................................................
C
      R=0.
      G=0.
      B=0.
      IF(H.LE.1./6.) THEN
        R=1.
        IF(H.LE.0.) THEN
*         B=-SIN(2.*PI*(H+1./12.))+0.5
          B=-6.*H
        ELSE
*         G= SIN(2.*PI*(H-1./12.))+0.5
          G= 6.*H
        END IF
      ELSE IF(H.LE.3./6.) THEN
        G=1.
        IF(H.LE.2./6.) THEN
*         R=-SIN(2.*PI*(H-3./12.))+0.5
          R=-6.*H+2.
        ELSE
*         B= SIN(2.*PI*(H-5./12.))+0.5
          B= 6.*H-2.
        END IF
      ELSE IF(H.LE.5./6.) THEN
        B=1.
        IF(H.LE.4./6.) THEN
*         G=-SIN(2.*PI*(H-7./12.))+0.5
          G=-6.*H+4.
        ELSE
*         R= SIN(2.*PI*(H-9./12.))+0.5
          R= 6.*H-4.
        END IF
      ELSE
        R=1.
        IF(H.LE.1.) THEN
*         B=-SIN(2.*PI*(H-11./12.))+0.5
          B=-6.*H+6.
        ELSE
*         G= SIN(2.*PI*(H-13./12.))+0.5
          G= 6.*H-6.
        END IF
      END IF
C     If V is saturation:
*     R=V*(1.-S*(1.-R))
*     G=V*(1.-S*(1.-G))
*     B=V*(1.-S*(1.-B))
C     If V is chroma:
      R=V-S*(1.-R)
      G=V-S*(1.-G)
      B=V-S*(1.-B)
C
      IF(R.LT.0.) THEN
C       PALLET-01
        CALL ERROR('PALLET-01: Red colour component negative')
      END IF
      IF(R.GT.1.) THEN
C       PALLET-02
        CALL ERROR('PALLET-02: Red colour component greater than 1')
      END IF
      IF(G.LT.0.) THEN
C       PALLET-03
        CALL ERROR('PALLET-03: Green colour component negative')
      END IF
      IF(G.GT.1.) THEN
C       PALLET-04
        CALL ERROR('PALLET-04: Green colour component greater than 1')
      END IF
      IF(B.LT.0.) THEN
C       PALLET-05
        CALL ERROR('PALLET-05: Blue colour component negative')
      END IF
      IF(B.GT.1.) THEN
C       PALLET-06
        CALL ERROR('PALLET-06: Blue colour component greater than 1')
      END IF
C
      RETURN
      END
C
C=======================================================================
C
      INCLUDE 'error.for'
C     error.for
      INCLUDE 'sep.for'
C     sep.for
      INCLUDE 'length.for'
C     length.for
C
C=======================================================================
C