← Back to branch summary

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

« back to all changes in this revision

Viewing changes to contrib/iue/libsrc/istfes.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/istfes.for
 
1
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
2
C.IDENTIFICATION        ISTFES.FOR
 
3
C.LANGUAGE:             F77 
 
4
C.AUTHOR:               J.D.PONZ  ESA-VILSPA        
 
5
C.KEYWORDS              IUE, GO FORMAT, FES IMAGE
 
6
C.PURPOSE
 
7
C  \begin{TeX}
 
8
C  Reads FES data 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 image file on disk (STFCRE). 
 
13
C     The format and size of the file is controlled by the 
 
14
C     argument DSKFMT (0 - floating point, 1 - byte).
 
15
C  \item  Iteration on the number of lines to:
 
16
C        \begin{itemize}
 
17
C         \item Read  a line (ISTREC)
 
18
C         \item Decode the pixel information
 
19
C         \item Write the line into disk (STFPUT).
 
20
C       \end{itemize}
 
21
C  \item Writes standard image descriptors (STDWRx)
 
22
C  \item Writes IUE specific descriptors (ISTDES).
 
23
C  \item Closes the file on disk (STFCLO)
 
24
C  \end{enumerate}
 
25
C \end{TeX}
 
26
C.COMMENTS
 
27
C \begin{TeX}
 
28
C  The following extensions are used :
 
29
C  \begin{itemize}
 
30
C  \item IMPLICIT NONE
 
31
C  \item INCLUDE statement
 
32
C  \item Long variable names
 
33
C  \item Underscore character
 
34
C  \end{itemize}
 
35
C \end{TeX}
 
36
C.VERSION: 1.0  INITIAL CODING  09 JUL 1990
 
37
C.VERSION: 1.1  Handle different FES sizes. 24 Sep 1990
 
38
C.VERSION: 1.2  Remove VMS extensions. 14 Apr 1992
 
39
C------------------------------------------------------------------
 
40
      SUBROUTINE ISTFES(CHANL,BUFF,FILE,DSKFMT,DSPFLG,
 
41
     .                  NRECO,NBYTE,STATUS)
 
42
C
 
43
      IMPLICIT NONE
 
44
      INTEGER       CHANL             ! IN: tape channel number
 
45
      CHARACTER*(*) BUFF              ! IN: buffer with the ascii header
 
46
      CHARACTER*(*) FILE              ! IN: disk file name
 
47
      INTEGER       DSKFMT            ! IN: image format (0:float, 1:Byte)
 
48
      INTEGER       DSPFLG            ! IN: display flag
 
49
      INTEGER       NRECO             ! IN: number of records
 
50
      INTEGER       NBYTE             ! IN: number of bytes
 
51
      INTEGER       STATUS            ! OUT: status (0 normal return)
 
52
C
 
53
      INTEGER   DTYPE, NO, SIZE, FELM, NL, NR, LEN, I, J
 
54
      INTEGER   NAXIS(1), NPIX(2), DUM(1)
 
55
      INTEGER   IBUFF(768)
 
56
      REAL      RBUFF(768)
 
57
      REAL      CUTS(4)
 
58
      DOUBLE PRECISION START(2), STEP(2)
 
59
      CHARACTER*72 IDENT, CUNIT
 
60
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
 
61
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
 
62
      DATA CUNIT/'FESCNT          PIXEL           PIXEL    '/
 
63
C
 
64
C     NL     = 113
 
65
C     NR     = 113
 
66
C     SIZE   = 113*113
 
67
      NL     = NBYTE
 
68
      NR     = NRECO
 
69
      SIZE   = NRECO*NBYTE
 
70
      STATUS = 0
 
71
C
 
72
C ... decode full header, print it and put info in common area
 
73
C
 
74
      CALL ISTFHD(CHANL,BUFF,DSPFLG,STATUS)
 
75
      IF (STATUS.NE.0) RETURN
 
76
      IF (DSKFMT.LT.0) RETURN     ! only displays header
 
77
C
 
78
C ... create the frame
 
79
C
 
80
      IF (DSKFMT.EQ.0) THEN
 
81
          DTYPE = D_R4_FORMAT
 
82
      ELSE
 
83
          DTYPE = D_I1_FORMAT
 
84
      ENDIF
 
85
      CALL STFCRE(FILE,DTYPE,F_O_MODE,F_IMA_TYPE,SIZE,NO,STATUS)
 
86
      IF (STATUS.NE.0) RETURN
 
87
C
 
88
C ... loop to read tape and write into disk
 
89
C
 
90
      FELM = 1
 
91
      IF (DSKFMT.EQ.0) THEN                        ! write with conversion
 
92
        DO 10 I = 1, NL
 
93
           CALL ISTRBY(CHANL,IBUFF,NR,LEN,STATUS)
 
94
           IF (NR.NE.LEN .OR. STATUS.NE.0) RETURN
 
95
           DO 5 J = 1, NR
 
96
              RBUFF(J) = IBUFF(J)
 
97
  5        CONTINUE
 
98
           CALL STFPUT(NO,FELM,NR,RBUFF,STATUS)
 
99
           IF (STATUS.NE.0) RETURN            
 
100
           FELM = FELM + NR
 
101
 10     CONTINUE
 
102
      ELSE                                         ! write without conversion
 
103
        DO 20 I = 1, NL
 
104
           CALL ISTRB1(CHANL,IBUFF,NR,LEN,STATUS)
 
105
           IF (NR.NE.LEN .OR. STATUS.NE.0) RETURN
 
106
           CALL STFPUT(NO,FELM,NR,IBUFF,STATUS)
 
107
           IF (STATUS.NE.0) RETURN            
 
108
           FELM = FELM + NR
 
109
 20     CONTINUE
 
110
      ENDIF
 
111
C
 
112
C ... write image descriptors
 
113
C
 
114
      NAXIS(1) = 2
 
115
      NPIX(1)  = NBYTE
 
116
      NPIX(2)  = NRECO
 
117
      START(1) = 1.0D0
 
118
      START(2) = 1.0D0
 
119
      STEP(1)  = 1.0D0
 
120
      STEP(2)  = 1.0D0
 
121
      CUTS(1)  = 0.
 
122
      CUTS(2)  = 255.
 
123
      CUTS(3)  = 0.
 
124
      CUTS(4)  = 255.
 
125
      IDENT    = BUFF(145:210)
 
126
      CALL STDWRI(NO,'NAXIS',NAXIS,1,1,DUM,STATUS)
 
127
      CALL STDWRI(NO,'NPIX',NPIX,1,2,DUM,STATUS)
 
128
      CALL STDWRD(NO,'START',START,1,2,DUM,STATUS)
 
129
      CALL STDWRD(NO,'STEP',STEP,1,2,DUM,STATUS)
 
130
      CALL STDWRR(NO,'LHCUTS',CUTS,1,4,DUM,STATUS)
 
131
      CALL STDWRC(NO,'IDENT',1,IDENT,1,72,DUM,STATUS)
 
132
      CALL STDWRC(NO,'CUNIT',1,CUNIT,1,48,DUM,STATUS)
 
133
C
 
134
C ... write label descriptors
 
135
C
 
136
      CALL ISTDES(NO,BUFF,STATUS)
 
137
      CALL STFCLO(NO,STATUS)
 
138
      RETURN
 
139
      END