C @(#)danstarx.for	17.1.1.1 (ES0-DMD) 01/25/02 17:17:31
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
         PROGRAM DANSTX
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT (c)
C.IDENT         danstarx.for
C.MODULE
C.AUTHOR        Andrew T. Young
C.KEYWORD
C.LANGUAGE      FORTRAN 77
C.PURPOSE       extract star positions from Danish photometric data files
C.COMMENTS
C.VERSION       0.0
C.RETURNS
C.ENVIRONMENT
C.
C-----------------------------------------------------------------------------
C*****************************************************************************
C
C       This program reads data recorded in intermixed formats and combines
C       them into a uniform format, in the file 'sdata.dat' that is converted
C       into a MIDAS table-format file, using the *.fmt file 'sdata.fmt'.
C
C       The version you see here is designed to convert data from the Danish
C       0.5-meter telescope.  Data codes are in col. 1.
C       These codes are read and decoded at statements 110-190 in the main
C       program.
C
C       The basic method is to load the data as they are read from different
C       types of cards into the COMMON blocks /OUTR/ and /OUTC/, which hold
C       real and character variables, respectively.  (Some compilers want you
C       to keep such blocks separate.)  When enough card images have been read
C       to make a complete observation, the contents of /OUT*/ are written to
C       the uniform-format file 'sdata.dat'; then the common blocks are cleared,
C       to the appropriate "null" values.  (Blanks are used to clear character
C       strings.)
C
C       The MIDAS command CREATE/TABLE can then be used, with the *.fmt file
C       supplied, to convert the uniform 'sdata.dat' file to MIDAS table format.
C       This is done in the command CONVERT/PHOT.
C
C       As this is based on the esodcon program, it probably contains fossils.
C
C
C*****************************************************************************
C
      IMPLICIT NONE
C
C  BEGIN Declarations:
C
      DOUBLE PRECISION DJD, DJZ
      REAL EQUINOX
C
      LOGICAL MATCH
      LOGICAL EFLAG
      INTEGER NDATA, NOUTP
C
C
      CHARACTER*80 LINE(2), DATFIL
      COMMON /LINES/LINE
C
      CHARACTER A*1, CODE*2
      CHARACTER*10 RASTR, DESTR
C
C
C
C       Declarations for the output (must be in WRITER too!):
C
      CHARACTER OBJECT*9
      COMMON /OUTC/ OBJECT,RASTR,DESTR
C
C  Set up MIDAS declarations:
C
      INTEGER MADRID(1)
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
C
      COMMON /VMR/ MADRID
C
      INTEGER NACTEL, IUNIT, NULLS, ISTAT
C
C  END Declarations.
C
C
C  BEGIN DATA statements:
C
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
      DATA NDATA/7/, NOUTP/8/
C
C
C  END DATA statements.
C
C
C
C  ********************  PROLOGUE  ********************
C
        CALL STSPRO ('DANSTARX')
C
C
C  Real program begins here:            (use RUN DANSTARX to test in MIDAS)
C
C
        INQUIRE(FILE='sdata.dat',EXIST=EFLAG)
        IF (EFLAG) THEN
                CALL TV('File "sdata.dat" already exists!')
    1           CALL ASK ('Do you want to write over it?? ',A)
                IF (MATCH(A,'Y')) THEN
                        CONTINUE
                ELSE IF (MATCH(A,'N')) THEN
                        CALL STETER(1,
     1                  'Please move "sdata.dat" to a new name.')
                ELSE
                        CALL TV('Please reply "yes" or "no".')
                        GO TO 1
                END IF
         END IF
C               Open the uniform-format ascii file:
        OPEN(NOUTP,FILE='sdata.dat',STATUS='UNKNOWN')
        REWIND NOUTP
C
C
C       clear data storage:
C
        OBJECT=' '
        RASTR=' '
        DESTR=' '
        DJZ=0.D0
C
C       *** Prepare input buffer ***
C
        CALL TV(' ')
C       Get file name:
    7   Call STKRDC ('RAWDAT',1,1,80,  NACTEL,DATFIL,IUNIT,NULLS,ISTAT)
C   7   CALL ASKFIL('What is the name of the file of observed data?',
C    1                  DATFIL)
        INQUIRE(FILE=DATFIL,EXIST=EFLAG)
        IF (.NOT.EFLAG) THEN
                CALL TV('No such file exists!')
                CALL TVN('Please try again:')
                GO TO 7
        END IF
        OPEN(NDATA,FILE=DATFIL,STATUS='UNKNOWN')
        REWIND NDATA
        CALL TV('Extracting star positions...')
C
C
C       Read data.
C
  110   READ (7,'(A80)',END=200) LINE(1),LINE(2)
C
C
C           Skip comment cards:
            IF (LINE(1)(:1).EQ.'c') GO TO 110
C
C           Read first card:
            READ (LINE(1),111,ERR=199) A,DJD,OBJECT,CODE,RASTR,DESTR
  111       FORMAT(A1,4X,F12.5,27X,A9,A2,2X,2A8)
C
C           Skip background data.
            IF (CODE.NE.' *') GO TO 110
C
C           Convert Danish MJD to real JD.
            DJD=DJD+2440000.D0
C           Convert real JD to MJD.
            IF (DJZ.EQ.0.D0) THEN
               DJZ=INT(DJD)+0.5
               EQUINOX=REAL(DJZ-2451545.D0)/365.25 + 2000.
            END IF
C
C
            IF (A.EQ.'s') THEN
C
C                       s: measurement
C
C               reject sky positions:
                IF (LINE(1)(55:55).EQ.'B') GO TO 110
C
                CALL WRITER(EQUINOX)
C
C               clear data arrays:
C
  160           OBJECT=' '
                RASTR=' '
                DESTR=' '
C
                GO TO 110
C
C
C
C           ELSE IF (A.EQ.'c')THEN
C
C                       c: comment
C
C               GO TO 110
C
C
            ELSE IF (A.EQ.'f') THEN
C
C                       f: error
C
                GO TO 110
C
C
            ELSE
C
C                       other: Illegal card.
C
                GO TO 199
C
            END IF
C
  199           CONTINUE
                CALL TV('These cards are not in standard format:')
                CALL TV(LINE(1))
                CALL TVN(LINE(2))
                CALL SPACE
                CALL TV('Please fix data and try again.')
                CALL STETER(199,'Data not in std. format')
C
C
  200   CLOSE(NOUTP)
C
C       Now make format file:
C
        OPEN (NOUTP,FILE='sdata.fmt',STATUS='UNKNOWN')
        WRITE(NOUTP,'(A46)')'! Format file for Danish Star Positions'
  300   FORMAT(A39)
C       Caution -- columns here MUST match FORMAT 5 in WRITER !!
        WRITE(NOUTP,300)'DEFINE/FIELD   1  32 C  A9    :OBJECT  '
        WRITE(NOUTP,300)'DEFINE/FIELD  33  48 R  R11.6 :RA      '
        WRITE(NOUTP,300)'DEFINE/FIELD  49  64 R  s11.5 :DEC     '
        WRITE(NOUTP,300)'DEFINE/FIELD  65  74 R  F8.3  :EQUINOX '
        WRITE(NOUTP,'(A3)')'END'
        CLOSE(NOUTP)
C
        CALL TV('DANSTARX is finished')
C
C
C       End MIDAS:
C
        CALL STSEPI
        END
      SUBROUTINE WRITER(EQUINOX)
C
C     writes output to uniform ascii file 'sdata.dat'
C
C
      REAL EQUINOX
C
      CHARACTER OBJECT*9
      CHARACTER*10 RASTR, DESTR
      COMMON /OUTC/ OBJECT,RASTR,DESTR
C
      CHARACTER C*74
C
C
      WRITE(C,5)OBJECT,RASTR(:2),RASTR(3:4),RASTR(5:6),RASTR(7:8),
     1                 DESTR(:3),DESTR(4:5),DESTR(6:7),DESTR(8:),EQUINOX
    5 FORMAT (A9,23X,5X,A2,':',A2,':',A2,'.',A2,5X,A3,':',A2,':',A2,'.',
     1A1,F10.3)
C
      WRITE(8,'(A74)') C
C
      RETURN
      END