C @(#)tblmiddao.for	17.1.1.1 (ESO-DMD) 01/25/02 17:14:18
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 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
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.PROGRAM:   TBLMIDDAO ("Tables, - Midas to Daophot")
C.AUTHOR:    F. Figon, LAS Marselle
C.OBJECTIVE: CONVERTI CERTAINES TABLES (ET CERTAINES COLONNES)
C.ALGORITHM: - Read in MIDAS table.
C            - Determine col. nos. corresponding to labels :X_COORD 
C              and :Y_COORD
C            - Get pointers to beg. of these columns.
C            - Then simply output the values in these two columns.
C            - ... and that's it.
C.VERSION:   8704?? FM  Keyw. TRANSF, etc.
C.VERSION:   910510 RHW rewritten for portable MIDAS
C.VERSION:   910815 RHW change :X and :Y to :X_COORD and :Y_COORD
C------------------------------------------------------------------
      PROGRAM MIDDAO
C
      IMPLICIT NONE
C 
      DOUBLE PRECISION  STASTE(4)
C 
      CHARACTER*4       TYPE
      CHARACTER*3       EXT
      CHARACTER*60      NAME
      CHARACTER*60      TABLE
      CHARACTER*80      STRING
C 
      INTEGER           I,IST
      INTEGER           NCARA, NACT
      INTEGER           KUN,KNUL
      INTEGER           MADRID(1)
      INTEGER           NELEM,BYTEL
      INTEGER           TID
      INTEGER           NCOL,NROW,NSC,NACOL,NAROW
      INTEGER           NOCOL1, NOCOL2
C 
      INTEGER*8         IPTR1, IPTR2
C
      INCLUDE           'MID_INCLUDE:ST_DEF.INC/NOLIST'
      COMMON            /VMR/MADRID
      INCLUDE           'MID_INCLUDE:ST_DAT.INC/NOLIST'
C
C *** get the connecttion
      CALL STSPRO('MIDDAO')
C
C *** get the table name
      CALL STKRDC('IN_A',1,1,60,NCARA,NAME,KUN,KNUL,IST)
      IF (NAME(1:1).EQ.'?') THEN
         CALL STTPUT('*** FATAL:  No MIDAS table name given',IST)
         CALL STSEPI
      END IF

      DO I=1,NCARA
         IF (NAME(I:I).EQ.' ') GO TO 12
      END DO
12    CONTINUE
      EXT='COO'
      TABLE=NAME(1:I-1)//'.'//EXT
      CALL LOWCAS(TABLE,TABLE)
C
C *** Get start and step values from keyword TRANSF
      CALL STKFND('TRANSF',TYPE,NELEM,BYTEL,IST)
      IF (NELEM.EQ.0) THEN 
         CALL STTPUT(' *** INFO: Keyword TRANSF missing; world and '//
     2               'pixel coords. assumed identical',IST)
         STASTE(1) = 0.0
         STASTE(2) = 0.0
         STASTE(3) = 1.0
         STASTE(4) = 1.0
      ELSE
         CALL STTPUT(' *** Getting start/step values from keyword '//
     2               'TRANSF...',IST)
         CALL STKRDD('TRANSF',1,4,NACT,STASTE,KUN,KNUL,IST)
      ENDIF
C
C *** Open daophot table
      OPEN(UNIT=20,FILE=TABLE,STATUS='UNKNOWN',ERR=101)
C
C *** get info from MIDAS table
      CALL TBTOPN(NAME,F_IO_MODE,TID,IST)
      CALL TBIGET(TID,NCOL,NROW,NSC,NACOL,NAROW,IST)
      CALL TBCSER(TID,':X_COORD',NOCOL1,IST)
      CALL TBCSER(TID,':Y_COORD',NOCOL2,IST)
      CALL TBCMAP(TID,NOCOL1,IPTR1,IST)
      CALL TBCMAP(TID,NOCOL2,IPTR2,IST)
      CALL DOIT(MADRID(IPTR1),MADRID(IPTR2),NROW,STASTE)
C
      CLOSE(20)
      CALL TBTCLO(TID,IST)
      CALL STSEPI

  101 CONTINUE
      STRING = '*** WARNING: Something wrong with output '//
     2         'table; I quit'
      CALL STTPUT(STRING,IST)
      CALL STSEPI                     ! finish up communication with monitor
      END



      SUBROUTINE DOIT(A,B,N,SS)
C +++
C ---
      INTEGER          I, N
C 
      REAL             A(N),B(N)
C 
      DOUBLE PRECISION SS(4)
C
  100 FORMAT(1X,I5,2F9.2)
C
      DO 1000,I=1,N
         A(I) = (A(I)-SS(1))/SS(3)         ! Transf. coords. from WORLD
         B(I) = (B(I)-SS(2))/SS(4)         ! coords. to PIXEL coords.
         WRITE(20,100) I,A(I),B(I)
1000  CONTINUE
      RETURN
      END