← Back to branch summary

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

« back to all changes in this revision

Viewing changes to stdred/irspec/src/irstilt.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/irspec/src/irstilt.for
 
1
C @(#)irstilt.for       19.1 (ES0-DMD) 02/25/03 14:23:43
 
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.COPYRIGHT   (C) 1992 European Southern Observatory
 
32
C.IDENT       .for
 
33
C.AUTHOR      E. Oliva,  Firenze-Arcetri
 
34
C.KEYWORDS    Spectroscopy, IRSPEC
 
35
C
 
36
C.PURPOSE     Execute command  ...
 
37
C
 
38
C.ALGORITHM
 
39
C
 
40
C
 
41
C.INPUT/OUTPUT
 
42
C
 
43
C
 
44
C.VERSION     1.0    Creation     02.09.1992   E. Oliva
 
45
C
 
46
C-------------------------------------------------------
 
47
C
 
48
      PROGRAM TILT
 
49
      IMPLICIT REAL(A-H,O-Z)
 
50
      IMPLICIT INTEGER(I-N)
 
51
 
 
52
      CHARACTER*60 FRAMEI,FRAMEO
 
53
      CHARACTER*64 CUNIT
 
54
      CHARACTER*72 IDENT
 
55
      INTEGER*8 INPNTR,OUPNTR
 
56
      INTEGER NPIX(2)
 
57
      DOUBLE PRECISION START(2),STEP(2),DCW
 
58
      DIMENSION GRARUL(2)
 
59
      COMMON/ISTPAR/COSG_SIG(2),SING0,CSI0
 
60
      COMMON /VMR/ MADRID(1)
 
61
 
 
62
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
 
63
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
 
64
 
 
65
      DATA MAXDIM/2/
 
66
 
 
67
      IRET=1
 
68
      CALL STSPRO('TILT')
 
69
C
 
70
C GET NAME OF INPUT FRAME AND MAP IT
 
71
C
 
72
      CALL STKRDC('framei',1,1,60,IRET,FRAMEI,KUNIT,KNUL,ISTAT)
 
73
      CALL CLNFRA(FRAMEI,FRAMEI,0)
 
74
      CALL STIGET(FRAMEI,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,MAXDIM,
 
75
     ,          NAXIS,NPIX,START,STEP,
 
76
     ,          IDENT,CUNIT,INPNTR,NIN,ISTAT)
 
77
      IF(NAXIS.NE.2) 
 
78
     +     CALL STETER(1,'Input frame must be 2-D')
 
79
C
 
80
C GET NAME OF OUTPUT FRAME AND MAP IT 
 
81
C
 
82
      CALL STKRDC('frameo',1,1,60,IRET,FRAMEO,KUNIT,KNUL,ISTAT)
 
83
      CALL CLNFRA(FRAMEO,FRAMEO,0)
 
84
      CALL STIPUT(FRAMEO,D_R4_FORMAT,F_O_MODE,F_IMA_TYPE,
 
85
     ,          NAXIS,NPIX,START,STEP,
 
86
     ,          IDENT,CUNIT,OUPNTR,NOU,ISTAT)
 
87
C
 
88
C Get values of gamma0,csi0,grarul
 
89
C and compute COSG_SIG(1:2)=cos(gamma0)*1000/grarul
 
90
C             SING0=sin(gamma0)
 
91
C
 
92
      CALL STKRDR('Igamma0',1,1,IRET,GAMMA0,KUNIT,KNUL,ISTAT)
 
93
      SING0=SIN(GAMMA0)
 
94
      CALL STKRDR('Igrarul',1,2,IRET,GRARUL,KUNIT,KNUL,ISTAT)
 
95
      DO I=1,2
 
96
        COSG_SIG(I)=COS(GAMMA0)*1000/GRARUL(I)
 
97
      ENDDO
 
98
      CALL STKRDR('Icsi0',1,1,IRET,R4,KUNIT,KNUL,ISTAT)
 
99
      CSI0=R4
 
100
C
 
101
C Get key which contain the reference row # (i.e. the #
 
102
C of the row which is left untouched
 
103
C
 
104
      CALL STKRDI('rowref',1,1,IRET,IRREF,KUNIT,KNUL,ISTAT)
 
105
C
 
106
C GET NAME OF KEY WHICH MIGHT CONTAIN THE VALUE OF THE TANGENT
 
107
C OF THE TILT ANGLE (CSI) ENTERED BY THE USER.
 
108
C IF = 0 TAKE THE VALUES OF CW, C GRAT # AND ORDER # C FROM THE 
 
109
C FILE DESCRIPTORS AND COMPUTE CSI ACCORDING TO THE PROPER 
 
110
C FORMULA (SEE FUNCTION VALUE_TILT).
 
111
C
 
112
      CALL STKRDR('angle',1,1,IRET,CSI,KUNIT,KNUL,ISTAT)
 
113
C
 
114
C Get values of grating#
 
115
C               order#
 
116
C               center wavelength
 
117
C
 
118
      IF(CSI.EQ.0.) THEN
 
119
        CALL STKRDI('ngrat',1,1,IRET,IGRAT,KUNIT,KNUL,ISTAT)
 
120
        CALL STKRDI('order',1,1,IRET,IORDER,KUNIT,KNUL,ISTAT)
 
121
        CALL STKRDD('wlcen',1,1,IRET,DCW,KUNIT,KNUL,ISTAT)
 
122
        CW=DCW
 
123
        CSI=VALUE_TILT(CW,IGRAT,IORDER)
 
124
      ENDIF
 
125
C
 
126
C CALL ROUTINE WHICH CORRECT SLIT TILT BY MEANS OF LINEAR REBINNING 
 
127
C ROW BY ROW.
 
128
C
 
129
      CALL RECTIFY(MADRID(INPNTR),MADRID(OUPNTR),
 
130
     ,           NPIX(1),NPIX(2),CSI,IRREF)
 
131
C
 
132
C RELEASE FILES, UPDATE KEYWORDS AND EXIT
 
133
C
 
134
      CALL STSEPI
 
135
      END
 
136
C
 
137
C
 
138
C
 
139
      SUBROUTINE RECTIFY(A,B,NX,NY,CSI,IRREF)
 
140
C
 
141
C RECTIFY THE SLIT, I.E. LEAVE THE SCAN-LINE #IRREF OF THE
 
142
C IMAGE UNTOUCHED AND SHIFT (=LINEAR REBIN....) THE OTHERS
 
143
C BY CSI*DISTANCE FROM CENTRAL COLUMN.
 
144
C
 
145
      IMPLICIT REAL(A-H,O-Z)
 
146
      IMPLICIT INTEGER(I-N)
 
147
 
 
148
      DIMENSION A(NX,NY),B(NX,NY)
 
149
C
 
150
C SET OUTPUT IMAGE TO ZERO
 
151
C
 
152
      DO J=1,NY
 
153
        DO I=1,NX
 
154
          B(I,J)=0.0
 
155
        ENDDO
 
156
      ENDDO
 
157
C
 
158
      ICROW=IRREF
 
159
      DO IY=1,NY
 
160
        SHIFT=CSI*FLOAT(ICROW-IY)
 
161
        DO IX=1,NX
 
162
          A1=FLOAT(IX)+SHIFT
 
163
          IA1=AINT(A1)
 
164
          IF(A1.LT.0.) IA1=IA1-1
 
165
          IF(IA1.LT.1) THEN
 
166
            B(IX,IY)=A(1,IY)
 
167
            GO TO 10
 
168
          ENDIF
 
169
          IF(IA1.GT.(NX-1)) THEN
 
170
            B(IX,IY)=A(NX,IY)
 
171
            GO TO 10
 
172
          ENDIF
 
173
          W1=1-A1+FLOAT(IA1)
 
174
          IA2=IA1+1
 
175
          W2=1.-W1
 
176
          X1=A(IA1,IY)
 
177
          X2=A(IA2,IY)
 
178
          B(IX,IY)=W1*X1+W2*X2
 
179
10        CONTINUE
 
180
        ENDDO
 
181
      ENDDO
 
182
C
 
183
      RETURN
 
184
      END
 
185
C
 
186
C
 
187
      FUNCTION VALUE_TILT(WAVE,NGRAT,IORDER)
 
188
C
 
189
      IMPLICIT REAL(A-H,O-Z)
 
190
      IMPLICIT INTEGER(I-N)
 
191
 
 
192
      COMMON/ISTPAR/COSG_SIG(2),SING0,CSI0
 
193
      CHARACTER*80 OUTPUT
 
194
 
 
195
      ORDER=IORDER
 
196
      CSI=TAN
 
197
     +(ATAN(2.*SING0/SQRT((2.*COSG_SIG(NGRAT)/ORDER/WAVE)**2-1.))-CSI0)
 
198
      WRITE(OUTPUT,100) CSI
 
199
100   FORMAT('Assumed value of tan(tilt) : ',F7.4)
 
200
      CALL STTPUT(OUTPUT,ISTAT)
 
201
      VALUE_TILT=CSI
 
202
      RETURN
 
203
      END