SUBROUTINE SET_COL
Interactive manipulation of look-up-tables for false-color on image displays.
The color look-up table is a spiral in color space.
The user controls the intensity, hue and saturation
at the beginning and end of the spiral, and the number of times
the spiral is repeated. The look-up table can be inverted.
Look-up tables can also be saved in and recalled from disk files.
--
Oct 1986 KDH @ STScI - adapted from palset
Feb 1987 KDH @ STScI - implement IMGUNW
Feb 1988 Keith Horne @ STScI - adapted from IMCOLOR for pgplot
Apr 1988 KDH @ STScI - make wedge optional, default scale on first call only
Nov 1988 KDH @ STScI - eliminate TYPE *, use PGQIMG.
May 90 KDH @ STScI - PGUPDT after each change
Jan 92 TRM @OXVAD - Adapted from PGPLUS
INTERACT -- TRUE if you want to change anything. FALSE
if you just want to set color scale.
IMPLICIT NONE
REAL VAL1, VAL2, HOLD
INTEGER I, J, LENGTH
INTEGER IFAIL
LOGICAL FIRSTCALL, OPEN, COLDEF, SAMECI
CHARACTER*10 REPLY, STATE
CHARACTER*70 FILE, STRING
INCLUDE 'setcol.inc'
COMMON/COLDEF/COLDEF
DATA FIRSTCALL/.TRUE./
SAVE FIRSTCALL
CALL PGQINF('STATE', STATE, LENGTH)
OPEN = .NOT.STATE(:LENGTH).EQ.'CLOSED'
IF(.NOT.OPEN) THEN
WRITE(*,*) 'No plot device is open but you may still set'
WRITE(*,*) 'the colour scale for future plots. You will'
WRITE(*,*) 'not be able to draw a calibration wedge.'
END IF
preliminaries
IF( FIRSTCALL ) THEN
FIRSTCALL = .FALSE.
ROUNDS = DROUNDS
HUE1 = DHUE1
HRANGE = DHRANGE
SAT1 = DSAT1
SAT2 = DSAT2
BRT1 = DBRT1
BRT2 = DBRT2
INVERT = .FALSE.
COLOUR = .TRUE.
USEGUN = .FALSE.
COLDEF = .TRUE.
IF(OPEN) CALL DEF_COL(IFAIL)
END IF
command list
0 WRITE(*,*) 'Colour command menu:'
WRITE(*,*) ' '
IF(OPEN) WRITE(*,*) ' wedge -- show wedge for calibration'
WRITE(*,*) ' default -- back to default colour scale'
IF(COLOUR) THEN
WRITE(*,*) ' grey -- greyscale. Now OFF'
WRITE(*,*) ' colour -- colours on. Now ON'
ELSE
WRITE(*,*) ' grey -- greyscale. Now ON'
WRITE(*,*) ' colour -- colours on. Now OFF'
END IF
WRITE(*,*) ' rounds -- set number of rounds. Now = ',
& ROUNDS
WRITE(*,*) ' intensity -- set intensity limits. Now = ',
& BRT1,BRT2
WRITE(*,*) ' saturation -- set saturation limits. Now = ',
& SAT1,SAT2
WRITE(*,*) ' hues -- set hues limits. Now = ',
& HUE1,HRANGE
IF(INVERT) THEN
WRITE(*,*) ' invert -- invert colour scale. Now ON.'
ELSE
WRITE(*,*) ' invert -- invert colour scale. Now OFF.'
END IF
IF(USEGUN) THEN
WRITE(*,*) ' load -- load+set colour'//
& ' table from disk file. Now ON.'
ELSE
WRITE(*,*) ' load -- load+set colour'//
& ' table from disk file. Now OFF.'
END IF
WRITE(*,*) ' quit -- quit'
WRITE(*,*) ' '
command node
0 WRITE(*,'(A,$)') 'colour> '
READ(*,'(A)') REPLY
IF(OPEN .AND. SAMECI(REPLY,'WEDGE')) THEN
Draw calibration wedge
CALL PGWEDGE(0.,0.,2)
ELSE IF(SAMECI(REPLY,'DEFAULT')) THEN
Set default color scale parameters
ROUNDS = DROUNDS
HUE1 = DHUE1
HRANGE = DHRANGE
SAT1 = DSAT1
SAT2 = DSAT2
BRT1 = DBRT1
BRT2 = DBRT2
INVERT = .FALSE.
COLOUR = .TRUE.
USEGUN = .FALSE.
IF(OPEN) CALL DEF_COL(IFAIL)
ELSE IF(SAMECI(REPLY,'GREY') .OR. SAMECI(REPLY,'COLOUR')) THEN
COLOUR = SAMECI(REPLY,'COLOUR')
USEGUN = .FALSE.
IF(OPEN) CALL DEF_COL(IFAIL)
IF(COLOUR) THEN
WRITE(*,*) 'Colour scale set'
ELSE
WRITE(*,*) 'Grey scale set'
END IF
ELSE IF(SAMECI(REPLY,'ROUNDS')) THEN
set number of rounds
WRITE(*,'(A,F6.2,A,$)') 'How many rounds do you want ? [',
& ROUNDS,']: '
READ(*,'(A)') STRING
IF(STRING.NE.' ') READ(STRING,*,IOSTAT=IFAIL) ROUNDS
IF(IFAIL.NE.0) THEN
WRITE(*,*) 'Error reading value'
GOTO 20
END IF
USEGUN = .FALSE.
IF(OPEN) CALL DEF_COL(IFAIL)
ELSE IF(SAMECI(REPLY,'INTENSITY')) THEN
Set brilliance limits
WRITE(*,*) 'Enter (1) Intensity (0-1) at bottom of scale'
WRITE(*,*) ' (2) Intensity at top of scale'
READ(*,*,IOSTAT=IFAIL) VAL1,VAL2
IF(IFAIL.NE.0) THEN
WRITE(*,*) 'Error reading values'
GOTO 20
END IF
BRT1 = VAL1
BRT2 = VAL2
USEGUN = .FALSE.
IF(OPEN) CALL DEF_COL(IFAIL)
ELSE IF(SAMECI(REPLY,'SATURATION')) THEN
Set saturation limits
WRITE(*,*)
& 'Saturation (0-1) measures the intensity of the colors.'
WRITE(*,*) 'Enter (1) Saturation at bottom of scale'
WRITE(*,*) ' (2) Saturation at top of scale'
READ(*,*,IOSTAT=IFAIL) VAL1,VAL2
IF(IFAIL.NE.0) THEN
WRITE(*,*) 'Error reading values'
GOTO 20
END IF
SAT1=VAL1
SAT2=VAL2
USEGUN = .FALSE.
IF(OPEN .AND. COLOUR) CALL DEF_COL(IFAIL)
ELSE IF(SAMECI(REPLY,'HUES')) THEN
Set hue limits
WRITE(*,*) 'COLOR: RED pur BLU aqu GRN yel'
WRITE(*,*) 'INDEX: 0 1 2 3 4 5'
WRITE(*,*) ' 6 7 8 9 10 11'
WRITE(*,*) ' 12 13 14 15 16 17 ...'
WRITE(*,*) 'Enter (1) INDEX at bottom of color scale'
WRITE(*,*) ' (2) INDEX at top of color scale'
READ(*,*,IOSTAT=IFAIL) VAL1,VAL2
IF(IFAIL.NE.0) THEN
WRITE(*,*) 'Error reading values'
GOTO 20
END IF
HUE1=VAL1
HRANGE=VAL2-VAL1
USEGUN = .FALSE.
IF(OPEN .AND. COLOUR) CALL DEF_COL(IFAIL)
ELSE IF(SAMECI(REPLY,'INVERT')) THEN
Invert color scale
HOLD = BRT1
BRT1 = BRT2
BRT2 = HOLD
HOLD = SAT2
SAT2 = SAT1
SAT1 = HOLD
HUE1 = HUE1 - HRANGE
HRANGE = - HRANGE
INVERT = .NOT. INVERT
USEGUN = .FALSE.
IF(OPEN) CALL DEF_COL(IFAIL)
WRITE(*,*) 'Scale inverted.'
ELSE IF(SAMECI(REPLY,'LOAD')) THEN
WRITE(*,*) 'Name of look-up table input file ? '
READ(*,'(A)') FILE
OPEN( UNIT=48, FILE=FILE, STATUS='OLD', FORM='FORMATTED',
$ ERR=8030)
WRITE(*,*) 'LUT input file opened.'
DO I=1,MAXLEVELS
READ( 48, *, ERR=8020, END=8025 ) (GUN(J,I), J=1,3)
END DO
CLOSE( UNIT=48 )
WRITE(*,*) 'LUT save file closed.'
USEGUN = .TRUE.
8010 CLOSE( UNIT=48 )
WRITE(*,*) 'LUT save file closed.'
GOTO 20
8020 WRITE(*,*) '** Read error.'
USEGUN = .FALSE.
GOTO 8010
8025 WRITE(*,*) '** Premature end of file.'
USEGUN = .TRUE.
GOTO 8010
8030 WRITE(*,*) '** Open error.'
ELSE IF(SAMECI(REPLY,'DUMP')) THEN
WRITE(*,*) 'Name of look-up table save file ? '
READ(*,'(A)') FILE
OPEN( UNIT=48, FILE=FILE, STATUS='NEW', FORM='FORMATTED',
$ ERR=8031 )
WRITE(*,*) 'LUT save file opened.'
DO I=1,MAXLEVELS
WRITE( 48, *, ERR=8021 ) (GUN(I,J), J=1,3)
END DO
WRITE(*,*) 'Values dumped=', MAXLEVELS
8011 CLOSE( UNIT=48 )
WRITE(*,*) 'LUT save file closed.'
GOTO 20
8021 WRITE(*,*) '** Read error.'
GOTO 8011
8031 WRITE(*,*) '** Open error.'
GOTO 20
ELSE IF(SAMECI(REPLY,'QUIT')) THEN
RETURN
ELSE
GOTO 10
END IF
GOTO 20
END
SUBROUTINE DEF_COL(IFAIL)
Sets colour representation if the device is open
IMPLICIT NONE
INTEGER LENGTH, IFAIL, MINCI, MAXCI, I, IGUN
INTEGER NCI, J
REAL RGB(3), TWOPI, PART, BRT, SAT, PHASE, RADIAN
REAL VALUE
CHARACTER*10 STATE
LOGICAL COLDEF
INCLUDE 'setcol.inc'
COMMON/COLDEF/COLDEF
Check that a device is open and that it has at least 1 colour
IFAIL = 1 -- no device open
= 2 -- not enough colours
CALL PGQINF('STATE', STATE, LENGTH)
IF(STATE(:LENGTH).EQ.'CLOSED') THEN
IFAIL = 1
RETURN
END IF
CALL PGQCIR( MINCI, MAXCI )
NCI = MAXCI - MINCI + 1
IF( NCI.LE.1 ) THEN
IFAIL = 2
RETURN
ELSE IF( USEGUN .AND. NCI.GT.MAXLEVELS ) THEN
WRITE(*,*) '** WARNING: NCI=', NCI, ' max=', MAXLEVELS
MAXCI = MINCI + MAXLEVELS - 1
NCI = MAXCI - MINCI + 1
END IF
TWOPI = 8.*ATAN2(1.,1.)
Define default colour scale if nothing has been defined so far
IF(.NOT.COLDEF) THEN
ROUNDS = DROUNDS
HUE1 = DHUE1
HRANGE = DHRANGE
SAT1 = DSAT1
SAT2 = DSAT2
BRT1 = DBRT1
BRT2 = DBRT2
INVERT = .FALSE.
COLOUR = .TRUE.
USEGUN = .FALSE.
COLDEF = .TRUE.
END IF
Apply colours
CALL PGBBUF
IF(USEGUN) THEN
DO I = MINCI, MAXCI
J = I - MINCI + 1
CALL PGSCR( I, GUN(1,J), GUN(2,J), GUN(1,J) )
END DO
ELSE
DO I= MINCI, MAXCI
PART = ROUNDS*REAL(I-MINCI)/REAL(MAXCI-MINCI)
PART = PART-INT(PART)
BRT = BRT1*(1.-PART) + BRT2*PART
IF(COLOUR) THEN
SAT = SAT1*(1.-PART) + SAT2*PART
PHASE = (HUE1 - HRANGE*PART)/6.
DO IGUN=1,3
RADIAN = TWOPI*( PHASE - REAL(IGUN-1)/3. )
VALUE = BRT + SAT*( 0.5*COS(RADIAN) - 0.5)
RGB(IGUN) = MAX(0., MIN(1., VALUE ) )
END DO
ELSE
DO IGUN=1,3
RGB(IGUN) = MAX(0., MIN(1., BRT))
END DO
END IF
CALL PGSCR( I, RGB(1), RGB(2), RGB(3))
END DO
Set extreme values to white and black
IF(INVERT) THEN
CALL PGSCR(MINCI,1.,1.,1.)
CALL PGSCR(MAXCI,0.,0.,0.)
ELSE
CALL PGSCR(MINCI,0.,0.,0.)
CALL PGSCR(MAXCI,1.,1.,1.)
END IF
END IF
CALL PGEBUF
CALL PGUPDT
IFAIL = 0
RETURN
END
This command belongs to the class: display