C===========================================================================
C Copyright (C) 1995,2004 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:   MIDDAO ("Tables - Midas to Daophot")
C.AUTHOR:    F. Figon, LAS Marselle
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.VERSION:   8704?? FM  Keyw. TRANSF, etc.
C.VERSION:   910510 RHW rewritten for portable MIDAS
C 040722	last modif
C 
C------------------------------------------------------------------
C 
      PROGRAM MIDDAO
C
      IMPLICIT NONE
C 
      DOUBLE PRECISION  STASTE(4)
C 
      CHARACTER*4       TYPE
      CHARACTER*80      NAME
      CHARACTER*84      TABLE
      CHARACTER*120     STRING
C 
      INTEGER           I,IST
      INTEGER           NCARA, NACT
      INTEGER           KUN,KNUL
      INTEGER           MADRID(1)
      INTEGER           NELEM,BYTEL
      INTEGER           PIXO,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 connection
      CALL STSPRO('MIDDAO')
C
C *** get the table name
      CALL STKRDC('IN_A',1,1,80,NCARA,NAME,KUN,KNUL,IST)
C 
C assumed to be without .tbl in the end
      I = INDEX(NAME,' ')
      IF (I.EQ.0) I = LEN(NAME) + 1            !no blanks...
      TABLE=NAME(1:I-1)//'.COO'
      CALL LOWCAS(TABLE,TABLE)
C
C *** Open daophot table
      OPEN(UNIT=20,FILE=TABLE,STATUS='UNKNOWN',ERR=101)
C
C *** get info from MIDAS table, use 1) pixel, 2) world coords.
      CALL TBTOPN(NAME,F_I_MODE,TID,IST)
      CALL TBIGET(TID,NCOL,NROW,NSC,NACOL,NAROW,IST)
      CALL TBCSER(TID,':X_COORDPIX',NOCOL1,IST)
      IF (NOCOL1 .GE. 0) THEN                       !we already have pixels
         CALL TBCSER(TID,':Y_COORDPIX',NOCOL2,IST)
         PIXO = 1
      ELSE
         CALL TBCSER(TID,':X_COORD',NOCOL1,IST)
         CALL TBCSER(TID,':Y_COORD',NOCOL2,IST)
         PIXO = 0
      ENDIF
C 
      IF ((NOCOL1.LT.0).OR.(NOCOL2.LT.0))
     +   CALL STETER(11,'No coord columns found...')
C
C  if world coords, get start and step values from keyword TRANSF
      IF (PIXO.EQ.0) THEN
         CALL STKFND('TRANSF',TYPE,NELEM,BYTEL,IST)
         IF (NELEM.EQ.0) THEN 
            CALL STTPUT(' *** INFO: Keyword TRANSF missing; world '//
     +               'and 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 '//
     +               'TRANSF...assume linear world_coord_system',IST)
            CALL STKRDD('TRANSF',1,4,NACT,STASTE,KUN,KNUL,IST)
         ENDIF
      ENDIF
C 
      CALL TBCMAP(TID,NOCOL1,IPTR1,IST)
      CALL TBCMAP(TID,NOCOL2,IPTR2,IST)
      CALL DOIT(PIXO,MADRID(IPTR1),MADRID(IPTR2),NROW,STASTE)
C 
      I = INDEX(TABLE,' ')
      IF (I.LT.2) I = LEN(TABLE)
      WRITE(STRING,12345) TABLE(1:I-1)
12345 FORMAT('DAOPHOT table ',A,' (ASCII) created')
      CALL STTPUT(STRING,IST)
C
      CLOSE(20)
      CALL STSEPI                      !closes table also

101   CONTINUE
      CALL STTPUT
     + ('*** WARNING: Something wrong with output table; I quit',IST)
      CALL STSEPI
      END


      SUBROUTINE DOIT(PXFLAG,A,B,N,SS)
C +++
C ---
      INTEGER          PXFLAG,N
      REAL             A(N),B(N)
      DOUBLE PRECISION SS(4)
C 
      INTEGER          I
C 
C
      IF (PXFLAG.EQ.0) THEN
         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
C 
      ELSE
         DO 2000,I=1,N                        !already pixel coords
            WRITE(20,100) I,A(I),B(I)
2000     CONTINUE
      ENDIF
      RETURN
C 
100   FORMAT(1X,I5,2F9.2)
      END
 
