C @(#)idauxz.for 17.1.1.1 (ESO-IPG) 01/25/02 17:39:59 C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C.COPYRIGHT: Copyright (c) 1987 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 5.30 DXZOPN -> DAZOPN C C 001201 last modif C C------------------------------------------------------------------- C PROGRAM IDAUXZ C IMPLICIT NONE C INTEGER IAV,STAT,DAZHLD(14) INTEGER UNI(1),NULO C CHARACTER ACTIO*2 C INCLUDE 'MID_INCLUDE:IDIDEV.INC' 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 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.EQ.0) 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