C @(#)rfotcheck.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 CHECK C+++ C.IDENTIFICATION: RFOTCHECK C.PURPOSE: Examine the number of artificial stars recovered and check their C photometric accuracy C.AUTHOR: R. Buonanno, G. Buscema, C. Corsi, I. Ferraro, G. Iannicola C Osservatorio Astronomico di Roma C Rewritten by Rein H. Warmels, ESO-IPG Garching C.VERSION: 890912 RHW MIDAS table file system implemented; new ST interfaces C---- IMPLICIT NONE C INTEGER NNN PARAMETER (NNN=100000) C INTEGER IFL(NNN) INTEGER ISTO(1000),IISTO(1000) INTEGER EC, ED, EL INTEGER I, IC, IR, II INTEGER IAV, ISTAT INTEGER IDUM2, IDUM3, IDUM6, IDUM7, IDUM8, IDUM9 INTEGER IDUM14, IDUM15 INTEGER ISTM INTEGER KW INTEGER KUN, KNUL INTEGER KKO INTEGER NCO, NRO INTEGER NSC, NSA INTEGER NOG INTEGER NCAN INTEGER NCM INTEGER NH INTEGER TIDCAT,TIDREG INTEGER MADRID INTEGER ICMP INTEGER ICOL(12) C REAL TAB(12) REAL X(NNN),Y(NNN),PMA(NNN) REAL DIF(NNN) REAL ACER REAL APPO, APPO2, APPO3 REAL DFMX, DFMN REAL FL REAL PMAX, PMIN REAL PM REAL RDUM1, RDUM2, RDUM3, RDUM4, RDUM5, RDUM6, RDUM7 REAL RDUM8, RDUM9, RDUM10, RDUM11, RDUM12, RDUM13 REAL XX, YY REAL FON, DIS C LOGICAL NUL(12) C CHARACTER STRING*80,XXX*30 CHARACTER*60 CATFIL,REGFIL C INCLUDE 'MID_INCLUDE:TABLES.INC' COMMON /VMR/MADRID INCLUDE 'MID_INCLUDE:TABLED.INC' C DATA ICOL/2,3,4,5,6,7,8,9,10,11,12,13/ DATA ISTO/1000*0/ DATA IISTO/1000*0/ C 99 FORMAT('*** INFO: Number of objects not detected: ',I6) 98 FORMAT(I5,'% of',I5,2X,E10.3,2X,'I',A30) C C *** Let's start the fun; is MIDAS out there? CALL STSPRO('CHECK') C C *** get the input catalogue file CALL STKRDC('IN_A',1,1,60,IAV,CATFIL,KUN,KNUL,ISTAT) 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: Catalogue table not present ...' CALL STTPUT(STRING,ISTAT) CALL STSEPI ELSE CALL CATDRD(TIDCAT,NOG,IDUM2,IDUM3,RDUM4,RDUM5,IDUM6, 2 IDUM7,IDUM8,IDUM9,RDUM10,RDUM11,RDUM12,RDUM13, 3 IDUM14,IDUM15) ENDIF C C *** get the registration table created by FCLEAN/ROMAFOT CALL STKRDC('IN_B',1,1,60,IAV,REGFIL,KUN,KNUL,ISTAT) CALL TBTOPN(REGFIL,F_I_MODE,TIDREG,ISTAT) IF (ISTAT.NE.0) THEN STRING = '*** FATAL: Registration table not present ...' CALL STTPUT(STRING,ISTAT) CALL STSEPI ELSE CALL TBIGET(TIDREG,NCO,NRO,NSC,KW,NSA,ISTAT) ENDIF CALL STECNT('PUT',EC,ED,EL) C C *** get the error in magnitude CALL STKRDR('INPUTR',1,1,IAV,ACER,KUN,KNUL,ISTAT) C C *** open a dump file C OPEN(UNIT=8,FILE='CHECK.DMP',STATUS='NEW') C C *** initialize the arrays DO 10 I=1,NNN DIF(I) = 0.0 IFL(I) = 0 10 CONTINUE PMAX = -1000 PMIN = -PMAX C C *** run through the entire catalogue DO 20 IC=1,NOG CALL CATTRD(TIDCAT,IC,ICMP,X(IC),Y(IC),RDUM3,PMA(IC), 2 RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,RDUM10, 3 RDUM11,RDUM12,RDUM13) PMAX = AMAX1(PMAX,PMA(IC)) PMIN = AMIN1(PMIN,PMA(IC)) 20 CONTINUE C C *** read the registration table DFMX = -99999. DFMN = -DFMX DO 30 IR = 1,NRO CALL TBRRDR(TIDREG,IR,12,ICOL,TAB,NUL,ISTAT) XX = TAB(1) YY = TAB(2) FON = TAB(4) DO 31 I=1,NOG IF (IFL(I).EQ.0) THEN DIS = (XX-X(I))**2+(YY-Y(I))**2 IF (DIS.LT.2) THEN IF (ABS(TAB(8)-PMA(I)).LT.ACER) THEN IFL(I) = 1 DIF(I) = TAB(8) - PMA(I) DFMX = AMAX1(DFMX,DIF(I)) DFMN = AMIN1(DFMN,DIF(I)) END IF END IF END IF 31 CONTINUE 30 CONTINUE C KKO = 0 DO 40 I=1,NOG NCAN = (PMA(I)-PMIN)/.5+1 !.5 e' il passo IF (IFL(I).NE.1) THEN ! istogramma pmag(i) non trovate ISTO(NCAN) = ISTO(NCAN)+1 KKO = KKO+1 ELSE IISTO(NCAN) = IISTO(NCAN)+1 END IF 40 CONTINUE C WRITE (STRING,99) KKO CALL STTPUT(STRING,ISTAT) C NCM = (PMAX-PMIN)/.5+1 ISTM = 0 DO 50 I=1,NCM IISTO(I) = ISTO(I)+IISTO(I) APPO = ISTO(I) APPO2 = IISTO(I) IF (APPO2.GT.0)THEN APPO3 = (APPO/APPO2)*100 ELSE APPO3 = 0 END IF ISTO(I) = APPO3 50 CONTINUE C DO 60 I=1,NCM ISTM=MAX0(ISTM,ISTO(I)) 60 CONTINUE C IF (ISTM.GT.0) THEN PM = PMIN-.49 DO 70 I=1,NCM XXX(1:30) = ' ' PM = PM+.5 NH = 30.*ISTO(I)/ISTM DO 71 II=1,NH XXX(II:II) = 'X' 71 CONTINUE WRITE(STRING,98) ISTO(I),IISTO(I),PM,XXX CALL STTPUT(STRING,ISTAT) 70 CONTINUE ELSE CALL STTPUT('*** INFO: No data available',ISTAT) END IF C DO 80 IC=1,NOG CALL CATTRD(TIDCAT,IC,ICMP,RDUM1,RDUM2,RDUM3,RDUM4, 2 RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,RDUM10,RDUM11, 3 RDUM12,RDUM13) FL = FLOAT(IFL(IC)) CALL CATTWR(TIDCAT,IC,ICMP,RDUM1,RDUM2,RDUM3,RDUM4, 2 RDUM5,RDUM6,FL,DIF(IC),RDUM9, 3 RDUM10,RDUM11,RDUM12,RDUM13) 80 CONTINUE CALL TBTCLO(TIDCAT,ISTAT) CALL TBTCLO(TIDREG,ISTAT) CALL STSEPI END