C===========================================================================
C Copyright (C) 1995,2004 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or 
C modify it under the terms of the GNU General Public License as 
C published by the Free Software Foundation; either version 2 of 
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public 
C License along with this program; if not, write to the Free 
C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
C MA 02139, USA.
C
C Correspondence concerning ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division 
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen 
C			GERMANY
C===========================================================================
C
      PROGRAM LUTMOD
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION:
C  program LUTMOD		version 1.00	870522
C  K. Banse			ESO - Garching
C
C.KEYWORDS:
C  LUT, Image Display
C
C.PURPOSE:
C  a1) manipulate the colour lookup tables of the ImageDisplay interactively
C      in the same way as the IHAP command KTABLE...
C  a2) rotate the offset of one or all LUTs
C 
C  b1) manipulate the colour lookup tables of ImageDisplay interactively
C      like IHAP command KLOOKUP
C 
C  c1) squeeze/stretch the colour lookup tables of the ImageDisplay interactively
C  
C.ALGORITHM:
C  a1) The joystick is used to move + modify a one-colour band along 
C      the refscale
C      the LUTs are modified accordingly and sent to the Image Display
C  a2) The joystick is used to move the start of a LUT along the refscale
C	
C  b1) In the upper right hand corner of the screen a graphic repesentation
C      of a linear function mapping gray scale values to the current colour
C      table is shown.
C      Moving the joystick horizontally changes the slope of the function,
C      moving it vertically changes the intercept.
C	
C  c1) An arrow will point to the start of the sqeezed/stretched colours 
C      of the old colour band in the new colour band, 
C      this start point is controlled via the horizontal joystick movements.
C      Vertical joystick movements control the sqeezing or stretching of the 
C      old colour band.
C
C  On the cursor board the cursor #1 has to be on.
C  Turning cursor #1 off will terminate the program.
C	
C.INPUT/OUTPUT:
C  DEFAULT/C/15/1		L or I for LUT or ITT business
C  DEFAULT/C/16/1		A, B or C to determine which section
C				of LUTMOD should be executed
C  DAZHOLD/I/10/1		LUT section no.
C 
C  A:
C  P1/C/1/1			method to use, R for rotate, B for band
C  P2/C/1/1			colour to work with, R (red), G (green),
C  				B (blue), W (white), D (dark) or A (all)
C  P3/C/1/1			print flag, Yes or No
C  or
C  INPUTI/I/1/3			intensities for red, green + blue LUT
C	
C  output values are written to:
C  OUTPUTR/R/1/3		if method BAND is used: the data values
C				corresponding to start, center + end of band
C  
C  B:
C  P2/C/1/1			colour to work with: A (all), R (red), G (green)
C				and B (blue)
C 
C  C:
C  P1/C/1/1			S(queeze) or C(ursor modified)
C
C.VERSION
C 040121	last modif
C 
C  --------------------------------
C
C.PURPOSE for the ITT part:
C  1) overlay a band on active ITT of DeAnza interactively
C  2) rotate the offset of the ITT
C  3) squeeze + stretch the ITT
C  4) convolve with another ITT
C  5) equalize histogram and send it as an ITT to the ImageDisplay
C  6) do contrast stretching with the ITT
C
C.ALGORITHM:
C  1) the joystick is used to move + modify a one-value band along the refscale
C     the ITT is modified accordingly and sent to the DeAnza
C  2) the joystick is used to move the start of the ITT along the refscale
C  3) vertical joystick movements control the sqeezing or stretching of the ITT
C  4) map output from current ITT through new one
C  5) see Gonzalez + Wintz: "Digital Image Processing"
C  6) use the joystick to identify the interval where contrast should be 
C     enhanced
C
C.INPUT/OUTPUT:
C  the following keywords are used:
C
C  DEFAULT/C/16/1		method to use, R for rotate, B for band
C				S for squeeze, C for convolve
C				H for histogram equalisation
C				K for contrast stretching
C  INPUTI/I/1/1			value to work with
C  INPUTC/C/1/60	for method = C, name of new ITT
C  IN_A/C/1/60		for method = H, name of input image
C  P3/C/1/60		for method = H, name of optional result ITT
C	
C  output values are written to:
C	
C  OUTPUTR/R/1/3		if method BAND is used: the data values
C				corresponding to start, center + end of band
C	
C.VERSIONS
C  1.00		from LUTA, LUTB and LUTC
C  for later changes see SCCS
C 
C 020502	last modif
C 
C---------------------------------------------------------
C
      IMPLICIT NONE
C      
      INTEGER      IAV,IMNO
      INTEGER      JX,JY,JF(2),N,LEN
      INTEGER      NOCURS,ICOLR,STAT
      INTEGER      DAZHLD(10),DISPI
      INTEGER      KSECT,BA,BB,DB,DB2,CB,OLDBA,OLDBB
      INTEGER      XA,XAA,XB,XBB,XMAX,XMIN,XOFF
      INTEGER      YA,YAA,YB,YBB,YMIN,YMAX,YOFF
      INTEGER      VECTOR(2,2),XFIG(5),YFIG(5),XVEC(2),YVEC(2)
      INTEGER      NN,LUTLIM,LUT2SZ,LUT3SZ
      INTEGER      IZZ,NAXIS,NPIX(3),NAXPIX(4),IVAL
      INTEGER      IOFF,BINS(256),KBINS(256),ITT(256)
      INTEGER      EC,ED,EL,TID
      INTEGER      TABNUL,TBCOLN,NCOLS,NROWS
      INTEGER      KUNI(1),KNUL,MADRID(1)
C      
      CHARACTER    COLOUR*1,ACTION*1,DEFA*2
      CHARACTER    FRAME*60,MORE*72,PFLAG*4
      CHARACTER    OUTPUT*80,DSCRO*15
      CHARACTER    NEWITT*60,PROMPT*80,FILE*80
      CHARACTER    TBLABL*16
C      
      REAL         RBUF(8),CUTS(4),DIF,COLVAL(3)
      REAL         ROLD(768),RNEW(768)
      REAL         FB,RM,ARM,RB,RX,RY,RLUTLM,RLUTSZ
      REAL         F,FDIST,FXB,FXA,FLOW,FHI,ZZ
      REAL         ROOT(768)
      REAL         OLD(256),NEW(256),AUX(256)
      REAL         VALUE,RINF(8)
C      
      DOUBLE PRECISION  START(3),STEP(3)
C 
      INCLUDE      'MID_INCLUDE:ST_DEF.INC'
C 
      INCLUDE  'MID_INCLUDE:IDIDEV.INC'
      INCLUDE  'MID_INCLUDE:IDIMEM.INC'
C
      COMMON  /VMR/ MADRID
C
      EQUIVALENCE      (VECTOR(1,1),XAA),(VECTOR(2,1),YAA)
      EQUIVALENCE      (VECTOR(1,2),XBB),(VECTOR(2,2),YBB)
C      
      DATA   XOFF   /400/, YOFF /400/
      DATA   XMIN   /0/,   YMIN /0/,   XMAX /100/,  YMAX /100/
      DATA   FRAME  /' '/
      DATA   BINS   /256*0/
      DATA   TBLABL /'ITT '/
C 
      INCLUDE      'MID_INCLUDE:ST_DAT.INC'
C
C  initialize MIDAS 
      CALL STSPRO('LUTMOD')
      PFLAG(1:) = ' '
      LUTLIM = 255
      RLUTLM = LUTLIM
      FILE(1:80) = ' '
C      
C  get DEFAULT(15:16) to determine what we should do
      CALL STKRDC('DEFAULT',1,15,2,IAV,DEFA,KUNI,KNUL,STAT)
      ACTION = DEFA(2:2)
      CALL UPCAS(ACTION,ACTION)
C 
C  for histogram equalization we have to par. 4
      DISPI = 1
      IF (DEFA(1:2).EQ.'IH') THEN
         CALL STKRDC('P4',1,1,2,IAV,OUTPUT,KUNI,KNUL,STAT)
         IF ((OUTPUT(1:1).EQ.'N') .OR. (OUTPUT(1:1).EQ.'n')) THEN
            DISPI = 0                         !we don't work with a display
            GOTO 15000
         ENDIF
      ENDIF
C
C  get main control block for ImageDisplay + attach
      STAT = 0
      CALL DTOPEN(1,STAT)
      CALL DTGICH(QDSPNO,QIMCH,FRAME,RINF,STAT)
C      
C  get currently used LUT section + enable joystick action
      CALL STKRDI('DAZHOLD',1,10,IAV,DAZHLD,KUNI,KNUL,STAT)
      KSECT = DAZHLD(10)
      NOCURS = DAZHLD(1)
      CALL JOYSTK(QDSPNO,0,NOCURS,JX,JY,STAT)
      RLUTSZ = QLUTSZ
      LUT2SZ = QLUTSZ + QLUTSZ
      LUT3SZ = LUT2SZ + QLUTSZ
C 
      CALL STKRDI('MODSCALE',1,2,IAV,JF,KUNI,KNUL,STAT)  !get scalings
C 
C  branch to LUT or ITT part
      IF (DEFA(1:1).NE.'L') GOTO 10000

C 
C  handle LUT modification business
      IF (ACTION(1:1).EQ.'B') THEN
         GOTO 3000
      ELSE IF (ACTION(1:1).EQ.'C') THEN
         GOTO 6000
      ELSE IF (ACTION(1:1).EQ.'D') THEN
         GOTO 9000
      ENDIF
C 
C -----------------------------------------------------------------
C      
C  here we work on section a)
C      
C -----------------------------------------------------------------
C      
C  get method + colour we want to work on
      CALL STKRDC('P1',1,1,1,IAV,ACTION,KUNI,KNUL,STAT)
      CALL UPCAS(ACTION,ACTION)
C      
C  read current LUT (all colours)
      CALL RDLUT(QDSPNO,KSECT,1,QLUTSZ,ROLD,STAT)
C      
C  branch according to method chosen
      IF (ACTION.EQ.'R') GOTO 2000
C      
C ***
C      
C  overlay a one colour band on the LUTs
C      
C ***
C      
      CALL STKRDC('P3',1,1,4,IAV,PFLAG,KUNI,KNUL,STAT)
      CALL UPCAS(PFLAG,PFLAG)
      CALL STKRDR('INPUTR',1,3,IAV,COLVAL,KUNI,KNUL,STAT)
      DO 40, N=1,3
         IF (COLVAL(N).GT.1.0) COLVAL(N) = COLVAL(N) / RLUTLM
         IF (COLVAL(N).LT.0.0) COLVAL(N) = 0.
         IF (COLVAL(N).GT.1.0) COLVAL(N) = 1.0
40    CONTINUE
C      
C  get displayed frame info and low + high cuts
      CALL DTGICH(QDSPNO,QIMCH,FRAME,RBUF,STAT)
      IF (PFLAG(1:1).EQ.'Y') THEN
         CALL STFOPN(FRAME,D_OLD_FORMAT,0,F_IMA_TYPE,IMNO,STAT)
         CALL STDRDR(IMNO,'LHCUTS',1,4,IAV,CUTS,KUNI,KNUL,STAT)
         DIF = CUTS(2) - CUTS(1)
         IF (DIF.LT.10.E-20) THEN 
            CUTS(1) = CUTS(3)
            DIF = CUTS(4) - CUTS(3)
         ENDIF
         DIF = DIF / RLUTSZ                  !normalize
      ENDIF
C      
C  put small band into middle of refscale
      BA = NINT(RLUTSZ * 0.5)             !start of band
      BB = BA + 4                         !end of band
      OLDBA = 0
      OLDBB = 0
C      
C  here we start the action
100   IF ( (BA.EQ.OLDBA) .AND. (BB.EQ.OLDBB) ) GOTO 200      !nothing changed 
C      
      OLDBA = BA
      OLDBB = BB
      DO 120, N=1,LUT3SZ                  !copy original tables
         RNEW(N) = ROLD(N)
120   CONTINUE
C      
C  modify LUTs in the interval defined by [BA,BB]
      DO 140, N=BA,BB
         RNEW(N) = COLVAL(1)
         RNEW(QLUTSZ+N) = COLVAL(2)
         RNEW(LUT2SZ+N) = COLVAL(3)
140   CONTINUE
C      
C  and send new LUT to ImageDisplay
      CALL QWRLUT(QDSPNO,QIMCH,QRGBFL,KSECT,1,QLUTSZ,RNEW,STAT)
CC      CALL WRLUT(QDSPNO,KSECT,1,QLUTSZ,RNEW,STAT)
C      
C  display corresponding pixel levels on terminal
      IF (PFLAG(1:1).EQ.'Y') THEN
         CB = (BA+BB)/2
         RBUF(1) = CUTS(1) + (BA*DIF)
         RBUF(2) = CUTS(1) + (CB*DIF)
         RBUF(3) = CUTS(1) + (BB*DIF)
C      
C  display, but not log the stuff (to save space)
         WRITE(MORE,30000) RBUF(1),RBUF(2),RBUF(3)
         CALL STTDIS(MORE,99,STAT)
      ENDIF
C      
C  now get joystick input
200   CALL JOYSTK(QDSPNO,1,NOCURS,JX,JY,STAT)
      IF (STAT.EQ.1) THEN                     !if all cursors off, terminate
         CALL STKWRR('OUTPUTR',RBUF,1,3,KUNI,STAT)
         GOTO 90000
      ENDIF
C      
C modify band according to joystick movement
      IF ((JX.LE.-64).OR.(JX.GE.64)) THEN
         JX = JX/JF(1)
      ELSE
         JX = JX/JF(2)
      ENDIF
      IF ((JY.LE.-64).OR.(JY.GE.64)) THEN
         JY = JY/JF(1)
      ELSE
         JY = JY/JF(2)
      ENDIF
C      
      IF (JX.EQ.0) GOTO 800                  !no horizontal movement
      DB = BB - BA                           !save band width
      IF (JX.GT.0) THEN
         BB = MIN(QLUTSZ,BB+JX)              !move band right
         BA = BB - DB
      ELSE
         BA = MAX(1,BA+JX)                   !move band left
         BB = BA + DB
      ENDIF
C      
800   IF (JY.EQ.0) GOTO 1000                 !no vertical  movement
      CB = (BA + BB)/2                       !save center of band
      DB = BB - BA                           !save band width
      IF (JY.GT.0) THEN
         DB = MIN(QLUTSZ,DB+JY)              !widen the band
         FB = DB
         DB2 = NINT(FB*0.5)
         BB = MIN(QLUTSZ,CB+DB2)
         BA = MAX(1,CB-DB2)
      ELSE
         DB = MAX(1,DB+JY)                   !sqeeze the band
         DB2 = DB/2
         BB = CB + DB2
         BA = CB - DB2
      ENDIF
C      
C  now loop
1000  GOTO 100
C      
C ***
C      
C  handle rotation of LUTs
C      
C ***
C      
2000  CALL STKRDC('P2',1,1,1,IAV,COLOUR,KUNI,KNUL,STAT)
      CALL UPCAS(COLOUR,COLOUR)
      ICOLR = 4
      IF (COLOUR.EQ.'R') ICOLR = 1
      IF (COLOUR.EQ.'G') ICOLR = 2
      IF (COLOUR.EQ.'B') ICOLR = 3
C      
C  set start, end of LUT to 0, QLUTSZ-1
      BA = 0             
      OLDBA = 0
      IZZ = QLUTSZ - 1
      DO 2020, N=1,LUT3SZ                        !copy original tables
         RNEW(N) = ROLD(N)
2020  CONTINUE
C      
C  now get joystick input
2100  CALL JOYSTK(QDSPNO,1,NOCURS,JX,JY,STAT)
      IF (STAT.EQ.1) GOTO 90000                  !if all cursors off, terminate
C      
C modify start of LUT according to joystick movement
      IF ((JX.LE.-64).OR.(JX.GE.64)) THEN
         JX = JX/JF(1)
      ELSE
         JX = JX/JF(2)
      ENDIF
      BA = BA + JX                               !move start addr.
      IF (BA .GT. IZZ) BA = BA - IZZ             !and wrap around
      IF (BA .LT. 0) BA = IZZ + BA
C      
C  only update, if changed
      IF (BA.NE.OLDBA) THEN
         OLDBA = BA
         LEN = QLUTSZ - BA
C      
C  handle only one colour
         IF (ICOLR.LT.4) THEN
            IAV = (ICOLR-1)*QLUTSZ
            DO 2200, N=1,QLUTSZ-BA
               RNEW(IAV+N+BA) = ROLD(IAV+N)
2200        CONTINUE
            IF (BA.GT.0) THEN
               DO 2300, N=1,BA
                  RNEW(IAV+N) = ROLD(IAV+LEN+N)
2300           CONTINUE
            ENDIF
C      
C  handle all colours
         ELSE
            DO 2400, N=1,QLUTSZ-BA
               RNEW(N+BA) = ROLD(N)
               RNEW(QLUTSZ+N+BA) = ROLD(QLUTSZ+N)
               RNEW(LUT2SZ+N+BA) = ROLD(LUT2SZ+N)
2400        CONTINUE
            IF (BA.GT.0) THEN
               DO 2440, N=1,BA
                  RNEW(N) = ROLD(LEN+N)
                  RNEW(QLUTSZ+N) = ROLD(QLUTSZ+LEN+N)
                  RNEW(LUT2SZ+N) = ROLD(LUT2SZ+LEN+N)
2440           CONTINUE
            ENDIF
         ENDIF
C      
C  send updated LUT
         CALL QWRLUT(QDSPNO,QIMCH,QRGBFL,KSECT,1,QLUTSZ,RNEW,STAT)
      ENDIF
C      
C  now loop
      GOTO 2100

C -----------------------------------------------------------------
C      
C  here we work on section b)
C      
C -----------------------------------------------------------------
C      
C  get colour we want to work on
3000  CALL STKRDC('P2',1,1,1,IAV,COLOUR,KUNI,KNUL,STAT)
      CALL UPCAS(COLOUR,COLOUR)
C      
C      
      ICOLR = 1                        !default = all
      IF (COLOUR.EQ.'R') ICOLR = 2
      IF (COLOUR.EQ.'G') ICOLR = 3
      IF (COLOUR.EQ.'B') ICOLR = 4
C      
C  read current LUT (all colours)
      CALL RDLUT(QDSPNO,KSECT,1,QLUTSZ,ROLD,STAT)
      IF (ICOLR.NE.1) THEN
         DO 3040, N=1,LUT3SZ
            RNEW(N) = ROLD(N)
3040     CONTINUE
      ENDIF      
C      
C  put small rectangle into right hand upper corner of screen
      XFIG(1) = XMIN + XOFF
      YFIG(1) = YMIN + YOFF
      XFIG(2) = XFIG(1)
      YFIG(2) = YMAX + YOFF
      XFIG(3) = XMAX + XOFF
      YFIG(3) = YFIG(2)
      XFIG(4) = XFIG(3)
      YFIG(4) = YFIG(1)
      XFIG(5) = XFIG(1)
      YFIG(5) = YFIG(1)
C      
      XA = XMIN                  !initialize vector
      XB = XMAX
      YA = YMIN
      YB = YMAX
      RB = 0.
      RM = 1.0
      ARM = 1.0
      CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,5,99,1,STAT)          !draw frame once
C      
C  here we start the action
3100  XAA = XA + XOFF
      XBB = XB + XOFF
      YAA = YA + YOFF
      YBB = YB + YOFF
C      
      XVEC(1) = VECTOR(1,1)
      XVEC(2) = VECTOR(1,2)
      YVEC(1) = VECTOR(2,1)
      YVEC(2) = VECTOR(2,2)

C draw the function y = LUT(x)
      CALL IIGPLY(QDSPNO,QOVCH,XVEC,YVEC,2,99,1,STAT)
C      
C  build new LUTs 
      FB = RB / RLUTSZ
      GOTO (3200,3300,3400,3500),ICOLR
C      
3200  DO 3220, N=1,256
         RNEW(N) = MAX(0.,MIN(1.,(ROLD(N)*RM)+FB))
         RNEW(QLUTSZ+N) = MAX(0.,MIN(1.,(ROLD(QLUTSZ+N)*RM)+FB))
         RNEW(LUT2SZ+N) = MAX(0.,MIN(1.,(ROLD(LUT2SZ+N)*RM)+FB))
3220  CONTINUE
      GOTO 3550
C      
3300  DO 3320, N=1,256
         RNEW(N) = MAX(0.,MIN(1.,(ROLD(N)*RM)+FB))
3320  CONTINUE
      GOTO 3550
C      
3400  DO 3420, N=1,256
         RNEW(QLUTSZ+N) = MAX(0.,MIN(1.,(ROLD(QLUTSZ+N)*RM)+FB))
3420  CONTINUE
      GOTO 3550
C      
3500  DO 3520, N=1,256
         RNEW(LUT2SZ+N) = MAX(0.,MIN(1.,(ROLD(LUT2SZ+N)*RM)+FB))
3520  CONTINUE
C      
C  and send new LUT to ImageDisplay
3550  CALL QWRLUT(QDSPNO,QIMCH,QRGBFL,KSECT,1,QLUTSZ,RNEW,STAT)
C      
C  now get joystick input
3600  CALL JOYSTK(QDSPNO,1,NOCURS,JX,JY,STAT)
      IF (STAT.EQ.1) GOTO 4400                  !if cursor(s) off, terminate
C      
C modify function according to joystick movement
      IF (JX.EQ.0) GOTO 3800                  !no horizontal movement
      IF ((JX.LE.-64).OR.(JX.GE.64)) THEN
         RX = FLOAT(JX)/32.
      ELSE
         RX = FLOAT(JX)/64.
      ENDIF
C      
      IF ((RM.GT.0.4).AND.(RM.LT.1.6)) RX = RX/4.
      RM = MAX(0.,(RM - RX))                  !update slope of function
      ARM = ABS(RM)
      YB = NINT(RM*XMAX + RB)
      YB = MAX(YMIN,MIN(YB,YMAX))            !keep new YB in rectangle
      IF (ARM.LT.10.E-6) THEN
         XB = XMAX
      ELSE
         XB = NINT((YB - RB)/RM)
      ENDIF
      XB = MAX(XMIN,MIN(XB,XMAX))      !keep XB in rectangle
C      
3800  IF (JY.EQ.0) GOTO 4000
      IF ((JY.LE.-64).OR.(JY.GE.64)) THEN
         RY = FLOAT(JY)/6.
      ELSE
         RY = FLOAT(JY)/10.
      ENDIF
      RB = MIN(FLOAT(YMAX),(RB + RY))            !update intercept of function
      YA = RB
      YA = MAX(YMIN,MIN(YA,YMAX))
      IF (ARM.LT.10.E-6) THEN
         XA = XMIN
      ELSE
         XA = NINT((YA - RB)/RM)
      ENDIF
      XA = MAX(XMIN,MIN(XA,XMAX))      !keep XA in rectangle
C      
      YB = NINT(RM*XMAX + RB)
      YB = MAX(YMIN,MIN(YB,YMAX))            !keep new YB in rectangle
      IF (ARM.LT.10.E-6) THEN
         XB = XMAX
      ELSE
         XB = NINT((YB - RB)/RM)
      ENDIF
      XB = MAX(XMIN,MIN(XB,XMAX))      !keep XB in rectangle
C      
C  now loop
4000  IF ((JX.EQ.0).AND.(JY.EQ.0)) GOTO 3600
C      
      XVEC(1) = VECTOR(1,1)
      XVEC(2) = VECTOR(1,2)
      YVEC(1) = VECTOR(2,1)
      YVEC(2) = VECTOR(2,2)
      CALL IIGPLY(QDSPNO,QOVCH,XVEC,YVEC,2,99,1,STAT)      !erase old vector
      GOTO 3100
C      
C  that's it folks...
C      
4400  XVEC(1) = VECTOR(1,1)
      XVEC(2) = VECTOR(1,2)
      YVEC(1) = VECTOR(2,1)
      YVEC(2) = VECTOR(2,2)
      CALL IIGPLY(QDSPNO,QOVCH,XVEC,YVEC,2,99,1,STAT)      !clear vector
      CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,5,99,1,STAT)      !clear frame
C      
      GOTO 90000

C -----------------------------------------------------------------
C      
C  here we work on section c)
C      
C -----------------------------------------------------------------
C      
6000  ZZ = RLUTSZ * RLUTSZ
C      
C
C  here for squeezing + stretching of LUT
C      
C
C  read current LUT
      CALL RDLUT(QDSPNO,KSECT,1,QLUTSZ,ROLD,STAT)
C      
C  initialize 
      FLOW = - ZZ
      FHI = (RLUTSZ + 1.) + ZZ
      FXA = 0.
      FXB = FXA + RLUTSZ
C      
C  here we start the action
6100  FDIST = FXB - FXA
      F = RLUTSZ / FDIST                     !get sqeeze/stretch factor
C      
C  update LUT accordingly
      DO 6200, N=1,QLUTSZ
         RNEW(N) = 0.
         RNEW(QLUTSZ+N) = 0.
         RNEW(LUT2SZ+N) = 0.
         IF ((N.GE.FXA).AND.(N.LE.FXB)) THEN
            NN = NINT((N - FXA)*F)
            IF ((NN.GE.1).AND.(NN.LE.QLUTSZ)) THEN
               RNEW(N) = ROLD(NN)
               RNEW(QLUTSZ+N) = ROLD(QLUTSZ+NN)
               RNEW(LUT2SZ+N) = ROLD(LUT2SZ+NN)
            ENDIF
         ENDIF
6200  CONTINUE
C      
C  and send new LUT to the De Anza
      CALL QWRLUT(QDSPNO,QIMCH,QRGBFL,KSECT,1,QLUTSZ,RNEW,STAT)
C      
C  now get joystick input
6600  CALL JOYSTK(QDSPNO,1,NOCURS,JX,JY,STAT)      
      IF (STAT.EQ.1) GOTO 90000            !if cursor(s) off, terminate
C      
C modify function according to joystick movement
      IF (JX.EQ.0) GOTO 6800                  !no horizontal movement
      IF ((JX.LE.-64).OR.(JX.GE.64)) THEN
         RX = FLOAT(JX)/FLOAT(JF(1))
      ELSE
         RX = FLOAT(JX)/FLOAT(JF(2))
      ENDIF
C      
      FXA = FXA + RX                     !virtual position
      FXA = MAX(FLOW,MIN(FXA,RLUTSZ))    !keep virt. pos. within limits
      FXB = FXA + FDIST                  !keep FXB at same distance from FXA
C      
6800  IF (JY.EQ.0) GOTO 7000
      IF ((JY.LE.-64).OR.(JY.GE.64)) THEN
         RY = FLOAT(JY)/FLOAT(JF(1))
      ELSE
         RY = FLOAT(JY)/FLOAT(JF(2))
      ENDIF
      FXB = FXB + RY                        !virtual position
      FXB = MIN(MAX(FXA+1.,FXB),FHI)
C 
7000  IF ( (JX.EQ.0) .AND. (JY.EQ.0) ) THEN
         GOTO 6600
      ELSE
         GOTO 6100
      ENDIF

C -----------------------------------------------------------------
C      
C  here we work on section d)
C      
C -----------------------------------------------------------------
C      
C ***
C      
C  handle modification of LUTs in HSI space
C      
C ***
C      
9000  CALL STKRDC('P2',1,1,1,IAV,COLOUR,KUNI,KNUL,STAT)
      CALL UPCAS(COLOUR,COLOUR)
C 
      IF (COLOUR.EQ.'S') THEN
         ICOLR = 2
         ZZ = 1.0
      ELSE IF (COLOUR.EQ.'I') THEN
         ICOLR = 3
         ZZ = 1.0
      ELSE
         ICOLR = 1
         ZZ = 360.
      ENDIF
C      
C  read current LUT (all colours)
      CALL RDLUT(QDSPNO,KSECT,1,QLUTSZ,RNEW,STAT)
      CALL MAKLUT(2,QLUTSZ,RNEW,256,ROOT)  
C      
C   convert RGB table to HSI table
      CALL HSIRGB(1,ROLD,ROOT)             !ROOT -> ROLD
C      
C   reconvert HSI table to RGB table
      CALL HSIRGB(2,ROLD,ROOT)             !ROLD -> ROOT
C      
C  send updated LUT
      CALL MAKLUT(1,256,ROOT,QLUTSZ,RNEW)
      CALL QWRLUT(QDSPNO,QIMCH,QRGBFL,KSECT,1,QLUTSZ,RNEW,STAT)
C 
C  now get joystick input
9100  CALL JOYSTK(QDSPNO,1,NOCURS,JX,JY,STAT)
      IF (STAT.EQ.1) GOTO 90000                  !if all cursors off, terminate
C      
C modify start of LUT according to joystick movement
      IF ((JX.LE.-64).OR.(JX.GE.64)) THEN
         JX = JX/JF(1)
      ELSE
         JX = JX/JF(2)
      ENDIF
C      
C  only update, if changed
      IF (JX.NE.0) THEN
         FXB = JX
         FXB = FXB / RLUTLM
         FDIST = FXB * ZZ                         !relate to H/S/I interval
C      
         IAV = (ICOLR-1) * QLUTSZ
         DO 9200, N=1,256
            ROLD(IAV+N) = ROLD(IAV+N)+FDIST
            IF (ROLD(IAV+N).LT.0.) THEN
               ROLD(IAV+N) = 0.
            ELSE IF (ROLD(IAV+N).GT.ZZ) THEN
               ROLD(IAV+N) = ZZ
            ENDIF
9200     CONTINUE
C      
C   convert RGB table to HSI table
         CALL HSIRGB(2,ROLD,ROOT)                !ROLD -> ROOT
C      
C  send updated LUT
         CALL MAKLUT(1,256,ROOT,QLUTSZ,RNEW)
         CALL QWRLUT(QDSPNO,QIMCH,QRGBFL,KSECT,1,QLUTSZ,RNEW,STAT)
      ENDIF
C      
C  now loop
      GOTO 9100

C      
C  here we handle the ITT modifications
C  get value we want to work on
C 
10000 CALL STKRDR('INPUTR',1,1,IAV,VALUE,KUNI,KNUL,STAT)
      IF (VALUE.GT.1.1) VALUE = VALUE / RLUTSZ
      IF (VALUE.GT.1.0) VALUE = 1.
      IF (VALUE.LT.0.0) VALUE = 0.
C      
C  force ITT visibility
      IF (ITTYES.EQ.0) THEN
         ITTYES = 1
         CALL DTPICH(QDSPNO,QIMCH,FRAME,RINF,STAT)
      ENDIF
      KSECT = 0
C
C  read current ITT
      CALL RDITT(QDSPNO,QIMCH,KSECT,1,QLUTSZ,OLD,STAT)
      DO 10020, N=1,256                  !copy original table
         NEW(N) = OLD(N)
10020 CONTINUE
C      
C  branch according to method chosen
      IF (ACTION.EQ.'R') THEN
         GOTO 12000
      ELSE IF (ACTION.EQ.'S') THEN
         GOTO 13000
      ELSE IF (ACTION.EQ.'C') THEN
         GOTO 14000
      ELSE IF (ACTION.EQ.'H') THEN
         GOTO 15000
      ELSE IF (ACTION.EQ.'K') THEN
         GOTO 16000
      ENDIF

C      
C ***
C      
C  overlay a one value band on the ITT
C      
C ***
C      
      CALL STKRDC('P3',1,1,4,IAV,PFLAG,KUNI,KNUL,STAT)
      CALL UPCAS(PFLAG,PFLAG)
C 
C  get displayed frame info + get low + high cuts
      CALL DTGICH(QDSPNO,QIMCH,FRAME,RBUF,STAT)
      IF (PFLAG(1:1).EQ.'Y') THEN
         CALL STFOPN(FRAME,D_OLD_FORMAT,0,F_IMA_TYPE,IMNO,STAT)
         CALL STDRDR(IMNO,'LHCUTS',1,4,IAV,CUTS,KUNI,KNUL,STAT)
         DIF = CUTS(2) - CUTS(1)
         IF (DIF.LT.10.E-20) THEN 
            CUTS(1) = CUTS(3)
            DIF = CUTS(4) - CUTS(3)
         ENDIF
         DIF = DIF / RLUTSZ                  !normalize
      ENDIF
C      
C  put small band into middle of refscale
      BA = NINT(RLUTSZ * 0.5)             !start of band
      BB = BA + 4                         !end of band
      OLDBA = 0
      OLDBB = 0
C      
C  here we start the action
10100 IF ( (BA.EQ.OLDBA) .AND. (BB.EQ.OLDBB) ) GOTO 10400
C      
      OLDBA = BA
      OLDBB = BB
      DO 10120, N=1,QLUTSZ                  !copy original table
         NEW(N) = OLD(N)
10120 CONTINUE
C      
C  modify ITT in the interval defined by [BA,BB]
      DO 10130, N=BA,BB
         NEW(N) = VALUE
10130 CONTINUE
C      
C  send new ITT to ImageDisplay
      CALL WRITT(QDSPNO,QIMCH,KSECT,1,QLUTSZ,NEW,STAT)
C      
C  display corresponding pixel levels on terminal
      IF (PFLAG(1:1).EQ.'Y') THEN
         CB = (BA+BB)/2
         RBUF(1) = CUTS(1) + (BA*DIF)
         RBUF(2) = CUTS(1) + (CB*DIF)
         RBUF(3) = CUTS(1) + (BB*DIF)
C      
C  display, but not log the stuff (to save space)
         WRITE(MORE,30000) RBUF(1),RBUF(2),RBUF(3)
         CALL STTDIS(MORE,99,STAT)
      ENDIF
C      
C  now get joystick input
10400 CALL JOYSTK(QDSPNO,1,NOCURS,JX,JY,STAT)      
      IF (STAT.EQ.1) THEN                  !if cursor(s) off, terminate
         CALL STKWRR('OUTPUTR',RBUF,1,3,KUNI,STAT)
         GOTO 90000
      ENDIF
C      
C modify band according to joystick movement
      IF ((JX.LE.-64).OR.(JX.GE.64)) THEN
         JX = JX/JF(1)
      ELSE
         JX = JX/JF(2)
      ENDIF
      IF ((JY.LE.-64).OR.(JY.GE.64)) THEN
         JY = JY/JF(1)
      ELSE
         JY = JY/JF(2)
      ENDIF
C      
      IF (JX.EQ.0) GOTO 10800                  !no horizontal movement
      DB = BB - BA                             !save band width
      IF (JX.GT.0) THEN
         BB = MIN(QLUTSZ,BB+JX)                !move band up
         BA = BB - DB
      ELSE
         BA = MAX(1,BA+JX)                     !move band down
         BB = BA + DB
      ENDIF
C      
10800 IF (JY.EQ.0) GOTO 11000
      CB = (BA + BB)/2                         !save center of band
      DB = BB - BA                             !save band width
      IF (JY.GT.0) THEN
         DB = MIN(QLUTSZ,DB+JY)                !widen the band
         FB = DB
         DB2 = NINT(FB*0.5)
         BB = MIN(QLUTSZ,CB+DB2)
         BA = MAX(1,CB-DB2)
      ELSE
         DB = MAX(1,DB+JY)                     !sqeeze the band
         DB2 = DB/2
         BB = CB + DB2
         BA = CB - DB2
      ENDIF
C      
C  now loop
11000 GOTO 10100
C      
C ***
C      
C  handle rotation of ITT
C      
C ***
C      
C      
C  init offset to 0
12000 BA = 0
      OLDBA = BA
      IZZ = QLUTSZ - 1
C      
C  now get joystick input
12100 CALL JOYSTK(QDSPNO,1,NOCURS,JX,JY,STAT)      
      IF (STAT.EQ.1) GOTO 90000            !if cursor(s) off, terminate
C      
      IF ((JX.LE.-64).OR.(JX.GE.64)) THEN
         JX = JX/JF(1)
      ELSE
         JX = JX/JF(2)
      ENDIF
      BA = BA + JX                               !move start addr.
      IF (BA .GT. IZZ) BA = BA - IZZ             !and wrap around
      IF (BA .LT. 0) BA = IZZ + BA
C      
C  only update, if a change occurred
      IF (BA.NE.OLDBA) THEN
         OLDBA = BA
         DO 12120, N=1,QLUTSZ-BA                  !shift ITT
            NEW(N+BA) = OLD(N)
12120    CONTINUE
         IF (BA.GT.0) THEN
            DO 12140, N=1,BA
               NEW(N) = OLD(QLUTSZ-BA+N)
12140       CONTINUE
         ENDIF
C      
         CALL WRITT(QDSPNO,QIMCH,KSECT,1,QLUTSZ,NEW,STAT)
      ENDIF
      GOTO 12100
C      
C ***
C      
C  squeeze/stretch ITT
C      
C ***
C      
C  initialize
13000 ZZ = RLUTSZ * RLUTSZ
      FLOW = - ZZ
      FHI = RLUTSZ + 1. + ZZ
      FXA = 0.
      FXB = FXA + RLUTSZ
C      
C  here we start the action
13100 FDIST = FXB - FXA
      F = RLUTSZ/FDIST                              !get sqeeze/stretch factor
C      
C  update ITT accordingly
      DO 13200, N=1,QLUTSZ
         NEW(N) = 0.
         IF ((N.GE.FXA).AND.(N.LE.FXB)) THEN
            NN = NINT((N - FXA)*F)
            IF ((NN.GE.1).AND.(NN.LE.QLUTSZ)) THEN
               NEW(N) = OLD(NN)
            ENDIF
         ENDIF
13200 CONTINUE
C      
C  and send it to the Image Display
      CALL WRITT(QDSPNO,QIMCH,KSECT,1,QLUTSZ,NEW,STAT)
C      
C  now get joystick input
13600 CALL JOYSTK(QDSPNO,1,NOCURS,JX,JY,STAT)
      IF (STAT.EQ.1) GOTO 90000            !if cursor(s) off, terminate
C      
C modify function according to joystick movement
      IF (JX.EQ.0) GOTO 13700                  !no horizontal movement
      IF ((JX.LE.-64).OR.(JX.GE.64)) THEN
         RX = FLOAT(JX)/FLOAT(JF(1))
      ELSE
         RX = FLOAT(JX)/FLOAT(JF(2))
      ENDIF
C      
      FXA = FXA + RX                     !virtual position
      FXA = MAX(FLOW,MIN(FXA,RLUTSZ))    !keep virt. pos. within limits
      FXB = FXA + FDIST                  !keep FXB at same distance from FXA
C      
13700 IF (JY.EQ.0) GOTO 13800
      IF ((JY.LE.-64).OR.(JY.GE.64)) THEN
         RY = FLOAT(JY)/FLOAT(JF(1))
      ELSE
         RY = FLOAT(JY)/FLOAT(JF(2))
      ENDIF
      FXB = FXB + RY                        !virtual position
      FXB = MIN(MAX(FXA+1.,FXB),FHI)
13800 IF ( (JX.EQ.0) .AND. (JY.EQ.0) ) THEN
         GOTO 13600
      ELSE
         GOTO 13100
      ENDIF
C      
C ***
C      
C  convolve current ITT with another one
C      
C ***
C      
14000 PROMPT(1:) = 'Enter ITT name to convolve with and RETURN '//
     +             '(just RETURN to stop): '
      IF (VALUE.GT.0.5) THEN
         IVAL = 1
      ELSE
         IVAL = 0
      ENDIF
C      
14100 NEWITT(1:) = ' '
      CALL STKWRC('INPUTC',1,NEWITT,1,60,KUNI,STAT)      !clear also key INPUTC
      CALL STKPRC(PROMPT,'INPUTC',1,1,60,IAV,NEWITT,KUNI,KNUL,STAT)
      DO 14110, N=60,1,-1
         IF (NEWITT(N:N).NE.' ') THEN
            NN = N + 1
            GOTO 14115
         ENDIF
14110 CONTINUE
      GOTO 90000
C 
14115 NEWITT(NN:) = '.itt'                  !append type of ITT table
C      
C  look for ITT table - first in MID_SYSTAB
      FILE(1:) = 'MID_SYSTAB:'//NEWITT
      CALL STECNT('GET',EC,EL,ED)
      CALL STECNT('PUT',1,0,0)            !disable errors ...
      CALL TBTOPN(FILE,F_I_MODE,TID,STAT)
      CALL STECNT('PUT',EC,EL,ED)
      IF (STAT.NE.0) THEN
         STAT = 0
         FILE = NEWITT//' '
         CALL TBTOPN(FILE,F_I_MODE,TID,STAT)
      ENDIF
C      
C  now get table info
      CALL TBIGET(TID,NCOLS,NROWS,N,N,N,STAT)
      CALL TBLSER(TID,TBLABL,TBCOLN,STAT)
      IF (TBCOLN.LE.0)                         !this stops everything...
     +   CALL STETER(1,'column labeled :ITT not found')
C      
C  now read the table
      DO 14200, N=1,256
         CALL TBRRDR(TID,N,1,TBCOLN,AUX(N),TABNUL,STAT)
14200 CONTINUE
      CALL MAKITT(256,AUX,QLUTSZ,RNEW)         !squeeze to QLUTSZ
C      
C  and finally do the convolution
      DO 14250, N=1,QLUTSZ
         NN = NINT(OLD(N)*RLUTSZ) + 1
         NEW(N) = RNEW(NN)
14250 CONTINUE
      CALL WRITT(QDSPNO,QIMCH,KSECT,1,QLUTSZ,NEW,STAT)
C      
C  if IVAL = 1, we want to convolve again and again...
      IF (IVAL.EQ.1) THEN
         DO 14300, N=1,256
            OLD(N) = NEW(N)
14300    CONTINUE
      ENDIF
C      
C  and loop for another ITT
      CALL TBTCLO(TID,STAT)
      GOTO 14100
C      
C ***
C      
C  equalize histogram and send appropriate ITT to the display
C      
C ***
C
C  get name of image + map data 
15000 CALL STKRDC('IN_A',1,1,80,IAV,FILE,KUNI,KNUL,STAT)
      CALL STFOPN(FILE,D_OLD_FORMAT,0,F_IMA_TYPE,IMNO,STAT)
      CALL STDRDI(IMNO,'NAXIS',1,1,IAV,NAXIS,KUNI,KNUL,STAT)
      IF (NAXIS.GT.3) NAXIS = 3              !max. 3 axes supported
      CALL STDRDI(IMNO,'NPIX',1,NAXIS,IAV,NPIX,KUNI,KNUL,STAT)
      CALL STDRDD(IMNO,'START',1,NAXIS,IAV,START,KUNI,KNUL,STAT)
      CALL STDRDD(IMNO,'STEP',1,NAXIS,IAV,STEP,KUNI,KNUL,STAT)
      IVAL = 1
      DO 15200, N=1,NAXIS
         IVAL = IVAL*NPIX(N)
15200 CONTINUE
      F = FLOAT(IVAL)
C
C  get descriptor for output + histogram info
      CALL STKRDC('P2',1,1,15,IAV,DSCRO,KUNI,KNUL,STAT)
      CALL STECNT('GET',EC,EL,ED)
      BA = 1
      BB = 0
      DB = 0
      CALL STECNT('PUT',BA,BB,DB)
      CALL STDRDR(IMNO,'STATISTIC',1,11,IAV,OLD,KUNI,KNUL,STAT)
      CALL STECNT('PUT',EC,EL,ED)
      IF (STAT.NE.0) THEN
         RBUF(1) = 256.0
         RBUF(2) = 0.0
         RBUF(3) = 0.0
         OUTPUT(1:) = 'E15.6 '
         OUTPUT(11:) = 'YYFNY '
         NAXPIX(1) = NAXIS
         DO 15220, N=1,NAXIS
            NAXPIX(1+N) = NPIX(N)
15220    CONTINUE
         CALL ZMSTAT(IMNO,PFLAG,NAXPIX,START,STEP,RBUF,
     +               OUTPUT(1:5),OUTPUT(11:15))
         CALL STDRDR(IMNO,'STATISTIC',1,11,IAV,OLD,KUNI,KNUL,STAT)
      ENDIF
      CALL STDRDR(IMNO,'HIST_BINS',1,1,IAV,ZZ,KUNI,KNUL,STAT)
      IOFF = 1
      IZZ = NINT(ZZ)
      IF ((IZZ.NE.256) .AND. (IZZ.NE.258)) THEN
         N = INDEX(FILE,' ') - 1
         OUTPUT(1:) = 'Warning: Histogram of frame '//
     +               FILE(1:N)//' has not exactly 256 bins...'
         CALL STTPUT(OUTPUT,STAT)
      ENDIF
      IF (IZZ.EQ.258) IOFF = 2            !omit excess bins
      CALL STDRDI(IMNO,'HISTOGRAM',IOFF,256,IAV,BINS,KUNI,KNUL,STAT)
C      
C  histogram equalisation
      IF (OLD(11).GT.OLD(8)) THEN
         CALL STTPUT
     +    ('ill formed histogram - no equalization possible',STAT)
         CALL STTPUT
     +    ('use low,high excess bins to get "better" histogram',STAT)
         DO 15250, N=1,256
            ITT(N) = N - 1
15250    CONTINUE
         IZZ = -1
      ELSE
         CALL HISTEQ(BINS,256,F,KBINS,ITT)
         IF (DSCRO(1:1).NE.'+')
     +      CALL STDWRI(IMNO,DSCRO,KBINS,1,256,KUNI,STAT)
         IZZ = 0
      ENDIF
      CALL STKWRI('PROGSTAT',IZZ,5,1,KUNI,STAT)
C      
C  now apply it to image
      ZZ = 1./RLUTLM
      DO 15300, N=1,256
         AUX(N) = ZZ * ITT(N)
15300 CONTINUE
      IF (DISPI .EQ. 1) THEN
         CALL MAKITT(256,AUX,QLUTSZ,NEW)
         CALL WRITT(QDSPNO,QIMCH,KSECT,1,QLUTSZ,NEW,STAT)
      ENDIF
C 
C  if desired, we also save the ITT in a table
      FILE(1:) = ' '
      CALL STKRDC('P3',1,1,60,IAV,FILE,KUNI,KNUL,STAT)
      IF (FILE(1:1).NE.'+') CALL BLDITT(FILE,AUX,STAT)
      GOTO 90000

C      
C ***
C      
C  stretch contrast in designated interval
C      
C ***
C      
C  initialize ITT to ramp
16000 F = 1./(QLUTSZ-1)
      DO 16030, N=1,QLUTSZ
         NEW(N) = (N-1) * F
16030 CONTINUE
      CALL WRITT(QDSPNO,QIMCH,KSECT,1,QLUTSZ,NEW,STAT)
C 
      BA = 1                  !start of interval
      BB = QLUTSZ             !end of interval
      OLDBA = BA
      OLDBB = BB
C      
C  here we start the action
16100 IF ( (BA.EQ.OLDBA) .AND. (BB.EQ.OLDBB) ) GOTO 16400
C      
      OLDBA = BA
      OLDBB = BB
C      
C  modify ITT in the interval defined by [BA,BB]
      DO 16120, N=1,BA                  ![1,BA] = 0
         NEW(N) = 0.
16120 CONTINUE
C 
      IF (BB.GT.BA) THEN
         F = 1. / (BB - BA)
         DO 16130, N=BA+1,BB
            NEW(N) = F * (N-BA)
16130    CONTINUE
      ENDIF
C 
      IF (BB.LT.QLUTSZ) THEN
         DO 16140, N=BB+1,QLUTSZ
            NEW(N) = 1.
16140    CONTINUE
      ENDIF
C 
C  send new ITT to ImageDisplay
      CALL WRITT(QDSPNO,QIMCH,KSECT,1,QLUTSZ,NEW,STAT)
C      
C  now get joystick input
16400 CALL JOYSTK(QDSPNO,1,NOCURS,JX,JY,STAT)      
      IF (STAT.EQ.1) THEN                  !if cursor(s) off, terminate
         CALL STKWRR('OUTPUTR',RBUF,1,3,KUNI,STAT)
         GOTO 90000
      ENDIF
C      
C modify band according to joystick movement
      IF ((JX.LE.-64).OR.(JX.GE.64)) THEN
         JX = JX/JF(1)
      ELSE
         JX = JX/JF(2)
      ENDIF
      IF ((JY.LE.-64).OR.(JY.GE.64)) THEN
         JY = JY/JF(1)
      ELSE
         JY = JY/JF(2)
      ENDIF
C      
      IF (JX.EQ.0) GOTO 16800                  !no horizontal movement
      DB = BB - BA                             !save band width
      IF (JX.GT.0) THEN
         BB = MIN(QLUTSZ,BB+JX)                !move band up
         BA = BB - DB
      ELSE
         BA = MAX(1,BA+JX)                     !move band down
         BB = BA + DB
      ENDIF
C      
16800 IF (JY.EQ.0) GOTO 16900
      CB = (BA + BB)/2                         !save center of band
      DB = BB - BA                             !save band width
      IF (JY.GT.0) THEN
         IF (JY.EQ.1) JY = 2
         DB = MIN(QLUTSZ,DB+JY)                !widen the band
         DB2 = DB/2
         BB = MIN(QLUTSZ,CB+DB2)
         BA = MAX(1,CB-DB2)
      ELSE
         IF (JY.EQ.-1) JY = -2
         DB = MAX(1,DB+JY)                     !sqeeze the band
         DB2 = DB/2
         BB = CB + DB2
         BA = CB - DB2
      ENDIF
C      
C  now loop
16900 GOTO 16100
C      

C 
C--------------------------------------------------------------------      
C      
C                          that's it folks...
C 
C--------------------------------------------------------------------      
C 
90000 IF (PFLAG(1:1).EQ.'Y') WRITE(*,30010)
      IF (DISPI.EQ.1) CALL DTCLOS(QDSPNO)
      CALL STSEPI
C      
30000 FORMAT(' start, center, end of band = ',3G10.4)
30010 FORMAT(' ')
C      
      END

      SUBROUTINE HISTEQ(BINS,LEVEL,FSIZE,KBINS,ITT)
C 
C +++++++++++++++++++++++++++++++++++++++++++++++++
C  input par:
C  BINS:       I*4 array      histogram
C  LEVEL:      I*4            no. of levels in histogram (= dim. of BINS)
C  FSIZE:      R*4            no. of pixels in image
C  KBINS:      I*4 array      equalized histogram
C  ITT:        I*2 array      ITT table to realize the equalized histogram
C --------------------------------------------------
C
      IMPLICIT NONE
C 
      INTEGER     BINS(*),LEVEL,KBINS(*),ITT(*)
      INTEGER     IS(512)
      INTEGER     N,NN,NST
C 
      REAL        T(512),S(512),RLEVL,FSIZE
C
      RLEVL = FLOAT((LEVEL-1) * 2)
      T(1) = 1./RLEVL                        !T(n) will be set to midpoints between intervals
      S(1) = FLOAT(BINS(1))/FSIZE            !S(n) is the transfer function
C
      DO 100, N=2,LEVEL
         T(N) = (2*N-1)/RLEVL
         S(N) = S(N-1) + FLOAT(BINS(N))/FSIZE
100   CONTINUE
C
C  assign values of transfer function to nearest slot
      NST = 1                        	!start at slot 1
      DO 1000, N=1,LEVEL
C
         IF (NST.EQ.LEVEL) THEN            !if last slot already reached,
            IS(N) = LEVEL                  !index must be the last possible one
         ELSE
C
            DO 500, NN=NST,LEVEL           !use T(n), to find nearest slot
               IF (S(N).LT.T(NN)) THEN     !in increasing order
                  IS(N) = NN
                  NST = NN
                  GOTO 1000
               ENDIF
500         CONTINUE
         ENDIF
1000  CONTINUE
C
C  calculate equalized histogram
      DO 2100, N=1,LEVEL
         KBINS(N) = 0
2100  CONTINUE
C
      DO 2500, N=1,LEVEL
         NN = IS(N)
         KBINS(NN) = KBINS(NN) + BINS(N)
         ITT(N) = NN - 1
2500  CONTINUE
C
      RETURN
      END

      SUBROUTINE QWRLUT(QD,QCH,QR,KS,KVAL,KLU,KNEW,STAT)

C 
      INTEGER  QD,QCH,QR,KS,KVAL,KLU,KNEW,STAT
      INTEGER  IVIS
C 
      CALL WRLUT(QD,KS,KVAL,KLU,KNEW,STAT)
      IF (QR.GE.2) THEN
         IVIS = 1
         CALL IILSBV(QD,QCH,IVIS,STAT)
      ENDIF
C 
      RETURN 
      END


