← Back to branch summary

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

« back to all changes in this revision

Viewing changes to contrib/invent/libsrc/averpr.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/invent/libsrc/averpr.for
 
1
C @(#)averpr.for        19.1 (ES0-DMD) 02/25/03 13:25:31
 
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
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
30
C
 
31
C.IDENTIFICATION
 
32
C
 
33
C  subroutine AVERPR         version 1.2       830914
 
34
C  A. Kruszewski             ESO Garching
 
35
C
 
36
C  modified                  version 1.3       870303
 
37
C  A. Kruszewski             Obs. de Geneve
 
38
C
 
39
C.KEYWORDS
 
40
C
 
41
C  profiles
 
42
C
 
43
C.PURPOSE
 
44
C
 
45
C  using a two-dimensional profile "PRFL" it calculates average
 
46
C  one-dimensional profile "AVPR" and a number of significant
 
47
C  profile rings "LIM"
 
48
C
 
49
C.INPUT/OUTPUT
 
50
C
 
51
C  input arguments
 
52
C
 
53
C  PRFL        real*4 array      two-dimensional profile
 
54
C  IHED        integer*4         radial dimension of profile in pixels
 
55
C  TRSH        real*4            limiting treshold for object detection
 
56
C  ICNT        integer*4 array   numbers of used pixels at calculating
 
57
C                                profile points
 
58
C
 
59
C  output arguments
 
60
C
 
61
C  AVPR        real*4 array      one-dimensional profile
 
62
C  LIM         integer*4         number of significant profile rings
 
63
C
 
64
C-----------------------------------------------------------------------
 
65
      SUBROUTINE AVERPR(IHED, PRFL, TRSH, ICNT, AVPR,
 
66
     &                  IAPR, KCLN, KSAT, LIM)
 
67
C
 
68
      IMPLICIT   NONE
 
69
      INCLUDE   'MID_REL_INCL:INVENT.INC/NOLIST'
 
70
C
 
71
      INTEGER   IHED
 
72
      REAL      PRFL(8,0:IHED)
 
73
      REAL      TRSH
 
74
      INTEGER   ICNT(8,0:IHED)
 
75
      REAL      AVPR(0:MAXSUB)
 
76
      INTEGER   IAPR(0:MAXSUB)
 
77
      INTEGER   KCLN
 
78
      INTEGER   KSAT
 
79
      INTEGER   LIM
 
80
C
 
81
C     INTEGER   IK(8)
 
82
      INTEGER   K, K1
 
83
      INTEGER   L
 
84
      INTEGER   NK
 
85
      REAL      TEMP
 
86
      REAL      TRSH3
 
87
     
 
88
C
 
89
      LOGICAL   VOID
 
90
C
 
91
C *** Calculates averaged over octants profile AVPR.
 
92
C
 
93
      DO 5 K = 0 , MAXSUB
 
94
          IAPR(K) = 0
 
95
    5 CONTINUE
 
96
      AVPR(0) = PRFL(1,0)
 
97
      IAPR(0) = ICNT(1,0)
 
98
      DO 10 K = 1 , IHED
 
99
          NK = 0
 
100
          TEMP = 0.0
 
101
          DO 20 L = 1 , 8
 
102
              IF ( ICNT(L,K) .EQ. -1 ) THEN
 
103
                  IAPR(K) = -1
 
104
                  AVPR(K) = PRFL(L,K)
 
105
                  GOTO 30
 
106
              ELSE        
 
107
                  TEMP = TEMP + ICNT(L,K) * PRFL(L,K)
 
108
                  NK = NK + ICNT(L,K)
 
109
              ENDIF
 
110
   20     CONTINUE
 
111
          IF ( NK .GT. 0 ) THEN
 
112
              AVPR(K) = TEMP / NK
 
113
              IAPR(K) = NK
 
114
          ELSE
 
115
              AVPR(K) = 0.0
 
116
              IAPR(K) = 0
 
117
          ENDIF
 
118
   30     CONTINUE
 
119
   10 CONTINUE
 
120
C
 
121
C *** Check how many profile rings are significantly above
 
122
C *** the sky background. Two profile rings with average
 
123
C *** less than 0.3*TRSH are a condition for terminating
 
124
C *** the profile. Skip invalid central points first.
 
125
C
 
126
      TRSH3 = 0.3 * TRSH
 
127
      IF ( IAPR(0) .EQ. 0 ) THEN
 
128
          VOID = .TRUE.
 
129
      ELSE
 
130
          VOID = .FALSE.
 
131
      ENDIF
 
132
      K = 0
 
133
   50 CONTINUE
 
134
          K = K + 1
 
135
          IF ( VOID ) THEN
 
136
              IF ( IAPR(K) .EQ. 0 ) THEN
 
137
                  GOTO 50
 
138
              ELSE
 
139
                  VOID = .FALSE.
 
140
              ENDIF
 
141
          ENDIF
 
142
      IF ( ( K .LT. IHED )
 
143
     &     .AND.
 
144
     &     ( MAX( AVPR(K-1) , AVPR(K) ) .GT. TRSH3 )
 
145
     &     .AND.
 
146
     &     ( .NOT. ( ( AVPR(K) .GT. AVPR(K-1) )
 
147
     &               .AND.
 
148
     &               ( AVPR(K-1) .LT. TRSH3 )
 
149
     &               .AND.
 
150
     &               (IAPR(K-1) .GT. 0 ) ) )
 
151
     &    .AND.
 
152
     &    ( AVPR(K+1) .GT. (-TRSH) ) ) GOTO 50
 
153
C
 
154
C *** Number of significant profile rings is defined as LIM.
 
155
C
 
156
      IF ( VOID ) THEN
 
157
          LIM = 0
 
158
      ELSE
 
159
          LIM = MIN( IHED , K )
 
160
          LIM = MAX( LIM , 4 )
 
161
      ENDIF
 
162
C
 
163
C *** Find extend of saturation KSAT.
 
164
C
 
165
      L = -1
 
166
   60 CONTINUE
 
167
          L = L + 1
 
168
      IF ( IAPR(L) .EQ. -1 .OR. IAPR(L) .EQ. 0 ) GOTO 60
 
169
      KSAT = L - 1
 
170
C
 
171
C *** Find extend of non-cleaned profile.
 
172
C
 
173
c      L = KSAT
 
174
c   70 CONTINUE
 
175
c         L = L + 1
 
176
c      IF ( IAPR(L) .GT. 0 .AND. L .LT. LIM ) GOTO 70
 
177
c      KCLN = L - 1
 
178
c      IF ( KCLN . EQ. KSAT ) THEN
 
179
c          KCLN = 0
 
180
c      ENDIF
 
181
C
 
182
C *** Set the remaining values to zero.
 
183
C
 
184
      IF ( LIM .LT. MAXSUB ) THEN
 
185
          K1 = LIM + 1
 
186
          DO 80 L = K1 , MAXSUB
 
187
              AVPR(L) = 0.0
 
188
              IAPR(L) = 0
 
189
   80     CONTINUE
 
190
      ENDIF
 
191
C
 
192
      RETURN
 
193
C
 
194
      END
 
195
C