← Back to branch summary

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

« back to all changes in this revision

Viewing changes to stdred/echelle/src/necripcor.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:
stdred/echelle/src/necripcor.for
 
1
C @(#)necripcor.for     19.1 (ESO-DMD) 02/25/03 14:20:25
 
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 Massachusetts Ave, Cambridge, 
 
18
C MA 02139, USA.
 
19
C
 
20
C Correspondence 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.COPYRIGHT: Copyright (c) 1991 European Southern Observatory,
 
32
C                                         all rights reserved
 
33
C
 
34
C.VERSION: 1.0          23-JULY-1991
 
35
C
 
36
C.LANGUAGE: F77+ESOext
 
37
C
 
38
C.AUTHOR: P.BALLESTER
 
39
C
 
40
C.IDENTIFICATION
 
41
C
 
42
C.KEYWORDS
 
43
C
 
44
C  ECHELLE, CASPEC, BLAZE FUNCTION
 
45
C
 
46
C.PURPOSE
 
47
C
 
48
C  compute the ECHELLE constants to set successive orders at the same level
 
49
C
 
50
C.ALGORITHM
 
51
C
 
52
C  IN DEVELOPMENT ...
 
53
C
 
54
C.VERSION
 
55
C 
 
56
C 010706                last modif
 
57
C C 
 
58
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
59
 
 
60
      PROGRAM RIPPLE
 
61
 
 
62
      IMPLICIT  NONE
 
63
 
 
64
      INTEGER   NAXISA,NPIXA(2),IAV,STAT,ACTVAL,MAXORD
 
65
      INTEGER   IMNOA
 
66
      INTEGER   KNULL,KUNIT(1),BOUND(3)
 
67
      INTEGER   MADRID(1)
 
68
C 
 
69
      INTEGER*8   PNTRA
 
70
C
 
71
      PARAMETER (MAXORD=500)
 
72
C
 
73
      CHARACTER FRAMEA*60
 
74
      CHARACTER CUNIT*64,IDENTA*72
 
75
C
 
76
      INTEGER          NPTOT(MAXORD)
 
77
      INTEGER          ORDSTA(MAXORD),ORDEND(MAXORD)
 
78
C 
 
79
      REAL             CONST(MAXORD)
 
80
C 
 
81
      DOUBLE PRECISION STEPA(2),STARTA(2),WSTART(MAXORD)
 
82
C 
 
83
      INCLUDE 'MID_INCLUDE:st_def.inc'
 
84
      COMMON /VMR/ MADRID
 
85
      INCLUDE 'MID_INCLUDE:st_dat.inc'
 
86
C
 
87
      CALL STSPRO('RIPPLE')
 
88
      CALL STKRDC('IN_A',1,1,60,IAV,FRAMEA,KUNIT,KNULL,STAT)
 
89
 
 
90
      CALL STIGET(FRAMEA,D_R4_FORMAT,F_IO_MODE,F_IMA_TYPE,
 
91
     +            2,NAXISA,NPIXA,STARTA,STEPA,IDENTA,CUNIT,
 
92
     +            PNTRA,IMNOA,STAT)
 
93
 
 
94
      IF (NPIXA(2).LT.MAXORD) THEN
 
95
          CALL STDRDD(IMNOA,'WSTART',1,NPIXA(2),ACTVAL,WSTART,
 
96
     +                                       KUNIT,KNULL,STAT)
 
97
          CALL STDRDI(IMNOA,'NPTOT',1,NPIXA(2),ACTVAL,NPTOT,
 
98
     +                                       KUNIT,KNULL,STAT)
 
99
          CALL STDRDI(IMNOA,'ORDSTA',1,NPIXA(2),ACTVAL,ORDSTA,
 
100
     +                                       KUNIT,KNULL,STAT)
 
101
          CALL STDRDI(IMNOA,'ORDEND',1,NPIXA(2),ACTVAL,ORDEND,
 
102
     +                                       KUNIT,KNULL,STAT)
 
103
      ELSE
 
104
          CALL STETER(10,'Buffer overflow in RIPPLE.')
 
105
      ENDIF
 
106
 
 
107
      CALL STKRDI('INPUTI',1,3,IAV,BOUND,KUNIT,KNULL,STAT)
 
108
 
 
109
      CALL NORM(MADRID(PNTRA),NPIXA(1),NPIXA(2),STARTA(1),STEPA(1),
 
110
     +            WSTART,BOUND,CONST,ORDSTA,ORDEND)
 
111
 
 
112
      CALL STSEPI
 
113
 
 
114
      END
 
115
 
 
116
C ======================Normalization Routine====================
 
117
 
 
118
      SUBROUTINE NORM(INPFRAM,NX,NY,START,STEP,
 
119
     +                WST,BOUND,CONST,ORDSTA,ORDEND)
 
120
 
 
121
      IMPLICIT   NONE
 
122
 
 
123
      INTEGER    NX,NY,BOUND(3),ROW,COL
 
124
      INTEGER    PIXSTA,PIXEND,NPIX,MIDORD
 
125
      INTEGER    ORDSTA(NY),ORDEND(NY)
 
126
 
 
127
      REAL       INPFRAM(NX,NY)
 
128
 
 
129
      REAL       SN,SN1,CONST(NY),FACTOR
 
130
 
 
131
      DOUBLE PRECISION  WST(NY),START,STEP,LAMBST,LAMBED
 
132
 
 
133
 
 
134
C --- LOOP ON ORDERS
 
135
 
 
136
      DO 10 ROW = 1,(NY-1)
 
137
 
 
138
 
 
139
C ---    Determine lambda start, lambda end and pixel width in overlap.
 
140
 
 
141
         PIXSTA = ORDSTA(ROW+1) + BOUND(1) + 1
 
142
         LAMBST = WST(ROW+1)+(PIXSTA-1)*STEP      !  Lambda Start
 
143
 
 
144
         PIXEND = ORDEND(ROW) - BOUND(2)
 
145
         LAMBED = WST(ROW)+(PIXEND-1)*STEP        !  Lambda End
 
146
 
 
147
         NPIX   = (LAMBED-LAMBST)/STEP ! Assume linear step in wavelength
 
148
C         TYPE*,'Order, nb pix., delta wav.',ROW,NPIX,LAMBST,LAMBED
 
149
 
 
150
C ---    Estimate normalization constant.
 
151
 
 
152
         SN  = 0.
 
153
         SN1 = 0.
 
154
 
 
155
         DO 40 COL = PIXEND , PIXEND-NPIX, -1
 
156
               SN = SN + INPFRAM(COL,ROW)
 
157
40       CONTINUE
 
158
 
 
159
         DO 50 COL = PIXSTA, PIXSTA+NPIX
 
160
               SN1 = SN1 + INPFRAM(COL,ROW+1)
 
161
50       CONTINUE
 
162
 
 
163
         CONST(ROW) = SN1/SN
 
164
 
 
165
10    CONTINUE
 
166
 
 
167
 
 
168
C --- Constant for the central order is set to 1. and the frames 
 
169
C --- are normalized.
 
170
 
 
171
      CONST(NY) = 1.0
 
172
 
 
173
      DO 90 ROW = NY-1,1,-1
 
174
 
 
175
         CONST(ROW) = CONST(ROW)*CONST(ROW+1)
 
176
 
 
177
90    CONTINUE
 
178
 
 
179
      MIDORD = NY/2
 
180
      FACTOR = CONST(MIDORD)
 
181
 
 
182
      DO 60 ROW = 1,NY
 
183
 
 
184
         CONST(ROW) = CONST(ROW)/FACTOR
 
185
C         TYPE*,'Order,const.',ROW,CONST(ROW)
 
186
 
 
187
60    CONTINUE
 
188
 
 
189
      DO 70  ROW = 1,NY
 
190
 
 
191
         PIXSTA = ORDSTA(ROW) + BOUND(1) + 1
 
192
         PIXEND = ORDEND(ROW) - BOUND(2)
 
193
 
 
194
         DO 75  COL = 1 , PIXSTA-1
 
195
 
 
196
             INPFRAM(COL,ROW) = 0.
 
197
 
 
198
75       CONTINUE
 
199
 
 
200
         DO 80  COL = PIXSTA,PIXEND
 
201
 
 
202
             INPFRAM(COL,ROW) = INPFRAM(COL,ROW) * CONST(ROW)
 
203
 
 
204
80       CONTINUE
 
205
 
 
206
         DO 85 COL = PIXEND+1,NX
 
207
 
 
208
             INPFRAM(COL,ROW) = 0.
 
209
 
 
210
85       CONTINUE
 
211
 
 
212
70    CONTINUE
 
213
 
 
214
      RETURN
 
215
      END