C @(#)echidena.for	17.1.1.1 (ESO-IPG) 01/25/02 17:52:20
      PROGRAM ECHIDA
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
C                                         all rights reserved
C
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  21:52 - 3 DEC 1987
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: D.PONZ
C
C.IDENTIFICATION:  ECHIDENA.FOR
C
C.KEYWORDS:
C  Tables
C
C.PURPOSE:
C  Identify features in an echelle spectrum
C     1.0     10-JAN-1988
C     1.1     11-JUl-1990  M.Peron
C     1.2      2-FEB-1995  O.Stahl
C-------------------------------------------------------------------
C
C
      IMPLICIT NONE
C
      INTEGER MADRID
      INTEGER KNUL
      INTEGER IDTID,IDNCOL,IDNROW,IDNS,IDACOL,IDAROW
      INTEGER IDCX,IDCY,IDCW,IDCO
      INTEGER IROW,ISTAT,NCOL,I,NULL
      INTEGER NPOS,NROW,NS,STAT
      INTEGER KUN,TID,ACOL,AROW
      INTEGER ICW,ICX,ICYN
C 
      INTEGER*8 IAW,IAX,IAYN
C
      REAL ORDER,X,Y,WID
C
      CHARACTER TABLE*80,IDTAB*8,TUNIT1*16,TUNIT2*16,FORM1*6,FORM2*6
      CHARACTER LINE*80
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
      COMMON /VMR/MADRID(1)
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C 
      DATA ORDER/0./
      DATA TUNIT1/'UNITLESS'/
      DATA TUNIT2/'ANGSTROM'/
      DATA FORM1/'I8'/
      DATA FORM2/'F9.2'/
C
C  initialize MIDAS
      CALL STSPRO('ECHIDA')
C
C  get descriptor or table name for storage of data

      CALL STKRDC('P1',1,1,80,I,TABLE,KUN,KNUL,ISTAT)
      
      CALL TBTOPN(TABLE,F_U_MODE,TID,STAT)

      CALL TBIGET(TID,NCOL,NROW,NS,ACOL,AROW,STAT)
      CALL TBCSER(TID,':X ',ICX,STAT)
      CALL TBCSER(TID,':MABS ',ICYN,STAT)
      IF (ICX.EQ.-1 .OR.ICYN.EQ.-1) THEN
         ISTAT  = 1
         GO TO 70
      END IF
      CALL TBCSER(TID,':WAVE',ICW,STAT)
      IF (ICW.EQ.-1) THEN
         CALL TBCINI(TID,D_R8_FORMAT,1,FORM2,TUNIT2,
     .        'WAVE',ICW,STAT)
      END IF
C
      CALL TBCMAP(TID,ICX,IAX,STAT)
      CALL TBCMAP(TID,ICYN,IAYN,STAT)
      CALL TBCMAP(TID,ICW,IAW,STAT)

      CALL SETNULL(MADRID(IAW),NROW)
C
      IDTAB = 'IDTAB'
      CALL TBTOPN(IDTAB,F_I_MODE,IDTID,STAT)
      CALL TBIGET(IDTID,IDNCOL,IDNROW,IDNS,IDACOL,IDAROW,STAT)
      CALL TBCSER(IDTID,':X',IDCX,STAT)
      CALL TBCSER(IDTID,':Y',IDCY,STAT)
      CALL TBCSER(IDTID,':IDENT',IDCW,STAT)
      CALL TBCSER(IDTID,':ORDER',IDCO,STAT)

      DO NPOS = 1, IDNROW
C     
         CALL TBERDR(IDTID,NPOS,IDCX,X,NULL,STAT)
         CALL TBERDR(IDTID,NPOS,IDCY,Y,NULL,STAT)
         CALL TBERDR(IDTID,NPOS,IDCW,WID,NULL,STAT)
         CALL TBERDR(IDTID,NPOS,IDCO,ORDER,NULL,STAT)
C     
C  search for the value on the table
C
         CALL SEARCH(X,ORDER,NROW,MADRID(IAX),MADRID(IAYN),IROW)
         IF(IROW.EQ.0) THEN 
            WRITE(LINE,100) X,Y,WID 
            CALL STTPUT(LINE,STAT)
         ELSE
            CALL GET(NROW,MADRID(IAW),IROW,WID)
         ENDIF
      ENDDO
C     
   70 CONTINUE
      IF (ISTAT.NE.0) THEN
          CALL STTPUT(' Columns :X :MABS are not present',ISTAT)
      END IF

      CALL TBTCLO(TID,STAT)
      CALL TBTCLO(IDTID,STAT)
      CALL STSEPI
C
 100  FORMAT('X = ',F7.2,'Y = ',F5.2,'  LAMBDA = ',F7.2,' not found')
      END

      SUBROUTINE GET(N,WAVE,IPOINT,WID)
C
C ASSIGN WAVELENGTH
C
      IMPLICIT NONE
C 
      INTEGER  IPOINT,N
      INTEGER      TINULL
C 
      REAL     TRNULL, WID
C 
      DOUBLE PRECISION WAVE(N)
      DOUBLE PRECISION TDNULL
C
      CALL TBMNUL(TINULL,TRNULL,TDNULL)

      IF (WID.LE.2.0) THEN
         WAVE(IPOINT) = TDNULL
      ELSE
         WAVE(IPOINT) = WID
      END IF
C 
      RETURN
      END

      SUBROUTINE SEARCH(XN,YN,N,X,Y,IPOINT)
C
C FIND FEATURE
C
      IMPLICIT NONE
C 
      INTEGER  N,IPOINT,I
C 
      REAL X(N),Y(N),DIST,X1,D,XN,YN
C
      IPOINT = 0
      DIST   = 0.1
      DO 10 I = 1,N
         IF (ABS(YN - Y(I)) .LT. 0.1) THEN
            X1     = XN - X(I)
            D      = ABS(X1)
            IF (D.LT.DIST) THEN
               DIST   = D
               IPOINT = I
            ELSE
               IF (IPOINT.NE.0) RETURN
            END IF
         ENDIF
 10   CONTINUE
      RETURN
      END

      SUBROUTINE SETNULL(WAVE,N)
C
C SET ALL WAVELENGTHS TO NULL
C
      IMPLICIT NONE
C 
      INTEGER  I,N
      INTEGER      INULL
C 
      REAL     RNULL
C 
      DOUBLE PRECISION WAVE(N)
      DOUBLE PRECISION DNULL
C
      CALL TBMNUL(INULL,RNULL,DNULL)

      DO I = 1,N
         WAVE(I) = DNULL
      ENDDO
C 
      RETURN
      END