C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.IDENTIFICATION ISDHIG.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. C The routine performs the following functions (routine names in brackets): C \begin{enumerate} C \item Handles the file header (ISDFHD) 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 (ISDREA) C \item Decode wavelengths C \item Write the wavelengths into the table (TBEWRR) C \item Read epsilon record (ISDREA) 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 24 Jun 1994. Initial coding. C------------------------------------------------------------------ SUBROUTINE ISDHIG(CHANL,BUFF,FILE,DSKFMT,K,KORD,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: 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 IOFF 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 ISDFHD(CHANL,BUFF,DSPFLG,IOFF,STATUS) IF (STATUS.NE.0) RETURN IF (DSKFMT.LT.0) RETURN ! only displays header C C ... reads record zero C CALL ISDRHW(CHANL,BZERO,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).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 ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).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 ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).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 ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).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 ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).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 ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).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 ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).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 ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).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