C @(#)rfotfclean.for 17.1.1.1 (ES0-DMD) 01/25/02 17:18:16 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