← Back to branch summary

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

« back to all changes in this revision

Viewing changes to contrib/iue/libsrc/isdlbl.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/isdlbl.for
 
1
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
2
C.IDENTIFICATION        ISDLBL.FOR
 
3
C.AUTHOR:               J.D.PONZ  ESA-VILSPA        
 
4
C.KEYWORDS              IUE, GO FORMAT, LINE-BY-LINE IMAGE
 
5
C.PURPOSE
 
6
C  \begin{TeX}
 
7
C   Reads the low dispersion line-by-line LBL and extended LBL files.
 
8
C
 
9
C   The routine performs the following functions (routine names in brackets):
 
10
C   \begin{enumerate}
 
11
C   \item Handles the file header (ISDFHD)
 
12
C   \item Creates the MIDAS image file on disk (STFCRE)
 
13
C      Format and size of the file is controlled by the argument
 
14
C      DSKFMT.
 
15
C   \item Iterates on pseudo-orders to:
 
16
C         \begin{itemize}
 
17
C           \item Read wavelength record 
 
18
C           \item Decode first and last wavelength if it is the first pseudo-order
 
19
C           \item Read epsilon record 
 
20
C           \item Read record with pixel values
 
21
C           \item Decode pixel values
 
22
C           \item Write into the disk file 
 
23
C         \end{itemize}
 
24
C   \item Writes standard image descriptors (STDWRx)
 
25
C   \item Writes IUE specific descriptors (ISTDES)
 
26
C   \item Closes the image file (STFCLO)
 
27
C   \end{enumerate}
 
28
C \end{TeX}
 
29
C.LANGUAGE:             F77 
 
30
C.COMMENTS
 
31
C \begin{TeX}
 
32
C   The following extensions are used:
 
33
C    \begin{itemize}
 
34
C    \item IMPLICIT NONE
 
35
C    \item INCLUDE statement
 
36
C    \item long variable names
 
37
C    \item Underscore character
 
38
C    \end{itemize}
 
39
C \end{TeX}
 
40
C.VERSION: 1.0  INITIAL CODING  24 JUN 1994
 
41
C------------------------------------------------------------------
 
42
      SUBROUTINE ISDLBL(CHANL,BUFF,FILE,DSKFMT,
 
43
     .                  NRECO,NBYTE,DSPFLG,IOFF,STATUS)
 
44
C
 
45
      IMPLICIT NONE
 
46
      INTEGER       CHANL             ! IN: tape channel number
 
47
      CHARACTER*(*) BUFF              ! IN: buffer with the ascii header
 
48
      CHARACTER*(*) FILE              ! IN: file name
 
49
      INTEGER       DSKFMT            ! IN: disk format (-1 no file)
 
50
      INTEGER       NRECO             ! IN: number of records
 
51
      INTEGER       NBYTE             ! IN: number of bytes per record
 
52
      INTEGER       DSPFLG            ! IN: display flag
 
53
      INTEGER       IOFF
 
54
      INTEGER       STATUS            ! OUT: status
 
55
C
 
56
      INTEGER   DTYPE, NO, SIZE, FELM, NL, LEN, I, J, IP
 
57
      INTEGER   NAXIS(1), NPIX(2), DUM(1), NP, NORDER, RPERGR
 
58
      INTEGER   KG, JG
 
59
      INTEGER   IBUFF(1024), IZERO(1024)
 
60
      INTEGER   LAMB0(100), IORD(100), NVAL(100)
 
61
      INTEGER   BBUFF(1024), BZERO(1024)
 
62
      REAL      RBUFF(1024)
 
63
      REAL      CUTS(4), XMIN, XMAX, SCG
 
64
      DOUBLE PRECISION START(2), STEP(2), W0, W1
 
65
      CHARACTER*72 IDENT, CUNIT
 
66
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
 
67
      EQUIVALENCE  (IBUFF(1),BBUFF(1))
 
68
      EQUIVALENCE  (IZERO(1), BZERO(1))
 
69
      EQUIVALENCE  (IZERO(103), LAMB0(1))
 
70
      EQUIVALENCE  (IZERO(203), IORD(1))
 
71
      EQUIVALENCE  (IZERO(303), NVAL(1))
 
72
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
 
73
      DATA   CUNIT/'FN              ANGSTROM        PIXEL'/
 
74
C
 
75
C ... decode full header, print it and put info in common area
 
76
C
 
77
      STATUS = 0
 
78
      XMIN   = 0.
 
79
      XMAX   = 0.
 
80
      CALL ISDFHD(CHANL,BUFF,DSPFLG,IOFF,STATUS)
 
81
      IF (STATUS.NE.0) RETURN
 
82
      IF (DSKFMT.LT.0) RETURN       ! only displays header
 
83
C
 
84
C ... reads data record 0
 
85
C
 
86
      CALL ISDRHW(CHANL,BZERO,NBYTE,LEN,IOFF,STATUS)
 
87
      IF ((NBYTE+IOFF).NE.LEN. OR. STATUS.NE.0) THEN
 
88
          STATUS = 1
 
89
          RETURN
 
90
      ENDIF
 
91
C
 
92
C ... define file dimensions and other parameters
 
93
C
 
94
      NORDER = IZERO(5)
 
95
      RPERGR = IZERO(8)
 
96
      JG     = IZERO(23)
 
97
      KG     = IZERO(24)
 
98
      SCG    = FLOAT(JG)/(2.**KG)
 
99
C 
 
100
C ... check info
 
101
C
 
102
      IF (NORDER.NE.(NRECO-1)/RPERGR) THEN
 
103
          CALL STTPUT('Problem with NORDER in LBL ***',STATUS)
 
104
          STATUS = 1
 
105
          RETURN
 
106
      ENDIF
 
107
      NP     = NVAL(1)
 
108
      NL     = NORDER
 
109
      SIZE   = NP*NL
 
110
C
 
111
C
 
112
C ... create the frame
 
113
C
 
114
      DTYPE = D_R4_FORMAT
 
115
      CALL STFCRE(FILE,DTYPE,F_O_MODE,F_IMA_TYPE,SIZE,NO,STATUS)
 
116
      IF (STATUS.NE.0) RETURN
 
117
C
 
118
C ... loop to read tape and write into disk
 
119
C
 
120
      FELM = 1
 
121
      DO 20 I = 1, NL
 
122
           CALL ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS)    ! read lambda
 
123
           IF (I.EQ.1) THEN
 
124
             W0 = IBUFF(3) * 0.2  + LAMB0(1)
 
125
             W1 = IBUFF(NP+2)*0.2 + LAMB0(1)
 
126
           ENDIF
 
127
           IF ((NBYTE+IOFF).NE.LEN .OR. STATUS.NE.0) RETURN
 
128
           CALL ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS)    ! read epsilon
 
129
           IF ((NBYTE+IOFF).NE.LEN .OR. STATUS.NE.0) RETURN
 
130
           CALL ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS)    ! read data
 
131
           IF ((NBYTE+IOFF).NE.LEN .OR. STATUS.NE.0) RETURN
 
132
           IP = 1
 
133
           DO 15 J = 5, NBYTE, 2
 
134
               RBUFF(IP)  = IBUFF(IP+2)*SCG
 
135
               XMAX       = AMAX1(XMAX,RBUFF(IP))
 
136
               XMIN       = AMIN1(XMIN,RBUFF(IP))
 
137
               IP         = IP + 1
 
138
               IF (IP.GT.NP) GO TO 17
 
139
  15       CONTINUE
 
140
  17       CALL STFPUT(NO,FELM,NP,RBUFF,STATUS)
 
141
           IF (STATUS.NE.0) RETURN            
 
142
           FELM = FELM + NP
 
143
 20   CONTINUE
 
144
C
 
145
C ... write image descriptors
 
146
C
 
147
      NAXIS(1) = 2
 
148
      NPIX(1)  = NP
 
149
      NPIX(2)  = NL
 
150
      START(1) = W0
 
151
      START(2) = 1.0D0
 
152
      STEP(1)  = (W1 - W0)/(NP-1)
 
153
      STEP(2)  = 1.0D0
 
154
      CUTS(1)  = XMIN
 
155
      CUTS(2)  = XMAX
 
156
      CUTS(3)  = XMIN
 
157
      CUTS(4)  = XMAX
 
158
      IDENT    = BUFF(145:210)
 
159
      CALL STDWRI(NO,'NAXIS',NAXIS,1,1,DUM,STATUS)
 
160
      CALL STDWRI(NO,'NPIX',NPIX,1,2,DUM,STATUS)
 
161
      CALL STDWRD(NO,'START',START,1,2,DUM,STATUS)
 
162
      CALL STDWRD(NO,'STEP',STEP,1,2,DUM,STATUS)
 
163
      CALL STDWRR(NO,'LHCUTS',CUTS,1,4,DUM,STATUS)
 
164
      CALL STDWRC(NO,'IDENT',1,IDENT,1,72,DUM,STATUS)
 
165
      CALL STDWRC(NO,'CUNIT',1,CUNIT,1,48,DUM,STATUS)
 
166
C
 
167
C ... write label descriptors
 
168
C
 
169
      CALL ISTDES(NO,BUFF,STATUS)
 
170
      CALL STFCLO(NO,STATUS)
 
171
      RETURN
 
172
      END