C @(#)lutmod.for 17.1.1.1 (ESO-DMD) 01/25/02 17:40:00 C=========================================================================== C Copyright (C) 1995 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 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 of the old C colour band in the new colour band, this start point is controlled via C the horizontal joystick movements. C Vertical joystick movements control the sqeezing or stretching of the old C 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 -------------------------------- 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 000627 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 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 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 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 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 WRLUT(QDSPNO,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 WRLUT(QDSPNO,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 WRLUT(QDSPNO,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 WRLUT(QDSPNO,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 WRLUT(QDSPNO,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,60,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