← Back to branch summary

~ubuntu-branches/ubuntu/wily/eso-midas/wily-proposed

« back to all changes in this revision

Viewing changes to contrib/invent/libsrc/smtpsf.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/smtpsf.for
 
1
C @(#)smtpsf.for        19.1 (ES0-DMD) 02/25/03 13:25:39
 
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
 
32
C
 
33
C
 
34
C-----------------------------------------------------------------------
 
35
      SUBROUTINE SMTPSF(LPXL, LSBP, LL, CPSF, DPSF,
 
36
     &                  IPSF, INZ, NN, SIGMA, I,
 
37
     &                  J, K, L, AMAG, GRI,
 
38
     &                  GRJ)
 
39
C
 
40
      IMPLICIT  NONE
 
41
C
 
42
      INTEGER   LPXL
 
43
      INTEGER   LSBP
 
44
      INTEGER   LL
 
45
      REAL      CPSF((-LL):LL,(-LL):LL)
 
46
      REAL      DPSF((-LL):LL,(-LL):LL)
 
47
      INTEGER   IPSF((-LSBP):LSBP,(-LSBP):LSBP)
 
48
      INTEGER   INZ
 
49
      INTEGER   NN
 
50
      REAL      SIGMA
 
51
      INTEGER   I
 
52
      INTEGER   J
 
53
      INTEGER   K
 
54
      INTEGER   L
 
55
      REAL      AMAG
 
56
      REAL      GRI
 
57
      REAL      GRJ
 
58
C
 
59
      INTEGER   MSBP, MSBP2
 
60
      INTEGER   MPXL, MPXL2
 
61
      INTEGER   II, II1, II2, III
 
62
      INTEGER   IC, ISTEP, ITMP
 
63
      INTEGER   NJ, NI
 
64
      INTEGER   LLL
 
65
      INTEGER   KKK     
 
66
      INTEGER   JJ, JJ1, JJ2, JJJ
 
67
      REAL      DI, DJ
 
68
C
 
69
      DOUBLE PRECISION   COEF(6,6) , S(6) , TEMP , TMP(6) , X(6)
 
70
C
 
71
      IF ( NN .LT. 7 ) THEN
 
72
          AMAG = 0.0
 
73
          GRI = 0.0
 
74
          GRJ = 0.0
 
75
          RETURN
 
76
      ENDIF
 
77
      MSBP = 2 * LSBP + 1
 
78
      MPXL = 2 * LPXL + 1
 
79
      MSBP2 = MSBP * MSBP
 
80
      MPXL2 = MPXL * MPXL
 
81
      ISTEP = MAX( 2 , NINT( ( SIGMA / 0.04 ) *
 
82
     &                       SQRT(FLOAT(MSBP2*MPXL2)/FLOAT(NN)) ) )
 
83
      II = I * MSBP - K
 
84
      JJ = J * MSBP - L
 
85
      IF ( DPSF(II,JJ) .LT. 0.01 ) THEN
 
86
          AMAG = CPSF(II,JJ)
 
87
          RETURN
 
88
      ENDIF
 
89
   71 CONTINUE
 
90
      DO 10 NJ = 1 , 6
 
91
          DO 20 NI = 1 , 6
 
92
              COEF(NI,NJ) = 0.0
 
93
   20     CONTINUE
 
94
   10 CONTINUE
 
95
   70 CONTINUE
 
96
          II1 = MAX( -LL , II-ISTEP )
 
97
          II2 = MIN( LL , II+ISTEP )
 
98
          IF ( II1 .EQ. -LL .AND. II2-II1 .LE. 2 ) THEN
 
99
              II2 = II1 + 3
 
100
          ENDIF
 
101
          IF ( II2 .EQ. LL .AND. II2-II1 .LE. 2 ) THEN
 
102
              II1 = II2 - 3
 
103
          ENDIF
 
104
          JJ1 = MAX( -LL , JJ-ISTEP )
 
105
          JJ2 = MIN( LL , JJ+ISTEP )
 
106
          IF ( JJ1 .EQ. -LL .AND. JJ2-JJ1 .LE. 2 ) THEN
 
107
              JJ2 = JJ1 + 3
 
108
          ENDIF
 
109
          IF ( JJ2 .EQ. LL .AND. JJ2-JJ1 .LE. 2 ) THEN
 
110
              JJ1 = JJ2 - 3
 
111
          ENDIF
 
112
          IC = 0
 
113
          DO 30 JJJ = JJ1 , JJ2
 
114
              IF ( JJJ .LT. 0 ) THEN
 
115
                  LLL = MOD( JJJ-LSBP , MSBP ) + LSBP
 
116
              ELSE IF ( JJJ .EQ. 0 ) THEN
 
117
                  LLL = 0
 
118
              ELSE
 
119
                  LLL = MOD( JJJ+LSBP , MSBP ) - LSBP
 
120
              ENDIF
 
121
              DO 40 III = II1 , II2
 
122
                  IF ( III .LT. 0 ) THEN
 
123
                      KKK = MOD( III-LSBP , MSBP ) + LSBP
 
124
                  ELSE IF ( III .EQ. 0 ) THEN
 
125
                      KKK = 0
 
126
                  ELSE
 
127
                      KKK = MOD( III+LSBP , MSBP ) - LSBP
 
128
                  ENDIF
 
129
                  ITMP = IPSF(KKK,LLL)
 
130
                  IF ( ITMP .GT. 0 ) THEN
 
131
                      TEMP = SQRT( DBLE( ITMP ) )
 
132
                      IC = IC + 1
 
133
                      DI = DBLE(III-II)
 
134
                      DJ = DBLE(JJJ-JJ)
 
135
                      TMP(1) = 1.0 * TEMP
 
136
                      TMP(2) = DI * TEMP
 
137
                      TMP(3) = DJ * TEMP
 
138
                      TMP(4) = DI * DI * TEMP
 
139
                      TMP(5) = DJ * DJ * TEMP
 
140
                      TMP(6) = DBLE( CPSF(III,JJJ) ) * TEMP
 
141
                      DO 50 NJ = 1 , 6
 
142
                          DO 60 NI = NJ , 6
 
143
                              COEF(NI,NJ) = COEF(NI,NJ) +
 
144
     &                                      TMP(NI) * TMP(NJ)
 
145
   60                     CONTINUE
 
146
   50                 CONTINUE
 
147
                  ENDIF
 
148
   40         CONTINUE
 
149
   30     CONTINUE
 
150
          IF ( IC .LT. 7 .AND. ISTEP .LE. LL/4 ) THEN
 
151
              ISTEP = ISTEP + 1
 
152
              GOTO 70
 
153
          ENDIF
 
154
      CONTINUE
 
155
      IF ( IC .GE. 7 ) THEN
 
156
          CALL LSQSOL( 6 , COEF , IC , X , S )
 
157
          IF ( SNGL(S(1)) .GT. 0.05 .AND. ISTEP .LE. LL/4 ) THEN
 
158
              ISTEP = ISTEP + 1
 
159
              GOTO 71
 
160
          ELSE
 
161
              AMAG = SNGL(X(1))
 
162
              GRI = SNGL(X(2)) * FLOAT(MSBP)
 
163
              GRJ = SNGL(X(3)) * FLOAT(MSBP)
 
164
          ENDIF
 
165
      ELSE
 
166
          AMAG = CPSF(II,JJ)
 
167
          GRI = 0.0
 
168
          GRJ = 0.0
 
169
      ENDIF
 
170
C
 
171
      RETURN
 
172
C
 
173
      END
 
174
C