C===========================================================================
C Copyright (C) 1995-2010 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 Massachusetts Ave, Cambridge, 
C MA 02139, USA.
C
C Correspondence 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
      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 
C 100616	last modif
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, CTEST
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),CTEST,NULL3,ISTAT)
                      CALL FT_EOS(CTEST,20,IDENT,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


