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