C @(#)exslit.for 13.1.1.1 (ESO-DMD) 06/02/98 18:11:33 PROGRAM EXSLIT C C++++++++++++++++++++++++++++++++++++++++++++++++++ C C.IDENTIFICATION C program EXSLIT version 1.00 890215 C K. Banse ESO - Garching C 1.10 900425 C C.KEYWORDS C DeAnza, subimage C C.PURPOSE C extract a rotated slit (of fixed size) from the displayed image C C.ALGORITHM C use cursor 2 to change the slope of the trace + cursor 1 as rotation C point (or vice versa), both cursors are moved via the joystick C exactly like in EXTRACT/TRACE C i.e., we exit on ENTER with both cursors off C C.INPUT/OUTPUT C the following keywords are used: C C INPUTR/R/1/2 stepsizes for slit C P3/C/1/60 slitlength, slitwidth, x/y C C.VERSIONS C 1.00 from version 2.80 as of 871123 C 1.10 fix bugs introduced by conversion to Portable Midas... C C-------------------------------------------------- C IMPLICIT NONE C INTEGER IAV,IPIXL,IPIXW INTEGER IS1,IS2,MAXIDX,N,NAXIS,NINDX,NN,NOCUR INTEGER PARAL,STAT,COOS(4) INTEGER IMNOA,IMNOB INTEGER*8 PNTRA,PNTRB,PNTRX,PNTRY INTEGER XR,YR,XS,YS INTEGER IX1,IY1,IX2,IY2,IX3,IY3,IX4,IY4 INTEGER XFIG(5),YFIG(5),XOLDFG(5),YOLDFG(5) INTEGER NPIX(3),NPOLD(2),SUBLO(3) INTEGER NEW1(2),NEW2(2),MC1,MC2 INTEGER ENTER,OVCON,ENTFLG,FIRTIM,RFNO INTEGER UNI(1),NULO INTEGER MADRID(1) C CHARACTER CUNIT*64,IDENT*72 CHARACTER CDUMMY*1,LINE*80,ATOM(2)*20,ACTION*2 CHARACTER*60 OUTFRA,INFRA,RFSLIT C REAL RBUF(6),PIXELS(6) REAL RINF(6),CUTS(4) REAL PXSTA(2),PXEND(2) REAL ALPHA,BETA,DX,DY REAL PXSTAA(2),PXENDA(2),CA,SA,PXSTEP(2) REAL X1,Y1,X2,Y2,X3,Y3,X4,Y4,XDELT,YDELT REAL XCENT,YCENT,WH,SH REAL FACTO C DOUBLE PRECISION START(3),STEP(3),RFSTA(2),STEPLN(2) C INCLUDE 'MID_INCLUDE:ST_DEF.INC' C INCLUDE 'MID_INCLUDE:IDIDEV.INC' INCLUDE 'MID_INCLUDE:IDIMEM.INC' C COMMON /VMR/ MADRID C EQUIVALENCE (IX1,XFIG(1)),(IY1,YFIG(1)), + (IX2,XFIG(2)),(IY2,YFIG(2)), + (IX3,XFIG(3)),(IY3,YFIG(3)), + (IX4,XFIG(4)),(IY4,YFIG(4)) C DATA CUTS /0.,0.,+999999.,-999999./ DATA XOLDFG /5*0/, YOLDFG /5*0/ DATA LINE /' '/ DATA START /3*0.D0/, STEP /3*1.D0/ DATA NPIX /3*1/ DATA COOS /-1,-1,-1,-1/ DATA FACTO /0.0174533/ ! Pi / 180. DATA IDENT /' '/, CUNIT /' '/ C INCLUDE 'MID_INCLUDE:ST_DAT.INC' C C get into MIDAS CALL STSPRO('EXSLIT') INFRA = ' ' PARAL = 0 FIRTIM = 0 C C get options + result frame CALL STKRDC('ACTION',1,1,2,IAV,ACTION,UNI,NULO,STAT) CALL STKRDC('OUT_A',1,1,60,IAV,OUTFRA,UNI,NULO,STAT) C C allocate virtual memory for x,y indices for extracted image CALL STKRDI('INPUTI',10,1,IAV,MAXIDX,UNI,NULO,STAT) CALL STFXMP(MAXIDX,D_R4_FORMAT,PNTRX,STAT) CALL STFXMP(MAXIDX,D_R4_FORMAT,PNTRY,STAT) C C if we use a reference slit, obtain all necessary info IF (ACTION(2:2).EQ.'F') THEN CALL STKRDC('IN_B',1,1,60,IAV,RFSLIT,UNI,NULO,STAT) CALL STFOPN(RFSLIT,D_OLD_FORMAT,0,F_IMA_TYPE,RFNO,STAT) CALL STDRDI(RFNO,'NAXIS',1,1,IAV,NN,UNI,NULO,STAT) IF (NN.LT.2) CALL STETER + (3,'reference slit must be at least 2-dim frame...') CALL STDRDI(RFNO,'NPIX',1,2,IAV,NPIX,UNI,NULO,STAT) IPIXW = NPIX(2) IPIXL = NPIX(1) CALL STDRDD(RFNO,'START',1,2,IAV,RFSTA,UNI,NULO,STAT) CALL STDRDD(RFNO,'STEP',1,2,IAV,STEPLN,UNI,NULO,STAT) C C now split according to input spec IF (ACTION(1:1).EQ.'F') THEN CALL STKRDC('IN_A',1,1,60,IAV,INFRA,UNI,NULO,STAT) CALL STIGET(INFRA,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE, + 2,NAXIS,NPIX,START,STEP,IDENT, + CUNIT,PNTRA,IMNOA,STAT) GOTO 5000 !there we handle cursorless stuff.. ENDIF ENDIF C C *************** C C here we come for cursor processing - connect to display + get channel info C C *************** C CALL DTOPEN(1,STAT) CALL STKRDI('DAZHOLD',13,1,IAV,OVCON,UNI,NULO,STAT) CALL DTGICH(QDSPNO,QIMCH,INFRA,RINF,STAT) IF (SOURCE.NE.1) CALL STETER(2,'no image loaded...') C C get displayed frame + null value CALL STIGET(INFRA,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,3, + NAXIS,NPIX,START,STEP, + IDENT,CUNIT,PNTRA,IMNOA,STAT) IF (ZPLANE .NE. 0) THEN NN = (ZPLANE-1)*NPIX(1)*NPIX(2) PNTRA = PNTRA + NN !use displayed plane ENDIF C CALL PIXXCV('INIT',IMNOA,RBUF,STAT) !set up PIXXCV C C if we do not use a reference slit, get width and length of slit + stepsizes IF (ACTION(2:2).EQ.'F') THEN CDUMMY = 'F' ELSE CALL STKRDC('P3',1,1,60,IAV,LINE,UNI,NULO,STAT) CALL STKRDD('INPUTD',1,2,IAV,STEPLN,UNI,NULO,STAT) C C extract length, width, x/y N = 1 CALL EXTRSS(LINE,',',N,ATOM(1),NN) IF (NN.LE.0) GOTO 9100 !wrong input... CALL EXTRSS(LINE,',',N,ATOM(2),NN) IF (NN.LE.0) GOTO 9100 !wrong input... CALL EXTRSS(LINE,',',N,CDUMMY,NN) IF (NN.LE.0) CDUMMY = 'X' !default is x-coords. ENDIF C C first of all we need the frame pixel at center of screen PIXELS(1) = (QDSZX-1) * 0.5 PIXELS(2) = (QDSZY-1) * 0.5 CALL PIXXCV('SRW',0,PIXELS,STAT) XCENT = PIXELS(3) YCENT = PIXELS(4) C C either use x-coords IF (CDUMMY.EQ.'X') THEN !convert char. strings to real pixels LINE(1:) = '[ ' LINE(2:) = ATOM(1) N = INDEX(LINE,' ') LINE(N+1:) = ',@1] ' CALL EXTCO1(IMNOA,LINE,2,N,SUBLO,STAT) IF (STAT.NE.0) GOTO 9100 IPIXW = SUBLO(1) LINE(1:) = '[ ' LINE(2:) = ATOM(2) N = INDEX(LINE,' ') LINE(N+1:) = ',@1] ' CALL EXTCO1(IMNOA,LINE,2,N,SUBLO,STAT) IF (STAT.NE.0) GOTO 9100 IPIXL = SUBLO(1) C C or use y-coords ELSE IF (CDUMMY.EQ.'Y') THEN LINE(1:) = '[@1, ' LINE(5:) = ATOM(1) N = INDEX(LINE,' ') LINE(N+1:) = '] ' CALL EXTCO1(IMNOA,LINE,2,N,SUBLO,STAT) IF (STAT.NE.0) GOTO 9100 IPIXW = SUBLO(2) LINE(1:) = '[@1, ' LINE(5:) = ATOM(2) N = INDEX(LINE,' ') LINE(N+1:) = '] ' CALL EXTCO1(IMNOA,LINE,2,N,SUBLO,STAT) IF (STAT.NE.0) GOTO 9100 IPIXL = SUBLO(2) ENDIF C C determine size of slit PIXELS(1) = XCENT - FLOAT(IPIXW/2) PIXELS(2) = YCENT - FLOAT(IPIXW/2) CALL PIXXCV('_RS',0,PIXELS,STAT) !get screen pixels IF (STAT.NE.0) GOTO 9100 !something wrong... X1 = PIXELS(5) !screen pixel offset Y1 = PIXELS(6) PIXELS(1) = PIXELS(1) + FLOAT(IPIXW) PIXELS(2) = PIXELS(2) + FLOAT(IPIXW) CALL PIXXCV('_RS',0,PIXELS,STAT) !get screen pixels IF (STAT.NE.0) GOTO 9100 !something wrong... X2 = PIXELS(5) !screen pixel end Y2 = PIXELS(6) IF (CDUMMY.NE.'Y') THEN WH = X2 - X1 ELSE WH = Y2 - Y1 ENDIF C PIXELS(1) = XCENT - FLOAT(IPIXL/2) PIXELS(2) = YCENT - FLOAT(IPIXL/2) CALL PIXXCV('_RS',0,PIXELS,STAT) !get screen pixels IF (STAT.NE.0) GOTO 9100 !something wrong... X1 = PIXELS(5) Y1 = PIXELS(6) PIXELS(1) = PIXELS(1) + FLOAT(IPIXL) PIXELS(2) = PIXELS(2) + FLOAT(IPIXL) CALL PIXXCV('_RS',0,PIXELS,STAT) !get screen pixels IF (STAT.NE.0) GOTO 9100 !something wrong... X2 = PIXELS(5) Y2 = PIXELS(6) IF (CDUMMY.NE.'Y') THEN SH = X2 - X1 ELSE SH = Y2 - Y1 ENDIF C C finally we get half the slit size in screen pixels WH = WH * 0.5 SH = SH * 0.5 IF ((WH.LT.1.).OR.(SH.LT.1.)) GOTO 9100 !SLITSZ too small IF ((WH+SH).GT.600.) GOTO 9100 !SLITSZ too large C C clear graphics channel (use same scroll values as for image channel) CALL CONCHA(QDSPNO,QOVCH,1,0) IF (OVCON.EQ.QIMCH) + CALL DAZZSC(QDSPNO,QOVCH,ZOOMX,SCROLX,SCROLY,STAT) C C set up both cursors as cross hairs IF (IDINUM.EQ.11) THEN NOCUR = 3 ENTFLG = 1 ELSE NOCUR = 2 ENTFLG = 2 ENDIF CALL SETCUR(QDSPNO,0,8,2,COOS,STAT) !shape = 8 for small crosshair CALL SETCUR(QDSPNO,1,8,2,COOS,STAT) CALL STKWRI('DAZHOLD',NOCUR,1,1,UNI,STAT) C C enable interaction CALL CURSIN(QDSPNO,0,NOCUR,NEW1,MC1,IS1,NEW2,MC2,IS2) C C poll cursors to upgrade the graphs 100 CALL CURSIN(QDSPNO,ENTFLG,NOCUR,NEW1,MC1,IS1,NEW2,MC2,IS2) C C update rotation and/or slope coords. IF (NEW2(1).LT.NEW1(1)) THEN XR = NEW2(1) !keep only 2 possibilities... YR = NEW2(2) XS = NEW1(1) YS = NEW1(2) ELSE XR = NEW1(1) YR = NEW1(2) XS = NEW2(1) YS = NEW2(2) ENDIF C IF ( (IS1.EQ.0) .AND. (IS2.EQ.0) ) THEN GOTO 1000 ELSE IF (IS1.LT.0) THEN ENTER = 1 ELSE ENTER = 0 ENDIF PARAL = 0 C C for XWindows we only draw upon ENTER IF ((IDINUM.EQ.11).AND.(ENTER.EQ.0)) GOTO 100 C C test for "critical" coordinates IF ((XS.EQ.XR).OR.(YS.EQ.YR)) THEN PARAL = 1 GOTO 100 ENDIF C C calculate slope of line through cursors DX = FLOAT(XS-XR) DY = FLOAT(YS-YR) ALPHA = ATAN2(DY,DX) !in radians C C first get center coords XCENT = (XR + XS) * 0.5 YCENT = (YR + YS) * 0.5 XDELT = COS(ALPHA) * SH YDELT = SIN(ALPHA) * SH XS = XCENT + XDELT XR = XCENT - XDELT YS = YCENT + YDELT YR = YCENT - YDELT C C determine line at 90 degrees angle + endpoint on it BETA = ALPHA + (90. * FACTO) !remember that we work in radians XDELT = ABS(WH * COS(BETA)) YDELT = ABS(WH * SIN(BETA)) C C now build up slit IF (ALPHA.GT.0.) THEN X1 = XR - XDELT Y1 = YR + YDELT X2 = XR + XDELT Y2 = YR - YDELT X3 = XS + XDELT Y3 = YS - YDELT X4 = XS - XDELT Y4 = YS + YDELT ELSE X1 = XR + XDELT Y1 = YR + YDELT X2 = XR - XDELT Y2 = YR - YDELT X3 = XS - XDELT Y3 = YS - YDELT X4 = XS + XDELT Y4 = YS + YDELT ENDIF C IX1 = NINT(X1) IX2 = NINT(X2) IY1 = NINT(Y1) IY2 = NINT(Y2) IX3 = NINT(X3) IX4 = NINT(X4) IY3 = NINT(Y3) IY4 = NINT(Y4) C C erase old vector + draw new vector XFIG(5) = XFIG(1) !close rectangle YFIG(5) = YFIG(1) DO 510 N=1,5 IF (XFIG(N).NE.XOLDFG(N)) GOTO 600 IF (YFIG(N).NE.YOLDFG(N)) GOTO 600 510 CONTINUE GOTO 100 !no change - poll cursors again C C draw slit in overlay plane 600 IF (FIRTIM.NE.0) THEN !erase old vector CALL IIGPLY(QDSPNO,QOVCH,XOLDFG,YOLDFG,5,0,1,STAT) ELSE FIRTIM = 1 ENDIF C CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,5,255,1,STAT) !draw new vector DO 610, N=1,5 !save old rectangle XOLDFG(N) = XFIG(N) YOLDFG(N) = YFIG(N) 610 CONTINUE IF (ACTION(1:1).EQ.'C') GOTO 100 C C check out, if PARAL 1000 IF (PARAL.EQ.1) THEN LINE(1:) = + 'PARAL subimages should be extracted via EXTRACT/CURSOR...' CALL STTPUT(LINE,STAT) CALL STTPUT('change angle or exit',STAT) GOTO 100 ENDIF C C now convert the corner points from screen pixels to real pixel no's C and world coords C PIXELS(1) = IX2 PIXELS(2) = IY2 CALL PIXXCV('IRW',0,PIXELS,STAT) IF (STAT.NE.0) GOTO 9200 !slit out of image bounds... PXSTA(1) = PIXELS(3) PXSTA(2) = PIXELS(4) C PIXELS(1) = IX3 PIXELS(2) = IY3 CALL PIXXCV('IRW',0,PIXELS,STAT) IF (STAT.NE.0) GOTO 9200 !slit out of image bounds... PXEND(1) = PIXELS(3) PXEND(2) = PIXELS(4) C PIXELS(1) = IX1 PIXELS(2) = IY1 CALL PIXXCV('IRW',0,PIXELS,STAT) IF (STAT.NE.0) GOTO 9200 !slit out of image bounds... PXSTAA(1) = PIXELS(3) PXSTAA(2) = PIXELS(4) C PIXELS(1) = IX4 PIXELS(2) = IY4 CALL PIXXCV('IRW',0,PIXELS,STAT) IF (STAT.NE.0) GOTO 9200 !slit out of image bounds... PXENDA(1) = PIXELS(3) PXENDA(2) = PIXELS(4) C IF (ABS(STEPLN(2)).LE.10.E-10) THEN STEPLN(2) = STEP(2) PXSTEP(2) = 1.0 ELSE PXSTEP(2) = STEPLN(2) / STEP(2) ENDIF IF (PXSTEP(2).LE.0.) GOTO 9300 !invalid stepsize... C IF (ABS(STEPLN(1)).LE.10.E-10) THEN STEPLN(1) = STEP(1) PXSTEP(1) = 1.0 ELSE PXSTEP(1) = STEPLN(1) / STEP(1) ENDIF IF (PXSTEP(1).LE.0.) GOTO 9300 !invalid stepsize... C C jump to common section GOTO 6000 C C *************** C C here we come for cursorless processing C C *************** C 5000 CALL STKRDR('INPUTR',1,1,IAV,ALPHA,UNI,NULO,STAT) !get slit angle ALPHA = ALPHA * FACTO !with base line BETA = ALPHA + (90. * FACTO) C C build up slit in input frame PXSTA(1) = (RFSTA(1) - START(1))/STEP(1) + 1. PXSTA(2) = (RFSTA(2) - START(2))/STEP(2) + 1. PXSTEP(1) = STEPLN(1) / STEP(1) PXSTEP(2) = STEPLN(2) / STEP(2) C C endpoint after slitlength (add 2 more pixels for security...) NN = IPIXL + 1 PXEND(1) = PXSTA(1) + (NN * PXSTEP(1) * COS(ALPHA)) PXEND(2) = PXSTA(2) + (NN * PXSTEP(1) * SIN(ALPHA)) C C endpoint after slitwidth (add 2 more pixels for security...) NN = IPIXW + 1 PXSTAA(1) = PXSTA(1) + (NN * PXSTEP(2) * COS(BETA)) PXSTAA(2) = PXSTA(2) + (NN * PXSTEP(2) * SIN(BETA)) C C *************** C C common section for all options C C *************** C C pull out max. MAXIDX lines from area inside slit 6000 CALL PIXLIN(PXSTA(1),PXSTA(2),PXSTAA(1),PXSTAA(2),PXSTEP(2), + MADRID(PNTRX),MADRID(PNTRY),MAXIDX,NINDX) IF (NINDX.LT.IPIXW) THEN WRITE(LINE,10002) NINDX CALL STTPUT(LINE,STAT) IPIXW = NINDX ENDIF C C pull out max. MAXIDX pixels per line along slit CALL PIXLIN(PXSTA(1),PXSTA(2),PXEND(1),PXEND(2),PXSTEP(1), + MADRID(PNTRX),MADRID(PNTRY),MAXIDX,NINDX) IF (NINDX.LT.IPIXL) THEN WRITE(LINE,10001) NINDX CALL STTPUT(LINE,STAT) IPIXL = NINDX ENDIF C C create output file + get z-values for pixels recorded in XINDX + YINDX NPOLD(1) = NPIX(1) NPOLD(2) = NPIX(2) NPIX(1) = IPIXL NPIX(2) = IPIXW START(1) = START(1) + (PXSTA(1)-1)*STEP(1) START(2) = START(2) + (PXSTA(2)-1)*STEP(2) STEP(1) = STEPLN(1) STEP(2) = STEPLN(2) C C map output frame CALL STIPUT(OUTFRA,D_R4_FORMAT,F_O_MODE,F_IMA_TYPE, + 2,NPIX,START,STEP,IDENT, + CUNIT,PNTRB,IMNOB,STAT) C C compute increments in y (in pixel space) CA = PXSTEP(2) * COS(BETA) SA = PXSTEP(2) * SIN(BETA) C C and pull out complete image DO 8000, N=1,IPIXW CALL ZIMA(MADRID(PNTRA),NPOLD,MADRID(PNTRX),MADRID(PNTRY), + IPIXL,MADRID(PNTRB),CUTS(3),CUTS(4)) C C increment ystep and extract next line PXSTA(1) = PXSTA(1) + CA PXSTA(2) = PXSTA(2) + SA PXEND(1) = PXEND(1) + CA PXEND(2) = PXEND(2) + SA CALL PIXLIN(PXSTA(1),PXSTA(2),PXEND(1),PXEND(2),PXSTEP(1), + MADRID(PNTRX),MADRID(PNTRY),IPIXL,NN) PNTRB = PNTRB + IPIXL !update pointer... 8000 CONTINUE C C complete file is extracted... NN = INDEX(OUTFRA,' ') - 1 IF (NN.LE.0) NN = LEN(OUTFRA) LINE(1:) = 'frame '//OUTFRA(1:NN)//' created' CALL STTPUT(LINE,STAT) CALL DSCUPT(IMNOA,IMNOB,' ',STAT) C C that's it folks... IF (ACTION(1:1).EQ.'C') CALL DTCLOS(QDSPNO) CALL STSEPI C 9100 CALL STETER(3,'invalid slit size given...') 9200 CALL STETER(4,'slit out of image bounds...') 9300 CALL STETER(5,'invalid stepsize...') C 10001 FORMAT(' Warning: slit length only ',I4,' pixels...') 10002 FORMAT(' Warning: slit width only ',I4,' lines...') C END