C @(#)optident.for	19.1 (ES0-DMD) 02/25/03 14:27:53
C===========================================================================
C Copyright (C) 1995 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or 
C modify it under the terms of the GNU General Public License as 
C published by the Free Software Foundation; either version 2 of 
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public 
C License along with this program; if not, write to the Free 
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
C MA 02139, USA.
C
C Corresponding concerning ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division 
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen 
C			GERMANY
C===========================================================================
C
C @(#)optident.for	19.1 (ESO-IPG) 14:27:53 02/25/03
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT:      Copyright (c) 1987 European Southern Observatory,
C                            all rights reserved
C.IDENTIFICATION: OPTIDENT
C.AUTHOR:    J.D.Ponz, ESO - Garching
C.KEYWORDS:  Line identification
C.PURPOSE:   Line identification with the graphics cursor
C.USE:       IDENTIFY/GCURSOR TABLE IDENTCOL X [Y] [ERROR]
C.ALGORITHM: Use the routines of the plotlib and midaslib
C.VERSION:   830104 JDP 
C.VERSION:   850411 JDP 
C.VERSION:   880704 RHW Conversion to Fortran 77 + eso extension
C.VERSION:   881201 JDP Selection mechanism
C.VERSION:   910130 MP  get also length of column label
C.VERSION:   910115 RHW IMPLICIT NONE added
C.VERSION:   910805 AG Adapted to Optopus context
C-----------------------------------------------------------------
      PROGRAM   OPTIDN
      IMPLICIT  NONE
C
      REAL      RERR,RVAL(2),RP(2)
      REAL      XCUR,YCUR,PXVL
      DOUBLE PRECISION  DERR,DVAL(2),DP(2), DELTA

      INTEGER   STATUS,ISTAT,IACT,NINCOL,IDUM,NV,NC,NCOL
      INTEGER   NROW,NSCOL,NACOL,NAROW,ICR,ICX,IL,ICY,ICID
      INTEGER   KEY,IROW,IAC,MADRID(1)
      INTEGER   IC(7),LEN
      INTEGER   TID,KUN,KNUL
      INTEGER   DTYPID, DTYPEX, DTYPEY
      INTEGER   ACCESS, PLMODE

      CHARACTER TABLE*64, FORM*8, HEAD*90
      CHARACTER COLUM1*17, COLUM2*17, COLUM3*17, COLUM4*17
      CHARACTER ERROR*17
      CHARACTER PROMPT*18, LINE*80, LINE1*27
      CHARACTER CVAL*80, IEXT*10, TNULL*10

      LOGICAL   IHEAD
C
      INCLUDE   'MID_INCLUDE:ST_DEF.INC/NOLIST'
      COMMON    /VMR/ MADRID
      INCLUDE   'MID_INCLUDE:ST_DAT.INC/NOLIST'
      DATA      IEXT /'^%&$*#(@)!'/
      DATA      TNULL/'*         '/
      DATA      IHEAD/.TRUE./
C
8001  FORMAT(I1)
8002  FORMAT(I2)
9000  FORMAT(' ',E11.5,' ',E11.5,' ')
C
C *** Start of executable code
      CALL STSPRO('OPTIDENT')
      CALL STKRDC('P1',1,1,64,IACT,TABLE,KUN,KNUL,STATUS)
      CALL STKRDC('P2',1,1,17,IACT,COLUM1,KUN,KNUL,STATUS)
      CALL STKRDC('P3',1,1,17,IACT,COLUM2,KUN,KNUL,STATUS)
      CALL STKRDC('P4',1,1,17,IACT,COLUM3,KUN,KNUL,STATUS)
      CALL STKRDC('P5',1,1,17,IACT,COLUM4,KUN,KNUL,STATUS)
      CALL STKRDC('P6',1,1,17,IACT,ERROR,KUN,KNUL,STATUS)
C
      IF (COLUM4(1:1).EQ.':' .OR. COLUM4(1:1).EQ.'#') THEN
         NINCOL = 3
      ELSE
         NINCOL = 2
         ERROR  = COLUM4
      ENDIF
C
      IF (ERROR(1:1).EQ.'?') THEN
         RERR = 2.
      ELSE
         CALL GENCNV(ERROR,2,1,IDUM,RERR,DERR,NV)
      ENDIF
      DERR = RERR
C
C *** initialize table
      NC = 0
      CALL TBTOPN(TABLE,F_U_MODE,TID,ISTAT)
      CALL TBIGET(TID,NCOL,NROW,NSCOL,NACOL,NAROW,ISTAT)
      CALL TBCSER(TID,COLUM1,ICR,ISTAT)
      IF (ICR.EQ.-1) THEN
         CALL TBCINI(TID,D_R4_FORMAT,1,'E14.6',' ',
     2               COLUM1(2:17),ICR,ISTAT)
      ENDIF
      NC     = NC + 1
      IC(NC) = ICR
      CALL TBCSER(TID,COLUM2,ICID,ISTAT)
      IF (ICID.LE.0) THEN
         CALL STTPUT('*** FATAL: Column not found ...',ISTAT)
         CALL TBTCLO(TID,ISTAT)
         GO TO 1001
      ELSE
         CALL TBFGET(TID,ICID,FORM,IL,DTYPID,ISTAT)
         IF (DTYPID.NE.D_C_FORMAT) THEN
            CALL STTPUT('*** FATAL: Wrong column format ...',ISTAT)
            CALL TBTCLO(TID,ISTAT)
            GO TO 1001
         ENDIF
         NC     = NC + 1
         IC(NC) = ICID
      ENDIF
C
      CALL TBCSER(TID,COLUM3,ICX,ISTAT)
      IF (ICX.LE.0) THEN
         CALL STTPUT('*** FATAL: Column not found ...',ISTAT)
         CALL TBTCLO(TID,ISTAT)
         GO TO 1001
      ELSE
         CALL TBFGET(TID,ICX,FORM,IL,DTYPEX,ISTAT)
         IF (DTYPEX.EQ.D_C_FORMAT) THEN
            CALL STTPUT('*** FATAL: Wrong column format ...',ISTAT)
            CALL TBTCLO(TID,ISTAT)
            GO TO 1001
         ENDIF
         NC     = NC + 1
         IC(NC) = ICX
      ENDIF
C
      IF (NINCOL.EQ.3) THEN
         CALL TBCSER(TID,COLUM4,ICY,ISTAT)
         IF (ICY.LE.0) THEN
            CALL STTPUT('*** FATAL: Column not found ...',ISTAT)
            CALL TBTCLO(TID,ISTAT)
            GO TO 1001
         ELSE
            CALL TBFGET(TID,ICY,FORM,IL,DTYPEY,ISTAT)
            IF (DTYPEY.EQ.D_C_FORMAT) THEN
               CALL STTPUT('*** FATAL: Wrong column format ...',ISTAT)
               CALL TBTCLO(TID,ISTAT)
               GO TO 1001
            ENDIF
            IF (DTYPEY.NE.DTYPEX) THEN
               CALL STTPUT('*** FATAL: Incompatible column format',
     2                     ISTAT)
               CALL TBTCLO(TID,ISTAT)
               GO TO 1001
            ENDIF
            NC = NC + 1
            IC(NC) = ICY
         ENDIF
      ENDIF
C
      CALL TBLGET(TID,ICR,PROMPT,ISTAT)
      CALL LENBUF(PROMPT,LEN)
      PROMPT(LEN+1:LEN+3) = ' ?:'
C
C *** restore the graphics display
      ACCESS = -1
      PLMODE = -1
      CALL PTOPEN(' ','none',ACCESS,PLMODE)
      CALL AGSSET('USER')
      CALL STTPUT(' *** INFO: Position the cursor and press any key',
     2            ISTAT)
      CALL STTPUT('     (space Bar to exit)',ISTAT)
1000  CONTINUE
      CALL AGVLOC(XCUR,YCUR,KEY,PXVL)
      IF ((KEY.EQ.13) .OR. (KEY.EQ.11)) THEN
         CALL STTPUT('*** WARNING: Do NOT use the return key',ISTAT)
         CALL TBTCLO(TID,ISTAT)
         GO TO 1001
      ELSE IF (KEY.EQ.32) THEN
         CALL TBTCLO(TID,ISTAT)
         GO TO 1001
      ELSE        
         CALL AGGPLM(XCUR,YCUR,1,4)
         RP (1) = XCUR
         RP (2) = YCUR
      ENDIF
C
C *** search for position in reference
      IF (NINCOL.EQ.1) THEN
         IF(DTYPEX.EQ.D_R4_FORMAT) THEN
            CALL TBES1R(TID,ICX,RP,IROW,RVAL,STATUS)
            DELTA   = ABS(RP(1)-RVAL(1))
         ELSE
            DP(1)   = RP(1)
            DERR    = RERR
            CALL TBES1D(TID,ICX,DP,IROW,DVAL,STATUS)
            DELTA   = DABS(DP(1)-DVAL(1))
         ENDIF
       ELSE
         IF (DTYPEX.EQ.D_R4_FORMAT) THEN
            CALL TBES2R(TID,ICX,ICY,RP,IROW,RVAL,ISTAT)
            DELTA   = SQRT((RP(1)-RVAL(1))**2 + (RP(2)-RVAL(2))**2)
         ELSE
            DP(1)   = RP(1)
            DP(2)   = RP(2)
            DERR    = RERR
            CALL TBES2D(TID,ICX,ICY,DP,IROW,DVAL,ISTAT)
            DELTA   = DSQRT((DP(1)-DVAL(1))**2 + (DP(2)-DVAL(2))**2)
         ENDIF
      ENDIF
      IF (IROW.EQ.0 .OR. DELTA.GT.DERR) THEN
         WRITE (LINE1,9000) RP(1),RP(2)
         CALL STTPUT(LINE1//'*** Feature not found, try again',ISTAT)
      ELSE
C
C *** get seq no, ident, x, (y)
         CALL TDLIS2(TID,NC,IC,IROW,LINE,IHEAD,HEAD,ISTAT)
         IF (IHEAD) THEN
            IHEAD = .FALSE.
            CALL STTPUT('    XCOORD      YCOORD    '//HEAD,ISTAT)
         ENDIF
C
         WRITE (LINE1,9000) RP(1),RP(2)
         CALL STTPUT(LINE1//LINE,ISTAT)
         CALL STKWRC('INPUTC',1,IEXT,1,10,KUN,ISTAT)
         CALL STKPRC(PROMPT,'INPUTC',1,1,80,IAC,CVAL,KUN,KNUL,ISTAT)
         IF (CVAL(1:10).NE.IEXT) THEN
            IF (CVAL(1:10).EQ.TNULL) THEN
               CALL TBEDEL(TID,IROW,ICR,ISTAT)
            ELSE
              CALL TBEWRC(TID,IROW,ICR,CVAL(1:1),ISTAT)
            ENDIF
         ENDIF
      ENDIF
      GO TO 1000
C
1001  CONTINUE
      CALL PTCLOS()
      CALL STSEPI
      END

