C @(#)holesid.for 17.1.1.1 (ES0-DMD) 01/25/02 17:55:13 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@(#)holesid.for 17.1.1.1 (ESO-IPG) 17:55:13 01/25/02 PROGRAM HOLESID C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.IDENTIFICATION: HOLESID.FOR C.PURPOSE: Draw identification of holes to be drilled on OPTOPUS plate. C.ALGORITHM: Use the routines of the AGL library C.AUTHOR: Alessandra Gemmo Padova Department of Astronomy C.VERSION: 050691 AG Creation C------------------------------------------------------------------------------ IMPLICIT NONE C INTEGER MADRID,TID,KUN,KNUL INTEGER NPAR,ISTAT,ILEN,ILAB INTEGER I,NACT INTEGER NCOLUM,NCOL,NROW,NSC INTEGER NLAB INTEGER COL(4) INTEGER PARNEV INTEGER DTYPE,NACOL,NAROW INTEGER IIDENT, PLMODE, ACCESS C C *** REAL VX,VY,RIDENT REAL X(1000),Y(1000) REAL XMIN,XMAX,YMIN,YMAX C C *** DOUBLE PRECISION DIDENT C C *** CHARACTER*64 TABLE CHARACTER*80 TEXT CHARACTER*17 COLUMN(4) CHARACTER*8 AFORM CHARACTER*16 FORM CHARACTER*20 IDENT1 CHARACTER*20 IDENT C C *** LOGICAL NULL1,NULL2,NULL3,ISEL C C *** INCLUDE 'MID_INCLUDE:TABLES.INC/NOLIST' COMMON /VMR/MADRID(1) INCLUDE 'MID_INCLUDE:TABLED.INC/NOLIST' C C *** DATA PARNEV/5/ DATA ACCESS/1/ DATA PLMODE/1/ C C *** start the code C CALL STSPRO('HOLESID') C C *** read parameters CALL TDPGET(PARNEV,NPAR,ISTAT) IF(ISTAT.NE.0)THEN TEXT = '*** FATAL: Problems with parameters input table' CALL STETER(9,TEXT) ENDIF C TABLE = TPARBF(1) COLUMN(1) = TPARBF(2) COLUMN(2) = TPARBF(3) COLUMN(3) = TPARBF(4) NCOLUM = 3 C C C C *** read table CALL TBTOPN(TABLE,F_I_MODE,TID,ISTAT) IF(ISTAT.NE.0)THEN TEXT = '*** FATAL: Failed to open table: '//TABLE CALL STETER(9,TEXT) ENDIF C CALL TBIGET(TID,NCOL,NROW,NSC,NACOL,NAROW,ISTAT) IF(ISTAT.NE.0)THEN TEXT = '*** FATAL: Failed to get table info '//TABLE CALL STETER(9,TEXT) ENDIF C C *** get column adresses DO I = 1,NCOLUM CALL TBCSER(TID,COLUMN(I),COL(I),ISTAT) IF(ISTAT.NE.0)THEN TEXT = '*** FATAL: Failed to get table column' CALL STETER(9,TEXT) ENDIF C IF(COL(I).EQ.-1)THEN TEXT = '*** FATAL: Failed to get table column' CALL STETER(9,TEXT) ENDIF ENDDO C CALL TBFGET(TID,COL(3),AFORM,ILEN,DTYPE,ISTAT) CALL LENBUF(AFORM,I) FORM = '('//AFORM(1:I)//')' C C ... plot - AGL window CALL PTOPEN(' ','none',ACCESS,PLMODE) CALL AGSSET('LFRG') CALL AGSSET('CHSM') C C *** first iteration to find label positions NLAB=0 DO I=1,NROW CALL TBSGET(TID,I,ISEL,ISTAT) IF(ISEL)THEN CALL TBERDR(TID,I,COL(1),VX,NULL1,ISTAT) CALL TBERDR(TID,I,COL(2),VY,NULL2,ISTAT) CALL STKRDR('PLRSTAT',11,1,NACT,XMIN,KUN,KNUL,ISTAT) CALL STKRDR('PLRSTAT',12,1,NACT,XMAX,KUN,KNUL,ISTAT) CALL STKRDR('PLRSTAT',15,1,NACT,YMIN,KUN,KNUL,ISTAT) CALL STKRDR('PLRSTAT',16,1,NACT,YMAX,KUN,KNUL,ISTAT) IF(.NOT.NULL1)THEN IF(.NOT.NULL2)THEN NLAB = NLAB+1 X(NLAB) = VX Y(NLAB) = VY ENDIF ENDIF ENDIF ENDDO C C *** second iteration to plot labels ILAB=0 DO I=1,NROW CALL TBSGET(TID,I,ISEL,ISTAT) IF (ISEL)THEN CALL TBERDR(TID,I,COL(1),VX,NULL1,ISTAT) CALL TBERDR(TID,I,COL(2),VY,NULL2,ISTAT) IF (.NOT.NULL1) THEN IF (.NOT.NULL2) THEN IF (DTYPE.EQ.D_C_FORMAT) THEN CALL TBERDC(TID,I,COL(3),IDENT,NULL3,ISTAT) ELSE IF (DTYPE.EQ.D_I4_FORMAT) THEN CALL TBERDI(TID,I,COL(3),IIDENT,NULL3,ISTAT) IF (.NOT.NULL3) THEN C WRITE(IDENT,FORM,ERR=30) IIDENT WRITE(IDENT,FORM) IIDENT ENDIF ELSE IF (DTYPE.EQ.D_R4_FORMAT) THEN CALL TBERDR(TID,I,COL(3),RIDENT,NULL3,ISTAT) IF (.NOT.NULL3) THEN C WRITE(IDENT,FORM,ERR=30) RIDENT WRITE(IDENT,FORM) RIDENT ENDIF ELSE IF (DTYPE.EQ.D_R8_FORMAT) THEN CALL TBERDD(TID,I,COL(3),DIDENT,NULL3,ISTAT) IF (.NOT.NULL3) THEN C WRITE(IDENT,FORM,ERR=30) DIDENT WRITE(IDENT,FORM) DIDENT ENDIF ENDIF ENDIF ENDIF C 30 CONTINUE ILAB = ILAB+1 IDENT1 = '~_~_'//IDENT CALL LENBUF(IDENT1,ILEN) CALL AGGTXT(X(ILAB),Y(ILAB),IDENT1(1:ILEN),22) ENDIF ENDDO C C *** over and out CALL TBTCLO(TID,ISTAT) CALL PTCLOS() CALL STSEPI END