C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.IDENTIFICATION ISDLOW.FOR C.AUTHOR: J.D.PONZ ESA-VILSPA C.KEYWORDS IUE, GO FORMAT, LOW DISPERSION SPECTRUM C.PURPOSE C \begin{TeX} C Reads low dispersion spectra and stores the C information into a MIDAS table. C C The routine performs the following functions: C \begin{enumerate} C \item Handles the file header (ISDFHD) C \item Creates the MIDAS table file (TBTINI) C \item Read wavelength record and decodes the values C \item Creates a column to store the wavelengths (TBCINI) C \item Writes the wavelengths into the table column (TBEWRR) C \item Read epsilon record and decodes the values C \item Creates a column to store the epsilon flags (TBCINI) C \item Writes the values into the table column (TBEWRI) C \item For each extracted spectrum (GROSS, BACKGROUND, NET, ABS. FLUX): C \begin{itemize} C \item Read record (ISTREA) and decodes the values C \item Creates a column to store the values (TBCINI) C \item Writes the values into the table column (TBEWRR) C \end{itemize} C \item Writes IUE specific descriptors (ISTDES) C \item Closes 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.VERSION: 1.0 INITIAL CODING 24 JUN 1994 C------------------------------------------------------------------ SUBROUTINE ISDLOW(CHANL,BUFF,FILE,DSKFMT, . NRECO,NBYTE,DSPFLG,IOFF,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 I, LEN, NROW, LAM0, TID, IROW, IVAL, IVALUE,IOFF INTEGER JG, KG, JB, KB, JN, KN, JF, KF, IC INTEGER BBUFF(1024) INTEGER IBUFF(1024) REAL VALUE, SCG, SCB, SCN, SCF CHARACTER*16 LLABEL,ELABEL,GLABEL,BLABEL,NLABEL,FLABEL CHARACTER*16 LUNIT,EUNIT,GUNIT,BUNIT,NUNIT,FUNIT CHARACTER*8 LFORM,EFORM,GFORM,BFORM,NFORM,FFORM C INCLUDE 'MID_INCLUDE:ST_DEF.INC' EQUIVALENCE (BBUFF,IBUFF) INCLUDE 'MID_INCLUDE:ST_DAT.INC' C DATA LLABEL/'WAVELENGTH'/,ELABEL/'EPSILON'/ DATA GLABEL/'GROSS'/, BLABEL/'BACKGROUND'/ DATA NLABEL/'NET'/, FLABEL/'FLUX'/ DATA LUNIT/'ANGSTROM'/, EUNIT/'UNITLESS'/ DATA GUNIT/'FN'/, BUNIT/'FN'/ DATA NUNIT/'FN'/, FUNIT/'ERG/CM2/A'/ DATA LFORM/'F8.3'/, EFORM/'I5'/ DATA GFORM/'E12.4'/ DATA BFORM/'E12.4'/ DATA NFORM/'E12.4'/ DATA FFORM/'E12.4'/ C STATUS = 0 C C ... decode full header, print it and put info in common area C CALL ISDFHD(CHANL,BUFF,DSPFLG,IOFF,STATUS) IF (STATUS.NE.0) RETURN IF (DSKFMT.LT.0) RETURN ! only displays the header C C ... reads record zero C CALL ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).NE.LEN .OR. STATUS.NE.0) RETURN C C ... extracts useful info C NROW = IBUFF(303) LAM0 = IBUFF(103) JG = IBUFF(23) KG = IBUFF(24) JB = IBUFF(27) KB = IBUFF(28) JN = IBUFF(31) KN = IBUFF(32) JF = IBUFF(35) KF = IBUFF(36) SCG = JG/(2.**KG) SCB = JB/(2.**KB) SCN = JN/(2.**KN) SCF = JF/(2.**KF) C C ... create the table file C CALL TBTINI(FILE,F_TRANS,F_O_MODE,10,NROW,TID,STATUS) IF (STATUS.NE.0) RETURN C C ... scaled wavelengths C CALL ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).NE.LEN .OR. STATUS.NE.0) RETURN CALL TBCINI(TID,D_R4_FORMAT,1,LFORM,LUNIT,LLABEL,IC,STATUS) IROW = 1 IVAL = 3 DO 10 I = 5, NBYTE, 2 VALUE = LAM0+0.2*IBUFF(IVAL) CALL TBEWRR(TID,IROW,IC,VALUE,STATUS) IVAL = IVAL + 1 IROW = IROW + 1 IF (IROW.GT.NROW) GOTO 15 10 CONTINUE C C ... epsilons C 15 CALL ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).NE.LEN .OR. STATUS.NE.0) RETURN CALL TBCINI(TID,D_I4_FORMAT,1,EFORM,EUNIT,ELABEL,IC,STATUS) IROW = 1 IVAL = 3 DO 20 I = 5, NBYTE, 2 IVALUE = IBUFF(IVAL) CALL TBEWRI(TID,IROW,IC,IVALUE,STATUS) IVAL = IVAL + 1 IROW = IROW + 1 IF (IROW.GT.NROW) GOTO 25 20 CONTINUE C C ... GROSS C 25 CALL ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).NE.LEN .OR. STATUS.NE.0) RETURN CALL TBCINI(TID,D_R4_FORMAT,1,GFORM,GUNIT,GLABEL,IC,STATUS) IROW = 1 IVAL = 3 DO 30 I = 5, NBYTE, 2 VALUE = IBUFF(IVAL)*SCG CALL TBEWRR(TID,IROW,IC,VALUE,STATUS) IVAL = IVAL + 1 IROW = IROW + 1 IF (IROW.GT.NROW) GOTO 35 30 CONTINUE C C ... BACKGROUND C 35 CALL ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).NE.LEN .OR. STATUS.NE.0) RETURN CALL TBCINI(TID,D_R4_FORMAT,1,BFORM,BUNIT,BLABEL,IC,STATUS) IROW = 1 IVAL = 3 DO 40 I = 5, NBYTE, 2 VALUE = IBUFF(IVAL)*SCB CALL TBEWRR(TID,IROW,IC,VALUE,STATUS) IVAL = IVAL + 1 IROW = IROW + 1 IF (IROW.GT.NROW) GOTO 45 40 CONTINUE C C ... NET C 45 CALL ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).NE.LEN .OR. STATUS.NE.0) RETURN CALL TBCINI(TID,D_R4_FORMAT,1,NFORM,NUNIT,NLABEL,IC,STATUS) IROW = 1 IVAL = 3 DO 50 I = 5, NBYTE, 2 VALUE = IBUFF(IVAL)*SCN CALL TBEWRR(TID,IROW,IC,VALUE,STATUS) IVAL = IVAL + 1 IROW = IROW + 1 IF (IROW.GT.NROW) GOTO 55 50 CONTINUE C C ... FLUX C 55 CALL ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).NE.LEN .OR. STATUS.NE.0) RETURN CALL TBCINI(TID,D_R4_FORMAT,1,FFORM,FUNIT,FLABEL,IC,STATUS) IROW = 1 IVAL = 3 DO 60 I = 5, NBYTE, 2 VALUE = IBUFF(IVAL)*SCF CALL TBEWRR(TID,IROW,IC,VALUE,STATUS) IVAL = IVAL + 1 IROW = IROW + 1 IF (IROW.GT.NROW) GOTO 65 60 CONTINUE C C ... write label descriptors C 65 CONTINUE CALL ISTDES(TID,BUFF,STATUS) CALL TBTCLO(TID,STATUS) RETURN END