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:  DAOMID 
C.AUTHOR:   P. Figon, LAS Marseille 4eme trimestre 1985
C.Purpose:  Convert DAOPHOT tables into MIDAS tables
C.VERSION:  F. Murtagh, ST-ECF, July 1987  (Allow for .ADD files).
C.VERSION:  910510 RHW rewriten for portable version
C.VERSION:  910815 RHW change column names to :X_COORD and :YCOORD (was :X, :Y)
C 040722	last modif
C 
C------------------------------------------------------------------
C 
      PROGRAM DAOMID
C
      IMPLICIT         NONE
C 
      DOUBLE PRECISION STASTE(4)
C 
      CHARACTER*3      EXT
      CHARACTER*4      TYPE
      CHARACTER*12     XLAB,YLAB
      CHARACTER*80     NAME,BID,BL
      CHARACTER*84     TABLE 
      CHARACTER*120    STRING
C 
      REAL             X,Y,MG,SH,R0,ST,CHI,MS,IT
C 
      INTEGER          MADRID(1)
      INTEGER          I, J, IST, ICOL, NACT
      INTEGER          PIXO,TID
      INTEGER          ITYP, RTYP
      INTEGER          NROW, NROW2, NCOL
      INTEGER          KUN, KNUL, NCARA, NELEM, BYTEL
C
      INCLUDE          'MID_INCLUDE:ST_DEF.INC/NOLIST'
      COMMON           /VMR/MADRID
      INCLUDE          'MID_INCLUDE:ST_DAT.INC/NOLIST'
C
C *** initialize the MIDAS environment
      CALL STSPRO('DAOMID')
C
C *** get the table name to convert
      CALL STKRDC('IN_A',1,1,80,NCARA,NAME,KUN,KNUL,IST)
C
C *** check the name of the table
      I = INDEX(NAME,'.')
      IF (I.EQ.0) 
     +   CALL STETER(11,'*** FATAL: Table name requires extension')
C
      EXT=NAME(I+1:I+3)
      CALL UPCAS(EXT,EXT)
      IF (EXT.NE.'COO' .AND. EXT.NE.'PK '.AND. EXT.NE.'NST' .AND.
     +    EXT.NE.'ADD'.AND.EXT.NE.'ALS') THEN
          CALL STETER(12,'*** FATAL: Only .COO, .PK, .ALS, .ADD '//
     +                'and .NST tables')
      END IF
C 
      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
         PIXO = 1
      ELSE
         CALL STTPUT('*** INFO: Get start/step values from '//
     +               ' keyword TRANSF...',IST)
         CALL STKRDD('TRANSF',1,4,NACT,STASTE,KUN,KNUL,IST)
         PIXO = 0
      ENDIF
C
C *** open the daophot table
      OPEN(UNIT=20,FILE=NAME,STATUS='OLD',ERR=9999)
C
C *** open scratch file
      OPEN(UNIT=30,STATUS='SCRATCH')
C
C *** get the useful line and their number
      BL='   '
      DO 200, I=1,3
         READ(20,'(A)') BID
200   CONTINUE
      NROW=0
C 
2010  READ(20,'(A)',END=2020) BID
      IF  (BID.NE.BL) THEN
         NROW=NROW+1
         WRITE(30,'(A)') BID
      END IF
      GO TO 2010
C 
2020  CONTINUE                                     !EOF reached
      REWIND 30
C
C *** number of columns
      IF (EXT.EQ.'COO') THEN
         NCOL=6
      ELSE IF(EXT.EQ.'PK '.OR. EXT.EQ.'NST'.OR. EXT.EQ.'ALS') THEN
         NCOL=9
      ELSE IF(EXT.EQ.'ADD') THEN
         NCOL=4
      END IF
C
C *** create MIDAS tables
      NROW2 = NROW*2
      CALL TBTINI(TABLE,0,F_O_MODE,NCOL,NROW2,TID,IST)
C
C *** define the columns
      ITYP = D_I4_FORMAT
      RTYP = D_R4_FORMAT
      IF (PIXO.EQ.0) THEN
         XLAB = 'X_COORD '
         YLAB = 'Y_COORD '
      ELSE
         XLAB = 'X_COORDPIX'
         YLAB = 'Y_COORDPIX'
      ENDIF
      IF (EXT.EQ.'COO') THEN
         CALL TBCINI(TID,ITYP,1,'I4',   ' ','I',  ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.2',' ',XLAB,  ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.2',' ',YLAB,  ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.3',' ','MG', ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.3',' ','SH', ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.3',' ','R0', ICOL,IST)
      ELSE IF(EXT.EQ.'ADD') THEN
         CALL TBCINI(TID,ITYP,1,'I4',   ' ','I',  ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.2',' ',XLAB,  ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.2',' ',YLAB,  ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.3',' ','MG', ICOL,IST)
      ELSE IF(EXT.EQ.'PK '.OR.EXT.EQ.'NST'.OR.EXT.EQ.'ALS') THEN
         CALL TBCINI(TID,ITYP,1,'I4',   ' ','I',  ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.2',' ',XLAB,  ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.2',' ',YLAB,  ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.3',' ','MG', ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.3',' ','ST', ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.3',' ','MS', ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.0',' ','IT', ICOL,IST)
         CALL TBCINI(TID,RTYP,1, 'F5.2',' ','CHI',ICOL,IST)
         CALL TBCINI(TID,RTYP,1,'F10.3',' ','SH', ICOL,IST)
      END IF
C
C *** write the table
      IF (EXT.EQ.'COO') THEN
         DO J=1,NROW
            READ(30,*) I,X,Y,MG,SH,R0
            IF (PIXO.EQ.0) THEN
               X = X*STASTE(3) + STASTE(1)      ! Transf. coords. from pix.
               Y = Y*STASTE(4) + STASTE(2)      ! coords. to world coords.
            ENDIF
            CALL TBEWRI(TID,J,1,I, IST)    
            CALL TBEWRR(TID,J,2,X, IST)
            CALL TBEWRR(TID,J,3,Y, IST) 
            CALL TBEWRR(TID,J,4,MG,IST)
            CALL TBEWRR(TID,J,5,SH,IST)
            CALL TBEWRR(TID,J,6,R0,IST)
         END DO
      ELSE IF(EXT.EQ.'ADD') THEN
         DO J=1,NROW
            READ(30,*) I,X,Y,MG
            IF (PIXO.EQ.0) THEN
               X = X*STASTE(3) + STASTE(1)      ! Transf. coords. from pix.
               Y = Y*STASTE(4) + STASTE(2)      ! coords. to world coords.
            ENDIF
            CALL TBEWRI(TID,J,1,I, IST)    
            CALL TBEWRR(TID,J,2,X, IST)
            CALL TBEWRR(TID,J,3,Y, IST) 
            CALL TBEWRR(TID,J,4,MG,IST)
         ENDDO
      ELSE IF(EXT.EQ.'PK '.OR.EXT.EQ.'NST'.OR.EXT.EQ.'ALS') THEN
         DO J=1,NROW
            READ(30,*) I,X,Y,MG,ST,MS,IT,CHI,SH	
            IF (PIXO.EQ.0) THEN
               X = X*STASTE(3) + STASTE(1)      ! Transf. coords. from pix.
               Y = Y*STASTE(4) + STASTE(2)      ! coords. to world coords.
            ENDIF
            CALL TBEWRI(TID,J,1,I, IST)    
            CALL TBEWRR(TID,J,2,X, IST)
            CALL TBEWRR(TID,J,3,Y, IST) 
            CALL TBEWRR(TID,J,4,MG,IST)
            CALL TBEWRR(TID,J,5,ST,IST)
            CALL TBEWRR(TID,J,6,MS,IST)
            CALL TBEWRR(TID,J,7,IT,IST)
            CALL TBEWRR(TID,J,8,CHI,IST)
            CALL TBEWRR(TID,J,9,SH,IST)
         END DO
      END IF
C 
      I = INDEX(TABLE,' ')
      IF (I.LT.2) I = LEN(TABLE)
      WRITE(STRING,12345) TABLE(1:I-1)
12345 FORMAT('Midas table ',A,'.tbl created')
      CALL STTPUT(STRING,IST)
C
C *** close the files
      CLOSE(20)
      CLOSE(30)
C
C *** exit 
      CALL STSEPI                             !also closes the Midas table
C 
9999  CALL STTPUT
     + ('*** WARNING: could not open DAOPHOT table...; I quit',IST)
      CALL STSEPI

      END
