C===========================================================================
C Copyright (C) 1995-2014 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
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.IDENTIFICATION: INTEAPER.FOR
C.AUTHOR:         Ch. Ounnas                  ESO - Garching
C.LANGUAGE:       F77+ESOext
C.KEYWORDS:       Image display, cursor, flux-magnitude
C.PURPOSE:        read the position of the two cursors on the DeAnza display
C                 and get integrated density of relevant pixels inside an 
C                 aperture
C.ALGORITHM:      Use cursor(s) or table entries to get center pixels
C		  for circular aperture integration
C.INPUT/OUTPUT:   the following keywords are used:
C                 IN_A/C/1/80		input frame (or Cursor)
C                 IN_B/C/1/80		input table (if not cursor input)
C		                        if = '* ', then fixed coord input
C 					           in inputr(11,12)
C                 INPUTC/C/1/80		name of output table
C                 INPUTR/R/1/2		(1) radius of the aperture
C					(2) pixel_type, = 1 (frame pixel)
C							= 0 (world coords)
C					used for radius
C.VERSION:        830610  CO  creation
C 140817	  fixed cursor input for scaled images:  KB
C 
C-------------------------------------------------------------------

      PROGRAM  INTAPR
C
      IMPLICIT     NONE
C
      DOUBLE PRECISION START(3),STEP(3)
C 
      INTEGER      MADRID
      INTEGER      IMF
      INTEGER      ST1,ST2,ISTAT,COORDC,COOFF
      INTEGER      INCURS,IAV,I,KRAY
      INTEGER      TIDI,TIDO,NROW,NCOL,NOP,N1,N2,ND1,ND2,NACOL,NAROW
      INTEGER      XY1(2),XY2(2)
      INTEGER      NAXIS,NPIX(3),ICOL(2),OCOL(7)
      INTEGER      XFIG(2048),YFIG(2048)
      INTEGER      COORD(3),NX,NY,ISCALE
      INTEGER      KUN,KNUL,PIXFLG,TABNUL(2)
      INTEGER      PACCESS, PLMODE
      INTEGER      LTYPE, STYPE, BIN,COLTYP

      INTEGER*8    IP,WPTR
C
      CHARACTER    IDENT*72,CUNIT*64
      CHARACTER    DSCTYP*1,DSCNAM*20
      CHARACTER*80 FRAME,INTAB,OUTAB
      CHARACTER    CERCLE*2
      CHARACTER*16 COLX,COLY
      CHARACTER*16 UNITO(7),LABELO(7)
      CHARACTER*16 TABFOR
      CHARACTER    TEXT*88
C
      REAL         RBUF(6), ARCS(2)
      REAL         PXLS1(6), PXLS2(6)
      REAL         XE,YE,RAYON,BEAM,BGSB,XEYE(2),ACAT(7)
      REAL         XSTA,YSTA,XSTE,YSTE,YOFF
C
      LOGICAL      SELFLG
C
      INCLUDE      'MID_INCLUDE:ST_DEF.INC'
      INCLUDE      'MID_INCLUDE:IDIDEV.INC'
      INCLUDE      'MID_INCLUDE:IDIMEM.INC'
C 
      COMMON       /VMR/MADRID(1)
C
      INCLUDE      'MID_INCLUDE:ST_DAT.INC' 
      DATA         UNITO /'World coord','World coord',' ',' ',
     +                    ' ',' ',' '/
      DATA         LABELO/'X_COORD','Y_COORD','RADIUS ','NPIX ',
     +                    'FLUX ','BGSB ','MAG '/
      DATA         TABFOR/'G13.6'/
      DATA         DSCNAM/'BACKGROUND'/
      DATA         CERCLE/'CI'/
      DATA         FRAME/' '/, INTAB/' '/, OUTAB/' '/
      DATA         KNUL/-1/
      DATA         ARCS/-1.0,-1.0/
C 
      DATA         STYPE/5/
      DATA         BIN/0/
      DATA         YOFF/0.0/
      DATA         PACCESS/1/
      DATA         PLMODE/-1/
C
C
      CALL STSPRO('INTAPR')
C
C get input option + map frame 
      CALL STKRDC('IN_A',1,1,80,IAV,FRAME,KUN,KNUL,ISTAT)
      IF (FRAME(1:1).EQ.'*') THEN           !display/graphics cursor
         IF (FRAME(2:2).EQ.'*') THEN                !use grpahics cursor
            CALL STKRDC('PLCDATA',1,1,60,IACT,TEXT,KUN,KNUL,ISTAT)
            IAV = INDEX(TEXT//' ',' ') - 1
            FRAME = TEXT(1:IAV)
            INCURS = 2                              !use graphics cursor
         ELSE
            CALL CLNFRA(FRAME,FRAME,0)  
            INCURS = 1                              !use display cursor
         ENDIF
      ELSE  
         INCURS = 0                                 !use table
         CALL STKRDC('IN_B',1,1,80,IAV,INTAB,KUN,KNUL,ISTAT)
      ENDIF
C 
      IMF = -1                             !map complete image (as real)
      CALL STIGET(FRAME,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,3,NAXIS,NPIX,
     +            START,STEP,IDENT,CUNIT,IP,IMF,ISTAT)
      XSTA = START(1)
      YSTA = START(2)
      XSTE = STEP(1)
      YSTE = STEP(2)
C 
      CALL PIXXCV('INIT',IMF,RBUF,ISTAT)
      IF (ISTAT .GT. 0) 
     +   CALL STETER(37,
     +   'Problem with setup of : world coord conversion')
C 
C read INPUTC to fill OUTAB if output table
      CALL STKRDC('INPUTC',1,1,80,IAV,OUTAB,KUN,KNUL,ISTAT)
      IF (OUTAB(1:1).NE.'?') THEN                   !new table with 7 columns
         COORDC = 100                               !initial no. of rows
         CALL TBTINI(OUTAB,0,F_O_MODE,7,COORDC,TIDO,ISTAT)
         DO 60, IAV = 1,7
            CALL TBCINI(TIDO,D_R4_FORMAT,1,TABFOR,UNITO(IAV),
     +                  LABELO(IAV),OCOL(IAV),ISTAT)
60       CONTINUE
      END IF
C
C does the descriptor BACKGROUND exist in FRAME ??
      CALL STDFND(IMF,DSCNAM,DSCTYP,ND1,ND2,ISTAT)
      IF (DSCTYP.EQ.' ') THEN
         BGSB   = 0.
      ELSE
         CALL STDRDR(IMF,DSCNAM,1,1,IAV,BGSB,KUN,KNUL,ISTAT)
      END IF
C
C get the radius of the aperture and pixel_spec flag
      CALL STKRDR('INPUTR',1,2,IAV,RBUF,KUN,KNUL,ISTAT) 
      BEAM = RBUF(1)
      IF (RBUF(2) .GT. 0.) THEN
         PIXFLG = 0                 ! use radius in frame pixels
      ELSE
         PIXFLG = 1                 ! use radius in world coord
      ENDIF
C  
      COORDC = 0
      TEXT(1:) = 'Center (w.c.)      Radius (w.c.)  '
      TEXT(35:) = '#Pixels    Flux      Background  Magnitude'
      CALL STTPUT(TEXT,ISTAT)
C 
C -----------------------------
C 
C read cursor positions in display window
C 
C -----------------------------
      IF (INCURS.EQ.1) THEN
         CALL STFXMP(2048,D_R4_FORMAT,WPTR,ISTAT)   !map 2K pixel space
         CALL DTOPEN(1,ISTAT)                       !attach display
         CALL CONCHA(QDSPNO,QOVCH,1,0)
         IF (BEAM.LT.0.) THEN
            CALL STTPUT
     +      ('use cursors to specify size of aperture',ISTAT)
         ELSE
            CALL STTPUT
     +      ('fixed aperture - single cursor to mark center',ISTAT)
            RAYON = BEAM
            CALL SCRPIX(IMF,PIXFLG,BEAM,1,NOP,ISTAT)
            IF (ISTAT.NE.0) THEN
               COORD(3) = 10
               CALL STTPUT
     +       ('Problems with screen pixel radius - set it to 10 pix...',
     +        ISTAT)
            ELSE
               COORD(3) = NOP
            ENDIF
         ENDIF
C      
C image must be loaded with equal scaling factors ...
         IF (SCALX .NE. SCALY) THEN 
            CALL STETER(47,
     +            'scale in X and Y must be the same...')
         ENDIF
C
         COOFF = 0
         FRAME  = ' '
C
10       CALL GETCUR('NNYY ',FRAME,XY1,PXLS1(3),PXLS1(5),RBUF(1),ST1,
     +                            XY2,PXLS2(3),PXLS2(5),RBUF(1),ST2)
         IF ((ST1.EQ.0) .AND. (ST2.EQ.0)) THEN
            GO TO 20
         ELSE
            GO TO 30
         END IF
C
20       IF ((COORDC.EQ.0).AND.(COOFF.EQ.0)) THEN
            CALL STTPUT
     +      ('switch cursor(s) on - next time we exit...',ISTAT)
            FRAME(1:)  = ' '
            COOFF = 1
            GO TO 10
         ELSE
            CALL DTCLOS(QDSPNO)
            CALL REFOVR(ISTAT)
            GO TO 50
         END IF
30       COORDC = COORDC + 1                       !update coordinate counter
C
         XE = PXLS1(5)
         YE = PXLS1(6)
         COORD(1) = XY1(1)
         COORD(2) = XY1(2)
         IF (BEAM.LT.0.0) THEN
            COORD(3) = NINT(PXLS2(3))
            RAYON = PXLS2(3)
C
            IF (SCALX .LT. -1) THEN                !adjust radius of circle
               ISCALE = -SCALX                     !to scaling of image
               KRAY = NINT(RAYON)/ISCALE
               RAYON = FLOAT(KRAY) 
            ELSE IF (SCALX .GT. 1) THEN
               KRAY = NINT(RAYON)*SCALX
               RAYON = FLOAT(KRAY) 
            ENDIF
         ENDIF
C 
C draw the aperture in the overlay channel
         CALL BLDGRA(CERCLE,COORD,ARCS,XFIG,YFIG,2048,NOP)
         CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,255,1,ISTAT)
C
         IF (NAXIS .GT. 1) THEN
            CALL SFLUX2(MADRID(WPTR),MADRID(IP),IMF,NAXIS,NPIX,START,
     +                 STEP,XE,YE,PIXFLG,RAYON,BGSB,ACAT)
         ELSE
            CALL SFLUX1(MADRID(WPTR),MADRID(IP),IMF,NPIX,START,
     +                 STEP,XE,PIXFLG,RAYON,BGSB,ACAT)
         ENDIF
C
         IF (ACAT(7).LE.-1000.) THEN
            ACAT(1) = XE
            ACAT(2) = YE
            ACAT(3) = 0.0
            ACAT(4) = 0.0
            ACAT(5) = 0.0
            ACAT(6) = 0.0
            ACAT(7) = 0.0
         ENDIF
 
         WRITE(TEXT,902) ACAT(1),ACAT(2),ACAT(3),ACAT(4),ACAT(5),
     +                   ACAT(6),ACAT(7)
         CALL STTPUT(TEXT,ISTAT) 
         IF (OUTAB(1:1).NE.'?') THEN
            CALL TBRWRR(TIDO,COORDC,7,OCOL,ACAT,ISTAT)
         ENDIF
         GOTO 10
C -----------------------------
C 
C  here the graphics cursor option
C 
C -----------------------------
      ELSE IF (INCURS.EQ.2) THEN
         CALL STFXMP(2048,D_R4_FORMAT,WPTR,ISTAT)      !map 2K pixel space
         CALL PTOPEN(' ','none',PACCESS,PLMODE)        !restore graphics dw.
         IF (BEAM.GT.0.) THEN
            CALL STTPUT
     +     ('fixed interval - single cursor to mark center',ISTAT)
         ELSE
            CALL STTPUT
     +     ('twice cursor input to mark interval',ISTAT)
         ENDIF
         YE = 0.0
C
130      CALL PTGCUR(PXLS1(1),PXLS1(2),IAV,ISTAT)      !get 1st x-coord. (w.c.)
         IF (ISTAT.EQ.1) THEN
            GOTO 130
         ELSE IF (IAV.EQ.32) THEN
            CALL PTCLOS()
            GOTO 50
         ENDIF
         LTYPE = 0
         BIN   = 0
         CALL PTDATA(STYPE,LTYPE,BIN,PXLS1(1),PXLS1(2),YOFF,1)
C
         IF (BEAM.GT.0.) THEN
            XE = PXLS1(1) 
            RAYON = BEAM
         ELSE                                          !get 2nd x-coord. (w.c.)
140         CALL PTGCUR(PXLS2(1),PXLS2(2),IAV,ISTAT) 
            IF (ISTAT.EQ.1) THEN
               GOTO 140
            ELSE IF (IAV.EQ.32) THEN
               CALL PTCLOS()
               GOTO 50
            ENDIF
            LTYPE = 0
            CALL PTDATA(STYPE,LTYPE,BIN,PXLS2(1),PXLS2(2),YOFF,1)
            XE = (PXLS1(1) + PXLS2(1)) / 2
            RAYON = ABS(PXLS2(1)-PXLS1(1)) / 2 
         ENDIF
C
         COORDC = COORDC + 1
         CALL SFLUX1(MADRID(WPTR),MADRID(IP),IMF,NPIX,START,
     +               STEP,XE,PIXFLG,RAYON,BGSB,ACAT)
C
         IF (ACAT(7).LE.-1000) THEN
            ACAT(1) = XE
            ACAT(2) = YE
            ACAT(3) = 0.0
            ACAT(4) = 0.0
            ACAT(5) = 0.0
            ACAT(6) = 0.0
            ACAT(7) = 0.0
         ENDIF
C
         WRITE(TEXT,902) ACAT(1),ACAT(2),ACAT(3),ACAT(4),ACAT(5),
     +                   ACAT(6),ACAT(7)
         CALL STTPUT(TEXT,ISTAT)
         IF (OUTAB(1:1).NE.'?') 
     +      CALL TBRWRR(TIDO,COORDC,7,OCOL,ACAT,ISTAT)
C -----------------------------
C 
C  here the table input option
C 
C -----------------------------
      ELSE               
         RAYON = ABS(BEAM)
         BEAM = 2 * RAYON                  !we use start + 2*radius as endpoint
         IF (PIXFLG.EQ.0) 
     +      BEAM = BEAM * ABS(STEP(1))            !radius now also in w.c.
C 
C        determine mapping size needed
         IF (STEP(1) .LT. 0.0) THEN
            RBUF(1) = SNGL(START(1)) - BEAM
         ELSE                           !so framepix = 2*(no. pixels) 
            RBUF(1) = SNGL(START(1)) + BEAM 
         ENDIF
         IF (NAXIS .GT. 1) THEN
            IF (STEP(2) .LT. 0.0) THEN
               RBUF(2) = SNGL(START(2)) - BEAM 
            ELSE
               RBUF(2) = SNGL(START(2)) + BEAM 
            ENDIF
         ELSE
            RBUF(2) = START(2)
         ENDIF
         CALL PIXXCV('WR_',IMF,RBUF,ISTAT)         !wc -> fp
         IF (ISTAT .GT. 0) THEN
            CALL STETER(38,
     +      'Problem with conversion: world coord -> frame pixels')
         ENDIF
         NX = RBUF(3) + 2          ! + 2 for security
         IF ((NX.LT.1) .OR. (NX.GT.NPIX(1)))
     +      CALL STETER(77,'bad radius...')  
         NY = 1
         IF (NAXIS .GT. 1) THEN
            NY = RBUF(4) + 2          ! + 2 for security
            IF ((NY.LT.1) .OR. (NY.GT.NPIX(2))) 
     +         CALL STETER(77,'bad radius...')  
         ENDIF
         CALL STFXMP(NX*NY,D_R4_FORMAT,WPTR,ISTAT)
C
C check, if table input, or fixed coords
         IF (INTAB(1:2).EQ.'* ') THEN
            NROW = 1				!ensure we only loop once
            I = 1
            COLTYP = 1				!we expect world coords
            CALL STKRDR('INPUTR',11,2,IAV,XEYE,KUN,KNUL,ISTAT)
            GOTO 44				!skip all table stuff
         ENDIF
C 
         CALL TBTOPN(INTAB,F_I_MODE,TIDI,ISTAT)
C 
C find columns X_COORD, Y_COORD or X_COORDPIX, Y_COORDPIX
         COLX = 'X_COORD'
         COLTYP = 1
         CALL TBLSER(TIDI,COLX,ICOL(1),ISTAT)
         IF (ICOL(1).LE.0) THEN
            COLTYP = 0
            COLX   = 'X_COORDPIX'
            CALL TBLSER(TIDI,COLX,ICOL(1),ISTAT)
            IF (ICOL(1).LE.0) THEN
               CALL STTPUT('The column label for X is not present',
     +                      ISTAT)
               CALL TBTCLO(TIDI,ISTAT)
               GOTO 50
            ENDIF
         ENDIF
         NCOL = 1
         IF (NAXIS .GT. 1) THEN
            IF (COLTYP.EQ.1) THEN
               COLY = 'Y_COORD'
            ELSE
               COLY = 'Y_COORDPIX'
            ENDIF
            CALL TBLSER(TIDI,COLY,ICOL(2),ISTAT)
            IF (ICOL(2).LE.0) THEN
               CALL STTPUT('The column label for Y is not present',
     +                      ISTAT)
               CALL TBTCLO(TIDI,ISTAT)
               GOTO 50
            ENDIF
            NCOL = 2
         ENDIF
C
C find number of rows
         CALL TBIGET(TIDI,N1,NROW,N2,NACOL,NAROW,ISTAT)
         I = 0
C
C ***    Read each row for XE,YE
40       I = I + 1
         IF (I.GT.NROW) THEN
            IF (INTAB(1:2).NE.'* ') CALL TBTCLO(TIDI,ISTAT)
            GOTO 50
         ENDIF
C
         CALL TBSGET(TIDI,I,SELFLG,ISTAT)        !only use selected rows
         IF (.NOT. SELFLG) GOTO 40
         CALL TBRRDR(TIDI,I,NCOL,ICOL,XEYE,TABNUL,ISTAT)
C 
44       XE = XEYE(1)
         IF (NAXIS .GT. 1) THEN
            YE = XEYE(2)
         ELSE
            YE = 0.0
         ENDIF
         IF (COLTYP.EQ.0) THEN                  !center pixels as f.p.
            RBUF(1) = XE
            RBUF(2) = YE
            CALL PIXXCV('_RW',IMF,RBUF,ISTAT)
            IF (ISTAT.NE.0) THEN
               CALL STTPUT('*** INFO: Problems in fp -> wc conversion',
     +                     ISTAT)
               GOTO 40
            ENDIF
            XE = RBUF(5)                        !XE,YE now in w.c.
            YE = RBUF(6)
         ENDIF
         COORDC = COORDC + 1                    !count of selected rows
C
         IF (NAXIS .GT. 1) THEN
            CALL SFLUX2(MADRID(WPTR),MADRID(IP),IMF,NAXIS,NPIX,START,
     +                 STEP,XE,YE,PIXFLG,RAYON,BGSB,ACAT)
         ELSE
            CALL SFLUX1(MADRID(WPTR),MADRID(IP),IMF,NPIX,START,
     +                 STEP,XE,PIXFLG,RAYON,BGSB,ACAT)
         ENDIF
C
         IF (ACAT(7).LE.-1000) THEN
            ACAT(1) = XE
            ACAT(2) = YE
            ACAT(3) = 0.0
            ACAT(4) = 0.0
            ACAT(5) = 0.0
            ACAT(6) = 0.0
            ACAT(7) = 0.0
         ENDIF
C 
         WRITE(TEXT,902) ACAT(1),ACAT(2),ACAT(3),ACAT(4),ACAT(5),
     +                   ACAT(6),ACAT(7)
         CALL STTPUT(TEXT,ISTAT) 
         IF (OUTAB(1:1).NE.'?') THEN
            CALL TBRWRR(TIDO,COORDC,7,OCOL,ACAT,ISTAT)
         ENDIF
         GOTO 40
      END IF
C
C *** That's it folks...
50    CONTINUE
C
C *** put the last entry in the keyword OUTPUTR
      CALL STKWRR('OUTPUTR',ACAT,1,7,KUN,ISTAT)
      IF (OUTAB(1:1).NE.'?') CALL TBTCLO(TIDO,ISTAT)
C
      CALL STSEPI
C
902   FORMAT(G11.5,1X,G11.5,1X,G9.4,1X,G9.4,2X,G10.4,2X,
     +       G11.6,1X,G12.6)
      END

C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.IDENTIFICATION: SFLUX
C.AUTHOR:         Ch. Ounnas                  ESO - Garching
C.LANGUAGE:       F77+ESOext
C.KEYWORDS:       flux-magnitude
C.PURPOSE:        compute flux inside an aperture
C.VERSION:        880919 RHW ESO-FORTRAN Conversion
C ----------------------------------------------------------------------
      SUBROUTINE SFLUX2(WBUF,RDAT,IMP,NAXIS,NPIX,START,STEP,XE,YE,
     +                 PIXFLG,RAYON,BGSB,TAB)
C
      IMPLICIT   NONE
C
      REAL       WBUF(1), RDAT(1)
      INTEGER    IMP,NAXIS,NPIX(2)
      DOUBLE PRECISION START(*),STEP(*)
      REAL       XE,YE
      INTEGER    PIXFLG
      REAL       RAYON,BGSB,TAB(7)
C 
      INTEGER    IMIN,IMAX
      INTEGER    LMIN,LMAX
      INTEGER    IST,LM,IL,IM,NPL
      INTEGER    NXP,NYP
C     
      REAL       DIF
      REAL       DX,DY,ADX
      REAL       PIX,RADIUS
      REAL       PS2,OPS2,POIDS
      REAL       R2,RES,RBUF(6)
      REAL       XP,YP
      REAL       XC,YC
      REAL       XSTA,YSTA
      REAL       XMIN,XMAX
      REAL       YMIN,YMAX
      REAL       VMAG
C 
      CHARACTER  ERSTRG*12,TEXT*60
C
      DX = STEP(1)
      DY = STEP(2)
      XSTA = START(1)
      YSTA = START(2)
C
      IF (PIXFLG.EQ.1) THEN
         RADIUS = RAYON                !radius  in w.c.
      ELSE
         RADIUS = RAYON * ABS(DX)      !radius now in w.c.
      ENDIF
C 
      XMIN   = XE - RADIUS
      XMAX   = XE + RADIUS
      IF (NAXIS .GT. 1) THEN
         YMIN   = YE - RADIUS
         YMAX   = YE + RADIUS
      ELSE
         YMIN   = START(2)
         YMAX   = YMIN
      ENDIF
      TAB(7) = 0.0
C 
      RBUF(1) = XMIN 
      RBUF(2) = YMIN 
      CALL PIXXCV('WR_',IMP,RBUF,IST)    !world coord -> frame pixel
      IF (IST .EQ. 0) THEN
         IMIN = NINT(RBUF(3))
         LMIN = NINT(RBUF(4))
         IF ((IMIN.LT.1) .OR. (IMIN.GT.NPIX(1)) .OR.
     +       (LMIN.LT.1) .OR. (LMIN.GT.NPIX(2))) THEN
            ERSTRG = '(lo x,y) '
            GOTO 40
         ENDIF
      ELSE
         ERSTRG = '(lo x,y) '
         GOTO 40
      ENDIF
C
      RBUF(1) = XMAX 
      RBUF(2) = YMAX 
      CALL PIXXCV('WR_',IMP,RBUF,IST)    ! world coord -> frame pixel
      IF (IST .EQ. 0) THEN
         IMAX = NINT(RBUF(3))
         LMAX = NINT(RBUF(4))
         IF ((IMAX.LT.1) .OR. (IMAX.GT.NPIX(1)) .OR.
     +       (LMAX.LT.1) .OR. (LMAX.GT.NPIX(2))) THEN
            ERSTRG = '(hi x,y) '
            GOTO 40
         ENDIF
      ELSE
         ERSTRG = '(hi x,y) '
         GOTO 40
      ENDIF
C 
      IF (DX.LE.0.) THEN
         IM = IMIN
         IMIN = IMAX
         IMAX = IM
      END IF
C
      IF (DY.LE.0.) THEN
         IM = LMIN
         LMIN = LMAX
         LMAX = IM
      ENDIF
C
C
      IM = IMAX - IMIN + 1
      LM = LMAX - LMIN + 1
      PIX = 0.
      RES = 0.
      ADX = ABS(DX)
      PS2 = ADX/2
      OPS2 = 2./ADX
C 
      DO 20, IL = 1,LM                   !loop over y-lines
         CALL LIRE(IL+LMIN-1,NPIX(1),IMIN,IMAX,1,RDAT,WBUF)
         NYP = LMIN + IL -1          ! YP = YSTA + FLOAT(LMIN+IL-2)*DY
         IF (DY.LT.0.) THEN
            CALL LIRE(LMAX-IL+1,NPIX(1),IMIN,IMAX,1,RDAT,WBUF)
            NYP = 1 + LMAX - IL          ! YP = YSTA + FLOAT(LMAX-IL)*DY
         END IF
C
         DO 10, NPL = 1,IM               !loop over x-pixels
            NXP = IMIN + NPL -1      ! XP = XSTA + FLOAT(IMIN+NPL-2)*DX
            IF (DX.LT.0.) THEN
               NXP = 1 + IMAX - NPL      ! XP = XSTA + FLOAT(IMAX-NPL)*DX
            END IF
C
            RBUF(1) = FLOAT(NXP)
            RBUF(2) = FLOAT(NYP)
            CALL PIXXCV('_RW',IMP,RBUF,IST)    ! frame pix -> world coord
            IF (IST .EQ. 0) THEN
               XP = RBUF(5)
               YP = RBUF(6)
            ELSE
               CALL STTPUT('*** INFO: Problems in fp -> wc conversion',
     +                     IST)
               GO TO 44
            ENDIF
C
            YC = (YE-YP)**2
            XC = (XE-XP)**2
            R2 = SQRT(YC+XC)               !distance to center pixel
            DIF = RADIUS - R2
C
C RADIUS, R2 refer to center of pixels (seen as area):
C DIF >= 0. => pixel center inside circle, but some part of pixel area
C could still be outside ...
C DIF < 0. => pixel center outside circle, but some part of pixel area
C could still be inside ...
C 
            IF (DIF.GE.0.) THEN           !pixel center inside
               IF (DIF.GE.PS2) THEN
                  POIDS = 1.              !completely inside
               ELSE
                  POIDS = 0.5 * (1.+DIF*OPS2)        !take inside portion
               END IF
            ELSE
               DIF = -DIF
               IF (DIF.GT.PS2) THEN
                  POIDS = 0.              !completely outside
               ELSE
                  POIDS = 0.5 * (1.-DIF*OPS2)        !take inside portion
               END IF
            END IF
C
            RES = RES + POIDS*WBUF(NPL)
            PIX = PIX + POIDS
   10    CONTINUE
   20 CONTINUE
C
      VMAG = RES - PIX*BGSB
      IF (VMAG.GT.0) THEN
         VMAG = -2.5*ALOG10(VMAG)
      ELSE
         VMAG = -9999.99
      END IF
C
      TAB(1) = XE
      TAB(2) = YE
      TAB(3) = RADIUS
      TAB(4) = PIX
      TAB(5) = RES
      TAB(6) = BGSB
      TAB(7) = VMAG
      RETURN
C 
40    TEXT = '*** INFO: Aperture area outside frame boundaries '
      CALL STTPUT(TEXT // ERSTRG,IST)
44    TAB(7) = -9999.99
      RETURN
      END

      SUBROUTINE LIRE(NL,NPX,LOWX,HIX,XSCAL,RDAT,WBUF)
C 
C PURPOSE:  Copy image area to work array
C	NL = y-line no.
C	NPX = no. of x-pixel per line
C	LOWX = first x-pixel
C	HIX = last x-pixel
C	XSCAL = x-pixel scaling
C	RDAT = image data array
C	WBUF = work array
C 
      IMPLICIT   NONE
C 
      INTEGER    NL,NPX,LOWX,HIX,XSCAL
      REAL       RDAT(1),WBUF(1)                                                
C 
      INTEGER    NPD, NPF, K, I 
C
C 
      NPD = (NL - 1)*NPX + LOWX                  !start pixel
      NPF = NPD + HIX - LOWX                     !end pixel
      K = 0
C 
      DO 10, I=NPD,NPF,XSCAL
         K = K + 1   
         WBUF(K) = RDAT(I)
10    CONTINUE
C
      RETURN
      END

      SUBROUTINE SFLUX1(WBUF,RDAT,IMP,NPIX,START,STEP,XE,
     +                 PIXFLG,RAYON,BGSB,TAB)
C
      IMPLICIT   NONE
C
      INTEGER    IMP,NPIX(1)
      INTEGER    PIXFLG
      REAL       WBUF(1), RDAT(1)
      REAL       XE
      REAL       RAYON,BGSB,TAB(7)
      DOUBLE PRECISION START(1),STEP(1)
C 
      INTEGER    IMIN,IMAX
      INTEGER    IST,IM,NPL,NXP
C     
      REAL       DIF
      REAL       DX,ADX
      REAL       PIX,RADIUS,YE
      REAL       PS2,OPS2,POIDS
      REAL       R2,RES,RBUF(6)
      REAL       XP,XSTA
      REAL       XMIN,XMAX
      REAL       VMAG
C 
      CHARACTER  ERSTRG*12,TEXT*60
C
      DX = STEP(1)
      XSTA = START(1)
      ADX = ABS(DX)
      PS2 = ADX/2
      OPS2 = 2./ADX
      YE = 0.0
      RBUF(2) = YE 
C
      XMIN   = XE - RAYON
      XMAX   = XE + RAYON
      TAB(7) = 0.0
C
      IF (PIXFLG.EQ.1) THEN
         RADIUS = RAYON                  !radius in w.c.
      ELSE                            !here we work with frame pixels
         RADIUS = RAYON * ADX            !radius now also in w.c.
      ENDIF
C 
      RBUF(1) = XMIN 
      CALL PIXXCV('WR_',IMP,RBUF,IST)    ! world coord -> frame pixel
      ERSTRG = '(lo x) '
      IF (IST .EQ. 0) THEN
         IMIN = NINT(RBUF(3))
         IF ((IMIN.LT.1) .OR. (IMIN.GT.NPIX(1))) GOTO 40
      ELSE
         GOTO 40
      ENDIF
C
      RBUF(1) = XMAX 
      CALL PIXXCV('WR_',IMP,RBUF,IST)    ! world coord -> frame pixel
      ERSTRG = '(hi x) '
      IF (IST .EQ. 0) THEN
         IMAX = NINT(RBUF(3))
         IF ((IMAX.LT.1) .OR. (IMAX.GT.NPIX(1))) GOTO 40
      ELSE
         GOTO 40
      ENDIF
C 
      IF (DX.LE.0.) THEN
         IM = IMIN
         IMIN = IMAX
         IMAX = IM
      ENDIF
C
      IM = IMAX - IMIN + 1
      PIX = 0.
      RES = 0.
C 
      CALL LIRE(1,NPIX(1),IMIN,IMAX,1,RDAT,WBUF)
      DO 10, NPL = 1,IM               !loop over x-pixels
         NXP = IMIN + NPL - 1   
         IF (DX.LT.0.) THEN
            NXP = 1 + IMAX - NPL      !XP = XSTA + FLOAT(IMAX-NPL)*DX
         ENDIF
C
         RBUF(1) = DBLE(NXP)
         CALL PIXXCV('_RW',IMP,RBUF,IST)    !frame pix -> world coord
         IF (IST .EQ. 0) THEN
            XP = RBUF(5)
         ELSE
            CALL STTPUT
     +      ('*** INFO: Problems in fp -> wc conversion',IST)
            GO TO 44
         ENDIF
C
         R2 = ABS(XE-XP)                      !distance to center pixel
         DIF = RADIUS - R2
C
C RADIUS, R2 refer to center of pixels (seen as area):
C DIF >= 0. => pixel center inside interval, but some part of pixel area
C could still be outside ...
C DIF < 0. => pixel center outside interval, but some part of pixel area
C could still be inside ...
C 
         IF (DIF.GE.0.) THEN           !pixel center inside
            IF (DIF.GE.PS2) THEN
               POIDS = 1.              !completely inside
            ELSE
               POIDS = 0.5 * (1.+DIF*OPS2)        !take inside portion
            END IF
         ELSE
            DIF = -DIF
            IF (DIF.GT.PS2) THEN
               POIDS = 0.              !completely outside
            ELSE
               POIDS = 0.5 * (1.-DIF*OPS2)        !take inside portion
            END IF
         END IF
C
         RES = RES + POIDS*WBUF(NPL)
         PIX = PIX + POIDS
10    CONTINUE
C
      VMAG = RES - PIX*BGSB
      IF (VMAG.GT.0) THEN
         VMAG = -2.5*ALOG10(VMAG)
      ELSE
         VMAG = -9999.99
      END IF
C
      TAB(1) = XE
      TAB(2) = YE
      TAB(3) = RADIUS
      TAB(4) = PIX
      TAB(5) = RES
      TAB(6) = BGSB
      TAB(7) = VMAG
      RETURN
C 
40    TEXT = '*** INFO: Aperture area outside frame boundaries '
      CALL STTPUT(TEXT // ERSTRG,IST)
44    TAB(7) = -9999.99
      RETURN
      END
