← Back to branch summary

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

« back to all changes in this revision

Viewing changes to contrib/iue/libsrc/isthig.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/iue/libsrc/isthig.for
 
1
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
2
C.IDENTIFICATION        ISTHIG.FOR
 
3
C.AUTHOR:               J.D.PONZ  ESA-VILSPA        
 
4
C.KEYWORDS              IUE, GO FORMAT, HIGH DISPERSION SPECTRUM
 
5
C.ENVIRONMENT           MIDAS, IUE context
 
6
C.PURPOSE
 
7
C \begin{TeX}
 
8
C   Reads High dispersion MEHI file from tape.
 
9
C   The routine performs the following functions (routine names in brackets):
 
10
C   \begin{enumerate}
 
11
C   \item Handles the file header (ISTFHD)
 
12
C   \item Creates the MIDAS table file on disk (TBTINI)
 
13
C   \item Creates the table columns (TBCINI)
 
14
C   \item Iterates on orders to 
 
15
C      \begin{itemize}
 
16
C         \item Read wavelength record (ISTREA)
 
17
C         \item Decode wavelengths
 
18
C         \item Write the wavelengths into the table (TBEWRR)
 
19
C         \item Read epsilon record (ISTREA)
 
20
C         \item Decode epsilon
 
21
C         \item Write the epsilon values into the table (TBEWRR)
 
22
C         \item Read/decode/write the extracted spectra
 
23
C               (Gross, background, net, 
 
24
C               ripple-corrected net and absolute flux)
 
25
C         \item Write the spectral order number
 
26
C       \end{itemize}
 
27
C    \item Writes IUE specific descriptors (ISTDES)
 
28
C    \item Closes the table file (TBTCLO)
 
29
C \end{enumerate}
 
30
C \end{TeX}
 
31
C   
 
32
C.LANGUAGE:             F77 
 
33
C.COMMENTS
 
34
C \begin{TeX}
 
35
C   The following extensions are used:
 
36
C   \begin{itemize}
 
37
C     \item IMPLICIT NONE
 
38
C     \item INCLUDE statement
 
39
C     \item Long variable names
 
40
C     \item Underscore character
 
41
C   \end{itemize}
 
42
C \end{TeX}
 
43
C.VERSION: 1.0  9 Jul 1991. Initial coding.
 
44
C.VERSION: 1.1  27 Nov 1991. Include variable number of records per group.
 
45
C.VERSION: 1.2  29 Nov 1991. Warning when Calibrated spectrum not present.
 
46
C.VERSION: 1.3  14 APR 1992. Remove VMS extensions
 
47
C------------------------------------------------------------------
 
48
      SUBROUTINE ISTHIG(CHANL,BUFF,FILE,DSKFMT,K,KORD,NRECO,NBYTE,
 
49
     .                  DSPFLG,STATUS)
 
50
C
 
51
      IMPLICIT NONE
 
52
      INTEGER       CHANL             ! IN: tape channel number
 
53
      CHARACTER*(*) BUFF              ! IN: buffer with the ascii header
 
54
      CHARACTER*(*) FILE              ! IN: file name
 
55
      INTEGER       DSKFMT            ! IN: file format (-1 no file)
 
56
      INTEGER       K                 ! IN: number of orders requested
 
57
      INTEGER       KORD(1)           ! IN: actual orders requested
 
58
      INTEGER       NRECO             ! IN: number of records
 
59
      INTEGER       NBYTE             ! IN: number of bytes per record
 
60
      INTEGER       DSPFLG            ! IN: display flag
 
61
      INTEGER       STATUS            ! OUT: status
 
62
C
 
63
      INTEGER I, LEN, NROW, TID, IROW, IVAL, IVALUE
 
64
      INTEGER JG, KG, JB, KB, JN, KN, JF, KF, IC, JR, KR
 
65
      INTEGER NORD, IPREV, JORDER, M, INUM, LAMB, IACT
 
66
      INTEGER NRECPO
 
67
      INTEGER    BBUFF(1024), BZERO(1024)
 
68
      INTEGER    IZERO(1024)
 
69
      INTEGER    IBUFF(1024), LAMB0(100), IORD(100), NVAL(100)
 
70
      REAL    VALUE, SCG, SCB, SCN, SCR, SCF
 
71
      CHARACTER*16 LLABEL,ELABEL,GLABEL,BLABEL,NLABEL,FLABEL
 
72
      CHARACTER*16 RLABEL, RUNIT, OLABEL, OUNIT
 
73
      CHARACTER*16 LUNIT,EUNIT,GUNIT,BUNIT,NUNIT,FUNIT
 
74
      CHARACTER*8  LFORM,EFORM,GFORM,BFORM,NFORM,FFORM,RFORM
 
75
      CHARACTER*8  OFORM
 
76
C
 
77
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
 
78
      EQUIVALENCE (BBUFF, IBUFF)
 
79
      EQUIVALENCE (BZERO, IZERO)
 
80
      EQUIVALENCE (IZERO(103), LAMB0(1))
 
81
      EQUIVALENCE (IZERO(203), IORD(1))
 
82
      EQUIVALENCE (IZERO(303), NVAL(1))
 
83
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
 
84
C
 
85
      DATA LLABEL/'WAVELENGTH'/,ELABEL/'EPSILON'/
 
86
      DATA GLABEL/'GROSS'/,     BLABEL/'BACKGROUND'/
 
87
      DATA NLABEL/'NET'/,       RLABEL/'RNET'/
 
88
      DATA OLABEL/'ORDER'/, FLABEL/'FLUX'/
 
89
      DATA LUNIT/'ANGSTROM'/, EUNIT/'UNITLESS'/
 
90
      DATA GUNIT/'FN'/,       BUNIT/'FN'/
 
91
      DATA NUNIT/'FN'/,       RUNIT/'FN'/
 
92
      DATA FUNIT/'ERGS/CM2/A'/, OUNIT/'UNITLESS'/
 
93
      DATA LFORM/'F8.3'/, EFORM/'I5'/, OFORM/'I4'/
 
94
      DATA GFORM/'E12.4'/
 
95
      DATA BFORM/'E12.4'/
 
96
      DATA NFORM/'E12.4'/
 
97
      DATA RFORM/'E12.4'/
 
98
      DATA FFORM/'E12.4'/
 
99
C
 
100
      STATUS = 0
 
101
C
 
102
C ... decode full header, print it and put info in common area
 
103
C
 
104
      CALL ISTFHD(CHANL,BUFF,DSPFLG,STATUS)
 
105
      IF (STATUS.NE.0) RETURN
 
106
      IF (DSKFMT.LT.0) RETURN        ! only displays header
 
107
C
 
108
C ... reads record zero
 
109
C
 
110
      CALL ISTRHW(CHANL,BZERO,NBYTE,LEN,STATUS)
 
111
      IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
 
112
C
 
113
C ... extracts useful info
 
114
C
 
115
      NORD   = IZERO(5)
 
116
      NRECPO = IZERO(8)
 
117
      JG   = IZERO(23)
 
118
      KG   = IZERO(24)
 
119
      JB   = IZERO(27)
 
120
      KB   = IZERO(28)
 
121
      JN   = IZERO(31)
 
122
      KN   = IZERO(32)
 
123
      JR   = IZERO(35)
 
124
      KR   = IZERO(36)
 
125
      JF   = IZERO(67)
 
126
      KF   = IZERO(68)  
 
127
      SCG  = JG/(2.**KG)
 
128
      SCB  = JB/(2.**KB)
 
129
      SCN  = JN/(2.**KN)
 
130
      SCR  = JR/(2.**KR)
 
131
      SCF  = JF/(2.**KF)
 
132
      IF (NRECPO.LT.6.OR.NRECPO.GT.7) THEN
 
133
          STATUS = 1
 
134
          RETURN
 
135
      ELSE
 
136
          IF (NRECPO.EQ.6) THEN
 
137
            CALL STTPUT('*** Calibrated flux not present ***',STATUS)
 
138
            CALL STTPUT('*** Output flux set to zero ***',STATUS)
 
139
          ENDIF
 
140
      ENDIF
 
141
C
 
142
C ... finds orders and number of samples
 
143
C
 
144
      NROW = 0
 
145
      DO 6 I = 1, NORD
 
146
         NROW = NROW + NVAL(I)   ! CHECK ORDER SELECTION
 
147
 6    CONTINUE
 
148
C
 
149
C ... create the table file and columns
 
150
C
 
151
      CALL TBTINI(FILE,F_TRANS,F_O_MODE,10,NROW,TID,STATUS)
 
152
      IF (STATUS.NE.0) RETURN
 
153
      CALL TBCINI(TID,D_R4_FORMAT,1,LFORM,LUNIT,LLABEL,IC,STATUS)
 
154
      CALL TBCINI(TID,D_I4_FORMAT,1,EFORM,EUNIT,ELABEL,IC,STATUS)
 
155
      CALL TBCINI(TID,D_R4_FORMAT,1,GFORM,GUNIT,GLABEL,IC,STATUS)
 
156
      CALL TBCINI(TID,D_R4_FORMAT,1,BFORM,BUNIT,BLABEL,IC,STATUS)
 
157
      CALL TBCINI(TID,D_R4_FORMAT,1,NFORM,NUNIT,NLABEL,IC,STATUS)
 
158
      CALL TBCINI(TID,D_R4_FORMAT,1,RFORM,RUNIT,RLABEL,IC,STATUS)
 
159
      CALL TBCINI(TID,D_R4_FORMAT,1,FFORM,FUNIT,FLABEL,IC,STATUS)
 
160
      CALL TBCINI(TID,D_I4_FORMAT,1,OFORM,OUNIT,OLABEL,IC,STATUS)
 
161
C
 
162
C ... iteration on orders
 
163
C
 
164
      IPREV = 1
 
165
      DO 100 JORDER = 1, NORD
 
166
         IROW = IPREV
 
167
         M    = IORD(JORDER)
 
168
         INUM = NVAL(JORDER)
 
169
         LAMB = LAMB0(JORDER)
 
170
C
 
171
C ... scaled wavelengths
 
172
C
 
173
         CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)
 
174
         IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
 
175
         IROW = IPREV
 
176
         IVAL = 3
 
177
         IACT = 1
 
178
         IC   = 1
 
179
         DO 10 I = 5, NBYTE, 2
 
180
            VALUE      = LAMB+0.002*IBUFF(IVAL)    
 
181
            CALL TBEWRR(TID,IROW,IC,VALUE,STATUS)
 
182
            IVAL = IVAL + 1
 
183
            IROW = IROW + 1
 
184
            IACT = IACT + 1
 
185
            IF (IACT.GT.INUM) GOTO 15
 
186
 10      CONTINUE
 
187
C
 
188
C ... epsilons
 
189
C
 
190
 15      CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)
 
191
         IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
 
192
         IROW = IPREV
 
193
         IVAL = 3
 
194
         IACT = 1
 
195
         IC   = 2
 
196
         DO 20 I = 5, NBYTE, 2
 
197
            IVALUE     = IBUFF(IVAL)    
 
198
            CALL TBEWRI(TID,IROW,IC,IVALUE,STATUS)
 
199
            IVAL = IVAL + 1
 
200
            IROW = IROW + 1
 
201
            IACT = IACT + 1
 
202
            IF (IACT.GT.INUM) GOTO 25
 
203
 20     CONTINUE
 
204
C
 
205
C ... GROSS
 
206
C
 
207
 25     CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)
 
208
        IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
 
209
         IROW = IPREV
 
210
         IVAL = 3
 
211
         IACT = 1
 
212
         IC   = 3
 
213
         DO 30 I = 5, NBYTE, 2
 
214
            VALUE      = IBUFF(IVAL)*SCG
 
215
            CALL TBEWRR(TID,IROW,IC,VALUE,STATUS)
 
216
            IVAL = IVAL + 1
 
217
            IROW = IROW + 1
 
218
            IACT = IACT + 1
 
219
            IF (IACT.GT.INUM) GOTO 35
 
220
 30   CONTINUE
 
221
C
 
222
C ... BACKGROUND
 
223
C
 
224
 35      CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)
 
225
         IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
 
226
         IROW = IPREV
 
227
         IVAL = 3
 
228
         IACT = 1
 
229
         IC   = 4
 
230
         DO 40 I = 5, NBYTE, 2
 
231
            VALUE      = IBUFF(IVAL)*SCB
 
232
            CALL TBEWRR(TID,IROW,IC,VALUE,STATUS)
 
233
            IVAL = IVAL + 1
 
234
            IROW = IROW + 1
 
235
            IACT = IACT + 1
 
236
            IF (IACT.GT.INUM) GOTO 45
 
237
 40      CONTINUE
 
238
C
 
239
C ... NET
 
240
C
 
241
 45      CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)
 
242
         IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
 
243
         IROW = IPREV
 
244
         IVAL = 3
 
245
         IACT = 1
 
246
         IC   = 5
 
247
         DO 50 I = 5, NBYTE, 2
 
248
            VALUE      = IBUFF(IVAL)*SCN    
 
249
            CALL TBEWRR(TID,IROW,IC,VALUE,STATUS)
 
250
            IVAL = IVAL + 1
 
251
            IROW = IROW + 1
 
252
            IACT = IACT + 1
 
253
            IF (IACT.GT.INUM) GOTO 55
 
254
 50      CONTINUE
 
255
C
 
256
C ... RNET
 
257
C
 
258
 55      CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)
 
259
         IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
 
260
         IROW = IPREV
 
261
         IVAL = 3
 
262
         IACT = 1
 
263
         IC   = 6
 
264
         DO 60 I = 5, NBYTE, 2
 
265
            VALUE      = IBUFF(IVAL)*SCR
 
266
            CALL TBEWRR(TID,IROW,IC,VALUE,STATUS)
 
267
            IVAL = IVAL + 1
 
268
            IROW = IROW + 1
 
269
            IACT = IACT + 1
 
270
            IF (IACT.GT.INUM) GOTO 65
 
271
 60      CONTINUE
 
272
C
 
273
C ... FLUX
 
274
C
 
275
 65      CONTINUE
 
276
         IF (NRECPO.EQ.7) THEN
 
277
C
 
278
C ...     calibrated flux included in the file
 
279
C
 
280
            CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)
 
281
            IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
 
282
            IROW = IPREV
 
283
            IVAL = 3
 
284
            IACT = 1
 
285
            IC   = 7
 
286
            DO 70 I = 5, NBYTE, 2
 
287
               VALUE      = IBUFF(IVAL)*SCF    
 
288
               CALL TBEWRR(TID,IROW,IC,VALUE,STATUS)
 
289
               IVAL = IVAL + 1
 
290
               IROW = IROW + 1
 
291
               IACT = IACT + 1
 
292
               IF (IACT.GT.INUM) GOTO 75
 
293
 70         CONTINUE
 
294
         ELSE
 
295
C
 
296
C ...    calibrated flux is not present in the file. Output column set to zero
 
297
C
 
298
            IROW  = IPREV
 
299
            IACT  = 1
 
300
            IC    = 7
 
301
            VALUE = 0.
 
302
            DO 71 I = 5, NBYTE, 2
 
303
               CALL TBEWRR(TID,IROW,IC,VALUE,STATUS)
 
304
               IROW = IROW + 1
 
305
               IACT = IACT + 1
 
306
               IF (IACT.GT.INUM) GOTO 75
 
307
 71         CONTINUE
 
308
         ENDIF
 
309
C
 
310
C ...  generates the order number
 
311
C
 
312
 75      IC   = 8
 
313
         IROW = IPREV
 
314
         DO 80 I = 1, INUM
 
315
            CALL TBEWRI(TID,IROW,IC,M,STATUS)
 
316
            IROW = IROW + 1
 
317
 80      CONTINUE
 
318
         IPREV = IPREV + INUM
 
319
 100  CONTINUE
 
320
C
 
321
C ... write label descriptors
 
322
C
 
323
      CALL ISTDES(TID,BUFF,STATUS)
 
324
      CALL TBTCLO(TID,STATUS)
 
325
      RETURN
 
326
      END