← Back to branch summary

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

« back to all changes in this revision

Viewing changes to contrib/invent/libsrc/rlgrnt.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/rlgrnt.for
 
1
C @(#)rlgrnt.for        19.1 (ES0-DMD) 02/25/03 13:25:38
 
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.IDENTIFICATION
 
31
C  subroutine RLGRNT         version 2.3       830916
 
32
C  A. Kruszewski             ESO Garching
 
33
C  modified                  version 2.4       870304
 
34
C  A. Kruszewski             Obs. de Geneve
 
35
C.KEYWORDS
 
36
C  profile gradient
 
37
C.PURPOSE
 
38
C  calculates gradient in an observed profile relative to the
 
39
C  standard stellar profile
 
40
C  this relative gradient should be close to zero for stars
 
41
C  negative for galaxies, and positive for majority of defects
 
42
C.ALGORYTHM
 
43
C  quantity  -LOG10(AVPR)-SPRF , or in other words, deviations of
 
44
C  an observed profile from the standard profile, is subjected to
 
45
C  the regression with respect to a ring number K expressed
 
46
C  in pixels
 
47
C  the coefficient of regression is accepted as relative gradient
 
48
C.INPUT/OUTPUT
 
49
C  input arguments
 
50
C  AVPR        real*4 array      observed one-dimensional profile
 
51
C  SPRF        real*4 array      cumulative standard profile
 
52
C  HHCUT       real*4            upper limit of usable data
 
53
C  TRSH        real*4            lower limiting treshold
 
54
C  output arguments
 
55
C  AVGR        real*4            relative gradient
 
56
C  SIGMA       real*4            sigma of single data point
 
57
C-----------------------------------------------------------------------
 
58
      SUBROUTINE RLGRNT(AVPR, SPRF, HHCUT, TRSH, AVGR, SIGMA)
 
59
C
 
60
      IMPLICIT  NONE
 
61
      INCLUDE  'MID_REL_INCL:INVENT.INC/NOLIST'
 
62
C
 
63
      REAL      AVPR(0:MAXSUB)
 
64
      REAL      SPRF(0:MAXSUB)
 
65
      REAL      HHCUT
 
66
      REAL      TRSH
 
67
      REAL      AVGR
 
68
      REAL      SIGMA
 
69
C
 
70
      INTEGER   K
 
71
      INTEGER   M1
 
72
      INTEGER   N, NN
 
73
      INTEGER   L
 
74
      REAL      ALIM, AMEAN
 
75
      REAL      BLIM
 
76
      REAL      GRSL
 
77
      REAL      ZRLV
 
78
      REAL      SGGR
 
79
      REAL      IC, ID
 
80
      INTEGER   IW(0:MAXSUB )
 
81
      REAL      X(0:MAXSUB), Y(0:MAXSUB)
 
82
      REAL      DVGR(0:MAXSUB)
 
83
      REAL      YY(MAXSUB+1)
 
84
C
 
85
      DO 10 K = 0 , MAXSUB
 
86
          IW(K) = 0
 
87
          X(K) = 0.0
 
88
          Y(K) = 0.0
 
89
   10 CONTINUE
 
90
      M1 = MAXSUB + 1
 
91
      DO 20 K = 1 , M1
 
92
          YY(K) = 0.0
 
93
   20 CONTINUE
 
94
      NN = 0
 
95
      BLIM = MIN( AVPR(0) , HHCUT )
 
96
      ALIM = MAX( 0.01*BLIM , 0.5*TRSH )
 
97
      L = 0
 
98
C
 
99
C ******      Select usable part of an observed profile.
 
100
C
 
101
   31 CONTINUE
 
102
          IF ( AVPR(L) .LT. ALIM .OR. L .GT. MAXSUB ) THEN
 
103
              N = L - 1
 
104
              GOTO 30
 
105
          ENDIF
 
106
          IF ( AVPR(L) .LT. HHCUT ) THEN
 
107
              X(L) = FLOAT(L)
 
108
              Y(L) = -ALOG10( AVPR(L) ) - SPRF(L)
 
109
              IW(L) = 1
 
110
              NN = NN + 1
 
111
              YY(NN) = Y(L)
 
112
          ELSE
 
113
              IW(L) = 0
 
114
          ENDIF
 
115
          L = L + 1
 
116
          GOTO 31
 
117
   30 CONTINUE
 
118
C
 
119
C ******      Calculate root mean square deviation SIGMA of used data.
 
120
C
 
121
      IF ( NN .GT. 1 ) THEN
 
122
          CALL MEAN( YY , NN , AMEAN , SIGMA )
 
123
      ELSE
 
124
          SIGMA = 1.0
 
125
      ENDIF
 
126
C
 
127
C ******      Calculate first approximation for relative gradient.
 
128
C
 
129
      IF ( NN .GE. 2 ) THEN
 
130
          CALL GRADET( L , X , Y , IW , AVGR , ZRLV , DVGR , SGGR )
 
131
          IF ( NN .EQ. 2 ) THEN
 
132
              IC = 0
 
133
              SGGR = 1.0
 
134
          ELSE
 
135
              IC = 3
 
136
          ENDIF
 
137
      ELSE
 
138
          AVGR = 1.0
 
139
          SGGR = 1.0
 
140
          IC = 0
 
141
      ENDIF
 
142
C
 
143
C ******      Repeat calculations after rejecting
 
144
C ******      points deviating more than 1.4*SGGR.
 
145
C
 
146
   41 CONTINUE
 
147
      IF ( IC .EQ. 0 ) GOTO 40
 
148
          GRSL = 1.4 * SGGR
 
149
          NN = 0
 
150
          ID = 0
 
151
          DO 50 L = 0 , N
 
152
              IF ( IW(L) .EQ. 1 ) THEN
 
153
                  IF ( ABS( DVGR(L) ) .GT. GRSL ) THEN
 
154
                      IW(L) = 0
 
155
                      ID = ID + 1
 
156
                  ELSE
 
157
                      NN = NN + 1
 
158
                  ENDIF
 
159
              ENDIF
 
160
   50     CONTINUE
 
161
          IF ( ID .EQ. 0 .OR. NN .LT. 2 ) THEN
 
162
              IC = 0
 
163
          ELSE
 
164
              CALL GRADET( MAXSUB , X , Y , IW , AVGR ,
 
165
     &                                    ZRLV , DVGR , SGGR )
 
166
              IF ( NN .GT. 2 ) THEN
 
167
                  IC = IC - 1
 
168
              ELSE 
 
169
                  IC = 0
 
170
                  SGGR = 1.0
 
171
              ENDIF
 
172
          ENDIF
 
173
          GOTO 41
 
174
   40 CONTINUE
 
175
C
 
176
      RETURN
 
177
      END