C===========================================================================
C Copyright (C) 1995-2005 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: INTESTAR 
C.PURPOSE:        Compute the stellar magnitude
C.LANGUAGE:       F77+ESOext
C.AUTHOR:         Charlie Ounnas
C.VERSION:        870928 RHW Change from old to new ST calls
C.VERSION:        880708 RHW Converted to standard Fortran
C.VERSION:        890214 RHW ST_interfaces
C.VERSION:        901128 RHW changes due to change in command syntax;
C.                           cursor selection now possible
C.VERSION:        910115 RHW IMPLICIT NONE added
C 
C 051116		last modif
C 
C-------------------------------------------------------------------

      PROGRAM  INTSTR
C
      IMPLICIT NONE
C
      INTEGER           MADRID(1)
      INTEGER           ISTAT
      INTEGER           I,IAC
      INTEGER*8         IP
      INTEGER           IMF,J,N,IR
      INTEGER           ST1,ST2,COORDC,COOFF
      INTEGER           KUN,KNUL, INCURS
      INTEGER           TIDI,TIDO,ACOL,AROW
      INTEGER           NAXIS,NCOL,NCOLO,NROW
      INTEGER           ICOL(8)
      INTEGER           MASK, OVCON
      INTEGER           NPIX(3)
      INTEGER           XY1(2),XY2(2)
      INTEGER           MASKO(1000)

      REAL              DMAX
      REAL              FPIX1(6),FPIX2(6)
      REAL              RVAL(11), RV
      REAL              RINF(6)
      REAL              CUTS(4)
      REAL              STA(2), STE(2)
      REAL              XYZI(2)
      REAL              XYZ(8)
      REAL              XYZO(8,1000)
      REAL              PARAM(3)
C 
      DOUBLE PRECISION  START(3),STEP(3)
C
      CHARACTER         FRAME*60,TBIN*60,TBOUT*60
      CHARACTER*16      COLX,COLY
      CHARACTER         FORM*5
      CHARACTER         INFO*40
      CHARACTER*16      LABEL(2),UNIT(2)
      CHARACTER         MODE*4
      CHARACTER         TEXT*88
      CHARACTER*16      LABELO(8),UNITO(8)
      CHARACTER         IDENT*72,CUNIT*64
      LOGICAL           NULL(2)
C
      INCLUDE           'MID_INCLUDE:ST_DEF.INC/NOLIST'
      INCLUDE           'MID_INCLUDE:IDIDEV.INC/NOLIST'
      INCLUDE           'MID_INCLUDE:IDIMEM.INC/NOLIST'
      COMMON            /VMR/MADRID
      INCLUDE           'MID_INCLUDE:ST_DAT.INC/NOLIST'
C
      DATA              LABEL /'X_COORD','Y_COORD'/
      DATA              LABELO/'X_COORD','Y_COORD','FLUX','MAGNITUDE',
     2                         'BACKGROUND','DIAMETER','LOG_DIAMETER',
     3                         'NO_REFERENCE'/
      DATA              UNIT  /'WORLD COORD.', 'WORLD COORD.'/
      DATA              UNITO /'WORLD COORD.', 'WORLD COORD.',
     2                          ' ', ' ', ' ', 'WORLD COORD.',' ',' '/
      DATA              FORM/'E12.5'/
      DATA              INFO/'*** INFO: Switch the cursor on ...'/
C
901   FORMAT(' Id.       World coord          Flux        Mag.      ',
     2       'Backgr     Diameter')
902   FORMAT(I4,2X,6(G12.6))
903   FORMAT('INFO: switch cursor on ...')
C
C *** start executable code
      CALL STSPRO('INTSTR')
C
C *** 
      CALL STKRDC('IN_A',1,1,60,IAC,FRAME,KUN,KNUL,ISTAT)
      IF (FRAME.EQ.'*') THEN
         CALL CLNFRA(FRAME,FRAME,0)
         INCURS = 1
      ELSE
         INCURS = 0
      ENDIF
      CALL STIGET(FRAME,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,
     2            3,NAXIS,NPIX,START,STEP,IDENT,CUNIT,IP,IMF,ISTAT)
C
C *** get the subarea input options
      CALL STKRDC('IN_B',1,1,60,IAC,TBIN,KUN,KNUL,ISTAT)
C
C *** get the output table
      CALL STKRDC('OUT_A',1,1,60,IAC,TBOUT,KUN,KNUL,ISTAT)
C
C *** get the parameters  
      CALL STKRDR('INPUTR',1,3,IAC,PARAM,KUN,KNUL,ISTAT)
      IF (PARAM(1).LE.0.) THEN
         PARAM(1)  = 30.
      ENDIF
      IF (PARAM(1).LT.10.) THEN
         CALL STTPUT('*** WARNING: Radius is less than 10 pixel',ISTAT)
         CALL STTPUT('             You can expect unreliable results',
     2                ISTAT)
C        PARAM(1)  = 10.
      ENDIF
      IF (PARAM(1).GT.200.) THEN
         PARAM(1)   = 200.
      ENDIF
C
C *** get the operation mode
      CALL STKRDC('INPUTC',1,1,4,IAC,MODE,KUN,KNUL,ISTAT)
      CALL UPCAS(MODE,MODE)
C
      CALL STDRDR(IMF,'LHCUTS',1,4,IAC,CUTS,KUN,KNUL,ISTAT)
      IF (CUTS(1).LT.CUTS(2)) THEN
         DMAX   = CUTS(2)
      ELSE
         DMAX   = CUTS(4)
      END IF
      STA(1) = START(1)
      STA(2) = START(2)
      STE(1) = STEP(1)
      STE(2) = STEP(2)
C
C *** main contreol loop for cursor input
      IF (INCURS.EQ.1) THEN
C
C *** get main control block for DeAnza + attach device
         CALL DTOPEN(1,ISTAT)
         CALL STKRDI('DAZHOLD',14,1,IAC,OVCON,KUN,KNUL,ISTAT)
C
C *** get scroll values of displayed channel + scroll overlay accordingly
         CALL DTGICH(QDSPNO,QIMCH,FRAME,RINF,ISTAT)
         CALL DAZSCR(QDSPNO,QIMCH,SCROLX,SCROLY,ISTAT)	
         COORDC  = 0
         COOFF  = 0
         FRAME  = ' '                    !that's needed for cursor interface
         NROW    = 0
C
C ***    read cursor position(s)
   10    CONTINUE 
         CALL GETCUR('NNYY',FRAME,XY1,FPIX1,RVAL(1),RV,ST1,
     +                            XY2,FPIX2,RVAL(3),RV,ST2)
         IF ((ST1.EQ.0) .AND. (ST2.EQ.0)) THEN
            GO TO 20
         ELSE
            GO TO 30
         END IF
C
C *** write output heading
   20    IF ((COORDC.EQ.0).AND.(COOFF.EQ.0)) THEN
            WRITE(TEXT,903)
            CALL STTPUT(TEXT,ISTAT)
            FRAME = ' '
            COOFF = 1
            GO TO 10
         ELSE
            GO TO 50
         END IF
C
   30    COORDC = COORDC + 1                       !  update coordinate counter
         IF (COORDC.EQ.1) THEN
            WRITE(TEXT,901)
            CALL STTPUT(TEXT,ISTAT)
         ENDIF
C
C ***    compute the radius of the aperture
C ***    world coordinates of the area center
         XYZI(1) = RVAL(1)
         XYZI(2) = RVAL(2)
         MASK    = 0
C
         IF (MODE.EQ.'AUTO') THEN
            CALL SPFLXA(MADRID(IP),NPIX,STA,STE,PARAM(1),
     2                  PARAM(2),DMAX,PARAM(3),XYZI,MASK,XYZ)
         ELSE
            CALL SPFLXI(MADRID(IP),NPIX,STA,STE,PARAM(1),
     2                  PARAM(2),DMAX,PARAM(3),XYZI,MASK,XYZ)
         ENDIF
C
C *** output the result
         IF (MASK.EQ.-1) THEN                     ! on error next entry
            CALL STTPUT('*** ERROR: Excessive background', ISTAT)
         ELSE IF (MASK.EQ.-2) THEN
            CALL STTPUT('*** ERROR: Indefinite diameter', ISTAT)
         ELSE IF (MASK.EQ.-3) THEN
            CALL STTPUT('*** ERROR: Maximum is outside the object',
     2                    ISTAT)
           
         ELSE                                       ! all systems ok
            NROW = NROW + 1                         !  update table row counter
            DO 120 J = 1,8
               XYZO(J,NROW) = XYZ(J)
  120       CONTINUE
            MASKO(NROW) = MASK

            WRITE(TEXT,902) INT(XYZ(8)),XYZ(1),XYZ(2),
     2                      XYZ(3),XYZ(4),XYZ(5),XYZ(6)
            CALL STTPUT(TEXT,ISTAT)
         ENDIF
         GO TO 10

      ELSE                                      ! here for the input from table
         WRITE(TEXT,901)
         CALL STTPUT(TEXT,ISTAT)
         COLX = 'X_COORD'
         COLY = 'Y_COORD'
         CALL TBTOPN(TBIN,F_I_MODE,TIDI,ISTAT)
         CALL TBIGET(TIDI,NCOL,NROW,N,ACOL,AROW,ISTAT)
C
C search for colomn indices by name
         DO 210 I = 1,2
            CALL TBLSER(TIDI,LABEL(I),ICOL(I),ISTAT)
  210    CONTINUE
         DO  220 IR = 1,NROW
            CALL TBRRDR(TIDI,IR,2,ICOL,XYZI,NULL,ISTAT)
            MASK = 0
            IF (MODE.EQ.'AUTO') THEN
               CALL SPFLXA(MADRID(IP),NPIX,STA,STE,PARAM(1),
     2                     PARAM(2),DMAX,PARAM(3),XYZI,MASK,XYZ)
            ELSE
               CALL SPFLXI(MADRID(IP),NPIX,STA,STE,PARAM(1),
     2                     PARAM(2),DMAX,PARAM(3),XYZI,MASK,XYZ)
            ENDIF
C
            IF (MASK.EQ.-1) THEN                         ! on error next entry
               CALL STTPUT('*** ERROR: Excessive background', ISTAT)
            ELSE IF (MASK.EQ.-2) THEN
               CALL STTPUT('*** ERROR: Indefinite diameter', ISTAT)
            ELSE IF (MASK.EQ.-3) THEN
               CALL STTPUT('*** ERROR: Maximum is outside the object',
     2                       ISTAT)
            ELSE                                    ! all systems ok
               DO 221 J = 1,8
                  XYZO(J,IR) = XYZ(J)
  221          CONTINUE
               MASKO(IR) = MASK
C
               WRITE(TEXT,902) INT(XYZ(8)),XYZ(1),XYZ(2),
     2                      XYZ(3),XYZ(4),XYZ(5),XYZ(6)
               CALL STTPUT(TEXT,ISTAT)
            ENDIF
  220    CONTINUE
         CALL TBTCLO(TIDI,ISTAT)
      ENDIF
C  
C *** open table if wanted	
   50 CONTINUE
      IF (TBOUT.NE.'?') THEN
         NCOLO = 8
         CALL TBTINI(TBOUT,F_O_MODE,F_TRANS,NCOLO,NROW,TIDO,ISTAT)
         DO 60 I = 1,8
            CALL TBCINI(TIDO,D_R4_FORMAT,1,FORM,UNITO(I),
     2                  LABELO(I),ICOL(I),ISTAT)
   60    CONTINUE
C
C *** write to table
         J = 0
         DO 130 I = 1,NROW
            IF (MASKO(I).GT.0) THEN
               J = J + 1
               CALL TBRWRR(TIDO,J,8,ICOL,XYZO(1,I),ISTAT)
            ENDIF
  130    CONTINUE
         CALL TBTCLO(TIDO,ISTAT)
      ENDIF
C
      IF (INCURS.EQ.1) THEN
         CALL DTCLOS(QDSPNO)
      ENDIF
      CALL STSEPI
      END
