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
