C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.IDENTIFICATION        ISTLBL.FOR
C.AUTHOR:               J.D.PONZ  ESA-VILSPA        
C.KEYWORDS              IUE, GO FORMAT, LINE-BY-LINE IMAGE
C.PURPOSE
C  \begin{TeX}
C   Reads the low dispersion line-by-line LBL and extended LBL files 
C   from tape and stores the infoprmation into a MIDAS image.
C
C   The routine performs the following functions (routine names in brackets):
C   \begin{enumerate}
C   \item Handles the file header (ISTFHD)
C   \item Creates the MIDAS image file on disk (STFCRE)
C      Format and size of the file is controlled by the argument
C      DSKFMT.
C   \item Iterates on pseudo-orders to:
C         \begin{itemize}
C           \item Read wavelength record (ISTREA)
C           \item Decode first and last wavelength if it is the first pseudo-order
C           \item Read epsilon record (ISTREA)
C           \item Read record with pixel values (ISTREA)
C           \item Decode pixel values
C           \item Write into the disk file (STFPUT)
C         \end{itemize}
C   \item Writes standard image descriptors (STDWRx)
C   \item Writes IUE specific descriptors (ISTDES)
C   \item Closes the image file (STFCLO)
C   \end{enumerate}
C \end{TeX}
C.LANGUAGE:             F77 
C.COMMENTS
C \begin{TeX}
C   The following extensions are used:
C    \begin{itemize}
C    \item IMPLICIT NONE
C    \item INCLUDE statement
C    \item long variable names
C    \item Underscore character
C    \end{itemize}
C \end{TeX}
C.VERSION: 1.0  INITIAL CODING  09 JUL 1990
C.VERSION: 1.1  REMOVE VMS EXTENSIONS
C------------------------------------------------------------------
      SUBROUTINE ISTLBL(CHANL,BUFF,FILE,DSKFMT,
     .                  NRECO,NBYTE,DSPFLG,STATUS)
C
      IMPLICIT NONE
      INTEGER       CHANL             ! IN: tape channel number
      CHARACTER*(*) BUFF              ! IN: buffer with the ascii header
      CHARACTER*(*) FILE              ! IN: file name
      INTEGER       DSKFMT            ! IN: disk format (-1 no file)
      INTEGER       NRECO             ! IN: number of records
      INTEGER       NBYTE             ! IN: number of bytes per record
      INTEGER       DSPFLG            ! IN: display flag
      INTEGER       STATUS            ! OUT: status
C
      INTEGER   DTYPE, NO, SIZE, FELM, NL, LEN, I, J, IP
      INTEGER   NAXIS(1), NPIX(2), DUM(1), NP, NORDER, RPERGR
      INTEGER   KG, JG
      INTEGER   IBUFF(1024), IZERO(1024)
      INTEGER   LAMB0(100), IORD(100), NVAL(100)
      INTEGER   BBUFF(1024), BZERO(1024)
      REAL      RBUFF(1024)
      REAL      CUTS(4), XMIN, XMAX, SCG
      DOUBLE PRECISION START(2), STEP(2), W0, W1
      CHARACTER*72 IDENT, CUNIT
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
      EQUIVALENCE  (IBUFF(1),BBUFF(1))
      EQUIVALENCE  (IZERO(1), BZERO(1))
      EQUIVALENCE  (IZERO(103), LAMB0(1))
      EQUIVALENCE  (IZERO(203), IORD(1))
      EQUIVALENCE  (IZERO(303), NVAL(1))
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
      DATA   CUNIT/'FN              ANGSTROM        PIXEL'/
C
C ... decode full header, print it and put info in common area
C
      STATUS = 0
      XMIN   = 0.
      XMAX   = 0.
      CALL ISTFHD(CHANL,BUFF,DSPFLG,STATUS)
      IF (STATUS.NE.0) RETURN
      IF (DSKFMT.LT.0) RETURN       ! only displays header
C
C ... reads data record 0
C
      CALL ISTRHW(CHANL,BZERO,NBYTE,LEN,STATUS)
      IF (NBYTE.NE.LEN. OR. STATUS.NE.0) THEN
          STATUS = 1
          RETURN
      ENDIF
C
C ... define file dimensions and other parameters
C
      NORDER = IZERO(5)
      RPERGR = IZERO(8)
      JG     = IZERO(23)
      KG     = IZERO(24)
      SCG    = FLOAT(JG)/(2.**KG)
C 
C ... check info
C
      IF (NORDER.NE.(NRECO-1)/RPERGR) THEN
          CALL STTPUT('Problem with NORDER in LBL ***',STATUS)
          STATUS = 1
          RETURN
      ENDIF
      NP     = NVAL(1)
      NL     = NORDER
      SIZE   = NP*NL
C
C
C ... create the frame
C
      DTYPE = D_R4_FORMAT
      CALL STFCRE(FILE,DTYPE,F_O_MODE,F_IMA_TYPE,SIZE,NO,STATUS)
      IF (STATUS.NE.0) RETURN
C
C ... loop to read tape and write into disk
C
      FELM = 1
      DO 20 I = 1, NL
           CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)    ! read lambda
           IF (I.EQ.1) THEN
             W0 = IBUFF(3) * 0.2  + LAMB0(1)
             W1 = IBUFF(NP+2)*0.2 + LAMB0(1)
           ENDIF
           IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
           CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)    ! read epsilon
           IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
           CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)    ! read data
           IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
           IP = 1
           DO 15 J = 5, NBYTE, 2
               RBUFF(IP)  = IBUFF(IP+2)*SCG
               XMAX       = AMAX1(XMAX,RBUFF(IP))
               XMIN       = AMIN1(XMIN,RBUFF(IP))
               IP         = IP + 1
               IF (IP.GT.NP) GO TO 17
  15       CONTINUE
  17       CALL STFPUT(NO,FELM,NP,RBUFF,STATUS)
           IF (STATUS.NE.0) RETURN            
           FELM = FELM + NP
 20   CONTINUE
C
C ... write image descriptors
C
      NAXIS(1) = 2
      NPIX(1)  = NP
      NPIX(2)  = NL
      START(1) = W0
      START(2) = 1.0D0
      STEP(1)  = (W1 - W0)/(NP-1)
      STEP(2)  = 1.0D0
      CUTS(1)  = XMIN
      CUTS(2)  = XMAX
      CUTS(3)  = XMIN
      CUTS(4)  = XMAX
      IDENT    = BUFF(145:210)
      CALL STDWRI(NO,'NAXIS',NAXIS,1,1,DUM,STATUS)
      CALL STDWRI(NO,'NPIX',NPIX,1,2,DUM,STATUS)
      CALL STDWRD(NO,'START',START,1,2,DUM,STATUS)
      CALL STDWRD(NO,'STEP',STEP,1,2,DUM,STATUS)
      CALL STDWRR(NO,'LHCUTS',CUTS,1,4,DUM,STATUS)
      CALL STDWRC(NO,'IDENT',1,IDENT,1,72,DUM,STATUS)
      CALL STDWRC(NO,'CUNIT',1,CUNIT,1,48,DUM,STATUS)
C
C ... write label descriptors
C
      CALL ISTDES(NO,BUFF,STATUS)
      CALL STFCLO(NO,STATUS)
      RETURN
      END