C @(#)rfotcheck.for	19.1 (ES0-DMD) 02/25/03 13:30:13
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
