C @(#)esodstarx.for	19.1 (ES0-DMD) 02/25/03 13:29:08
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 ESODSTX
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT (c)
C.IDENT         esodstarx.for
C.MODULE
C.AUTHOR        Andrew T. Young
C.KEYWORD
C.LANGUAGE      FORTRAN 77
C.PURPOSE       convert La Silla photometric data files to uniform ascii
C.COMMENTS
C.VERSION       5.2
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 ESO
C       1-meter telescope, as described in "The Optical Photometer on the
C       ESO 1m Telescope" by H. Lindgren & F. Gutierrez W. (ESO Operating
C       Manual No. 14, Version No.1, August 1991).  These data come in
C       several different card-image formats, flagged by a digit in col.2.
C       These codes are read and decoded at statements 110-190 in the main
C       program.
C
C       This program extracts ONLY the star names and positions from data
C       cards of types 5 and 6.  These are estimates of the observed apparent
C       positions by the telescope-control system, and may be in error by a
C       minute of arc or more.
C
C       The basic method is to load the data as they are read from different
C       types of cards into the COMMON block /OUTC/, which holds
C       character variables.  When enough card images have been read
C       to make a complete observation, the contents of /OUTC/ are written to
C       the uniform-format file 'sdata.dat'; then the common block is cleared
C       to blanks.
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       This program is modified from the "esodcon" program, and may contain
C       fossils from it.
C
C
C*****************************************************************************
C
C
        IMPLICIT NONE
C
C  BEGIN Declarations:
C
        DOUBLE PRECISION DJZ, DJZ1
        DOUBLE PRECISION DNULL
        REAL RNULL
        INTEGER INULL
        COMMON /NULLS/ INULL, RNULL, DNULL
C
        LOGICAL MATCH
        LOGICAL EFLAG, UTWRAP, SIDTIM, TIMSEL
        INTEGER NDATA, NOUTP
C
        INTEGER MXLINE
        PARAMETER (MXLINE=100)
        CHARACTER*80 LINE(MXLINE), DATFIL
        COMMON /LINES/LINE
        INTEGER LENBUF,NOW
        COMMON /BUF/LENBUF, NOW
C
        CHARACTER A*1
        CHARACTER*32 COM1
        CHARACTER*3 MON
C
        INTEGER NLINE,I,I1,I2,M,NTYPE,NSTSK
C
        REAL UT,UT1,UT2,OLDUT,DAY,YEAR
        REAL EQUINOX
C
C    Types for external fcns.:
C
        REAL TIMER
        INTEGER MON2M
C
C    Declarations for the output (must be in WRITER too!):
C
        CHARACTER OBJECT*32
        CHARACTER*10 RASTR, DESTR
        COMMON /OUTC/ OBJECT,RASTR,DESTR
C
C  Set up MIDAS declarations:
C
        INTEGER MADRID(1)
C
        COMMON /VMR/ MADRID
C
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'
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  END DATA statements.
C
C
C  ********************  PROLOGUE  ********************
C
        CALL STSPRO ('ESODSTX')
C
C       Because the Sun library barfs on -Inf (which is used as NULL
C       by MIDAS), I define my own "NULL" values here as 3.e33:
C
        RNULL=3.E33
        DNULL=3.D33
C
C  Real program begins here:            (use RUN ESODSTX 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=' '
C
C       *** Prepare input buffer ***
C
        CALL TV(' ')
    5   Call STKRDC ('RAWDAT',1,1,80,  NACTEL,DATFIL,IUNIT,NULLS,ISTAT)
C   5   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 5
        END IF
        OPEN(NDATA,FILE=DATFIL,STATUS='UNKNOWN')
        REWIND NDATA
        NOW=0
C
C       Read data.  (READER returns negative NLINE at EOF.)
C
        CALL READER(NLINE)
C
C       Initialize times on first read:
C
        UTWRAP=.FALSE.
        SIDTIM=.FALSE.
        TIMSEL=.FALSE.
        DJZ=0.D0
        DJZ1=0.D0
        OLDUT=-1.
        UT1=0.
        UT2=0.
        UT=-1.
C
        DO 10 I=1,LENBUF
            IF (LINE(I)(:2).EQ.' 8') THEN
C               Look for first day of double date:
                IF (DJZ.EQ.0.D0) THEN
                        CALL GETJDC (I,DJZ)
                        IF (DJZ.GT.0.D0) THEN
C                               found date on card.
                                CALL TV('Date found on:')
                                CALL TVN(LINE(I))
                                DJZ1=DJZ
                        END IF
                END IF
C               Look for UT:
                CALL GETUT(I,UT)
C               Look for "Tim.Out":
                IF (LINE(I)(5:11).EQ.'Tim.Out' .AND.
     1              LINE(I)(13:14).EQ.'SI') THEN
                    CALL TV('Using Local Sidereal Time.')
                    SIDTIM=.TRUE.
                    TIMSEL=.TRUE.
                ELSE IF (LINE(I)(5:11).EQ.'Tim.Out' .AND.
     1              LINE(I)(13:14).EQ.'UT') THEN
                    CALL TV('Using Universal Time.')
                    SIDTIM=.FALSE.
                    TIMSEL=.TRUE.
                END IF
            ELSE IF (LINE(I)(:2).EQ.' 7') THEN
                UT=TIMER(LINE(I)(26:33))
C               Look for JD of 0h UT:
                IF (DJZ.EQ.0.D0) THEN
                        READ(LINE(I)(11:19),'(F9.1)') DJZ
                END IF
            END IF
            IF (UT.GE.0.) GO TO 12
   10   CONTINUE
        CALL TV('Can''t find U.T. in first 100 cards.')
C
   12   UT1=UT
        I1=I
        UT=-1.
C
        DO 20 I=I+1,LENBUF
            IF (LINE(I)(:2).EQ.' 8') THEN
C               Look for first day of double date:
                IF (DJZ.EQ.0.D0) THEN
                        CALL GETJDC (I,DJZ)
                        IF (DJZ.GT.0.D0) THEN
C                               found date on card.
                                CALL TV('Date found on:')
                                CALL TVN(LINE(I))
                                DJZ1=DJZ
                        END IF
                END IF
C               Look for UT:
                CALL GETUT(I,UT)
C               Look for "Tim.Out":
                IF (LINE(I)(5:11).EQ.'Tim.Out' .AND.
     1              LINE(I)(13:14).EQ.'SI') THEN
                    CALL TV('Using Local Sidereal Time.')
                    SIDTIM=.TRUE.
                    TIMSEL=.TRUE.
                ELSE IF (LINE(I)(5:11).EQ.'Tim.Out' .AND.
     1              LINE(I)(13:14).EQ.'UT') THEN
                    CALL TV('Using Universal Time.')
                    SIDTIM=.FALSE.
                    TIMSEL=.TRUE.
                END IF
            ELSE IF (LINE(I)(:2).EQ.' 7') THEN
                UT=TIMER(LINE(I)(26:33))
                IF (DJZ.EQ.0.D0) THEN
                        READ(LINE(I)(11:19),'(F9.1)') DJZ
                        IF (UT.LT.UT1) THEN
                                DJZ=DJZ-1.D0
                        END IF
                END IF
            END IF
            IF (UT.GE.0.) GO TO 22
   20   CONTINUE
C
   22   UT2=UT
        I2=I
C
        IF (UT2.GT.UT1) THEN
C               OK.
        ELSE IF (UT1.GT.21. .AND. UT2.LT.UT1+24.+3.) THEN
C               wrap through 0h U.T.; 3-hr. grace period.
                IF (DJZ.EQ.0.D0) UTWRAP=.TRUE.
        ELSE
                CALL TV('Times are out of order!')
                CALL TV(' ')
                IF (I2.GT.I1 .AND. I2.LT.MXLINE)THEN
                    DO 23 I=I1,I2
                        CALL TVN(LINE(I))
   23               CONTINUE
                    CALL TV(' ')
                    CALL STETER(23,'Please fix data.')
                ELSE
                    CALL STETER(23,'Please fix data.')
                END IF
        END IF
C
        IF (DJZ.EQ.0.D0) THEN
C               read on until we find a type 7 card...
                DO 26 I=I,LENBUF
                    IF (LINE(I)(:2).EQ.' 7') THEN
                        UT=TIMER(LINE(I)(26:33))
                        READ(LINE(I)(11:19),'(F9.1)') DJZ
                        IF (UT.LT.UT1) THEN
                                DJZ=DJZ-1.D0
                        END IF
                        GO TO 30
                    END IF
   26           CONTINUE
C
                IF (DJZ.EQ.0.D0) THEN
C                       still not found, so ask for help:
   28                   CALL ASK ('Please supply UT date at start:',
     1                             COM1)
                        CALL MDYC(COM1,MON,DAY,YEAR)
                        M=MON2M(MON)
                        IF (M.EQ.0 .OR. DAY.LT.0. .OR. DAY.GT.32. .OR.
     1                      YEAR.LT.0. .OR. YEAR.GT.2100. .OR.
     2                      (YEAR.GT.99. .AND. YEAR.LT.1900.)) GOTO 28
                        IF (YEAR.LT.50.) THEN
                                 YEAR=YEAR+2000.
                        ELSE
                                YEAR=YEAR+1900.
                        END IF
C                       compute JD of 0h UT:
                        IF (M.GT.2) GOTO 29
                        M=M+12
                        YEAR=YEAR-1.
   29                   DJZ=AINT(365.25*YEAR) + AINT(30.6001*(M+1)) +
     1                       DAY + 1720981.5D0
                        COM1=' '
                END IF
        ELSE
                IF (UTWRAP) DJZ=DJZ-1.D0
        END IF
   30   CONTINUE
C
        IF(.NOT.TIMSEL .AND. NLINE.LT.25) THEN
            DO 33 I=I,25
                IF (LINE(I)(5:11).EQ.'Tim.Out' .AND.
     1              LINE(I)(13:14).EQ.'SI') THEN
                    CALL TV('Using Local Sidereal Time.')
                    SIDTIM=.TRUE.
                    TIMSEL=.TRUE.
                ELSE IF (LINE(I)(5:11).EQ.'Tim.Out' .AND.
     1              LINE(I)(13:14).EQ.'UT') THEN
                    CALL TV('Using Universal Time.')
                    SIDTIM=.FALSE.
                    TIMSEL=.TRUE.
                END IF
   33       CONTINUE
        END IF
C
        IF(.NOT.TIMSEL) THEN
                CALL TV('ASSUMING Universal Time is used...')
                CALL ASK('               IS this correct???',COM1)
                IF (MATCH(COM1,'Y')) THEN
                        TIMSEL=.TRUE.
                ELSE IF (MATCH(COM1,'N'))THEN
                        CALL TV('Assuming Sidereal Time is used.')
                        TIMSEL=.TRUE.
                        SIDTIM=.TRUE.
                END IF
        END IF
C
C       Decide which date to use:
C               use 1st day of double date.
C
C       Now fix up JD zero-point to make EQUINOX:
        EQUINOX=REAL(DJZ-2451545.D0)/365.25 +2000.
        GO TO 111
C
  110   CALL READER(NLINE)
  111   IF (NLINE.GT.0) THEN
                READ (LINE(NLINE)(:2),'(I2)',ERR=199) NTYPE
                IF (NTYPE.LT.0 .OR. NTYPE.GT.9) GOTO 199
                NTYPE=NTYPE+1
                GO TO (115,110,110,110,110,150,160,110,110,110) NTYPE
C                 type: 0   1   2   3   4   5   6   7   8   9
C
C                 Card Type:
C
C                       0: measurement
C
  115           CONTINUE
                READ (LINE(NLINE),116) NSTSK
  116           FORMAT(30X,I4)
                IF (NSTSK.EQ.0) THEN
C                       Star.
                ELSE IF (NSTSK.EQ.1) THEN
C                       Sky.
                ELSE
                        CALL TV('Unexpected value in STAR/SKY column:')
                        CALL TV(LINE(NLINE))
                        CALL STETER(119,'Fix data and try again.')
                END IF
                GO TO 110
C
C                       1: last integration results if MAGtape,All (??)
C
C                       2: (unused)
C
C                       3 or 4: rejects (should never occur!)
C
C                       5: Object identifier
  150           CONTINUE
                READ (LINE(NLINE),'(2X,A32)') OBJECT
                GO TO 110
C
C                       6: Telescope coordinates
  160           CONTINUE
                READ (LINE(NLINE),'(5X,A10,1X,A10)') RASTR, DESTR
                CALL WRITER(EQUINOX)
                GO TO 110
C
C                       7: measurement number, UT, & JD
C
C                       8: Heading or comment
C
C                       9: End of object
C
C                       other: Illegal card.
  199           CONTINUE
                CALL TV('This card is not in standard format:')
                CALL TV(LINE(NLINE))
                CALL TV('Please fix data and try again.')
                CALL STETER(199,'Data not in std. ESO format')
        END IF
C
C       *** fall through at EOF ***
C
        CLOSE(NOUTP)
C
C       Now make format file:
C
        OPEN (NOUTP,FILE='sdata.fmt',STATUS='UNKNOWN')
        REWIND NOUTP
        WRITE(NOUTP,'(A35)')'! Format file for ESO Star Positions'
  200   FORMAT(A39)
        WRITE(NOUTP,200)'DEFINE/FIELD   1  32 C  A32   :OBJECT '
        WRITE(NOUTP,200)'DEFINE/FIELD  33  48 R  R10.5 :RA     '
        WRITE(NOUTP,200)'DEFINE/FIELD  49  64 R  s9.4  :DEC    '
        WRITE(NOUTP,200)'DEFINE/FIELD  65  75 R  F10.3 :EQUINOX'
        WRITE(NOUTP,'(A3)')'END'
        CLOSE(NOUTP)
C
        CALL TV('STARPOS 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
        IMPLICIT NONE
C
        REAL EQUINOX
C
        DOUBLE PRECISION DNULL
        REAL RNULL
        INTEGER INULL
        COMMON /NULLS/ INULL, RNULL, DNULL
C
        CHARACTER OBJECT*32, C*74
        CHARACTER*10 RASTR, DESTR
        COMMON /OUTC/ OBJECT,RASTR,DESTR
C
C
        WRITE(C,5) OBJECT,RASTR,DESTR,EQUINOX
    5   FORMAT(A32,2A16,F10.3)
C
        WRITE(8,'(A74)') C
C
C       clear data arrays:
C
        OBJECT=' '
        RASTR=' '
        DESTR=' '
C
        RETURN
        END
        SUBROUTINE READER(NLINE)
C
C       Reads data lines, and returns ptr. to one in buffer each time.
C
C *****************************************************************************
C
C       This subroutine uses a circular buffer to read the data, because the
C       ESO data contain codes for "cancel last star" and "cancel last datum".
C
C       The circular buffer is also used here to look ahead, and interpolate
C       times to assign to comments that lack time information.
C
C *****************************************************************************
C
        IMPLICIT NONE
C
        INTEGER NLINE
C
C
        INTEGER MXLINE
        PARAMETER (MXLINE=100)
C
        CHARACTER*80 LINE(MXLINE)
        COMMON /LINES/LINE
        INTEGER LENBUF,NOW
        COMMON /BUF/LENBUF, NOW
C
        INTEGER NEOF
        INTEGER LAST
C
        SAVE NEOF
C
        DATA NEOF/0/
C
C
        IF (NOW.EQ.0) THEN
C
C       *****   initial entry:  *****
C
                NOW=1
    1           READ (7,'(A80)', END=9) LINE(NOW)
C                       Test for backup (bad data):
                IF (LINE(NOW)(:2).EQ.' 4') THEN
C                       Back up over object:
                        DO 4 NOW=NOW-1,1,-1
                        IF (LINE(NOW)(:2).EQ.' 5') GO TO 6
    4                   CONTINUE
                        NOW=0
                ELSE IF (LINE(NOW)(:2).EQ.' 3') THEN
C                       Back up over last filter:
                        IF (LINE(NOW-1)(:2).EQ.' 0') THEN
                                NOW=NOW-2
                        ELSE IF (LINE(NOW-2)(:2).EQ.' 0') THEN
                                NOW=NOW-3
                        ELSE
                                CALL TV('Did not find bad datum:')
                        END IF
                END IF
C
                NOW=NOW+1
C
C               *** test for full buffer ***
C
    6           IF(NOW.GT.MXLINE) THEN
                        LENBUF=MXLINE
                ELSE
                        GO TO 1
                END IF
C
C               *** return from initial entry ***
C
    8           NOW=1
                NLINE=1
                RETURN
C
C               *** EOF found on initial entry ***
C
    9           LENBUF=NOW
                NEOF=LENBUF
                GOTO 8
C
        ELSE
C
C       *****  normal entry (NOW > 0):  *****
C
                LAST=NOW
   10           IF (NEOF.EQ.0) THEN
C                       overwrite last output line:
   11                   READ (7, '(A80)',END=99) LINE(NOW)
C
C                       Test for backup (bad data):
   13                   IF (LINE(NOW)(:2).EQ.' 4') THEN
C                               back up over object:
                                DO 14 NOW=NOW-1,1,-1
                                IF (LINE(NOW)(:2).EQ.' 5') GOTO 10
   14                           CONTINUE
                                DO 15 NOW=LENBUF,LAST+1,-1
                                IF (LINE(NOW)(:2).EQ.' 5') GOTO 10
   15                           CONTINUE
                                CALL TV('Backed up over entire buffer!')
                                CALL STETER(15,
     1                          'Increase MXLINE and recompile')
C
                        ELSE IF (LINE(NOW)(:2).EQ.' 3') THEN
C                               back up over filter:
                                DO 17 NOW=NOW-1,1,-1
                                IF (LINE(NOW)(:2).EQ.' 0') GOTO 10
   17                           CONTINUE
                                DO 18 NOW=LENBUF,LAST+1,-1
                                IF (LINE(NOW)(:2).EQ.' 0') GOTO 10
   18                           CONTINUE
                                CALL TV('Backed up over entire buffer!')
                                CALL STETER(18,
     1                          'Increase MXLINE and recompile')
                        END IF
                END IF
C
   20           IF (NOW.NE.LAST) THEN
C                       Refill buffer, if needed:
                        NOW=NOW+1
                        IF (NOW.GT.LENBUF) NOW=1
                        GO TO 10
                END IF
C
C               Advance line counter:
                IF (NOW.EQ.LENBUF) THEN
                        NOW=1
                ELSE
                        NOW=NOW+1
                END IF
C
                IF (NOW.EQ.NEOF) THEN
C                       Return negative value at eof:
                        NLINE=-NOW
                        RETURN
                ELSE
                        NLINE=NOW
                END IF
C
                RETURN
C
   99           NEOF=NOW
                IF (NEOF.GT.LENBUF) NEOF=1
                GO TO 20
C
        END IF
C
        END
