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