C @(#)rfotfclean.for	19.1 (ES0-DMD) 02/25/03 13:30:14
C===========================================================================
C Copyright (C) 1995 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 Massachusetss Ave, Cambridge, 
C MA 02139, USA.
C
C Corresponding 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
      PROGRAM FCLEAN
C++++
C.PURPOSE: Select window in the intermediate table which are also present
C          in the catalogue table. Put the selection flag on these components.
C.AUTHORS: R. Buonanno, G. Buscema, C. Corsi, I. Ferraro, G. Iannicola
C          Osservatorio Astronomico di Roma
C.VERSION: 880921  First running version in MIDAS               R. Buonanno
C          890809  Rewritten on basis of MIDAS tables;
C                  implementation of ST interfaces              R.H. Warmels
C---
      IMPLICIT     NONE
      INCLUDE      'MID_REL_INCL:RFOTDECL.INC'
C
      INTEGER      IDB
      PARAMETER    (IDB=256)
C
      INTEGER      TIDCAT, TIDIN,TIDOUT
      INTEGER      IAV
      INTEGER      ISTAT
      INTEGER      EC, ED, EL
      INTEGER      IA3
      INTEGER      NGRP
      INTEGER      IRIN, IROUT
      INTEGER      NCP, NHL
      INTEGER      IPX, IPY
      INTEGER      NP, NC
      INTEGER      IH
      INTEGER      LFWT
      INTEGER      LI
      INTEGER      JK, JKR
      INTEGER      LFW
      INTEGER      ICB
      INTEGER      KUN, KNUL
      INTEGER      NST,NCCAT,NRCAT,NSCAT,NACCAT,NARCAT
      INTEGER      NCINT,NRINT,NSINT,NACINT,NARINT
      INTEGER      IA1,IA2,IA4,IA5,IA6,IA7,IA8
      INTEGER      TINULL
      INTEGER      MADRID
      INTEGER      IKT,NSR
      INTEGER      ICAT,IDENT,KGR,KCP
      INTEGER      IXE, IYE
      
C
      DOUBLE PRECISION TDNULL,TDTRUE,TDFALS
C
      REAL         D1,D2,RMA,V,B,U,PPP,FLCO
      REAL         SAT,FAT,SIGMA,BETA,SIV,AIN,FOG
      REAL         BA1,BA2,BA3,BA4,BA5,BA6
      REAL         TRNULL, TBLSEL
      REAL         XM(NINTO),YM(NINTO),KM(NINTO)
      REAL         PB(IDB)
      REAL         RR
      REAL         XR, YR
C
      CHARACTER    CATFIL*60, INTIN*60, INTOUT*60
      CHARACTER    STRING*80
C
      LOGICAL      SFLAG
C       
      INCLUDE      'MID_INCLUDE:ST_DEF.INC'
      COMMON       /VMR/MADRID
      INCLUDE      'MID_INCLUDE:ST_DAT.INC'
C
999   FORMAT('*** INFO: Number of objects in the catalogue table: ',I5)
998   FORMAT('          Number of groups in intermediate table:   ',I5)
997   FORMAT('          Number of components:                     ',I5)
996   FORMAT('          Final number of groups selected:          ',I5)
C
C *** start here 
      CALL STSPRO('FCLEAN')                              ! is somebody out there
      CALL TBMCON(TBLSEL,TDTRUE,TDFALS)
      CALL TBMNUL(TINULL,TRNULL,TDNULL)
      SFLAG = .TRUE.
C
C *** get the catalogue table
      CALL STKRDC('IN_A',1,1,60,IAV,CATFIL,KUN,KNUL,ISTAT)   !get catalogue name
C
C *** open the catalogue table
      CALL STECNT('GET',EC,ED,EL)
      CALL STECNT('PUT',1,0,0)
      CALL TBTOPN(CATFIL,F_IO_MODE,TIDCAT,ISTAT)
      IF (ISTAT.NE.0) THEN
         STRING = '*** FATAL: Problems with opening the catalogue'//
     2            ' table; Try again ...'
         CALL STTPUT(STRING,ISTAT)
         CALL STSEPI
      ENDIF
C
      CALL TBIGET(TIDCAT,NCCAT,NRCAT,NSCAT,NACCAT,NARCAT,ISTAT)
      IF (ISTAT.NE.0) THEN
         STRING = '*** FATAL: Problems with getting info for'//
     2            ' catalogue table; Try again ...'
         CALL STTPUT(STRING,ISTAT)
         CALL STSEPI
      ENDIF
      IF (NRCAT.EQ.0) THEN
         STRING = '*** FATAL: No data in the catalogue table'
         CALL STTPUT(STRING,ISTAT)
         CALL STSEPI
      ENDIF
      CALL STECNT('PUT',EC,ED,EL)
C
C *** read the descriptor data
      CALL CATDRD(TIDCAT,NST,IA1,IA2,BA1,BA2,IA3,IA4,IA5,IA6,
     2                   BA3,BA4,BA5,BA6,IA7,IA8)          ! read the descriptor
C
C *** get the intermediate input table
      CALL STKRDC('IN_B',1,1,60,IAV,INTIN,KUN,KNUL,ISTAT)   ! get interm. name
C
C *** get intermediate file info
      CALL TBTOPN(INTIN,F_IO_MODE,TIDIN,ISTAT)
      IF (ISTAT.NE.0) THEN
         STRING = '*** FATAL: Intermediate table not present; '//
     2            'will create a new one ...'
         CALL STTPUT(STRING,ISTAT)

      ELSE
         CALL TBIGET(TIDIN,NCINT,NRINT,NSINT,NACINT,NARINT,ISTAT)
         IF (ISTAT.NE.0) THEN
            STRING = '*** FATAL: Problems with getting info for '//
     2               'intermediate table ...'
            CALL STTPUT(STRING,ISTAT)
            CALL STSEPI
         ENDIF
C
         IF (NRINT.EQ.0) THEN
            STRING = 'FATAL: No points in the intermediate table'
            CALL STTPUT(STRING,ISTAT)
            CALL STSEPI
         ENDIF
C
C *** get the intermediate table parameters
         CALL INTDRD(TIDIN,NGRP,IKT,NSR,SAT,FAT,SIGMA,
     2                                BETA,SIV,AIN,FOG)         ! get descriptor
      ENDIF
C
C *** get the intermediate input table
      CALL STKRDC('OUT_A',1,1,60,IAV,INTOUT,KUN,KNUL,ISTAT)   ! get interm. name
      IF (INTOUT(1:4).NE.'NONE') THEN
         CALL INTINI(INTOUT,TIDOUT)
      ENDIF
C
C *** get information to user
      WRITE(STRING,999) NST
      CALL STTPUT(STRING,ISTAT)
      WRITE(STRING,998) NGRP
      CALL STTPUT(STRING,ISTAT)
      WRITE(STRING,997) IKT
      CALL STTPUT(STRING,ISTAT)
C
C *** do the work
      DO 100 ICAT = 1,NST
         CALL CATTRD(TIDCAT,ICAT,IDENT,D1,D2,RMA,V,B,U,PPP,
     2                      FLCO,BA1,BA2,BA3,BA4,BA5)
         XM(ICAT) = D1
         YM(ICAT) = D2
         KM(ICAT) = 0
  100 CONTINUE
C
      KGR   = 0                        ! initialize the found-components-counter
      KCP   = 0
      IRIN  = 1
      IROUT = 1
C
  200 CONTINUE
          CALL INTWRD(TIDIN,IRIN,NCP,NHL)
          IPX   = INT(PARINT(1))
          IPY   = INT(PARINT(2))
          NP    = INT(PARINT(6))
          NC    = INT(PARINT(7))
          PB(1) = PARINT(8)
          PB(2) = PARINT(9)
          PB(3) = PARINT(10)
          IXE   = IPX+NP-1
          IYE   = IPY+NC-1
C
          DO 201 IH = 1,NHL
             PB((IH-1)*3+1) = FITCMP((IH-1)*3+1)
             PB((IH-1)*3+2) = FITCMP((IH-1)*3+2)
             PB((IH-1)*3+3) = FITCMP((IH-1)*3+3)
  201     CONTINUE
C
          LFWT=0
C
          DO 210 JK = 1,NST
             IF (KM(JK).EQ.0) THEN
                IF (XM(JK).GE.IPX .AND. XM(JK).LE.IXE) THEN
                   IF (YM(JK).GE.IPY .AND. YM(JK).LE.IYE) THEN
                      LI  = 0
                      LFW = 0
220                   CONTINUE
                      IF (LFW.NE.0 .OR. LI.GE.NHL) GO TO 221
                         LI  = LI+1
                         ICB = (LI-1)*3
                         RR  = PB(ICB+3)**2
                         XR  = ((XM(JK)-IPX+1)-PB(ICB+1))**2
                         YR  = ((YM(JK)-IPY+1)-PB(ICB+2))**2
                         IF (XR+YR.LE.RR) THEN
                            LFW = 1
                         END IF
                      GO TO 220
C
  221                 CONTINUE
                      IF (LFW.EQ.0) THEN
                         KM(JK)  = 1
                         JKR     = JK
                         LFWT    = 1
                      END IF
                   END IF
                END IF
             END IF
  210     CONTINUE
C
          IF (LFWT.EQ.1) THEN
             KGR = KGR+1
             IF (INTOUT(1:4).NE.'NONE') THEN              ! write to ouput table
                CALL INTWWR(TIDOUT,IROUT,NCP,NHL)
                KCP = KCP + NCP
                IROUT = IROUT+NCP+NHL
C            ELSE
C               DO 230 IR = IRIN,IRIN+NCP+NHL-1          ! set selection flag on
C                  CALL TBSPUT(TIDIN,IR,SFLAG,ISTAT)
C 230           CONTINUE
             ENDIF
          ENDIF
C
C *** end of loop
          IRIN = IRIN + NCP+NHL
          IF (IRIN.LE.NRINT) THEN
             GO TO 200
          ENDIF
C
C *** put info on screen
      WRITE(STRING,996) KGR
      CALL STTPUT(STRING,ISTAT)
C
C *** finish up
      IF (INTOUT(1:4).NE.'NONE') THEN
         CALL INTDWR(TIDOUT,KGR,KCP,NSR,SAT,FAT,SIGMA,
     2                                BETA,SIV,AIN,FOG)         ! get descriptor
         CALL TBSINI(TIDOUT,ISTAT)
         CALL TBTCLO(TIDOUT,ISTAT)
      ENDIF
      CALL TBTCLO(TIDIN,ISTAT)
      CALL TBTCLO(TIDCAT,ISTAT)
      CALL STSEPI
      END
