C @(#)tdazident.for 17.1.1.1 (ES0-DMD) 01/25/02 17:10:05 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