← Back to branch summary

~ubuntu-branches/debian/jessie/eso-midas/jessie

« back to all changes in this revision

Viewing changes to contrib/romafot/src/rfotcheck.for

  • Committer: Package Import Robot
  • Author(s): Ole Streicher
  • Date: 2014-04-22 14:44:58 UTC
  • Revision ID: package-import@ubuntu.com-20140422144458-okiwi1assxkkiz39
Tags: upstream-13.09pl1.2+dfsg
Import upstream version 13.09pl1.2+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
contrib/romafot/src/rfotcheck.for
 
1
C @(#)rfotcheck.for     19.1 (ES0-DMD) 02/25/03 13:30:13
 
2
C===========================================================================
 
3
C Copyright (C) 1995 European Southern Observatory (ESO)
 
4
C
 
5
C This program is free software; you can redistribute it and/or 
 
6
C modify it under the terms of the GNU General Public License as 
 
7
C published by the Free Software Foundation; either version 2 of 
 
8
C the License, or (at your option) any later version.
 
9
C
 
10
C This program is distributed in the hope that it will be useful,
 
11
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
13
C GNU General Public License for more details.
 
14
C
 
15
C You should have received a copy of the GNU General Public 
 
16
C License along with this program; if not, write to the Free 
 
17
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
 
18
C MA 02139, USA.
 
19
C
 
20
C Corresponding concerning ESO-MIDAS should be addressed as follows:
 
21
C       Internet e-mail: midas@eso.org
 
22
C       Postal address: European Southern Observatory
 
23
C                       Data Management Division 
 
24
C                       Karl-Schwarzschild-Strasse 2
 
25
C                       D 85748 Garching bei Muenchen 
 
26
C                       GERMANY
 
27
C===========================================================================
 
28
C
 
29
      PROGRAM CHECK
 
30
C+++
 
31
C.IDENTIFICATION: RFOTCHECK
 
32
C.PURPOSE: Examine the number of artificial stars recovered and check their
 
33
C          photometric accuracy
 
34
C.AUTHOR:  R. Buonanno, G. Buscema, C. Corsi, I. Ferraro, G. Iannicola
 
35
C          Osservatorio Astronomico di Roma
 
36
C          Rewritten by Rein H. Warmels, ESO-IPG Garching
 
37
C.VERSION: 890912  RHW MIDAS table file system implemented; new ST interfaces
 
38
C----
 
39
      IMPLICIT     NONE
 
40
C
 
41
      INTEGER      NNN
 
42
      PARAMETER    (NNN=100000)
 
43
C
 
44
      INTEGER      IFL(NNN)
 
45
      INTEGER      ISTO(1000),IISTO(1000)
 
46
      INTEGER      EC, ED, EL
 
47
      INTEGER      I, IC, IR, II
 
48
      INTEGER      IAV, ISTAT
 
49
      INTEGER      IDUM2, IDUM3, IDUM6, IDUM7, IDUM8, IDUM9
 
50
      INTEGER      IDUM14, IDUM15
 
51
      INTEGER      ISTM
 
52
      INTEGER      KW
 
53
      INTEGER      KUN, KNUL
 
54
      INTEGER      KKO
 
55
      INTEGER      NCO, NRO
 
56
      INTEGER      NSC, NSA
 
57
      INTEGER      NOG
 
58
      INTEGER      NCAN
 
59
      INTEGER      NCM
 
60
      INTEGER      NH
 
61
     
 
62
      INTEGER      TIDCAT,TIDREG
 
63
      INTEGER      MADRID
 
64
      INTEGER      ICMP
 
65
      INTEGER      ICOL(12)
 
66
C
 
67
      REAL         TAB(12)
 
68
      REAL         X(NNN),Y(NNN),PMA(NNN)
 
69
      REAL         DIF(NNN)
 
70
      REAL         ACER
 
71
      REAL         APPO, APPO2, APPO3
 
72
      REAL         DFMX, DFMN
 
73
      REAL         FL
 
74
      REAL         PMAX, PMIN
 
75
      REAL         PM
 
76
      REAL         RDUM1, RDUM2, RDUM3, RDUM4, RDUM5, RDUM6, RDUM7
 
77
      REAL         RDUM8, RDUM9, RDUM10, RDUM11, RDUM12, RDUM13
 
78
      REAL         XX, YY
 
79
      REAL         FON, DIS
 
80
C
 
81
      LOGICAL      NUL(12)
 
82
C
 
83
      CHARACTER    STRING*80,XXX*30
 
84
      CHARACTER*60 CATFIL,REGFIL
 
85
C
 
86
      INCLUDE      'MID_INCLUDE:TABLES.INC'
 
87
      COMMON       /VMR/MADRID
 
88
      INCLUDE      'MID_INCLUDE:TABLED.INC'
 
89
C
 
90
      DATA         ICOL/2,3,4,5,6,7,8,9,10,11,12,13/
 
91
      DATA         ISTO/1000*0/
 
92
      DATA         IISTO/1000*0/
 
93
C
 
94
   99 FORMAT('*** INFO: Number of objects not detected: ',I6)
 
95
   98 FORMAT(I5,'% of',I5,2X,E10.3,2X,'I',A30)
 
96
C
 
97
C *** Let's start the fun; is MIDAS out there?
 
98
      CALL STSPRO('CHECK')
 
99
C
 
100
C *** get the input catalogue file
 
101
      CALL STKRDC('IN_A',1,1,60,IAV,CATFIL,KUN,KNUL,ISTAT)
 
102
      CALL STECNT('GET',EC,ED,EL)
 
103
      CALL STECNT('PUT',1,0,0)
 
104
      CALL TBTOPN(CATFIL,F_IO_MODE,TIDCAT,ISTAT)
 
105
      IF (ISTAT.NE.0) THEN
 
106
         STRING = '*** FATAL: Catalogue table not present ...'
 
107
         CALL STTPUT(STRING,ISTAT)
 
108
         CALL STSEPI
 
109
      ELSE
 
110
         CALL CATDRD(TIDCAT,NOG,IDUM2,IDUM3,RDUM4,RDUM5,IDUM6,
 
111
     2               IDUM7,IDUM8,IDUM9,RDUM10,RDUM11,RDUM12,RDUM13,
 
112
     3               IDUM14,IDUM15)
 
113
      ENDIF
 
114
C
 
115
C *** get the registration table created by FCLEAN/ROMAFOT
 
116
      CALL STKRDC('IN_B',1,1,60,IAV,REGFIL,KUN,KNUL,ISTAT)
 
117
      CALL TBTOPN(REGFIL,F_I_MODE,TIDREG,ISTAT)
 
118
      IF (ISTAT.NE.0) THEN
 
119
         STRING = '*** FATAL: Registration table not present ...'
 
120
         CALL STTPUT(STRING,ISTAT)
 
121
         CALL STSEPI
 
122
      ELSE
 
123
         CALL TBIGET(TIDREG,NCO,NRO,NSC,KW,NSA,ISTAT)
 
124
      ENDIF
 
125
      CALL STECNT('PUT',EC,ED,EL)
 
126
C
 
127
C *** get the error in magnitude
 
128
      CALL STKRDR('INPUTR',1,1,IAV,ACER,KUN,KNUL,ISTAT)
 
129
C
 
130
C *** open a dump file 
 
131
C     OPEN(UNIT=8,FILE='CHECK.DMP',STATUS='NEW')
 
132
C
 
133
C *** initialize the arrays
 
134
      DO 10 I=1,NNN
 
135
         DIF(I) = 0.0
 
136
         IFL(I) = 0
 
137
   10 CONTINUE
 
138
      PMAX = -1000
 
139
      PMIN = -PMAX
 
140
C
 
141
C *** run through the entire catalogue
 
142
      DO 20 IC=1,NOG
 
143
         CALL CATTRD(TIDCAT,IC,ICMP,X(IC),Y(IC),RDUM3,PMA(IC),
 
144
     2               RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,RDUM10,
 
145
     3               RDUM11,RDUM12,RDUM13)
 
146
         PMAX = AMAX1(PMAX,PMA(IC))
 
147
         PMIN = AMIN1(PMIN,PMA(IC))
 
148
   20 CONTINUE
 
149
C
 
150
C *** read the registration table
 
151
      DFMX = -99999.
 
152
      DFMN = -DFMX
 
153
      DO 30 IR = 1,NRO
 
154
         CALL TBRRDR(TIDREG,IR,12,ICOL,TAB,NUL,ISTAT)
 
155
         XX  = TAB(1)
 
156
         YY  = TAB(2)
 
157
         FON = TAB(4)
 
158
         DO 31 I=1,NOG
 
159
            IF (IFL(I).EQ.0) THEN
 
160
               DIS = (XX-X(I))**2+(YY-Y(I))**2
 
161
               IF (DIS.LT.2) THEN
 
162
                  IF (ABS(TAB(8)-PMA(I)).LT.ACER) THEN
 
163
                     IFL(I) = 1
 
164
                     DIF(I) = TAB(8) - PMA(I)
 
165
                     DFMX   = AMAX1(DFMX,DIF(I))
 
166
                     DFMN   = AMIN1(DFMN,DIF(I))
 
167
                  END IF
 
168
               END IF
 
169
            END IF
 
170
   31    CONTINUE
 
171
   30 CONTINUE
 
172
C
 
173
      KKO = 0
 
174
      DO 40 I=1,NOG
 
175
         NCAN = (PMA(I)-PMIN)/.5+1                               !.5 e' il passo
 
176
         IF (IFL(I).NE.1) THEN                  ! istogramma pmag(i) non trovate
 
177
            ISTO(NCAN)  = ISTO(NCAN)+1
 
178
            KKO         = KKO+1
 
179
          ELSE
 
180
            IISTO(NCAN) = IISTO(NCAN)+1
 
181
         END IF
 
182
   40 CONTINUE
 
183
C
 
184
      WRITE (STRING,99) KKO
 
185
      CALL STTPUT(STRING,ISTAT)
 
186
C
 
187
      NCM  = (PMAX-PMIN)/.5+1
 
188
      ISTM = 0
 
189
      DO 50 I=1,NCM
 
190
         IISTO(I) = ISTO(I)+IISTO(I)
 
191
         APPO     = ISTO(I)
 
192
         APPO2    = IISTO(I)
 
193
         IF (APPO2.GT.0)THEN
 
194
            APPO3 = (APPO/APPO2)*100 
 
195
         ELSE
 
196
            APPO3 = 0
 
197
         END IF
 
198
         ISTO(I) = APPO3
 
199
   50 CONTINUE
 
200
C
 
201
      DO 60 I=1,NCM
 
202
         ISTM=MAX0(ISTM,ISTO(I))
 
203
   60 CONTINUE
 
204
C
 
205
      IF (ISTM.GT.0) THEN
 
206
         PM = PMIN-.49
 
207
         DO 70 I=1,NCM
 
208
            XXX(1:30) = ' '
 
209
            PM        = PM+.5
 
210
            NH        = 30.*ISTO(I)/ISTM
 
211
            DO 71 II=1,NH
 
212
               XXX(II:II) = 'X'
 
213
   71       CONTINUE
 
214
            WRITE(STRING,98) ISTO(I),IISTO(I),PM,XXX
 
215
            CALL STTPUT(STRING,ISTAT)
 
216
   70    CONTINUE
 
217
      ELSE
 
218
         CALL STTPUT('*** INFO: No data available',ISTAT)
 
219
      END IF
 
220
C
 
221
      DO 80 IC=1,NOG
 
222
         CALL CATTRD(TIDCAT,IC,ICMP,RDUM1,RDUM2,RDUM3,RDUM4,
 
223
     2               RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,RDUM10,RDUM11,
 
224
     3               RDUM12,RDUM13)
 
225
         FL = FLOAT(IFL(IC))
 
226
         CALL CATTWR(TIDCAT,IC,ICMP,RDUM1,RDUM2,RDUM3,RDUM4,
 
227
     2               RDUM5,RDUM6,FL,DIF(IC),RDUM9,
 
228
     3               RDUM10,RDUM11,RDUM12,RDUM13)
 
229
   80 CONTINUE
 
230
      CALL TBTCLO(TIDCAT,ISTAT)
 
231
      CALL TBTCLO(TIDREG,ISTAT)
 
232
      CALL STSEPI
 
233
      END