C===========================================================================
C Copyright (C) 1995-2012 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
C.IDENTIFICATION:
C  program MAGNI			version 1.00	881028
C  K. Banse				ESO - Garching
C
C.KEYWORDS:
C  Gaussian profiles, intensity moments
C
C.PURPOSE:
C  find magnitude of objects
C
C.ALGORITHM:
C  simple integration over center part and subtraction of background
C  it is the JMAG command of IHAP (Author: P. Grosbol)
C
C.INPUT/OUTPUT:
C
C  The following keywords are used:
C  IN_A/C/1/60				input frame
C  P1/C/1/80				input specs,
C					= CURSOR for cursor input
C					= image for image center or
C					= image,xpix,ypix for image pixel or
C					= image,table for table input
C  ACTION/C/1/3				magnitude method,
C					CEN for center method 
C					CIR for method with circular aperture
C					REC for method with rect. aperture
C  P2/C/1/80				out specs (for data storage)
C					= :label for table or table,:label (a)
C					= descr,DESCR for descriptor (b)
C					= + for just display of data
C  P4/C/1/2				(a) identifier flag for table,
C					= I(D), append an identifier, else no.
C  					(b) append flag for descriptor,
C					= A, append data to descriptor
C					= +, start again at position 1 in descr
C  AREA/C/1/80				nopix, (npiy) for magnitude, 
C					nopix for no_mans_land,
C					nopix for sky - as char. string
C  P5/C/1/30				first char: '1' or '0' for center flag
C					then optional ",kappa" (default = 2.0)
C  COPTION/I/1/4			no. of cursors to use,
C                                       draw_flag for circles/rectangles,
C                                       draw_flag for labels (INPUTC(31)='I',
C                                       max. no. of cursor inputs
C	
C  DAZIN/I/1/5				zoom,aux_win_sizes (for cursor only)
C  OUTPUTR/R/1/12			last displayed results
C  OUTPUTI/I/1/1			no. of loops in program
C	
C.VERSIONS
C
C 120207		last modif
C--------------------------------------------------------------------------
C 
      PROGRAM MAGNI
C
      IMPLICIT NONE
C      
      INTEGER      BAKPIX,MAGPIX,MAGPIY,NOMPIX
      INTEGER      COOS(5),CUROPT
      INTEGER      CENTFL,IDFL,INFL,OUTFL,TBMAG
      INTEGER      IDYES,FELEM
      INTEGER      IAV,N,NN,NLIMIT,NMAL
      INTEGER      LLABL,OVCON,COOFF
      INTEGER      NCOOS,NROW
      INTEGER      OUCOLS,CENTY,TBAPP
      INTEGER*8    PNTRA,PNTRC
      INTEGER      STAT1,STAT2,STAT,INPUT(4),NOCURS
      INTEGER      VIMNO1,VIMNO2,IMNO
      INTEGER      NAXIS,NPIX(3),NPIXT(3),XYALP(3)
      INTEGER      ALOW(3),BLOW(3),HIGH(3)
      INTEGER      ICUR1(2),ICUR2(2),INBUF(5)
      INTEGER      BOX(5),SPIX(4)
      INTEGER      INCOLN(13),OUCOLN(13)
      INTEGER      OPTION,LRVALS,NCOU,YESNO,LOOPI,DRAWY
      INTEGER      TIDI,TIDO,TABNUL(13)
      INTEGER      XFIGU(256),YFIGU(256),MAXPNT,NPNTS
      INTEGER      CXSIZE,CYSIZE,KXSIZE,KYSIZE,KXS,KYS
      INTEGER      ZMPIX,ZMPIY,ZNPIX,ZBPIX
      INTEGER      RADIUS(4)
      INTEGER      XINDX,UNI(1),NULO,MADRID(1),EC,EL,ED
C 
      INTEGER      GENNUM
C 
      LOGICAL      SELFLG
C
      CHARACTER    FRAME*60
      CHARACTER    DESCR*15,APPFL*2
      CHARACTER    CUNIT*48,IDENT*72,CBUF*80,ACTION*3
      CHARACTER    IDF*8,OLDIDF*8,LABL*8,INFO*50
      CHARACTER    INTABL*60,OUTABL*60,CURACT*8
      CHARACTER    TUNITW*16,TUNIT*16,LABEL(13)*16
C      
      DOUBLE PRECISION  STEP(3),START(3)
      DOUBLE PRECISION  DIN(4),DOUT(4)                 !MaxDim = 4 in wrldco.c
      DOUBLE PRECISION  DVALS(10)
C 
      REAL         RBUF(17),PCUR1(6),PCUR2(6)
      REAL         RVALS(12),RR(2),R1,R2,R3,R4,FAC
      REAL         AMAG,AMSIG,SKY,SSKY,APIX,XC,YC,XCC,YCC
      REAL         TEMP(2),FLUX,RINF(8),XOFF,YOFF
C
      INCLUDE      'MID_INCLUDE:ST_DEF.INC'
C 
      INCLUDE  'MID_INCLUDE:IDIDEV.INC'
      INCLUDE  'MID_INCLUDE:IDIMEM.INC'
C 
      COMMON  /VMR/  MADRID
      COMMON  /FLAGS/  INFL,OUTFL,OPTION,TBMAG
C      
      DATA      LABEL /'XSTART ','YSTART ','XEND ','YEND ',
     +                 'MAGNITUDE ','MAG_SIGMA ','SKY ','SKY_SIGMA ',
     +                 'IDENT ','XCEN ','YCEN ','MAGPIX ',
     +                 'FLUX '/
      DATA      INCOLN /13*0/,      OUCOLN /13*0/
      DATA      TUNITW /'WORLD COORD '/
      DATA      TUNIT  /' '/
C      
      DATA      IDF    /'ID '/,      OLDIDF /' '/
      DATA      COOS   /5*-1/,       RADIUS /4*0/,    TEMP/-1.0,-1.0/
      DATA      NPIXT  /3*1/,  ALOW /3*1/,   BLOW /3*1/,   HIGH /3*1/
      DATA      DESCR  /' '/
      DATA      IDENT  /' '/,  CUNIT /' '/
      DATA      XYALP  /0,0,0/,   DVALS /10*0.0/
      DATA      INTABL /' '/,  OUTABL /' '/
      DATA      MAXPNT /256/
      DATA      INFO   /'switch cursors on - next time we exit... '/
C
      INCLUDE      'MID_INCLUDE:ST_DAT.INC'
C      
C  set up MIDAS environment + enable automatic error abort
      CALL STSPRO('MAGNI')
      NCOOS = 0               !init no. of coords. read
      IDFL = 0
      IDYES = 0
      CUROPT = 0
      CENTFL = 1              !if = 1, shift window
      CENTY = 1               !if = 1, we have already center vals in in_table
      NCOU = 0                !count used for various purposes
      TIDO = -1               !default to NO output table
      TBAPP = 0               !point to start of table
      TBMAG = 0               !use MAGPIX,MAGPIY...
      OUTFL = 0       
      XCC = -1                !init to invalid value
      YCC = -1
      INFL = -1
C 
C  INFL = 1, cursor input		OUTFL = 0, just display data 
C  INFL = 2, table input		      = 1, results to descriptor
C  INFL = 3, image center 		OUTFL > 1, results to table:
C  INFL = 4, image pixel			2 = same input, output table 
C          					3 = new output table
C  OPTION = 1, MAGNITUDE/CENTER
C  OPTION = 2, MAGNITUDE/RECTANGLE
C  OPTION = 3, MAGNITUDE/CIRCLE
C 
C      
C  get method 
C 
      CALL STKRDC('ACTION',1,1,3,IAV,ACTION,UNI,NULO,STAT)
      CALL UPCAS(ACTION,ACTION)
      IF (ACTION.EQ.'CIR') THEN
         OPTION = 3                                 !MAGNI/CIRCLE
      ELSE IF (ACTION(1:1).EQ.'R') THEN
         OPTION = 2                                 !MAGNI/RECT
      ELSE
         OPTION = 1                                 !MAGNI/CENT
      ENDIF
      LRVALS = 12                                   !for "real" data
      XINDX = LRVALS + 1                            !index for control data
      R1 = -1.111                                   !OUTPUTR(xindx) < 0.0
      CALL STKWRR('OUTPUTR',R1,XINDX,1,UNI,STAT)
C
C  get the input options
C 
      CALL STKRDC('P1',1,1,78,IAV,CBUF,UNI,NULO,STAT)
      NN = INDEX(CBUF,',')
      IF (NN.GT.1) THEN
         FRAME(1:) = CBUF(1:NN-1)//' '
         INTABL(1:) = CBUF(NN+1:)//' '
         IAV = GENNUM(INTABL)                     !check for image,xpix,ypix
         IF ((INTABL(1:1).EQ.'@') .OR. (IAV.EQ.1)) THEN
            INFL = 4
         ELSE
            CALL CLNTAB(INTABL,INTABL,0)
            CALL TBTOPN(INTABL,F_IO_MODE,TIDI,STAT)
            INFL = 2                              !INFL = 2 for table
            CENTY = 0                             !default to No Center columns
C 
            CALL TBLSER(TIDI,LABEL(9),INCOLN(9),STAT)  !look for :IDENT column
            IF (INCOLN(9).NE.-1) IDYES = 1
            CALL TBLSER(TIDI,LABEL(10),INCOLN(10),STAT)   !look for center cols 
            CALL TBLSER(TIDI,LABEL(11),INCOLN(11),STAT)
            IF ( (INCOLN(10).GT.0) .AND. (INCOLN(11).GT.0)) THEN
               CENTY = 1                !indicate that we already have a center
            ENDIF
         ENDIF
      ELSE
         CALL UPCAS(CBUF(1:6),IDENT)
         IF (IDENT(1:6).EQ.'CURSOR') THEN
            CALL STKRDC('IN_A',1,1,60,IAV,FRAME,UNI,NULO,STAT)
            INFL = 1                              !INFL = 1 for cursor
            COOFF = 0
         ELSE
            FRAME(1:) = CBUF(1:60)
            INFL = 3                              !INFL = 3 for image center
            CALL STTPUT
     +      ('We work on crude center of input frame. ',STAT)
         ENDIF
      ENDIF
      IF (INFL.LT.1) CALL STETER(12,'invalid input')
C      
C  get center flag + kappa for kappa-sigma clipping
C 
      CALL STKRDC('P5',1,1,30,IAV,CBUF,UNI,NULO,STAT)
      IF (CBUF(1:1).EQ.'0') THEN
         CENTFL = 0
      ELSE IF (CBUF(1:1).NE.'1') THEN
         IF ((INFL.EQ.4) .OR. (CENTY.EQ.1)) CENTFL = 0      !force to NO
      ENDIF
      NN = INDEX(CBUF,',')
      IF (NN.GT.1) THEN
         CALL GENCNV(CBUF(NN+1:),2,1,N,FAC,STEP,IAV)
         IF (IAV.LE.0) THEN
            CALL STTPUT
     +   ('Wrong syntax for center params, Kappa set to 2.0',STAT)
            FAC = 2.0
         ENDIF
      ELSE
         FAC = 2.0
      ENDIF
C 
C  open input frame 
      CALL CLNFRA(FRAME,FRAME,0)
      CALL STFOPN(FRAME,D_R4_FORMAT,0,F_IMA_TYPE,IMNO,STAT)
      CALL STDRDI(IMNO,'NAXIS',1,1,IAV,NAXIS,UNI,NULO,STAT)
      IF (NAXIS.EQ.1)
     +   CALL STETER(1,'input frame must be at least 2-dim frame...')
      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
C  init frame pixls  <->  world coords conversion
      CALL FPXWCO(0,IMNO,DIN,DOUT,STAT)
      IF (STAT .GT. 0)
     +   CALL STETER(11,'problems with WCS of input frame...')
C      
C  get integration sizes + check them
C 
      CALL STKRDC('AREA',1,1,78,IAV,CBUF,UNI,NULO,STAT)
      CALL PULLOU(CBUF,STEP,2,2,MAGPIX,MAGPIY,NOMPIX,BAKPIX)
      IF ((MAGPIX.LE.0).OR.(NOMPIX.LT.0).OR.(BAKPIX.LT.0))
     +   CALL STETER(2,'invalid pixel string ...')
      IF (MAGPIY.LE.0) MAGPIY = MAGPIX
C 
      NN = 2*(BAKPIX+NOMPIX)
      IF (OPTION.EQ.1) THEN
         MAGPIX = 3                !only take 9 center pixels
         CXSIZE = MAGPIX + NN
         CYSIZE = CXSIZE
      ELSE IF (OPTION.EQ.3) THEN
         NN =  2 * ((MAGPIX/2) + BAKPIX + NOMPIX)
         CXSIZE = 1 + NN        !add center pixel for total no. of x/y-pixel
         CYSIZE = CXSIZE
      ELSE                      !for rectangle xpix, ypix may differ
         CXSIZE = MAGPIX + NN
         CYSIZE = MAGPIY + NN
      ENDIF
C 		get size of subwindow to pull out, at least 100 lines
      IF (CXSIZE .LT. 100) THEN
         KXS = 100
      ELSE
         KXS = CXSIZE
      ENDIF
      IF (CYSIZE .LT. 100) THEN
         KYS = 100
      ELSE
         KYS = CYSIZE
      ENDIF
      KXS = MIN(NPIX(1),KXS)
      KYS = MIN(NPIX(2),KYS)
      KXSIZE = KXS
      KYSIZE = KYS
C      
C  map temporary work frames:
C                           virtual1 = npix(1) * kysize
C                           virtual2 = kxsize * kysize
      N = NPIX(1)*KYSIZE                !full KYSIZE lines
      CALL STFCRE('virtual1',D_R4_FORMAT,F_X_MODE,F_IMA_TYPE,
     +            N,VIMNO1,STAT)
      CALL STFMAP(VIMNO1,F_X_MODE,1,N,IAV,PNTRA,STAT)
      N = KXSIZE * KYSIZE               !KYSIZE lines * KXSIZE pixels
      CALL STFCRE('virtual2',D_R4_FORMAT,F_X_MODE,F_IMA_TYPE,
     +            N,VIMNO2,STAT)
      CALL STFMAP(VIMNO2,F_X_MODE,1,N,IAV,PNTRC,STAT)

C
C  get append_flag + output_specs 
C 
      CALL STKRDC('P4',1,1,2,IAV,CBUF,UNI,NULO,STAT)
      CALL UPCAS(CBUF(1:2),APPFL)
      IF ((APPFL(1:1).EQ.'I').OR.(APPFL(2:2).EQ.'I')) IDFL = 1 
C 
      CALL STKRDC('P2',1,1,80,IAV,CBUF,UNI,NULO,STAT)
      IF (CBUF(1:1).EQ.'+') GOTO 500              !neither table nor descriptor
C      
      NN = INDEX(CBUF,',D')              !test for ,D or ,d
      IF (NN .LE. 0) NN = INDEX(CBUF,',d')    
C      
C  handle descriptor storage
      IF (NN.GT.1) THEN                  !it's a descriptor
         DESCR = CBUF(1:NN-1)
         IF (APPFL(1:1).EQ.'A') THEN     !see, if data is to be appended
            FELEM = -1
         ELSE
            FELEM = 1
         ENDIF
         OUTFL = 1                       !OUTFL = 1 for descriptor
         GOTO 500                        !skip following table stuff
      ENDIF
C      
C +++
C  handle table storage
C +++
C      
      OUCOLS = 13                         !no. of columns in out_table
      CALL CLNTAB(CBUF,OUTABL,0)
C      
C  either same table involved ...
      IF (OUTABL.EQ.INTABL) THEN            !results go to same table
         TIDO = TIDI
         OUTFL = 2                          !OUTFL = 2 for same table
C      
         DO 100,IAV=5,8                     !test, if label(s) already there
            CALL TBLSER(TIDI,LABEL(IAV),OUCOLN(IAV),STAT)
            IF (OUCOLN(IAV).EQ.-1)             !No. We have to define it...
     +         CALL TBCINI(TIDI,D_R4_FORMAT,1,'E12.5',
     +                     TUNIT,LABEL(IAV),OUCOLN(IAV),STAT)
100      CONTINUE
C      
         IF (CENTY.EQ.1) THEN
            OUCOLN(10) = INCOLN(10)
            OUCOLN(11) = INCOLN(11)
         ELSE
            DO 120,IAV=10,11               !create :XCEN,:YCEN as double
               CALL TBCINI(TIDI,D_R8_FORMAT,1,'E24.15',
     +                     TUNITW,LABEL(IAV),OUCOLN(IAV),STAT)
120         CONTINUE
         ENDIF
         IF (IDFL.EQ.1) THEN
            IF (IDYES.EQ.1) THEN
               OUCOLN(9) = INCOLN(9)
            ELSE
               CALL TBCINI
     +           (TIDI,D_C_FORMAT,8,'A8',TUNIT,LABEL(9),OUCOLN(9),STAT)
            ENDIF
         ENDIF
C      
         DO 140,IAV=12,13
            CALL TBLSER(TIDI,LABEL(IAV),OUCOLN(IAV),STAT)
            IF (OUCOLN(IAV).EQ.-1)
     +         CALL TBCINI(TIDI,D_R4_FORMAT,1,'E12.5',
     +                     TUNIT,LABEL(IAV),OUCOLN(IAV),STAT)
140      CONTINUE
C      
C  or just output table ...
C 
      ELSE                       !output to table - valid for any input option
         OUTFL = 3
C 
         IF (APPFL(1:1).EQ.'A') THEN        !append to existing table
            CALL STECNT('GET',EC,EL,ED)
            CALL STECNT('PUT',1,0,0)            !disable errors ...
            CALL TBTOPN(OUTABL,F_IO_MODE,TIDO,STAT)
            CALL STECNT('PUT',EC,EL,ED)
            IF (STAT.NE.0) THEN             !continue only, if TBTOPN o.k.
               APPFL(1:1) = '+'
            ELSE
               CALL TBIGET(TIDO,N,TBAPP,N,N,N,STAT)      !get no. of rows
               DO 260,IAV=1,4
                  CALL TBLSER(TIDO,LABEL(IAV),OUCOLN(IAV),STAT)
                  IF (OUCOLN(IAV).EQ.-1) 
     +               CALL TBCINI(TIDO,D_R8_FORMAT,1,'E24.15',
     +                           TUNITW,LABEL(IAV),OUCOLN(IAV),STAT)
260            CONTINUE
               DO 270,IAV=5,8
                  CALL TBLSER(TIDO,LABEL(IAV),OUCOLN(IAV),STAT)
                  IF (OUCOLN(IAV).EQ.-1) 
     +               CALL TBCINI(TIDO,D_R4_FORMAT,1,'E12.5',
     +                           TUNIT,LABEL(IAV),OUCOLN(IAV),STAT)
270            CONTINUE
C
               IF (IDFL.EQ.1) THEN
                  CALL TBLSER(TIDO,LABEL(9),OUCOLN(9),STAT)
                  IF (OUCOLN(9).EQ.-1)
     +               CALL TBCINI(TIDO,D_C_FORMAT,8,'A8',
     +                           TUNIT,LABEL(9),OUCOLN(9),STAT)
               ENDIF
               DO 280,IAV=10,11
                  CALL TBLSER(TIDO,LABEL(IAV),OUCOLN(IAV),STAT)
                  IF (OUCOLN(IAV).EQ.-1)
     +               CALL TBCINI(TIDO,D_R8_FORMAT,1,'E24.15',
     +                           TUNITW,LABEL(IAV),OUCOLN(IAV),STAT)
280            CONTINUE
C 
               DO 290,IAV=12,13
                  CALL TBLSER(TIDO,LABEL(IAV),OUCOLN(IAV),STAT)
                  IF (OUCOLN(IAV).EQ.-1)
     +               CALL TBCINI(TIDO,D_R4_FORMAT,1,'E12.5',
     +                           TUNIT,LABEL(IAV),OUCOLN(IAV),STAT)
290            CONTINUE
C 
               GOTO 500
            ENDIF
         ENDIF
C 
C  we create a new table (starting with 100 rows)
C 
         CALL TBTINI(OUTABL,0,F_O_MODE,OUCOLS+10,100,TIDO,STAT)
         DO 460,IAV=1,4
            CALL TBCINI(TIDO,D_R8_FORMAT,1,'E24.15',
     +                  TUNITW,LABEL(IAV),OUCOLN(IAV),STAT)
460      CONTINUE
         DO 470,IAV=5,8
            CALL TBCINI(TIDO,D_R4_FORMAT,1,'E12.5',
     +                  TUNIT,LABEL(IAV),OUCOLN(IAV),STAT)
470      CONTINUE
C      
         IF (IDFL.EQ.1) 
     +      CALL TBCINI(TIDO,D_C_FORMAT,8,'A8',
     +                  TUNIT,LABEL(9),OUCOLN(9),STAT)
         DO 480,IAV=10,11
            CALL TBCINI(TIDO,D_R8_FORMAT,1,'E24.15',
     +                  TUNITW,LABEL(IAV),OUCOLN(IAV),STAT)
480         CONTINUE
C      
         DO 490,IAV=12,13
            CALL TBCINI(TIDO,D_R4_FORMAT,1,'E12.5',
     +                  TUNIT,LABEL(IAV),OUCOLN(IAV),STAT)
490      CONTINUE
      ENDIF
C      
C  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C  here all options join:
C  display header line + branch according to input option
C  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C      
500   IF (INFL.NE.2) THEN
         IF (CENTFL.EQ.1) 
     +      CALL STTPUT
     +      ('input windows will be adjusted around the center ',
     +      STAT)
      ELSE
         IF (CENTFL.EQ.0) THEN
            IF (CENTY.EQ.1) THEN
               CBUF(1:) = 'x,ycenter will be taken from input table '
               CALL STTPUT(CBUF,STAT)
            ENDIF
         ELSE
            IF (CENTY.EQ.1) THEN
               CBUF(1:) = 
     +         'x,ycenter of input table will be overwritten '
               CALL STTPUT(CBUF,STAT)
            ENDIF
         ENDIF
      ENDIF
      IF (INFL.NE.1) THEN
         CBUF(1:) =
     +   'xcenter    ycenter    magnitude  mag-sigma  sky '//
     +   '  sky-sigma  magpix   flux '
         CALL STTPUT(CBUF,STAT)
         IF (IDFL.EQ.1) CALL STTPUT(' ident ',STAT)      
      ENDIF
C      
C  branch according to input option
      NMAL = 0                        !init counter
      IF (INFL.EQ.1) THEN
         GOTO 900
      ELSE IF (INFL.EQ.2) THEN
         GOTO 2000
      ENDIF
C      
C  --------------------------------------------------------------------
C      
C  a) input frame is used - use crude center or given x,ypixel
C     INFL = 3 or 4  (no looping)
C      
C  --------------------------------------------------------------------
C      
      IF (INFL.EQ.3) THEN
         COOS(1) = NPIX(1)/2 
         COOS(2) = NPIX(2)/2 
      ELSE
         CALL EXTCO1(IMNO,INTABL,2,N,COOS,STAT)    !get frame pixels
         IF (STAT.NE.0) THEN
            CALL STTPUT('invalid pixel specification,...')
            R1 = -2.22
            GOTO 7000
         ENDIF
      ENDIF
      XCC = COOS(1)
      YCC = COOS(2)
C 
      IF (OPTION.NE.3) THEN
         BOX(1) = COOS(1) - CXSIZE/2
         BOX(2) = COOS(2) - CYSIZE/2
         BOX(3) = BOX(1) + CXSIZE - 1
         BOX(4) = BOX(2) + CYSIZE - 1
         PCUR1(1) = FLOAT(BOX(1))
         PCUR1(2) = FLOAT(BOX(2))
         PCUR2(1) = FLOAT(BOX(3))
         PCUR2(2) = FLOAT(BOX(4))
      ELSE                                       !circle option
         PCUR1(1) = FLOAT(COOS(1))
         PCUR1(2) = FLOAT(COOS(2))
      ENDIF
C 
      NMAL = 1                                   !maybe we write a row to table
      WRITE(IDF(3:),10010) NMAL
      GOTO 3000
C      
C  --------------------------------------------------------------------
C      
C  b) cursor defined subimage(s) - get main control block for ImageDisplay
C     INFL = 1    (loop on cursor input)
C      
C  --------------------------------------------------------------------
C      
900   CALL DTOPEN(1,STAT)
      CALL STKRDI('DAZHOLD',14,1,IAV,OVCON,UNI,NULO,STAT)
      CALL STKRDI('COPTION',1,4,IAV,INPUT,UNI,NULO,STAT)
      IF (OPTION.EQ.1) THEN
         NOCURS = 0                          !for CENTER use 1 cursor
      ELSE IF (OPTION.EQ.2) THEN
         IF (INPUT(1).EQ.1) THEN
            NOCURS = 0
         ELSE
            NOCURS = 2
         ENDIF
      ELSE
         NOCURS = 2                          !for CIRCLE use 2 cursors
         CUROPT = INPUT(1)                   !save 1 or 2 cursor mode
         IF (CUROPT.EQ.1) THEN
            N = 2*MAGPIX + 1
            YESNO = N + 2*NOMPIX
            NLIMIT = YESNO + 2*BAKPIX
            WRITE(CBUF,20004) MAGPIX,NOMPIX,BAKPIX
            CALL STTDIS(CBUF,0,STAT)
            WRITE(CBUF,20009) N,YESNO,NLIMIT
            CALL STTDIS(CBUF,0,STAT)
         ENDIF
      ENDIF
      DRAWY = INPUT(2)
      YESNO = INPUT(3)
      NLIMIT = INPUT(4)
C 
C  adjust cursor shape
      CALL DTGICH(QDSPNO,QIMCH,CBUF,RINF,STAT)
      ZMPIX = MAGPIX
      ZMPIY = MAGPIY
      IAV = ZMPIX/2
      ZNPIX = NOMPIX
      ZBPIX = BAKPIX
      IF ((SCALX.EQ.-1) .OR. (SCALX.EQ.0)) SCALX = 1
      IF ((SCALY.EQ.-1) .OR. (SCALY.EQ.0)) SCALY = 1
      IF (SCALX.NE.SCALY) CALL STETER
     +      (6,'image not loaded with same x-, y-scale...')
      IF (SCALX.LT.-1) THEN
         NN = -SCALX
         ZMPIX = MAGPIX*NN
         ZMPIY = MAGPIY*NN
         IAV = (MAGPIX*NN)/2
         ZNPIX = NOMPIX*NN
         ZBPIX = BAKPIX*NN
      ELSE IF (SCALX.GT.1) THEN
         ZMPIX = MAGPIX/SCALX + 1           !so we have at least 1 pixel
         ZMPIY = MAGPIY/SCALY + 1
         IAV = MAGPIX/(2*SCALX) + 1
         ZNPIX = NOMPIX/SCALX + 1
         ZBPIX = BAKPIX/SCALX + 1
      ENDIF
      COOS(1) = QDSZX/2
      COOS(2) = QDSZY/2
      LOOPI = 2
      IF (OPTION.NE.3) THEN 
         IF (NOCURS.EQ.0) THEN
            NN = 3                          !use rectangle
            LOOPI = 2
         ELSE
            NN = 1                          !use rectangle
            N = ZMPIX + 2*(ZNPIX+ZBPIX)
            COOS(3) = COOS(1) + N - 1
            N = ZMPIY + 2*(ZNPIX+ZBPIX)
            COOS(4) = COOS(2) + N - 1
         ENDIF
      ELSE
         NN = 2                             !use circle
         COOS(3) = IAV
         COOS(4) = COOS(3) + ZNPIX
         COOS(5) = COOS(4) + ZBPIX
         RADIUS(1) = COOS(3)                !save original radius
         RADIUS(2) = COOS(4)
         RADIUS(3) = COOS(5)
      ENDIF
      CALL SETCUR(QDSPNO,NOCURS,NN,LOOPI,COOS,STAT)
C      
      CALL STKRDI('AUX_MODE',9,1,IAV,N,UNI,NULO,STAT)
      IF (N.NE.0) CALL CONCHA(QDSPNO,QOVCH,1,0)      !clear overlay channel
      IF (OVCON.EQ.QIMCH)
     +   CALL DAZZSC(QDSPNO,QOVCH,ZOOMX,SCROLX,SCROLY,STAT)
C 
      FRAME(1:) = ' '
      CALL STKRDI('DAZIN',1,1,IAV,INBUF,UNI,NULO,STAT)
      CURACT = 'NNYY?C0 '              !set up for Cursor with ENTER button
      IF (INBUF(1).GT.0) THEN          !we use the zoom window...
         IF (NOCURS.EQ.0) THEN
            CURACT(5:7) = 'ZC0'        !prepare zoom_window stuff for GETCUR
         ELSE
            IF (OPTION.EQ.3) THEN      !we want circles in zoom window
               CURACT(5:7) = 'ZC7'
            ELSE
               CURACT(5:7) = 'ZC2'
            ENDIF
         ENDIF
         INBUF(1) = (QDSZX * 3) / 4    !use 3/4 of main display size
         INBUF(2) = (QDSZY * 3) / 4
         INBUF(3) = 0                  !start at lower left of display
         INBUF(4) = 0
         CALL STKWRI('DAZIN',INBUF,2,4,UNI,STAT)
         N = 0
         CALL AUXHLP(-10)              !initialize display_it for parallel view
         CALL SETCUR(QDSPNO,N,3,2,COOS,STAT)          !use cross
C
C  if `novice', display initial help, show current zoomfactor
         CALL STKRDI('ERROR',2,1,IAV,N,UNI,NULO,STAT)
         IF (N.EQ.1) CALL AUXHLP(0)         !for novice users display help
      ENDIF
C 
      CALL PIXXCV('INIT',IMNO,RBUF,NN)
      GOTO 1000
C
990   WRITE(CBUF,30000) MAGPIX,BAKPIX
      CALL STTDIS(CBUF,99,STAT)
C 
C  get cursor positions 
1000  IF (NMAL.GE.NLIMIT) GOTO 9000
C      
      CALL GETCUR(CURACT,FRAME,
     +            ICUR1,PCUR1(1),RVALS(1),FLUX,STAT1,
     +            ICUR2,PCUR2(1),RVALS(3),FLUX,STAT2)
C
C  check cursor status for EXIT condition
      IF ((STAT1.EQ.0).AND.(STAT2.EQ.0)) THEN
         IF ((NMAL.EQ.0) .AND. (COOFF.EQ.0)) THEN
            CALL STTPUT(INFO,STAT)
            COOFF = 1
            FRAME(1:) = ' '
            GOTO 1000
         ELSE
            GOTO 9000
         ENDIF
      ELSE IF (NMAL.EQ.0) THEN
         CBUF(1:) =
     +   'xcenter        ycenter      magnitude    mag-sigma'
         CALL STTPUT(CBUF,STAT)
         CBUF(1:) =
     +   '        sky         sky-sigma       magpix        flux '
         CALL STTPUT(CBUF,STAT)
         IF (IDFL.EQ.1) CALL STTPUT(' ident ',STAT)
      ENDIF
C
C  show graph used for magnitude determination
C 
      IF (OPTION.EQ.3) THEN                       !MAGNI/CIRCLE
         BOX(1) = ICUR1(1)
         BOX(2) = ICUR1(2)
         INBUF(1) = PCUR2(1)
         INBUF(2) = PCUR2(2)
         INBUF(3) = RVALS(3)
C 
C  check radii if in 1 cursor option for circle
         IF (CUROPT.EQ.1) THEN
            IF ((RADIUS(1).NE.INBUF(1)) .OR.
     +          (RADIUS(2).NE.INBUF(2)) .OR.
     +          (RADIUS(3).NE.INBUF(3))) THEN
               IF (RADIUS(4).GT.2) GOTO 1200
C              
               RADIUS(4) = RADIUS(4) + 1
               CALL STTDIS
     +         ('The radii of the circles should not be modified!',
     +          0,STAT)
               CALL STTDIS
     +         ('Original size of circles will be used anyway!',
     +          0,STAT)
               IF (SCALX.NE.SCALY) GOTO 1500    !skip the radius update part
C
1200           INBUF(1) = RADIUS(1)             !draw original radii again
               INBUF(2) = RADIUS(2)
               INBUF(3) = RADIUS(3)
            ENDIF
C 
C  update radii only in 2 cursor option for circle
         ELSE
            IF (SCALX.GT.1) THEN
               INBUF(1) = INBUF(1)*SCALX
               INBUF(2) = INBUF(2)*SCALX
               INBUF(3) = INBUF(3)*SCALX
            ELSE IF (SCALX.LT.-1) THEN
               NN = -SCALX
               INBUF(1) = INBUF(1)/NN
               INBUF(2) = INBUF(2)/NN
               INBUF(3) = INBUF(3)/NN
            ENDIF
            NOMPIX = INBUF(2) - INBUF(1)
            BAKPIX = INBUF(3) - INBUF(1) - NOMPIX
            CXSIZE = 1 + 2*INBUF(3)            !in frame pixels
            INBUF(1) = PCUR2(1)                !reset for following drawing
            INBUF(2) = PCUR2(2)
            INBUF(3) = RVALS(3)
         ENDIF
C
         IF (DRAWY.EQ.1) THEN
            BOX(3) = INBUF(1)
            CALL BLDGRA('CIR',BOX,TEMP,XFIGU,YFIGU,MAXPNT,NPNTS)
            CALL IIGPLY(QDSPNO,QOVCH,XFIGU,YFIGU,NPNTS,255,1,STAT)
            BOX(3) = INBUF(2)
            CALL BLDGRA('CIR',BOX,TEMP,XFIGU,YFIGU,MAXPNT,NPNTS)
            CALL IIGPLY(QDSPNO,QOVCH,XFIGU,YFIGU,NPNTS,255,1,STAT)
            BOX(3) = INBUF(3)
            CALL BLDGRA('CIR',BOX,TEMP,XFIGU,YFIGU,MAXPNT,NPNTS)
         ENDIF
         XCC = PCUR1(1)                        !xc,yc in frame pixels
         YCC = PCUR1(2)
C 
      ELSE                                         !MAGNI/RECT + MAGNI/CENT
         IF (NOCURS.EQ.2) THEN                     !with two cursors
            IF ( (ICUR1(1).EQ.ICUR2(1)) .OR.
     +           (ICUR1(2).EQ.ICUR2(2)) ) GOTO 990
            CXSIZE = ICUR2(1) - ICUR1(1) + 1
            CYSIZE = ICUR2(2) - ICUR1(2) + 1
            ZMPIX = CXSIZE - 2*(ZNPIX+ZBPIX)
            ZMPIY = CYSIZE - 2*(ZNPIX+ZBPIX)
            IF ((ZMPIX.LT.1) .OR. (ZMPIY.LT.1)) GOTO 990
C 
            IF (OPTION.EQ.2) THEN                 !only for RECT we modify
               IF (SCALX.GT.1) THEN
                  MAGPIX = ZMPIX*SCALX
                  CXSIZE = CXSIZE*SCALX
               ELSE IF (SCALX.LT.-1) THEN
                  NN = -SCALX
                  MAGPIX = ZMPIX/NN
                  CXSIZE = CXSIZE/NN
               ELSE
                  MAGPIX = ZMPIX
               ENDIF
               IF (SCALY.GT.1) THEN
                  MAGPIY = ZMPIY*SCALY
                  CYSIZE = CYSIZE*SCALY
               ELSE IF (SCALY.LT.-1) THEN
                  NN = -SCALY
                  MAGPIY = ZMPIY/NN
                  CYSIZE = CYSIZE/NN
               ELSE
                  MAGPIY = ZMPIY
               ENDIF
            ENDIF
C 
            SPIX(1) = (ICUR1(1)+ICUR2(1))/2            !xcenter
            SPIX(2) = (ICUR1(2)+ICUR2(2))/2            !ycenter
            XCC = (PCUR1(1)+PCUR2(1))/2                !xc,yc in frame pixels
            YCC = (PCUR1(2)+PCUR2(2))/2
C 
         ELSE                                      !single cursor
            SPIX(1) = ICUR1(1)                         !xcenter
            SPIX(2) = ICUR1(2)                         !ycenter
            XCC = PCUR1(1)                             !xc,yc in frame pixels
            YCC = PCUR1(2)
            PCUR1(1) = XCC - CXSIZE/2
            PCUR1(2) = YCC - CYSIZE/2
            PCUR2(1) = PCUR1(1) + CXSIZE - 1
            PCUR2(2) = PCUR1(2) + CYSIZE - 1
         ENDIF
C 
         BOX(1) = SPIX(1) - ZMPIX/2
         BOX(2) = SPIX(2) - ZMPIY/2
         BOX(3) = SPIX(1) + ZMPIX/2 - 1
         BOX(4) = SPIX(2) + ZMPIY/2 - 1
         IF (DRAWY.EQ.0) THEN
            BOX(1) = BOX(1) - ZNPIX - ZBPIX
            BOX(2) = BOX(2) - ZNPIX - ZBPIX
            BOX(3) = BOX(3) + ZNPIX + ZBPIX
            BOX(4) = BOX(4) + ZNPIX + ZBPIX
         ELSE
            CALL BLDGRA('REC',BOX,TEMP,XFIGU,YFIGU,MAXPNT,NPNTS)
            CALL IIGPLY(QDSPNO,QOVCH,XFIGU,YFIGU,NPNTS,255,1,STAT)
            BOX(1) = BOX(1) - ZNPIX
            BOX(2) = BOX(2) - ZNPIX
            BOX(3) = BOX(3) + ZNPIX 
            BOX(4) = BOX(4) + ZNPIX 
            CALL BLDGRA('REC',BOX,TEMP,XFIGU,YFIGU,MAXPNT,NPNTS)
            CALL IIGPLY(QDSPNO,QOVCH,XFIGU,YFIGU,NPNTS,255,1,STAT)
            BOX(1) = BOX(1) - ZBPIX
            BOX(2) = BOX(2) - ZBPIX
            BOX(3) = BOX(3) + ZBPIX
            BOX(4) = BOX(4) + ZBPIX
            CALL BLDGRA('REC',BOX,TEMP,XFIGU,YFIGU,MAXPNT,NPNTS)
         ENDIF
      ENDIF
      IF (DRAWY.EQ.1)
     +   CALL IIGPLY(QDSPNO,QOVCH,XFIGU,YFIGU,NPNTS,255,1,STAT)
C 
1500  NMAL = NMAL + 1
      IF (IDFL.EQ.1) THEN
         CALL STTDIS('enter identifier: ',1,STAT)
         READ(*,10003) IDF 
         IF (IDF.EQ.' ') IDF = OLDIDF
         OLDIDF = IDF                            !save last identifier
      ELSE
         WRITE(IDF(3:),10010) NMAL
      ENDIF
C 
      KXSIZE = CXSIZE
      KYSIZE = CYSIZE
      GOTO 3000
C      
C  --------------------------------------------------------------------
C      
C  c) table defined subimage(s)
C     INFL = 2    (loop through table rows)
C      
C  --------------------------------------------------------------------
C      
2000  CALL TBIGET(TIDI,N,NROW,N,N,N,STAT)        !get total no. of rows
C      
2300  DO 2350,IAV=1,4                            !search for columns
         CALL TBLSER(TIDI,LABEL(IAV),INCOLN(IAV),STAT)
         IF (INCOLN(IAV).LE.0) THEN
            CBUF(1:) = 'column labelled '//LABEL(IAV)//
     +                 ' is missing in input table... '
            CALL STETER(4,CBUF)
         ENDIF
2350  CONTINUE
C      
C  here we loop
2800  NMAL = NMAL + 1
      IF (NMAL.GT.NROW) THEN                  !test for end of table
         WRITE(CBUF,10001) 'no. of table entries processed = ',NCOU
         CALL STTPUT(CBUF,STAT)
         IF (OUTFL.NE.2) CALL TBTCLO(TIDI,STAT)
         GOTO 9000
      ENDIF
C      
C  get next row of values
C 
      CALL TBSGET(TIDI,NMAL,SELFLG,STAT)
      IF (.NOT.SELFLG) GOTO 2800
C 
      IF (IDYES.EQ.1) THEN
         CALL TBRRDC(TIDI,NMAL,1,INCOLN(9),IDF,TABNUL,STAT)
      ELSE
         WRITE(IDF(3:),10010) NMAL
      ENDIF
C 
      CALL TBRRDD(TIDI,NMAL,4,INCOLN,DVALS,TABNUL,STAT)

      DIN(1) = DVALS(1)                   !convert from wco's to fp's
      DIN(2) = DVALS(2)
      CALL FPXWCO(-1,IMNO,DIN,DOUT,STAT)
      IF (STAT.NE.0) THEN
         WRITE(CBUF,10077) NMAL
         CALL STTPUT(CBUF,STAT)
         GOTO 2800
      ENDIF
C 
      PCUR1(1) = REAL(DOUT(1))
      PCUR1(2) = REAL(DOUT(2))
      DIN(1) = DVALS(3)
      DIN(2) = DVALS(4)
      CALL FPXWCO(-1,IMNO,DIN,DOUT,STAT)
      IF (STAT.NE.0) THEN
         WRITE(CBUF,10077) NMAL
         CALL STTPUT(CBUF,STAT)
         GOTO 2800
      ENDIF
      PCUR1(3) = REAL(DOUT(1))
      PCUR1(4) = REAL(DOUT(2))
CC       write(*,50000) pcur1(1),pcur1(2),pcur1(3),pcur1(4)
CC 50000 format('pcur1(1,2,3,4) = ',4f12.2)
C 
      IF (TBMAG.NE.0) THEN                     !that implies OPTION = 2 (RECT)
         CXSIZE = PCUR1(3) - PCUR1(1) + 1      !get size of pixel interval
         CYSIZE = PCUR1(4) - PCUR1(2) + 1
         NN = 2*(BAKPIX+NOMPIX)
         IF (TBMAG.EQ.1) THEN                  !pix_intv + BAKPIX + NOMPIX
            MAGPIX = CXSIZE
            MAGPIY = CYSIZE
            CXSIZE = CXSIZE + NN
            CYSIZE = CYSIZE + NN
         ELSE                                  !pix_intv - BAKPIX - NOMPIX
            MAGPIX = CXSIZE - NN
            MAGPIY = CYSIZE - NN
         ENDIF
         KXSIZE = CXSIZE
         KYSIZE = CYSIZE
      ENDIF
C 
      IF (CENTY.EQ.1) THEN
         CALL TBRRDD(TIDI,NMAL,2,INCOLN(10),DVALS(5),TABNUL,STAT)
         DIN(1) = DVALS(5)
         DIN(2) = DVALS(6)
         CALL FPXWCO(-1,IMNO,DIN,DOUT,STAT)
         IF (STAT.NE.0) THEN
            WRITE(CBUF,10077) NMAL
            CALL STTPUT(CBUF,STAT)
            GOTO 2800
         ENDIF
         XCC = REAL(DOUT(1))
         YCC = REAL(DOUT(2))
      ENDIF
C 
C  if center_flag = 0 .and. centy = 1, use `final' sized rectangle already
      IF ((CENTY.EQ.1) .AND. (CENTFL.EQ.0)) THEN         !use center from table
         IF (OPTION.EQ.3) THEN  
            PCUR1(1) = XCC 
            PCUR1(2) = YCC                      !use given areas, not the
            KXSIZE = CXSIZE                     !size of the mapped window
            KYSIZE = KXSIZE
         ELSE
            PCUR1(1) = XCC - CXSIZE/2 
            PCUR1(2) = YCC - CYSIZE/2
            PCUR2(1) = PCUR1(1)+ CXSIZE - 1
            PCUR2(2) = PCUR1(2)+ CYSIZE - 1
         ENDIF
      ELSE
         IF (OPTION.EQ.3) THEN  
            PCUR1(1) = (PCUR1(1)+PCUR1(3))/2             !get center
            PCUR1(2) = (PCUR1(2)+PCUR1(4))/2
            PCUR1(3) = PCUR1(3)-PCUR1(1)                 !get diameter
            PCUR1(4) = PCUR1(4)-PCUR1(2)
            KXSIZE = NINT((PCUR1(3)+PCUR1(4)))/2         !from mean radius
            KXSIZE = 2*KXSIZE + 1
            KYSIZE = KXSIZE
         ELSE
            DIN(1) = DVALS(3)
            DIN(2) = DVALS(4)
            CALL FPXWCO(-1,IMNO,DIN,DOUT,STAT)
            IF (STAT.NE.0) THEN
               WRITE(CBUF,10077) NMAL
               CALL STTPUT(CBUF,STAT)
               GOTO 2800
            ENDIF
            PCUR2(1) = REAL(DOUT(1))
            PCUR2(2) = REAL(DOUT(2))
         ENDIF
      ENDIF
CC       write(*,50000) pcur1(1),pcur1(2),pcur1(3),pcur1(4)
      NCOU = NCOU + 1
C 
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C      
C  common section for option a) and b) and c)
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C      
C  pull out subwindow of frame 
C 
3000  LOOPI = 0
      STAT1 = 0
      IF (OPTION.EQ.3) THEN               !circle
         NN = KXSIZE/2
         SPIX(1) = NINT(PCUR1(1)) - NN            !xstart in frame pixels
         SPIX(2) = NINT(PCUR1(2)) - NN            !ystart
         SPIX(3) = SPIX(1) + KXSIZE - 1           !xend
         SPIX(4) = SPIX(2) + KXSIZE - 1           !yend
      ELSE                                !rectangle
         SPIX(1) = NINT(PCUR1(1))                 !xstart in frame pixels
         SPIX(2) = NINT(PCUR1(2))                 !ystart
         SPIX(3) = NINT(PCUR2(1))                 !xend
         SPIX(4) = NINT(PCUR2(2))                 !yend
      ENDIF
      IAV = 0
C 
C  check for out-of-bounds
3030  N = 0
      IF (SPIX(1).LT.1) THEN
         WRITE(CBUF,10020) 'start x'
         CALL STTDIS(CBUF,0,STAT)
         NN = 1 - SPIX(1)
         SPIX(1) = 1
         SPIX(3) = MIN(SPIX(3)+NN,NPIX(1))
         N = 99
      ENDIF
      IF (SPIX(3).GT.NPIX(1)) THEN
         WRITE(CBUF,10020) 'end x'
         CALL STTDIS(CBUF,0,STAT)
         NN = SPIX(3) - NPIX(1)
         SPIX(3) = NPIX(1)
         SPIX(1) = MAX(SPIX(1)-NN,1)
         N = 99
      ENDIF
      IF (SPIX(2).LT.1) THEN
         WRITE(CBUF,10020) 'start y'
         CALL STTDIS(CBUF,0,STAT)
         NN = 1 - SPIX(2)
         SPIX(2) = 1
         SPIX(4) = MIN(SPIX(4)+NN,NPIX(2))
         N = 99
      ENDIF
      IF (SPIX(4).GT.NPIX(2)) THEN
         WRITE(CBUF,10020) 'end y'
         CALL STTDIS(CBUF,0,STAT)
         NN = SPIX(4) - NPIX(2)
         SPIX(4) = NPIX(2)
         SPIX(2) = MAX(SPIX(2)-NN,1)
         N = 99
      ENDIF
      XFIGU(1) = SPIX(3) - SPIX(1)
      YFIGU(1) = SPIX(4) - SPIX(2)
C 
C  check for changes
      IF (N.NE.0) THEN
         IF (IAV.NE.0) THEN
            CBUF(1:) = 
     +      'we should not come here - contact the ESO Midas team...'
            CALL STETER(47,CBUF)
         ENDIF
         CXSIZE = XFIGU(1) + 1
         CYSIZE = YFIGU(1) + 1
         KXS = CXSIZE
         KYS = CYSIZE
         KXSIZE = KXS
         KYSIZE = KYS
         IAV = 111
         GOTO 3030                       !check once more - should be o.k., now
      ENDIF
C 
      DIN(1) = SPIX(1)
      DIN(2) = SPIX(2)
      CALL FPXWCO(1,IMNO,DIN,DOUT,STAT)          !move from fp's to wco's
      IF (STAT.NE.0) THEN
         WRITE(CBUF,10070) DIN(1),DIN(2)
         CALL STETER(13,CBUF)
      ENDIF
C 
      DVALS(1) = DOUT(1)
      DVALS(2) = DOUT(2)
      DIN(1) = SPIX(3)
      DIN(2) = SPIX(4)
      CALL FPXWCO(1,IMNO,DIN,DOUT,STAT)
      IF (STAT.NE.0) THEN
         WRITE(CBUF,10070) DIN(1),DIN(2)
         CALL STETER(13,CBUF)
      ENDIF
C 
      DVALS(3) = DOUT(1)
      DVALS(4) = DOUT(2)
      DO 3100,IAV=1,4
         RVALS(IAV) = REAL(DVALS(IAV))
3100  CONTINUE
C 
3130  XOFF = SPIX(1) - 1.                       !offset from pixel 1 on
      YOFF = SPIX(2) - 1.
      INBUF(1) = NPIX(1)
      INBUF(2) = SPIX(4) - SPIX(2) + 1          !ysize
      KYSIZE = INBUF(2) 
C 
C check, if we have to augment working subimages
      IF (KYSIZE.GT.KYS) THEN
         CALL STFCLO(VIMNO1,STAT)
         CALL STFCLO(VIMNO2,STAT)
         N = NPIX(1)*KYSIZE             !full KYSIZE lines
         CALL STFCRE('virtual1',D_R4_FORMAT,F_X_MODE,F_IMA_TYPE,
     +               N,VIMNO1,STAT)
         CALL STFMAP(VIMNO1,F_X_MODE,1,N,IAV,PNTRA,STAT)
         N = KXSIZE * KYSIZE            !KYSIZE lines * KXSIZE pixels
         CALL STFCRE('virtual2',D_R4_FORMAT,F_X_MODE,F_IMA_TYPE,
     +               N,VIMNO2,STAT)
         CALL STFMAP(VIMNO2,F_X_MODE,1,N,IAV,PNTRC,STAT)
C 
         WRITE(CBUF,10071) KXSIZE,KYSIZE,KXS,KYS
         CALL STTPUT(CBUF,STAT)
         KXS = KXSIZE
         KYS = KYSIZE
      ENDIF
      INBUF(3) = 1
C 
C  get a y-stripe from disk + copy subwindow out
C 
      N = INBUF(1) * INBUF(2)               !size of y-dim stripe in frame
      NN = ((SPIX(2)-1)*NPIX(1)) + 1        !1. pixel in there
      CALL STFGET(IMNO,NN,N,IAV,MADRID(PNTRA),STAT)
C 
      NPIXT(1) = SPIX(3) - SPIX(1) + 1      !xsize, ysize to copy
      NPIXT(2) = INBUF(2)
      ALOW(1) = SPIX(1)                     !first x,y pixel in source
      ALOW(2) = 1                           !and destination frame
      HIGH(1) = SPIX(3)
      HIGH(2) = INBUF(2)
      CALL COPWND(MADRID(PNTRA),INBUF(1),MADRID(PNTRC),NPIXT,
     +            ALOW,BLOW,HIGH)
C 
C  get center points - but only once and if CENTFL = 1
C 
      IF (LOOPI.EQ.0) THEN
         IF ((CENTY.EQ.0).OR.(CENTFL.EQ.1)) THEN   
C 
C  use STACEN to get center
            INPUT(1) = 1                         !xstart
            INPUT(2) = NPIXT(1)                  !xend 
            INPUT(3) = 1                         !ystart
            INPUT(4) = NPIXT(2)                  !yend 
            NN = INPUT(4) - INPUT(3) + INPUT(2) - INPUT(1)
            IF (NN.GT.300)                       !marginal points = NN*2 < 600 !
     +         CALL STETER
     +         (7,'window too large for centering algorithm')
C      
            CALL STACEN(MADRID(PNTRC),NPIXT(1),NPIXT(2),'M',INPUT,XC,YC,
     +                  R1,R2,R3,R4,AMAG,STAT1)  !get x,y-center in subframe
            IF (STAT1.NE.0)
     +         CALL STTPUT('Cent. algorithm: center not in array...',
     +                     STAT)
            XCC = XC + XOFF                      !center in full frame
            YCC = YC + YOFF
         ELSE
            XC = XCC - XOFF                      !relate center to subwindow
            YC = YCC - YOFF
         ENDIF
C 
         DIN(1) = XCC
         DIN(2) = YCC
         CALL FPXWCO(1,IMNO,DIN,DVALS(5),STAT)        !move from fp's to wco's
         RR(1) = REAL(DVALS(5))
         RR(2) = REAL(DVALS(6))
C      
C  check, if we use recentered window or CSIZE .NE. KSIZE
C 
         IF ((CENTFL.EQ.1) .OR. 
     +       (KXSIZE.NE.CXSIZE) .OR. (KYSIZE.NE.CYSIZE)) THEN
            NN = CXSIZE / 2
            N = NINT(XCC) - NN          !relate to complete frame
            IAV = N - SPIX(1)                     !difference to old start
            XC = XC - IAV                         !update xcent accordingly
            SPIX(1) = N
            NN = CYSIZE / 2
            N = NINT(YCC) - NN
            IAV = N - SPIX(2)                     !difference to old start
            YC = YC - IAV                         !update ycent accordingly
            SPIX(2) = N
            SPIX(3) = SPIX(1) + CXSIZE - 1 
            SPIX(4) = SPIX(2) + CYSIZE - 1
            LOOPI = 1                             !avoid passing here again...
            GOTO 3130                   !go + extract new subframe
         ENDIF
      ENDIF
C      
C  actual magnitude algorithm
C      
      CALL JMAGN(OPTION,MADRID(PNTRC),NPIXT(1),NPIXT(2),NOMPIX,
     +           BAKPIX,FAC,XC,YC,AMAG,AMSIG,SKY,SSKY,APIX,FLUX,STAT)
C 
      R1 = 1.11
      IF (STAT1.EQ.0) THEN
         IF (STAT.LT.0) THEN
            IF (STAT.EQ.-2)
     +         CALL STTPUT('Mag. algorithm: center not in array...',
     +                     STAT)
            IF (STAT.EQ.-3)
     +         CALL STTPUT('Mag. algorithm: area too small...',STAT)
            AMAG = 0.
            AMSIG = 0.
            SKY = 0.
            SSKY = 0.
            FLUX = 0.
            R1 = -1.11
         ELSE IF (STAT.EQ.1) THEN
            CALL STTPUT(
     +           'Mag. algorithm: (Warning) source not in center ...',
     +           STAT)
         ELSE IF (STAT.EQ.2) THEN
            AMAG = 0.
            AMSIG = 0.
            FLUX = 0.
            CALL STTPUT
     +  ('Mag. algorithm: (Warning) flux not above sky background ...',
     +           STAT)
            R1 = -1.11
         ENDIF
      ENDIF
C      
      NCOOS = NCOOS + 1                  !increment coord. counter
      IF ((INFL.EQ.1).AND.(YESNO.EQ.1)) THEN     !for cursor input draw numbers
         IF (IDFL.EQ.1) THEN
            LABL = IDF
            NN = 1
            LLABL = INDEX(LABL,' ') - 1
         ELSE
            WRITE(LABL(5:),10011) NCOOS
            NN = 5
            DO 3900,N=5,7
               IF (LABL(N:N).EQ.' ') NN = N + 1
3900        CONTINUE
            LLABL = 9 - NN
         ENDIF
         IF (OPTION.NE.3) THEN                !place string right of center
            XYALP(1) = (BOX(1)+BOX(3))/2 + 5
            XYALP(2) = (BOX(2)+BOX(4))/2 + 2
         ELSE
            XYALP(1) = BOX(1) + 5
            XYALP(2) = BOX(2) + 2
         ENDIF
         CALL IIGTXT(QDSPNO,QOVCH,LABL(NN:),XYALP(1),XYALP(2),
     +               0,0,255,0,STAT)
      ENDIF
C
C  prepare results (but check for infinity, nan ... first)
      WRITE(CBUF,70001) AMAG
      CALL BADVAL(CBUF,N)
      IF (N.NE.1) THEN
         R1 = -1.11                          !magnitude algorithm failed!
      ENDIF
C 
      RVALS(5) = RR(1)
      RVALS(6) = RR(2)
      RVALS(7) = AMAG
      RVALS(8) = AMSIG
      RVALS(9) = SKY
      RVALS(10) = SSKY
      RVALS(11) = APIX
      RVALS(12) = FLUX
C      
      WRITE(CBUF,20005) (RVALS(N),N=5,8)
      CALL STTPUT(CBUF,STAT)
      WRITE(CBUF,20006) (RVALS(N),N=9,12)
      CALL STTPUT(CBUF,STAT)
      IF (IDFL.EQ.1) CALL STTPUT(IDF,STAT)
C
C  fill descriptor, table or nothing
      IF (OUTFL.EQ.1) THEN
         CALL STDWRR(IMNO,DESCR,RVALS,FELEM,LRVALS,UNI,STAT)   !fill descr
         FELEM = -1
      ELSE IF (OUTFL.GT.1) THEN                                !fill table
         N = NMAL + TBAPP
         IF (OUTFL.EQ.3) THEN        
            CALL TBRWRD(TIDO,N,4,OUCOLN(1),DVALS(1),STAT)
            CALL TBRWRD(TIDO,N,2,OUCOLN(10),DVALS(5),STAT)
            IF (IDFL.EQ.1) CALL TBEWRC(TIDO,N,OUCOLN(9),IDF,STAT)
         ELSE 
            IF (CENTY.NE.1) 
     +         CALL TBRWRD(TIDO,N,2,OUCOLN(10),DVALS(5),STAT)
            IF (IDFL.EQ.1) CALL TBEWRC(TIDO,N,OUCOLN(9),IDF,STAT)
         ENDIF
         CALL TBRWRR(TIDO,N,4,OUCOLN(5),RVALS(7),STAT)
         CALL TBRWRR(TIDO,N,2,OUCOLN(12),RVALS(11),STAT)
      ENDIF
C      
C  and loop again  (only for INFL=1,2)
C 
7000  IF (INFL.EQ.1) THEN 
         GOTO 1000
      ELSE IF (INFL.EQ.2) THEN 
         GOTO 2800
      ENDIF
C
C  That's it folks...
9000  IF (OUTFL.EQ.3) CALL TBSINI(TIDO,STAT)
      IF (TIDO.GE.0) THEN
         CALL STKRDC('MID$LINE',1,1,80,IAV,CBUF,UNI,NULO,STAT)
         CALL STDWRC(TIDO,'HISTORY',1,CBUF,-1,80,UNI,STAT)
      ENDIF
C      
C  save last set of data + no. of coordinates obtained
      CALL STKWRR('OUTPUTR',RVALS,1,LRVALS,UNI,STAT)
      CALL STKWRR('OUTPUTR',R1,XINDX,1,UNI,STAT)         !set control flag
      CALL STKWRD('OUTPUTD',DVALS,1,6,UNI,STAT)
      CALL STKWRI('OUTPUTI',NCOOS,1,1,UNI,STAT)
C      
      IF (INFL.EQ.1) THEN
         CALL DTCLOS(QDSPNO)
         CALL REFOVR(STAT)
      ENDIF
      CALL STSEPI
C      
C  format statements
10001 FORMAT(A,I4)
10003 FORMAT(A)
10010 FORMAT(I4.4)
10011 FORMAT(I4)
10020 FORMAT(A,
     + '-pixel out of frame ...')
10070 FORMAT('bad coord(s) - X, Y: ',2F20.10)
10071 FORMAT('new subwindow dims = ',I4,',',I4,' > ',I4,',',I4,
     +       ' (last dims)')
10072 FORMAT('Radii of Flux, Noman, Backgr = ',
     +       I4,',',I4,',',I4,' pixels, total diameter = ',I5)
10077 FORMAT('row no. ',I5,' contains bad coord(s) - we skip ...')
20004 FORMAT('diameter of circles according to Fsiz(',I3,
     + '),Nsiz(',I3,'),Bsiz(',I3,')')
20009 FORMAT('will be ',I3,',',I4,',',I4,' pixels')
20005 FORMAT(G13.7,1X,G13.7,1X,G11.5,1X,G11.5)
20006 FORMAT(6X,G13.7,1X,G13.7,1X,G13.7,1X,G13.7)
30000 FORMAT('Square too small for Fsize =',I3,' Bsize = ',I3)
70001 FORMAT('[',G12.5,']')
      END         

      SUBROUTINE PULLOU(CBUF,STEP,NDF,BDF,
     +                  MAGPIX,MAGPIY,NOMPIX,BAKPIX)
C      
      IMPLICIT NONE
C
      INTEGER    BAKPIX,MAGPIX,MAGPIY,NOMPIX
      INTEGER    BDF,NDF
      INTEGER    LL,COUNT
      INTEGER    OPTION,INFL,OUTFL,TBMAG
C
      CHARACTER*(*)  CBUF
      CHARACTER      SAVBUF*80,STRING*30
C
      DOUBLE PRECISION STEP(2)
C 
      COMMON  /FLAGS/  INFL,OUTFL,OPTION,TBMAG
C
      MAGPIY = -1
C 
      LL = INDEX(CBUF,',')               !we expect "a,b,c" or "a,b" or "a"
      IF (LL.LE.0) THEN                  !only "a" given
         NOMPIX = NDF
         BAKPIX = BDF
         CALL SPULLO(CBUF,STEP(1),MAGPIX)
         RETURN
      ENDIF
C
      IF (OPTION.EQ.2) THEN              !for RECT we may have magpix,magpiy,..
         IF (INFL.EQ.2) THEN             !for table input only...
            IF (CBUF(1:2).EQ.'+,') THEN
               TBMAG = 1                 !we use the table interval
               CBUF(1:) = CBUF(3:)
               MAGPIX = 1
               GOTO 4000
            ELSE IF (CBUF(1:2).EQ.'-,') THEN
               TBMAG = -1                !we use the table interval
               CBUF(1:) = CBUF(3:)
               MAGPIX = 1
               GOTO 4000
            ENDIF
         ENDIF
C 
         SAVBUF(1:) = CBUF(1:)
         DO 1000, COUNT=1,3
            LL = INDEX(CBUF,',')
            IF (LL.LE.0) GOTO 2000        !NO - magpiy = magpix
            CBUF(LL:LL) = '^'
1000     CONTINUE
C 
         LL = INDEX(CBUF,'^')
         STRING(1:) = CBUF(1:LL-1)//' '      !copy out "ax" from "ax,ay,b,c"
         CALL SPULLO(STRING,STEP(1),MAGPIX)
         CBUF = CBUF(LL+1:)//' '
         LL = INDEX(CBUF,'^')
         STRING(1:) = CBUF(1:LL-1)//' '      !copy out "ay" 
         CALL SPULLO(STRING,STEP(2),MAGPIY)
         CBUF = CBUF(LL+1:)//' '
         LL = INDEX(CBUF,'^')
         STRING(1:) = CBUF(1:LL-1)//' '      !copy out "b" from "a,b,c"
         CALL SPULLO(STRING,STEP(1),NOMPIX)
         CALL SPULLO(CBUF(LL+1:),STEP(1),BAKPIX)
         RETURN
C 
2000     CBUF(1:) = SAVBUF(1:)
         LL = INDEX(CBUF,',')               !reset LL
       ENDIF
C 
      STRING(1:) = CBUF(1:LL-1)//' '         !copy out "a" from "a,b" or "a,b,c"
      CALL SPULLO(STRING,STEP(1),MAGPIX)
      CBUF = CBUF(LL+1:)//' '
C 
4000  LL = INDEX(CBUF,',')
      IF (LL.LE.0) THEN                      !only "a,b" given
         BAKPIX = BDF
         CALL SPULLO(CBUF,STEP(1),NOMPIX)
      ELSE
         STRING(1:) = CBUF(1:LL-1)//' '      !copy out "b" from "a,b,c"
         CALL SPULLO(STRING,STEP(1),NOMPIX)
         CALL SPULLO(CBUF(LL+1:),STEP(1),BAKPIX)
      ENDIF
C      
      RETURN
      END

      SUBROUTINE BADVAL(CBUF,OK)
C      
      IMPLICIT NONE
C      
      INTEGER    OK
C 
      CHARACTER*(*)      CBUF
      CHARACTER*24       MYBUF
      DATA       MYBUF /' '/
C      
      CALL UPCAS(CBUF,MYBUF)
      IF (INDEX(MYBUF,'INF').GE.1) THEN
         OK = -1
      ELSE IF (INDEX(MYBUF,'NAN').GE.1) THEN
         OK = -1
      ELSE
         OK = 1
      ENDIF

      RETURN
      END

      SUBROUTINE SPULLO(CBUF,STEP,PIX)
C      
      IMPLICIT NONE
C      
      INTEGER    PIX
      INTEGER    SL
C      
      CHARACTER*(*)      CBUF
C      
      REAL     RR
C 
      DOUBLE PRECISION   STEP,DD
C      
      IF (CBUF(1:1).EQ.'@') THEN
         CALL GENCNV(CBUF(2:),1,1,PIX,RR,DD,SL)
         IF (SL.LE.0) PIX = -1            !indicate wrong syntax...
      ELSE
         CALL GENCNV(CBUF(1:),4,1,PIX,RR,DD,SL)
         IF (SL.LE.0) THEN
            PIX = -1            !indicate wrong syntax...
         ELSE
            PIX = NINT(DD/STEP)
         ENDIF
      ENDIF
C      
      RETURN
      END
