C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.IDENTIFICATION ISDLBL.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 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 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 C \item Decode first and last wavelength if it is the first pseudo-order C \item Read epsilon record C \item Read record with pixel values C \item Decode pixel values C \item Write into the disk file 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 24 JUN 1994 C------------------------------------------------------------------ SUBROUTINE ISDLBL(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 IOFF 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 ISDFHD(CHANL,BUFF,DSPFLG,IOFF,STATUS) IF (STATUS.NE.0) RETURN IF (DSKFMT.LT.0) RETURN ! only displays header C C ... reads data record 0 C CALL ISDRHW(CHANL,BZERO,NBYTE,LEN,IOFF,STATUS) IF ((NBYTE+IOFF).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 ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,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+IOFF).NE.LEN .OR. STATUS.NE.0) RETURN CALL ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) ! read epsilon IF ((NBYTE+IOFF).NE.LEN .OR. STATUS.NE.0) RETURN CALL ISDRHW(CHANL,BBUFF,NBYTE,LEN,IOFF,STATUS) ! read data IF ((NBYTE+IOFF).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