C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.IDENTIFICATION        ISTHIG.FOR
C.AUTHOR:               J.D.PONZ  ESA-VILSPA        
C.KEYWORDS              IUE, GO FORMAT, HIGH DISPERSION SPECTRUM
C.ENVIRONMENT           MIDAS, IUE context
C.PURPOSE
C \begin{TeX}
C   Reads High dispersion MEHI file from tape.
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 table file on disk (TBTINI)
C   \item Creates the table columns (TBCINI)
C   \item Iterates on orders to 
C      \begin{itemize}
C         \item Read wavelength record (ISTREA)
C         \item Decode wavelengths
C         \item Write the wavelengths into the table (TBEWRR)
C         \item Read epsilon record (ISTREA)
C         \item Decode epsilon
C         \item Write the epsilon values into the table (TBEWRR)
C         \item Read/decode/write the extracted spectra
C               (Gross, background, net, 
C               ripple-corrected net and absolute flux)
C         \item Write the spectral order number
C       \end{itemize}
C    \item Writes IUE specific descriptors (ISTDES)
C    \item Closes the table file (TBTCLO)
C \end{enumerate}
C \end{TeX}
C   
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  9 Jul 1991. Initial coding.
C.VERSION: 1.1  27 Nov 1991. Include variable number of records per group.
C.VERSION: 1.2  29 Nov 1991. Warning when Calibrated spectrum not present.
C.VERSION: 1.3  14 APR 1992. Remove VMS extensions
C------------------------------------------------------------------
      SUBROUTINE ISTHIG(CHANL,BUFF,FILE,DSKFMT,K,KORD,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: file format (-1 no file)
      INTEGER       K                 ! IN: number of orders requested
      INTEGER       KORD(1)           ! IN: actual orders requested
      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 I, LEN, NROW, TID, IROW, IVAL, IVALUE
      INTEGER JG, KG, JB, KB, JN, KN, JF, KF, IC, JR, KR
      INTEGER NORD, IPREV, JORDER, M, INUM, LAMB, IACT
      INTEGER NRECPO
      INTEGER    BBUFF(1024), BZERO(1024)
      INTEGER    IZERO(1024)
      INTEGER    IBUFF(1024), LAMB0(100), IORD(100), NVAL(100)
      REAL    VALUE, SCG, SCB, SCN, SCR, SCF
      CHARACTER*16 LLABEL,ELABEL,GLABEL,BLABEL,NLABEL,FLABEL
      CHARACTER*16 RLABEL, RUNIT, OLABEL, OUNIT
      CHARACTER*16 LUNIT,EUNIT,GUNIT,BUNIT,NUNIT,FUNIT
      CHARACTER*8  LFORM,EFORM,GFORM,BFORM,NFORM,FFORM,RFORM
      CHARACTER*8  OFORM
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
      EQUIVALENCE (BBUFF, IBUFF)
      EQUIVALENCE (BZERO, IZERO)
      EQUIVALENCE (IZERO(103), LAMB0(1))
      EQUIVALENCE (IZERO(203), IORD(1))
      EQUIVALENCE (IZERO(303), NVAL(1))
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
      DATA LLABEL/'WAVELENGTH'/,ELABEL/'EPSILON'/
      DATA GLABEL/'GROSS'/,     BLABEL/'BACKGROUND'/
      DATA NLABEL/'NET'/,       RLABEL/'RNET'/
      DATA OLABEL/'ORDER'/, FLABEL/'FLUX'/
      DATA LUNIT/'ANGSTROM'/, EUNIT/'UNITLESS'/
      DATA GUNIT/'FN'/,       BUNIT/'FN'/
      DATA NUNIT/'FN'/,       RUNIT/'FN'/
      DATA FUNIT/'ERGS/CM2/A'/, OUNIT/'UNITLESS'/
      DATA LFORM/'F8.3'/, EFORM/'I5'/, OFORM/'I4'/
      DATA GFORM/'E12.4'/
      DATA BFORM/'E12.4'/
      DATA NFORM/'E12.4'/
      DATA RFORM/'E12.4'/
      DATA FFORM/'E12.4'/
C
      STATUS = 0
C
C ... decode full header, print it and put info in common area
C
      CALL ISTFHD(CHANL,BUFF,DSPFLG,STATUS)
      IF (STATUS.NE.0) RETURN
      IF (DSKFMT.LT.0) RETURN        ! only displays header
C
C ... reads record zero
C
      CALL ISTRHW(CHANL,BZERO,NBYTE,LEN,STATUS)
      IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
C
C ... extracts useful info
C
      NORD   = IZERO(5)
      NRECPO = IZERO(8)
      JG   = IZERO(23)
      KG   = IZERO(24)
      JB   = IZERO(27)
      KB   = IZERO(28)
      JN   = IZERO(31)
      KN   = IZERO(32)
      JR   = IZERO(35)
      KR   = IZERO(36)
      JF   = IZERO(67)
      KF   = IZERO(68)  
      SCG  = JG/(2.**KG)
      SCB  = JB/(2.**KB)
      SCN  = JN/(2.**KN)
      SCR  = JR/(2.**KR)
      SCF  = JF/(2.**KF)
      IF (NRECPO.LT.6.OR.NRECPO.GT.7) THEN
          STATUS = 1
          RETURN
      ELSE
          IF (NRECPO.EQ.6) THEN
            CALL STTPUT('*** Calibrated flux not present ***',STATUS)
            CALL STTPUT('*** Output flux set to zero ***',STATUS)
          ENDIF
      ENDIF
C
C ... finds orders and number of samples
C
      NROW = 0
      DO 6 I = 1, NORD
         NROW = NROW + NVAL(I)   ! CHECK ORDER SELECTION
 6    CONTINUE
C
C ... create the table file and columns
C
      CALL TBTINI(FILE,F_TRANS,F_O_MODE,10,NROW,TID,STATUS)
      IF (STATUS.NE.0) RETURN
      CALL TBCINI(TID,D_R4_FORMAT,1,LFORM,LUNIT,LLABEL,IC,STATUS)
      CALL TBCINI(TID,D_I4_FORMAT,1,EFORM,EUNIT,ELABEL,IC,STATUS)
      CALL TBCINI(TID,D_R4_FORMAT,1,GFORM,GUNIT,GLABEL,IC,STATUS)
      CALL TBCINI(TID,D_R4_FORMAT,1,BFORM,BUNIT,BLABEL,IC,STATUS)
      CALL TBCINI(TID,D_R4_FORMAT,1,NFORM,NUNIT,NLABEL,IC,STATUS)
      CALL TBCINI(TID,D_R4_FORMAT,1,RFORM,RUNIT,RLABEL,IC,STATUS)
      CALL TBCINI(TID,D_R4_FORMAT,1,FFORM,FUNIT,FLABEL,IC,STATUS)
      CALL TBCINI(TID,D_I4_FORMAT,1,OFORM,OUNIT,OLABEL,IC,STATUS)
C
C ... iteration on orders
C
      IPREV = 1
      DO 100 JORDER = 1, NORD
         IROW = IPREV
         M    = IORD(JORDER)
         INUM = NVAL(JORDER)
         LAMB = LAMB0(JORDER)
C
C ... scaled wavelengths
C
         CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)
         IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
         IROW = IPREV
         IVAL = 3
         IACT = 1
         IC   = 1
         DO 10 I = 5, NBYTE, 2
            VALUE      = LAMB+0.002*IBUFF(IVAL)    
            CALL TBEWRR(TID,IROW,IC,VALUE,STATUS)
            IVAL = IVAL + 1
            IROW = IROW + 1
            IACT = IACT + 1
            IF (IACT.GT.INUM) GOTO 15
 10      CONTINUE
C
C ... epsilons
C
 15      CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)
         IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
         IROW = IPREV
         IVAL = 3
         IACT = 1
         IC   = 2
         DO 20 I = 5, NBYTE, 2
            IVALUE     = IBUFF(IVAL)    
            CALL TBEWRI(TID,IROW,IC,IVALUE,STATUS)
            IVAL = IVAL + 1
            IROW = IROW + 1
            IACT = IACT + 1
            IF (IACT.GT.INUM) GOTO 25
 20     CONTINUE
C
C ... GROSS
C
 25     CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)
        IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
         IROW = IPREV
         IVAL = 3
         IACT = 1
         IC   = 3
         DO 30 I = 5, NBYTE, 2
            VALUE      = IBUFF(IVAL)*SCG
            CALL TBEWRR(TID,IROW,IC,VALUE,STATUS)
            IVAL = IVAL + 1
            IROW = IROW + 1
            IACT = IACT + 1
            IF (IACT.GT.INUM) GOTO 35
 30   CONTINUE
C
C ... BACKGROUND
C
 35      CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)
         IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
         IROW = IPREV
         IVAL = 3
         IACT = 1
         IC   = 4
         DO 40 I = 5, NBYTE, 2
            VALUE      = IBUFF(IVAL)*SCB
            CALL TBEWRR(TID,IROW,IC,VALUE,STATUS)
            IVAL = IVAL + 1
            IROW = IROW + 1
            IACT = IACT + 1
            IF (IACT.GT.INUM) GOTO 45
 40      CONTINUE
C
C ... NET
C
 45      CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)
         IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
         IROW = IPREV
         IVAL = 3
         IACT = 1
         IC   = 5
         DO 50 I = 5, NBYTE, 2
            VALUE      = IBUFF(IVAL)*SCN    
            CALL TBEWRR(TID,IROW,IC,VALUE,STATUS)
            IVAL = IVAL + 1
            IROW = IROW + 1
            IACT = IACT + 1
            IF (IACT.GT.INUM) GOTO 55
 50      CONTINUE
C
C ... RNET
C
 55      CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)
         IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
         IROW = IPREV
         IVAL = 3
         IACT = 1
         IC   = 6
         DO 60 I = 5, NBYTE, 2
            VALUE      = IBUFF(IVAL)*SCR
            CALL TBEWRR(TID,IROW,IC,VALUE,STATUS)
            IVAL = IVAL + 1
            IROW = IROW + 1
            IACT = IACT + 1
            IF (IACT.GT.INUM) GOTO 65
 60      CONTINUE
C
C ... FLUX
C
 65      CONTINUE
         IF (NRECPO.EQ.7) THEN
C
C ...     calibrated flux included in the file
C
            CALL ISTRHW(CHANL,BBUFF,NBYTE,LEN,STATUS)
            IF (NBYTE.NE.LEN .OR. STATUS.NE.0) RETURN
            IROW = IPREV
            IVAL = 3
            IACT = 1
            IC   = 7
            DO 70 I = 5, NBYTE, 2
               VALUE      = IBUFF(IVAL)*SCF    
               CALL TBEWRR(TID,IROW,IC,VALUE,STATUS)
               IVAL = IVAL + 1
               IROW = IROW + 1
               IACT = IACT + 1
               IF (IACT.GT.INUM) GOTO 75
 70         CONTINUE
         ELSE
C
C ...    calibrated flux is not present in the file. Output column set to zero
C
            IROW  = IPREV
            IACT  = 1
            IC    = 7
            VALUE = 0.
            DO 71 I = 5, NBYTE, 2
               CALL TBEWRR(TID,IROW,IC,VALUE,STATUS)
               IROW = IROW + 1
               IACT = IACT + 1
               IF (IACT.GT.INUM) GOTO 75
 71         CONTINUE
         ENDIF
C
C ...  generates the order number
C
 75      IC   = 8
         IROW = IPREV
         DO 80 I = 1, INUM
            CALL TBEWRI(TID,IROW,IC,M,STATUS)
            IROW = IROW + 1
 80      CONTINUE
         IPREV = IPREV + INUM
 100  CONTINUE
C
C ... write label descriptors
C
      CALL ISTDES(TID,BUFF,STATUS)
      CALL TBTCLO(TID,STATUS)
      RETURN
      END
