C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.COPYRIGHT: Copyright (c) 1987-2006 European Southern Observatory,
C                                         all rights reserved
C.IDENTIFICATION:
C  program IDAUXZ 		version	5.10    900712
C  K. Banse         	        ESO - Garching
C  5.20     901220	5.30	910904
C
C.KEYWORDS:
C  ImageDisplay functions with cursor interaction
C
C.PURPOSE:
C  read keyword ACTION and call the relevant subroutine to do the job
C 
C.ALGORITHM:
C  all done in the subroutines
C
C.INPUT/OUTPUT:
C  the following keywords are used:
C
C  ACTION/C/1/2			action = = SC for scroll/zoom (c)
C				       = CU for set/cursor (d)
C  DAZHOLD/I/1/14		cursor(s) enabled, cursor form(s),
C				split screen mode + other info
C
C.VERSIONS
C  5.10		get the no. of cursor from the command line
C  5.20		add access to graphics window in SUBCUR
C	
C 060928		last modif
C 
C-------------------------------------------------------------------
C
      PROGRAM IDAUXZ
C 
      IMPLICIT NONE
C 
      INTEGER    IAV,STAT,DAZHLD(14)
      INTEGER    UNI(1),NULO
      INTEGER    MADRID(1)
C 
      CHARACTER  ACTIO*2
C      
      INCLUDE  'MID_INCLUDE:IDIDEV.INC'
C
      COMMON  /VMR/ MADRID
C 
      INCLUDE  'MID_INCLUDE:IDIMEM.INC'
C 
C  initialize MIDAS
      CALL STSPRO('IDAUXZ')
C
      CALL STKRDC('ACTION',1,1,2,IAV,ACTIO,UNI,NULO,STAT)
      CALL UPCAS(ACTIO,ACTIO)
C 
C  branch accordingly
      IF (ACTIO .EQ. 'CD') THEN
         CALL SUBCUR(1)
      ELSE IF (ACTIO .EQ. 'CG') THEN
         CALL SUBCUR(2)
      ELSE IF (ACTIO .EQ. 'SC') THEN
         CALL STKRDI('DAZHOLD',1,14,IAV,DAZHLD,UNI,NULO,STAT)
         CALL SUBSCR(DAZHLD)
      ELSE
         CALL STETER(9,'Module IDAUXZ: invalid option...')
      ENDIF
C 
      CALL STSEPI
      END

      SUBROUTINE SUBCUR(JFLAG)
C
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine SUBCUR		version 2.01	840409
C  K. Banse			ESO - Garching
C  2.65      871123     2.70  890306	2.80	890630
C  2.90	     930112
C
C.KEYWORDS
C  ImageDisplay, cursor
C
C.PURPOSE
C  enable/disable fixed cursor(s) of different shapes or programmable cursors
C  and (optionally) set cursor coordinates
C
C.ALGORITHM
C  use IDI interfaces for interacting with the DeAnza (form = 0,...,15)
C  or programmed shape (form=99) or from=100,101 for X11;
C  disable cursors with form=-1
C
C.INPUT/OUTPUT
C  
C  call as SUBCUR(JFLAG)
C 
C  input par:
C  JFLAG:	Integer		= 1 for display cursor
C				  2 for graphics cursor
C 
C  also the following keywords are used
C
C  DAZIN/I/1/4		(1) = cursor_form_flag: 
C			      98 for fixed cursor_form no. (only DeAnza)
C			      99 for programmable
C			      100 for IDI cursor shapes
C			      101 for IDI region of interest (ROI)
C			      200 for ANGLE
C			      -1 for CLEAR/CURSOR
C			(2) = cursor no. (0,1,2) for cursor 1,2 or both
C			(3) = form_no. if (1) = 98
C			      if (1) = 100 then
C			      shape = 0 (implement. dependent),
C				      1 (full cross hair), 2 (cross)
C			              3 (open cross), 7 (arrow)
C			      if (1) = 101 then
C			      shape = 1 (recangular ROI)
C			      shape = 2 (circular ROI)
C			(4) = colour = 0 (checkered in our case)
C			               1 (black), 2 (white)
C			cf. IDI-doc. page 44 and 38
C  P3/C/1/60 		x1,y1,x2,y2 - cursor coordinates
C  			xc,yc,r1,r2,r3 if circular ROI
C  P4/C/1/5             = F(RAME) to indicate, that coordinates in P2
C                       are not screen coords. but frame related ones
C  INPUTR/R/1/2		angle, length in case of DAZIN(1) = 200
C
C.VERSIONS
C  2.20            move to standard interfaces
C  2.50            move to IDI interfaces
C  2.60            add ANGLE option to available shapes
C  2.65            use CLEAN_FRAME with '*' instead of '?'
C  2.70            use new IDIs + move to FORTRAN 77
C  2.80            make a subroutine out of it
C  2.90            add circular ROI
C
C--------------------------------------------------
C
      IMPLICIT NONE
C 
      INTEGER      JFLAG
C
      INTEGER      IAV,IMNO,DISPNO,ICO
      INTEGER      L1,L2,LL,N,STAT
      INTEGER      COORDS(5),NPIX(2),SUBLO(3)
      INTEGER      CURSNO,FM,DAZZIN(4)
      INTEGER      SHAPE,COLOUR,CNO
      INTEGER      UNI(1),NULO
C
      CHARACTER    INPUTC*60,FRAME*80,CWORK*2,AUXSTR*60
C 
CC      REAL         ALPHA,SIZE
      REAL         RINF(8),RDUM,RBUF(6)
C 
      DOUBLE PRECISION START(2),STEP(2)
      DOUBLE PRECISION  DDUM
C 
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
C
      INCLUDE 'MID_INCLUDE:IDIDEV.INC'
      INCLUDE 'MID_INCLUDE:IDIMEM.INC'
C 
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
C  get cursor info
      CALL STKRDI('DAZIN',1,4,IAV,DAZZIN,UNI,NULO,STAT)
      FM = DAZZIN(1)                        !internal no.
      CURSNO = DAZZIN(2) 
      IF (CURSNO.LT.0) CURSNO = 0
      SHAPE = DAZZIN(3)
      COLOUR = DAZZIN(4)
C 
      IF (JFLAG.EQ.1) THEN
         CALL DTOPEN(1,STAT)
         DISPNO = QDSPNO
      ELSE
         CALL DTOPEN(2,STAT)                      !open graphics window
         DISPNO = GDSPNO
      ENDIF
C 
C  handle ANGLE cursor definition in a special way
C       IF (DAZZIN(1).EQ.200) THEN
C          CURSNO = 2
C          FM = 99
C          CALL STKRDR('INPUTR',1,2,IAV,RBUF,UNI,NULO,STAT)
C          ALPHA = RBUF(1)
C          SIZE = RBUF(2)
C          CALL ANGLE(ALPHA,SIZE,COORDS)
C 
C
C see, if it's CLEAR/CURSOR (only possible for display window)
C 
      IF (FM.EQ.-1) THEN
         IF (CURSNO.EQ.2) THEN                  !region of interest
            CALL IIRSRV(DISPNO,0,0,STAT)
         ELSE IF (CURSNO.EQ.3) THEN             !two independent cursors
            CALL IICSCV(DISPNO,0,0,STAT)
            CALL IICSCV(DISPNO,1,0,STAT)
         ELSE
            CALL IICSCV(DISPNO,CURSNO,0,STAT)   !single cursor
         ENDIF
         L1 = -1                                !update key DAZIN(2)
         CALL STKWRI('DAZIN',L1,2,1,UNI,STAT)
         GOTO 9090
      ENDIF
C
      IF (CURSNO.GT.1) THEN
         IF ((FM.EQ.101).AND.(SHAPE.EQ.2)) THEN
            L1 = 5                              !circular ROI
         ELSE
            L1 = 4  
         ENDIF
      ELSE
         L1 = 2                                 !no. of coordinates needed...
      ENDIF
C
C  now check, if also the cursor coordinates should be set
C 
      CALL STKRDC('P3',1,1,60,IAV,INPUTC,UNI,NULO,STAT)
      IF (INPUTC(1:1).EQ.'+') THEN
         IF (L1.EQ.5) THEN                    !circular ROI
            COORDS(1) = -1
            COORDS(2) = -1
            COORDS(3) = 5                     !set inner raidus to 5 pixels
            COORDS(4) = 0
            COORDS(5) = 0
         ELSE
            DO 800 N=1,5
               COORDS(N) = -1                 !indicate that we don't use them
800         CONTINUE
         ENDIF
         GOTO 8000
      ENDIF
C
C  yes. set coordinates (frame or screen coords. input)
C 
      CALL STKRDC('P4',1,1,1,IAV,CWORK,UNI,NULO,STAT)  
      IF ((CWORK(1:1).NE.'F') .AND.
     +    (CWORK(1:1).NE.'f') ) THEN                      !screen coordinates
         CALL GENCNV(INPUTC,1,L1,COORDS,RDUM,DDUM,LL)
         IF (LL.LE.0) GOTO 9100
      ELSE
C
C  we work with frame coordinates
         CALL DTGICH(DISPNO,QIMCH,FRAME,RINF,STAT)       !FRAME = 80 chars now
         CALL STFOPN(FRAME,D_R4_FORMAT,0,F_IMA_TYPE,IMNO,STAT)
         CALL STDRDI(IMNO,'NPIX',1,2,IAV,NPIX,UNI,NULO,STAT)
         CALL STDRDD(IMNO,'START',1,2,IAV,START,UNI,NULO,STAT)
         CALL STDRDD(IMNO,'STEP',1,2,IAV,STEP,UNI,NULO,STAT)
C
         CALL PIXXCV('INIT',IMNO,RBUF,STAT)  
C
         IF (CURSNO.EQ.1) THEN
            CNO = 3
         ELSE
            CNO = 1
         ENDIF
         ICO = 0
C
C  handle cursor #0 or #1
1400     IF (ICO.GT.1) GOTO 8000
C 
         LL = INDEX(INPUTC,',')
         IF (LL.LE.0) GOTO 9100
         INPUTC(LL:LL) = '^'
         L2 = INDEX(INPUTC,',')
C 
         INPUTC(LL:LL) = ','
         IF (L1.GT.2) THEN                        !rectangle or circle
            IF (L2.GT.0) THEN
               AUXSTR(1:) = INPUTC(L2+1:)//' '
               INPUTC(L2:) = ' '
            ENDIF
         ENDIF
         ICO = ICO + 1
         CALL EXTCO1(IMNO,INPUTC,2,N,SUBLO,STAT)
         IF (STAT.NE.0) CALL STSEPI
         RBUF(1) = SUBLO(1)
         RBUF(2) = SUBLO(2)
         CALL PIXXCV('_RS',0,RBUF,STAT)           !convert to screen pixels...
         COORDS(CNO) = RBUF(5)
         COORDS(CNO+1) = RBUF(6)
         IF (CURSNO.EQ.0) GOTO 8000               !we're done
         IF (L2.GT.0) THEN
            INPUTC(1:) = AUXSTR(1:)//' ' 
            IF (L1.NE.5) THEN                     !if not circular ROI
               CNO = 3                            !move to next coords.
               GOTO 1400
            ELSE
               CALL GENCNV(INPUTC,1,3,COORDS(3),RDUM,DDUM,LL)
            ENDIF
         ENDIF
      ENDIF
C
C  now send the cursor specs to the Image Display (or graphics window)
8000  CALL SETCUR(DISPNO,CURSNO,SHAPE,COLOUR,COORDS,STAT)
C
C  job done
9090  CALL DTCLOS(DISPNO)
      RETURN
C
9100  CALL STETER(1,'Invalid cursor coords. given...')
C
      END

      SUBROUTINE ANGLE(ALPHA,SIZE,IC)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION:
C  subroutine ANGLE            version 1.00      860708
C  K. Banse                  ESO - Garching
C
C.KEYWORDS:
C  ANGLEn fill
C
C.PURPOSE:
C  calculate coordinates for cursors to obtain a line of required angle + size
C
C.ALGORITHM:
C  straight forward
C
C.INPUT/OUTPUT:
C  call as ANGLE(ALPHA,SIZE,IC)
C
C.VERSIONS
C
C--------------------------------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER      IDX,IDY,MDX,MDY,IC(4)
C
      REAL         ALPHA,SIZE,RLIM
      REAL         CA,TA,DX,DY,FACTO
C
      DATA    FACTO  /0.0174533/                    ! PI / 180.
      RLIM = 500.
      IF (SIZE.GT.RLIM) SIZE = RLIM
C
C  fix angle into [-90,+90]
C
100   IF (ALPHA.GT.90.0) THEN
         ALPHA = ALPHA - 180.
         GOTO 100
      ENDIF
200   IF (ALPHA.LT.-90.0) THEN
         ALPHA = ALPHA + 180.
         GOTO 200
      ENDIF
      IF (ABS(ALPHA).GE.89.9) THEN
         IDX = 0
         IDY = NINT(SIZE)
         GOTO 8000
      ENDIF
C
C  compute triangular functions
      CA = COS(ALPHA*FACTO)
      TA = TAN(ALPHA*FACTO)
C
C  test size
1000  IF (SIZE.LE.1.)
     +   CALL STETER(1,'invalid angle or size...')
C
      DX = SIZE * CA                        !delta x
      DY = DX * TA                                !delta y
C
C  make sure we remain in screen space...
      IF (ABS(DY).GT.RLIM) THEN
         SIZE = SIZE - 1.
         GOTO 1000                        !loop more...
      ELSE
         IDX = NINT(DX)
         IDY = NINT(DY)
      ENDIF
C
C  final section
8000  MDX = (512 - IDX) / 2                  !left/right margin in x
      MDY = (512 - ABS(IDY)) / 2            !left/right margin in y
      IC(1) = MDX                  !coords start with 0 ...
      IC(3) = IC(1) + IDX            !delta x always > 0
      IF (ALPHA.GT.0.) THEN
         IC(2) = MDY
      ELSE
         IC(2) = 511 - MDY
      ENDIF
      IC(4) = IC(2) + IDY            !delta y > 0 or < 0 possible
C
      RETURN
      END

      SUBROUTINE SUBSCR(DAZHLD)
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION:
C  subroutine SUBSCR			version 1.00	870520
C  K. Banse			   	ESO - Garching
C  1.10	871124 		1.20	881005		1.30	890424
C  1.40	890630		1.50	901015
C
C.KEYWORDS:
C  Image display, scrolling, zooming
C
C.PURPOSE:
C  a) update the scroll values of the currently displayed memory channel
C     under joystick control
C  b) do the zooming: either cursor window to determine zoom factor + center
C                     or single cursor and given zoom factor
C
C.ALGORITHM:
C  a) the scroll values in x and y are moved according to the joystick movement
C	
C   On the cursor board at least one cursor has to be on, TRACK has to be on
C   and RATE has to be on.
C   Switching both cursors off will terminate the program.
C	
C.INPUT/OUTPUT:
C
C  the following keywords are used:
C 
C  a) 			Scrolling...
C  DEFAULT/C/1/2	(1)= Y for scrolling via joystick
C			(1)= N for fixed scroll values
C			(1)= C for clear/scroll (i.e. reset to original)
C			(2)= O, scroll overlay channel accordingly
C			else scroll only given channel
C  DAZIN/I/1/2		scroll values in case of DEFAULT = N
C  DAZHOLD/I/8/1	refscale flag
C
C  b)			Zooming...
C  ACTION/C/3/3		action flags
C			(1) = C, use size of cursor square to get zoom factors
C			(1) = F, read zoom factors from DAZHOLD
C			(1) = U, zoom stepwise up from current level
C			(1) = D, zoom stepwise down from current level
C			(1) = X, clear zoom
C			(3) = X, use F option above at fixed position,
C				 which are in INPUTI(1,2)
C			(3) = else - use the cursor ...
C
C.VERSIONS
C  1.00		from vers. 1.80 of SCROLL + vers. 3.20 of ZOOM
C  1.10		take care of display screen size
C  1.20		add DEFAULT(1::1) = C option
C               and move to new IDI and ST interfaces
C  1.30		for XWindow systems, we only scroll on ENTER ...
C  1.40		make a subroutine out of it
C  1.50		use QMSZY instead of QDSZY for scrolling...
C
C---------------------------------------------------------
C
C
      IMPLICIT NONE
C	
      INTEGER      DAZHLD(*)
C 
      INTEGER      FLAG,IAV,STAT,INC,ZMLIM(2)
      INTEGER      N,LOOP,IDX,XM,YM
      INTEGER      OLDZX,ZFX,ZFY,SCRX,SCRY
      INTEGER      CHAN,REFSC,COORDS(4)
      INTEGER      DX,DY,MEMC1,MEMC2,ST1,ST2
      INTEGER      IZOOM(2)
      INTEGER      XY1(2),XY2(2),YESCUR
      INTEGER      SPLMOD,CURNO
      INTEGER      SCRVAL(2),JX,JY,ZOOMR
      INTEGER      SPLCX(4,5),SPLCY(4,5)
      INTEGER      KUNI,KNUL
C
      CHARACTER    COMPAR(5)*1,ACTION*3
      CHARACTER    DEFAUL*16,WORK*80
C      
      REAL         ZFACT,RINF(8)
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
C      
      INCLUDE  'MID_INCLUDE:IDIDEV.INC'
      INCLUDE  'MID_INCLUDE:IDIMEM.INC'
C      
      DATA      COMPAR      /'C','F','U','D','X'/
      DATA      COORDS      /-1,-1,-1,-1/
C 
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
      CALL DTOPEN(1,STAT)
      REFSC = DAZHLD(8)                        !get global refscale flag
      SPLMOD = DAZHLD(3)
      SCRX = 0
      SCRY = 0
      FLAG = 0
      INC = 0
C      
C  read keyword DEFAULT(16) to determine, if we want to scroll or zoom
      CALL STKRDC('DEFAULT',1,1,16,IAV,DEFAUL,KUNI,KNUL,STAT)
      CALL UPCAS(DEFAUL,DEFAUL)
      IF ((DEFAUL(16:16).EQ.'Z') .OR. (DEFAUL(16:16).EQ.'z'))
     +    GOTO 1000                            !do Zooming at label 1000
C 
C ------------------------------------------------------
C      
C  here we do the scrolling
C      
C ------------------------------------------------------
C 
C  read "image environment" for current channel 
      CALL DTGICH(QDSPNO,QIMCH,WORK,RINF,STAT)
      IF ((ZOOMX + ZOOMY) .GT. 2)
     +   CALL STETER(2,'No scrolling of zoomed channel supported...')
C      
C  if DEFAULT(1:1) = Y, we get the scroll values via joystick
      IF (DEFAUL(1:1).EQ.'Y') THEN
         SCRVAL(1) = SCROLX
         SCRVAL(2) = SCROLY
         CURNO = 1
         CALL JOYSTK(QDSPNO,0,CURNO,JX,JY,STAT)  
C 
      ELSE
         IF (DEFAUL(1:1).EQ.'N') THEN
            CALL STKRDI('DAZIN',1,2,IAV,SCRVAL,KUNI,KNUL,STAT)
         ELSE IF (DEFAUL(1:1).EQ.'C') THEN
            SCRVAL(1) = 0
            SCRVAL(2) = QDSZY - 1
         ENDIF
C 
         CALL DAZSCR(QDSPNO,QIMCH,SCRVAL(1),SCRVAL(2),STAT)
         IF (DAZHLD(13).EQ.QIMCH)
     +      CALL DAZSCR(QDSPNO,QOVCH,SCRVAL(1),SCRVAL(2),STAT)
         SCROLX = SCRVAL(1)
         SCROLY = SCRVAL(2)
         GOTO 500                              !that's it already...
      ENDIF
C 
C  get joystick input 
100   CALL JOYSTK(QDSPNO,1,CURNO,JX,JY,STAT)
      IF (STAT.EQ.1) GOTO 500                  !if cursor(s) off, terminate
C      
C modify scroll values according to joystick movement
      IF (IDINUM.NE.11) THEN
         IF ((JX.LE.-64).OR.(JX.GE.64)) THEN
            JX = JX/8
         ELSE
            JX = JX/12
         ENDIF
         IF ((JY.LE.-64).OR.(JY.GE.64)) THEN
            JY = JY/8
         ELSE
            JY = JY/12
         ENDIF
      ENDIF
C      
      IF ((JX.EQ.0) .AND. (JY.EQ.0)) GOTO 100
C 
      SCRVAL(1) = SCRVAL(1) - JX
      SCRVAL(2) = SCRVAL(2) - JY
C 
      IF (IDINUM.NE.11) THEN
         IF (SCRVAL(1).LT.-QMSZX) THEN
            SCRVAL(1) = - (QMSZX - 1)
         ELSE IF (SCRVAL(1).GE.QMSZX) THEN
            SCRVAL(1) = QMSZX - 1
         ENDIF
         IF (SCRVAL(2).LT.-QMSZY) THEN
            SCRVAL(2) = - (QMSZY - 1)
         ELSE IF (SCRVAL(2).GE.QMSZY) THEN
            SCRVAL(2) = QMSZY - 1
         ENDIF
      ENDIF
C 
C  send new scroll values to ImageDisplay
      CALL DAZSCR(QDSPNO,QIMCH,SCRVAL(1),SCRVAL(2),STAT) 
      IF (DAZHLD(13).EQ.QIMCH)
     +   CALL DAZSCR(QDSPNO,QOVCH,SCRVAL(1),SCRVAL(2),STAT)      
C      
C  now loop
      GOTO 100
C      
C  that's it folks...
500   SCROLX = SCRVAL(1)
      SCROLY = SCRVAL(2)
      CALL DAZVIS(QDSPNO,QIMCH,1,REFSC)                  !keep LUT display
      CALL DTPICH(QDSPNO,QIMCH,WORK,RINF,STAT)
C      
      IF (DAZHLD(13).EQ.QIMCH) THEN
         SCRX = SCROLX                                   !save scroll values
         SCRY = SCROLY
         CALL DTGICH(QDSPNO,QOVCH,WORK,RINF,STAT)
         SCROLX = SCRX
         SCROLY = SCRY
         CALL DTPICH(QDSPNO,QOVCH,WORK,RINF,STAT)
      ENDIF
C      
C  goto common end section
      GOTO 9000

C 
C ---------------------------------------------------------------
C      
C  here we do the zooming
C
C ---------------------------------------------------------------
C 
C  see what we should do
1000  CALL STKRDC('ACTION',1,3,3,IAV,ACTION,KUNI,KNUL,STAT)
      CALL UPCAS(ACTION,ACTION)
      DO 1010 N=1,5
         IF (ACTION(1:1).EQ.COMPAR(N)) THEN
            FLAG = N
            GOTO 1020
         ENDIF
1010  CONTINUE
      CALL STETER(3,'Invalid option...')           !invalid input...
C
1020  CALL IIDQCI(QDSPNO,17,2,ZMLIM,N,STAT)        !get zoom limits
C 
C  see, if it's CLEAR/ZOOM...
      IF (FLAG.EQ.5) THEN
         CALL SPLCNT(SPLCX,SPLCY)
C      
         ZOOMR = 1
         IF (QRGBFL.NE.1) THEN                      !pseudo-colour mode
            CALL DTGICH(QDSPNO,QIMCH,WORK,RINF,STAT)
            ZOOMX = ZOOMR
            ZOOMY = ZOOMR
            IF (SPLMOD.EQ.0) THEN            !init scroll values
               SCROLX = 0
               SCROLY = QDSZY - 1
            ELSE
               SCROLX = SPLCX(QIMCH+1,SPLMOD)
               SCROLY = SPLCY(QIMCH+1,SPLMOD)
            ENDIF
C 
            CALL DAZZSC(QDSPNO,QIMCH,1,SCROLX,SCROLY,STAT)  !reset zoom, scroll
            CALL DAZVIS(QDSPNO,QIMCH,1,REFSC)         !update refscale flag
            CALL DTPICH(QDSPNO,QIMCH,WORK,RINF,STAT)
C 
         ELSE                                 !in RGB mode
            DO 1100 CHAN=0,2                  !loop through all colour channels
               CALL DTGICH(QDSPNO,CHAN,WORK,RINF,STAT)
               ZOOMX = ZOOMR
               ZOOMY = ZOOMR
               IF (SPLMOD.EQ.0) THEN          !init scroll values
                  SCROLX = 0
                  SCROLY = QDSZY - 1
               ELSE
                  SCROLX = SPLCX(QIMCH+1,SPLMOD)
                  SCROLY = SPLCY(QIMCH+1,SPLMOD)
               ENDIF
               CALL DAZZSC(QDSPNO,CHAN,ZOOMX,SCROLX,SCROLY,STAT)   
               CALL DAZVIS(QDSPNO,CHAN,1,REFSC)
               CALL DTPICH(QDSPNO,CHAN,WORK,RINF,STAT)
1100     CONTINUE
         ENDIF
C 
         IF (DAZHLD(13).EQ.QIMCH) THEN
            IF (QOVCH.GE.0) THEN 
               CALL DTGICH(QDSPNO,QOVCH,WORK,RINF,STAT)
               SCROLX = SCRX
               SCROLY = SCRY
               ZOOMX = ZOOMR
               ZOOMY = ZOOMX
               CALL DAZZSC(QDSPNO,QOVCH,ZOOMX,SCROLX,SCROLY,STAT)
               CALL DTPICH(QDSPNO,QOVCH,WORK,RINF,STAT)
            ENDIF
         ENDIF
         GOTO 9000                              !jump to end section
      ENDIF
C      
C  --------------------------------------
C      
C  here for real zooming
C      
C  --------------------------------------
C      
C  init for stepwise zooming...
      LOOP = 0                             !initialize loop counter
      IDX = 0                              !and iteration count for rectangles
C
C  look, if we do not need cursors
      IF ( (FLAG.EQ.2) .AND. (ACTION(3:3).EQ.'X') ) THEN
         CALL STKRDI('INPUTI',1,2,IAV,XY1,KUNI,KNUL,STAT)
         MEMC1 = QIMCH
         YESCUR = 0
         IF (QRGBFL.EQ.1) THEN
            GOTO 4000
         ELSE
            GOTO 1500
         ENDIF
      ENDIF
C      
C  enable cursors
      YESCUR = 1
      IF (FLAG.EQ.1) THEN  
         CURNO = 2
         CALL SETCUR(QDSPNO,CURNO,0,0,COORDS,STAT)    !use ROI
      ELSE  
         CURNO = 0
         CALL SETCUR(QDSPNO,CURNO,3,0,COORDS,STAT)    !use curs0 as open cross
      ENDIF
C      
C  for ZOOM/UP, /DOWN set increments + limits
      IF (FLAG.EQ.3) THEN
         INC = +1
      ELSE IF (FLAG.EQ.4) THEN
         INC = -1
      ENDIF
C      
C  fork according to QRGBFL
      IF (QRGBFL.EQ.1) GOTO 4000
C
C  wait for cursor input
1500  IF (YESCUR.NE.1) GOTO 1600           !so we can jump to 1550...
C
      CALL CURSIN(QDSPNO,0,CURNO,XY1,MEMC1,ST1,XY2,MEMC2,ST2)
1550  CALL CURSIN(QDSPNO,1,CURNO,XY1,MEMC1,ST1,XY2,MEMC2,ST2)
      IF (ST1.EQ.0) THEN
         IF (LOOP.EQ.0) THEN
            CALL STTDIS('Turn cursor on...',80,STAT)
            GOTO 1550
         ELSE               
            GOTO 9000                   !for stepwise zoom, check
         ENDIF
      ENDIF
C
C  get channel info for relevant memory board
1600  CALL DTGICH(QDSPNO,MEMC1,WORK,RINF,STAT)
      OLDZX = ZOOMX                        !save old zoom factor
      CHAN = MEMC1                         !we use CHAN for image channel later on
C
C  zoomfactor taken from cursor box
C      
      IF (FLAG.EQ.1) THEN                  !cursor window option
         DX = ABS(XY2(1) - XY1(1))
         DY = ABS(XY2(2) - XY1(2))
         XM = XY1(1) + DX/2
         YM = XY1(2) + DY/2
C      
         IF ((DX.EQ.0).OR.(DY.EQ.0)) THEN           !check, if valid rectangle
            IF (IDX.EQ.1) GOTO 9000                 !allow only one iteration
            CALL STTDIS('use cursors to form a rectangle...',99,STAT)
            IDX = 1
            GOTO 1550
         ENDIF
C      
         ZFX = NINT(FLOAT(QDSZX)/FLOAT(DX))
         IF (ZFX.LT.ZMLIM(1)) ZFX = ZMLIM(1)
         IF (ZFX.GT.ZMLIM(2)) ZFX = ZMLIM(2)
         ZFY = NINT(FLOAT(QDSZY)/FLOAT(DY))
         IF (ZFY.LT.ZMLIM(1)) ZFY = ZMLIM(1)
         IF (ZFY.GT.ZMLIM(2)) ZFY = ZMLIM(2)
         IF (ZFX.GT.ZFY) THEN
            ZOOMR = ZFX
         ELSE
            ZOOMR = ZFY
         ENDIF
C      
C  fixed zoom factor
C      
      ELSE IF (FLAG.EQ.2) THEN
         XM = XY1(1)
         YM = XY1(2)
         ZOOMR = DAZHLD(6)
C      
C  here for stepwise zooming
C      
      ELSE
         XM = XY1(1)
         YM = XY1(2)
         ZFX = ZOOMX + INC
         IF ( (ZFX.LT.ZMLIM(1)) .OR. (ZFX.GT.ZMLIM(2)) ) GOTO 9000     !done...
         ZOOMR = ZFX
      ENDIF
C
C  common section for all zoom options...
C  set XSCROL, YSCROL such, that zoom center remains unchanged
C
      IF (ZOOMR.NE.OLDZX) THEN
         ZFACT = FLOAT(ZOOMX) / FLOAT(ZOOMR)
         SCROLX = XM - NINT( (XM - SCROLX) * ZFACT )
         SCROLY = YM + NINT( (SCROLY - YM) * ZFACT )
      ENDIF
C
C  now we finally zoom
C      
      CALL DAZZSC(QDSPNO,CHAN,ZOOMR,SCROLX,SCROLY,STAT)
      CALL DAZVIS(QDSPNO,CHAN,1,REFSC)             !for refscale flag 
      IF (DAZHLD(13).EQ.CHAN)
     +   CALL DAZZSC(QDSPNO,QOVCH,ZOOMR,SCROLX,SCROLY,STAT)
C
C  update channel info
      ZOOMX = ZOOMR
      ZOOMY = ZOOMX                        !we use same zoom factor in x + y
      SCRX = SCROLX                        !save scroll values
      SCRY = SCROLY
      CALL DTPICH(QDSPNO,MEMC1,WORK,RINF,STAT)
C      
C  if requested also update stuff for overlay channel
      IF (DAZHLD(13).EQ.CHAN) THEN
         IF (QOVCH.GE.0) THEN            !check, if an overlay channel exists
            CALL DTGICH(QDSPNO,QOVCH,WORK,RINF,STAT)
            SCROLX = SCRX
            SCROLY = SCRY
            ZOOMX = ZOOMR
            ZOOMY = ZOOMX
            CALL DTPICH(QDSPNO,QOVCH,WORK,RINF,STAT)
         ENDIF
      ENDIF
C      
C  for stepwise zooming, we loop
      IF (FLAG.GE.3) THEN
         LOOP = 1                        !loop
         GOTO 1550
      ENDIF
C 
C  jump to the end
      GOTO 9000                        !We're done ...
C      
C ---------------------------------------------------
C
C  handle all 3 colour channels in RGB_MODE
C
C ---------------------------------------------------
C
C  wait for cursor input
4000  IF (YESCUR.EQ.1) THEN
         CALL CURSIN(QDSPNO,0,CURNO,XY1,MEMC1,ST1,XY2,MEMC2,ST2)
         CALL CURSIN(QDSPNO,1,CURNO,XY1,MEMC1,ST1,XY2,MEMC2,ST2)
         IF ((LOOP.GT.0).AND.(ST1.EQ.0)) GOTO 5900              !done..
      ENDIF
C      
C  now loop through channels 0,1,2
      DO 4400 CHAN=0,2
         CALL DTGICH(QDSPNO,CHAN,WORK,RINF,STAT)
         OLDZX = ZOOMX                  !save old zoom factors
C
C  zoomfactor taken from cursor box
C      
         IF (FLAG.EQ.1) THEN
            DX = ABS(XY2(1) - XY1(1))
            DY = ABS(XY2(2) - XY1(2))
            XM = XY1(1) + DX/2
            YM = XY1(2) + DY/2
C      
            IF ((DX.EQ.0).OR.(DY.EQ.0)) THEN         !check, if valid rectangle
               IF (IDX.EQ.1) GOTO 9000               !allow only one iteration
               CALL STTDIS('use cursors to form a rectangle...',1,STAT)
               IDX = 1
               GOTO 4000
            ENDIF
C      
            ZFX = NINT(FLOAT(QDSZX)/FLOAT(DX))
            IF (ZFX.LT.ZMLIM(1)) ZFX = ZMLIM(1)
            IF (ZFX.GT.ZMLIM(2)) ZFX = ZMLIM(2)
            ZFY = NINT(FLOAT(QDSZY)/FLOAT(DY))
            IF (ZFY.LT.ZMLIM(1)) ZFY = ZMLIM(1)
            IF (ZFY.GT.ZMLIM(2)) ZFY = ZMLIM(2)
            IF (ZFX.GT.ZFY) THEN
               ZOOMR = ZFX
            ELSE
               ZOOMR = ZFY
            ENDIF
C      
C  explicit zoom factors
C      
         ELSE IF (FLAG.EQ.2) THEN
            XM = XY1(1)
            YM = XY1(2)
            ZOOMR = DAZHLD(6)
C      
C  here for stepwise zooming
C      
         ELSE
            XM = XY1(1)
            YM = XY1(2)
            ZFX = ZOOMX + INC
            IF ( (ZFX.LT.ZMLIM(1)) .OR. (ZFX.GT.ZMLIM(2)) ) GOTO 5900   !done..
            ZOOMR = ZFX
         ENDIF
C
C  set SCROLX, SCROLY such, that zoom center remains unchanged
         IF (ZOOMR.NE.OLDZX) THEN
            ZFACT = FLOAT(ZOOMX) / FLOAT(ZOOMR)
            SCROLX = XM - NINT( (XM - SCROLX) * ZFACT )
            SCROLY = YM - NINT( (YM - SCROLY) * ZFACT )
C                                          keep x-scroll value in [0,memsize-1]
4100        IF (SCROLX.GE.QMSZX) THEN
               SCROLX = SCROLX - QMSZX
               GOTO 4100
            ENDIF
4120        IF (SCROLX.LT.0) THEN
               SCROLX = SCROLX + QMSZX
               GOTO 4120
            ENDIF
C                                          keep y-scroll value in [0,memsize-1]
4150        IF (SCROLY.GE.QMSZY) THEN
               SCROLY = SCROLY - QMSZY
               GOTO 4150
            ENDIF
4180        IF (SCROLY.LT.0) THEN
               SCROLY = SCROLY + QMSZY
               GOTO 4180
            ENDIF
         ENDIF
C
C  now zoom
         CALL DAZZSC(QDSPNO,CHAN,ZOOMR,SCROLX,SCROLY,STAT)   !set zoom + scroll
         CALL DAZVIS(QDSPNO,CHAN,1,REFSC)
C
C  update keyword DAZMEMI
         ZOOMX = ZOOMR
         ZOOMY =ZOOMX
         SCRX = SCROLX                  !save scroll values
         SCRY = SCROLY
         CALL DTPICH(QDSPNO,CHAN,WORK,RINF,STAT)
4400  CONTINUE
C      
C  if stepwise zooming, loop
      IF (FLAG.GE.3) THEN
         LOOP = 1
         GOTO 4000
      ENDIF
C      
C  if requested also update stuff for overlay channel
5900  IF (DAZHLD(13).EQ.0) THEN
         IF (QOVCH.GE.0) THEN 
            CALL DTGICH(QDSPNO,QOVCH,WORK,RINF,STAT)
            SCROLX = SCRX
            SCROLY = SCRY
            ZOOMX = ZOOMR
            ZOOMY = ZOOMX
            CALL DAZZSC(QDSPNO,QOVCH,ZOOMX,SCROLX,SCROLY,STAT)  
            CALL DTPICH(QDSPNO,QOVCH,WORK,RINF,STAT)
         ENDIF
      ENDIF
C      
C      
C  that's it folks...
C
C
9000  IZOOM(1) = ZOOMR
      IZOOM(2) = ZOOMR
      CALL STKWRI('DAZHOLD',IZOOM,6,2,KUNI,STAT)         !update keyword DAZHLD
      CALL DTCLOS(QDSPNO)
C 
      RETURN
      END
