C @(#)identigcur.for	19.1 (ES0-DMD) 02/25/03 13:19:45
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++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT:      Copyright (c) 1987 European Southern Observatory,
C                            all rights reserved
C.IDENTIFICATION: IDENTIGCUR
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-----------------------------------------------------------------
      PROGRAM   IDENTGC
      IMPLICIT  NONE
C
      REAL      RERR,RVAL(2),RP(2)
      REAL      XCUR,YCUR
      DOUBLE PRECISION  DERR,DVAL(2),DP(2), DELTA

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

      CHARACTER TABLE*64, FORM*8, HEAD*80
      CHARACTER COLUM1*17, COLUM2*17, COLUM3*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(' ',E12.6,' ',E12.6,' ')
C
C *** Start of executable code
      CALL STSPRO('IDENTGC')
      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,ERROR,KUN,KNUL,STATUS)
C
      IF (COLUM3(1:1).EQ.':' .OR. COLUM3(1:1).EQ.'#') THEN
         NINCOL = 2
      ELSE
         NINCOL = 1
         ERROR  = COLUM3
      ENDIF
C
      IF (ERROR(1:1).EQ.'?') THEN
         RERR = 2.
      ELSE
         CALL GENCNV(ERROR,2,1,IDUM,RERR,DERR,NV)
      ENDIF
      DERR = ABS(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,ICX,ISTAT)
      IF (ICX.LE.0) THEN
         CALL STTPUT('*** FATAL: Column not found ...',ISTAT)
         CALL TBTCLO(TID,ISTAT)
         CALL STSEPI
         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)
            CALL STSEPI
            GO TO 1001
         ENDIF
         NC     = NC + 1
         IC(NC) = ICX
      ENDIF
C
      IF (NINCOL.EQ.2) THEN
         CALL TBCSER(TID,COLUM3,ICY,ISTAT)
         IF (ICY.LE.0) THEN
            CALL STTPUT('*** FATAL: Column not found ...',ISTAT)
            CALL TBTCLO(TID,ISTAT)
            CALL STSEPI
            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)
               CALL STSEPI
               GO TO 1001
            ENDIF
            IF (DTYPEY.NE.DTYPEX) THEN
               CALL STTPUT('*** FATAL: Incompatible column format',
     2                     ISTAT)
               CALL TBTCLO(TID,ISTAT)
               CALL STSEPI
               GO TO 1001
            ENDIF
            NC = NC + 1
            IC(NC) = ICY
         ENDIF
      ENDIF
C
      CALL TBLGET(TID,ICR,PROMPT,ISTAT)
      CALL GENLEN(PROMPT,LEN)
      PROMPT(LEN+1:16) = ' '
      PROMPT(17:18) = '?:'
      CALL TBFGET(TID,ICR,FORM,IL,DTYPER,ISTAT)
      IF (DTYPER.EQ.D_R4_FORMAT) THEN
         NBYT2 = -4
      ELSE IF (DTYPER.EQ.D_R8_FORMAT) THEN
         NBYT2 = -8
      ELSE
         NBYT2 = IL
      ENDIF
C
C *** restore the graphics display
      ACCESS = -1
      PLMODE = 1
      CALL PTOPEN(' ',' ',ACCESS,PLMODE)
      CALL STTPUT('*** INFO: Position cursor and press left mouse'//
     2            ' button or any key (not RETURN)', ISTAT)
      CALL STTPUT('          Use second left mouse button or space'//
     2            ' bar to exit',ISTAT)
1000  CONTINUE
      CALL PTGCUR(XCUR,YCUR,KEY,STATUS)
      IF (KEY.EQ.32) THEN
         CALL TBTCLO(TID,ISTAT)
         CALL PTCLOS()
         CALL STSEPI
         GO TO 1001
      ELSE        
         CALL PTDATA(4,0,1,XCUR,YCUR,0.0,1)
         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('    X COORD.    Y COORD.    '//HEAD,ISTAT)
         ENDIF
C
         WRITE (LINE1,9000) RP(1),RP(2)
         CALL STTPUT(LINE1//LINE,ISTAT)
C5        CVAL = IEXT
         CVAL  = ' '
         STAT = 0
         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)
C
            ELSE
               CALL TBEWRC(TID,IROW,ICR,CVAL,ISTAT)
            ENDIF
         ENDIF
      ENDIF
      GO TO 1000
C
1001  CONTINUE
      END
