C @(#)tdazident.for	19.1 (ES0-DMD) 02/25/03 13:17:06
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
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  15:18 - 18 DEC 1987
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: J.D.PONZ, K.BANSE
C
C.IDENTIFICATION: TDAZIDENT.FOR      
C
C.KEYWORDS:
C  image display, cursor, tables, identification
C
C.PURPOSE:
C  Identify table entries via the cursor
C  read the position of the cursor on the DeAnza
C  ask for identification
C  store the information on a column
C
C.ALGORITHM:
C   Use enabled cursor(s) and read screen pixels, get real pixels
C  and world coord
C  when the ENTER button is pressed on the cursor board.
C  Exit by pressing ENTER with enabled cursor(s) off.
C   Max. no. of coords is read from CURSOR(1), if this max. is reached,
C  we exit automatically!
C  MODIFIED VERSION OF COORD
C
C.INPUT/OUTPUT:
C  the following keywords are used:
C
C  DEANZA/I/1/6   main display info
C  DAZHOLD/I/1/3  cursor(s) enabled, cursor form(s) + split screen mode
C
C  P1/C/1/15   optional descriptor name where world coordinates
C    + pixel values should be stored
C    or table name, if data should go to a table
C    = ?, if data only to be displayed on terminal
C
C  OUTPUTR/R/10/10  receives real pixels, world coords + intensities 
C    for each cu
C  OUTPUTI/I/1/1  receives total no. of coordinates obtained
C  CURSOR/I/1/4   (1) holds max. no. of coords reading on input
C    (1,,,4) will be filled with cursor pos. on output
C
C.VERSIONS
C  1.50  use IMPLICT NONE and use IDI interfaces + new cursor interface  GETCUR
C
C-------------------------------------------------------------------
C
C
      PROGRAM TDAZID
      IMPLICIT NONE
C
      LOGICAL IFIRST
      LOGICAL IHEAD
      LOGICAL STUPID
C
      INTEGER MADRID
      INTEGER COOCNT,COOMAX
      INTEGER IAV,ICR,ICX,ICY
      INTEGER IL,IROW,J,N,NBYT2,NC
      INTEGER NCOL,NROW,NINCOL,NN,NOC,NOREC,NPOS
      INTEGER STAT,ST1,ST2
      INTEGER XY1(2),XY2(2)
      INTEGER IC(7)
      INTEGER TID,NAC,NAR,DTYPEX,DTYPEY,DTYPER,KUN,KNUL
C
      CHARACTER OUTPUT*1
      CHARACTER INFO*24,HEAD*80
      CHARACTER FRAME*60
      CHARACTER TABLE*64,COLM1*17,COLM2*17,COLM3*17
      CHARACTER ERROR*17,FORM*8
      CHARACTER PROMPT*18,LINE*80,LINE1*27
      CHARACTER CVAL*80
      CHARACTER IEXT*10,TNULL*10
C
      REAL RBUF,RERR,RVAL(2)
      REAL FPIX(4),WCOO(4)
C
      DOUBLE PRECISION DDUM(2),DVAL(2),DERR
C
      INCLUDE 'MID_INCLUDE:TABLES.INC'
      INCLUDE 'MID_INCLUDE:IDIDEV.INC'
      INCLUDE 'MID_INCLUDE:IDIMEM.INC'
      COMMON /VMR/MADRID(1)
      INCLUDE 'MID_INCLUDE:TABLED.INC'
C
      DATA IFIRST/.FALSE./
      DATA IHEAD/.TRUE./
      DATA INFO/'switch cursor(s) on...'/
      DATA IEXT/'^%&$*#(@)!'/
      DATA TNULL/'*         '/
C
C ...  INITIALIZE MIDAS
C
      CALL STSPRO('TDAZIDENT')
C
C ... GET DISPLAY UNIT FOR DEANZA + ATTACH IT
C
      CALL DTOPEN(1,STAT)
C
C ...  GET CURSORS INVOLVED
C
      CALL STKRDI('DAZHOLD',1,1,IAV,NOC,KUN,KNUL,STAT)  !  NOC = 1,2,3 for cursor 1,2 or both
      NOC    = NOC + 1
C
C ...  GET PARAMETERS
C
      NOREC  = 1
      CALL STKRDC('P1',1,1,64,IAV,TABLE,KUN,KNUL,STAT)
      CALL STKRDC('P2',1,1,17,IAV,COLM1,KUN,KNUL,STAT)
      CALL STKRDC('P3',1,1,17,IAV,COLM2,KUN,KNUL,STAT)
      CALL STKRDC('P4',1,1,17,IAV,COLM3,KUN,KNUL,STAT)
      CALL STKRDC('P5',1,1,17,IAV,ERROR,KUN,KNUL,STAT)
      IF (COLM3(1:1).EQ.':' .OR. COLM3(1:1).EQ.'#') THEN
          NINCOL = 2
      ELSE
          NINCOL = 1
          ERROR  = COLM3
      END IF
      IF (ERROR(1:1).EQ.'?') THEN
          RERR   = 2.
      ELSE
          CALL GENCNV(ERROR,2,1,N,RERR,DERR,NN)
      END IF
C
C ... READ TABLE
C
      NC     = 0
      CALL TBTOPN(TABLE,F_U_MODE,TID,STAT)
      CALL TBIGET(TID,NCOL,NROW,N,NAC,NAR,STAT)
      CALL TBCSER(TID,COLM1,ICR,STAT)
      IF (ICR.EQ.-1) 
     .CALL TBCINI(TID,D_R4_FORMAT,'E14.6','  ',COLM1(2:17),ICR,STAT)
      NC     = NC + 1
      IC(NC) = ICR
      CALL TBCSER(TID,COLM2,ICX,STAT)
      IF (ICX.EQ.-1) THEN
          CALL STETER(1,'COLM not found ... ')
      ELSE
          CALL TBFGET(TID,ICX,FORM,IL,DTYPEX,STAT)
          IF (DTYPEX.EQ.D_C_FORMAT) 
     +        CALL STETER(2,'Wrong COLM format ... ')
          NC     = NC + 1
          IC(NC) = ICX
      END IF
      IF (NINCOL.EQ.2) THEN
          CALL TBCSER(TID,COLM3,ICY,STAT)
          IF (ICY.EQ.-1) THEN
              CALL STETER(1,'COLM not found ... ')
          ELSE
              CALL TBFGET(TID,ICY,FORM,IL,DTYPEY,STAT)
              IF (DTYPEY.EQ.D_C_FORMAT) 
     .            CALL STETER(2,'Wrong COLM format ... ')
              IF (DTYPEX.NE.DTYPEY) 
     .            CALL STETER(3,'Incompatible COLM format ... ')
          END IF
          NC     = NC + 1
          IC(NC) = ICY
      END IF
      CALL TBLGET(TID,ICR,PROMPT,STAT)
      PROMPT(17:18) = '?:'
      CALL TBFGET(TID,ICR,FORM,IL,DTYPER,STAT)
      IF (DTYPER.EQ.D_R4_FORMAT) THEN
          NBYT2 = -4
      ELSE IF (DTYPER.EQ.D_R8_FORMAT) THEN
          NBYT2 = -8
      ELSE
          NBYT2 = IL
      END IF
C
C ... INIT + GET MAX. COORD READINGS
C
      NPOS   = 0
      CALL STTPUT(' - Position the cursor ',STAT)
      CALL STTPUT(' - Press ENTER',STAT)
      OUTPUT = CHAR(07)
      CALL STTPUT(OUTPUT,STAT)
      CALL STKRDI('CURSOR',1,1,IAV,COOMAX,KUN,KNUL,STAT)
      COOCNT = 0
C !necessary to tell GETCUR, that it's first time...
      FRAME  = ' '
C
C ... READ CURSOR POSITION(S)
C
C !'NN' = no drawing, no pixel value
   10 CALL GETCUR('NNYY',FRAME,XY1,FPIX(1),WCOO(1),RBUF,
     .            ST1,XY2,FPIX(3),WCOO(3),RBUF,ST2)
      GO TO (20,30,40),NOC
C
   20 IF (ST1.EQ.0) THEN
          GO TO 50
      ELSE
          GO TO 60
      END IF
   30 IF (ST2.EQ.0) THEN
          GO TO 50
      ELSE
          GO TO 60
      END IF
   40 IF ((ST1.EQ.0) .AND. (ST2.EQ.0)) THEN
          GO TO 50
      ELSE
          GO TO 60
      END IF
C
C ... IF CURSORS ARE NOT SWITCHED ON INITIALLY, DISPLA INFO MESSAGE
C
   50 IF (COOCNT.EQ.0) THEN
          CALL STTPUT(INFO,STAT)
          GO TO 10
      ELSE
          GO TO 110
      END IF
C  !  update coordinate counter
   60 COOCNT = COOCNT + 1
C
C ... SEARCH FOR THE VALUE ON THE TABLE
C
      IF (NINCOL.EQ.1) THEN
          IF (DTYPEX.EQ.D_R4_FORMAT) THEN
              CALL TBES1R(TID,ICX,FPIX,IROW,RVAL,STAT)
          ELSE
              DDUM(1) = FPIX(1)
              DERR   = RERR
              CALL TBES1D(TID,ICX,DDUM,IROW,DVAL,STAT)
          END IF
      ELSE
          IF (DTYPEX.EQ.D_R4_FORMAT) THEN
              CALL TBES2R(TID,ICX,ICY,FPIX,IROW,RVAL,STAT)
          ELSE
              DDUM(1) = FPIX(1)
              DDUM(2) = FPIX(2)
              DERR   = RERR
              CALL TBES2D(TID,ICX,ICY,DDUM,IROW,DVAL,STAT)
          END IF
      END IF
      IF (IROW.EQ.0) THEN
          WRITE (LINE1,9010) FPIX(1),FPIX(2)
          CALL STTPUT(LINE1//' Feature not found, try again',STAT)
      ELSE
C
C ... GET FPIX(1), FPIX(2), IDENT, X, (Y)
C
          CALL TDLIS2(TID,NC,IC,IROW,LINE,IHEAD,HEAD,STAT)
          IF (IHEAD) THEN
              IHEAD  = .FALSE.
              CALL STTPUT('  X COORD.   Y COORD.   '//HEAD,STAT)
          END IF
          WRITE (LINE1,9010) FPIX(1),FPIX(2)
          CALL STTPUT(LINE1//LINE,STAT)
C
C ... WRITE PROMPT FPIX(1), FPIX(2), IDENT, X, (Y),
C ... AND ENTER VALUE IN THE TID
C
          STUPID = .FALSE.             ! standard update identification
  100     IF (STUPID) CALL STTPUT('Error in input. ',STAT)
          STUPID = .TRUE.
   70     CVAL   = IEXT
          STAT   = 0
          CALL STKPRC(PROMPT,'INPUTC',1,1,80,IAV,CVAL,KUN,KNUL,STAT)
          IF (CVAL(1:10).NE.IEXT) THEN
              IF (CVAL(1:10).EQ.TNULL) THEN
                  CALL TBEDEL(TID,IROW,ICR,STAT)
              ELSE
                  DO 80 J = 80,1,-1
                      IF (CVAL(J:J).NE.' ') GO TO 90
   80             CONTINUE
                  J      = 80
   90             CONTINUE
C       CALL TZCV1C(CVAL,J,1,TYPER,NBYT2,RVAL,RVAL,
C     .         DVAL,CVAL1,STAT)
                  IF (STAT.NE.0) GO TO 70
                  IF (DTYPER.EQ.D_R4_FORMAT) THEN
                      READ (CVAL(1:J),9000,ERR=100) RVAL(1)
                      CALL TBEWRR(TID,IROW,ICR,RVAL,STAT)
                  ELSE IF (DTYPER.EQ.D_R8_FORMAT) THEN
                      READ (CVAL(1:J),9000,ERR=100) DVAL(1)
                      CALL TBEWRD(TID,IROW,ICR,DVAL,STAT)
                  ELSE
                      CALL TBEWRC(TID,IROW,ICR,CVAL,STAT)
                  END IF
              END IF
          END IF
          STUPID = .FALSE.
      END IF  !  look for more
      GO TO 10
C
C ... END
C
  110 CALL TBTCLO(TID,STAT)
C
      CALL DTCLOS(QDSPNO)
      CALL STSEPI
C
C  Formats
 9000 FORMAT (BN,F4.0)
 9010 FORMAT (' ',E12.6,' ',E12.6,' ')
      END
