C===========================================================================
C Copyright (C) 1995-2010 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
         PROGRAM DANISH
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.IDENT         danish.for
C.MODULE
C.AUTHOR        Andrew T. Young
C.KEYWORD
C.LANGUAGE      FORTRAN 77
C.PURPOSE       convert Danish photometric data files to uniform ascii
C.COMMENTS
C.VERSION       5.2    ATY  April 21, 1993
C 
C 100621	last modif
C-----------------------------------------------------------------------------
C*****************************************************************************
C
C       This program reads data recorded in intermixed formats and combines
C       them into a uniform format, in the file 'data.dat' that is converted
C       into a MIDAS table-format file, using the *.fmt file 'data.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 'data.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 'data.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, OLDMJD
C
        REAL DIAM, ELONG, PHI
C
        INTEGER INULL
        REAL RNULL
        DOUBLE PRECISION DNULL
        COMMON /NULLS/ INULL, RNULL, DNULL
C
        INTEGER NDATA, NOUTP
C
        INTEGER NREC,NRECOLD
C
        INTEGER NBAD(4)
        REAL RELERR(4),COUNT(4)
C
        CHARACTER*80 LINE(2), DATFIL
        COMMON /LINES/LINE
        INTEGER LENBUF, NOW
        COMMON /BUF/LENBUF, NOW
C
        INTEGER ITBL, ISTAT, NCOLS, NROWS, NSORTC, NWPRAL, 
     1         NROWSAL, NCOL, NCDIAM, NROW, I, NBANDS, J, LWORD, K, K2
C
        CHARACTER A*1, CODE*2, END*1, STATUS*7
        CHARACTER*10 LSTSTR,OLDLST
        CHARACTER*32 COM1,COM2,COM3
C 
        CHARACTER*32  CTEST
C
        CHARACTER BNDCOD(6),BNAME(6)*5,CODES(4)
C
        LOGICAL MATCH
        LOGICAL EFLAG
C
C
C       Declarations for the output (must be in WRITER too!):
C
        DOUBLE PRECISION MJDOBS
        REAL SIGNAL,EXPTIME,ESTERR
        COMMON /OUTR/ SIGNAL,EXPTIME,MJDOBS,ESTERR
        CHARACTER OBJECT*9,STARSKY*4,BAND*8,COMMENT*32,DIAPH
        COMMON /OUTC/ OBJECT,STARSKY,BAND,COMMENT,DIAPH
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
C
C  END Declarations.
C
C
C  BEGIN DATA statements:
C
        INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
        DATA NDATA/7/, NOUTP/8/
C
        DATA BNDCOD/'U', 'V', 'B', 'Y',   'W',    'N'/
        DATA BNAME /'u', 'v', 'b', 'y', 'betaW','betaN'/
C
C
C  END DATA statements.
C
C
C  ********************  PROLOGUE  ********************
C
        CALL STSPRO ('DANISH')
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 DANISH to test in MIDAS)
C
C
        INQUIRE(FILE='data.dat',EXIST=EFLAG)
        IF (EFLAG) THEN
                CALL TV('File "data.dat" already exists!')
    1           CALL ASK ('Do you want to write over it?? ',A)
                IF (MATCH(A,'Y')) THEN
                        OPEN(NOUTP,FILE='data.dat',STATUS='UNKNOWN')
                        REWIND NOUTP
C                       Make sure it gets truncated to zero length.
                        CLOSE (NOUTP,STATUS='DELETE')
                ELSE IF (MATCH(A,'N')) THEN
                        CALL STETER(1,
     1                  'Please move "data.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='data.dat',STATUS='UNKNOWN')
        REWIND NOUTP
C
C       Find telescope coordinates:
C
        INQUIRE (FILE='esotel.tbl', EXIST=EFLAG)
        IF (EFLAG) THEN
                CALL TBTOPN ('esotel.tbl', 0,  ITBL, ISTAT)
                IF (ISTAT.NE.0) THEN
                        CALL TV('Problem opening "esotel.tbl".')
                        CALL STETER(2,'Do you have read permission?')
                END IF
                CALL TBIGET (ITBL,
     1                    NCOLS, NROWS, NSORTC, NWPRAL, NROWSAL, ISTAT)
                CALL TBLSER (ITBL, 'TELESCOP',  NCOL, ISTAT)
                CALL TBLSER (ITBL, 'DIAM',  NCDIAM, ISTAT)
                CALL TV(' ')
                CALL TV ('Which telescope did you use?')
                DO 2 NROW=1,NROWS
                CALL TBERDC (ITBL, NROW, NCOL, CTEST, EFLAG, ISTAT)
                CALL FT_EOS (CTEST,32,COM2,ISTAT)
                IF (EFLAG.OR. ISTAT.NE.0) GOTO 2
                CALL TBERDR (ITBL, NROW, NCDIAM,  DIAM, EFLAG, ISTAT)
                IF (EFLAG.OR. ISTAT.NE.0) GOTO 2
                WRITE (COM1,'(8X,I2,'':  '',A8,F6.2,'' m'')')
     1                              NROW,COM2,DIAM
                CALL TV (COM1)
    2           CONTINUE
                WRITE(COM1,'(8X,I2,'':  (None of these)'')') NROWS+1
                CALL TV(COM1)
                CALL ASK ('Please enter the number: ',COM1)
    3           READ (COM1,'(BN,I2)', ERR=4) NROW
                IF (NROW.LE.NROWS .AND. NROW.GE.1) THEN
                       CALL TBERDC (ITBL,NROW,NCOL,CTEST,EFLAG,ISTAT)
                       CALL FT_EOS (CTEST,32,COM2,ISTAT)
                ELSE
                        COM2='"none"'
                END IF
                GO TO 6
C
C               Bad row number:
    4           DO 5 NROW=1,NROWS
                CALL TBERDC (ITBL, NROW, NCOL,CTEST, EFLAG, ISTAT)
                CALL FT_EOS (CTEST,32,COM2,ISTAT)
                IF (COM1.EQ.COM2) THEN
                        GO TO 6
                END IF
    5           CONTINUE
                CALL ASK ('Please use the numbers at left.',COM1)
                GO TO 3
C
    6           WRITE(COM1,'(''   You selected '',A8)') COM2
                CALL TV (COM1)
C
                IF (INDEX(COM2,'DAN').NE.1) THEN
                   CALL TV('Not a Danish telescope.  Please try again.')
                   GO TO 3
                END IF
C
                IF (NROW.LE.NROWS .AND. NROW.GE.1) THEN
                        CALL TBLSER (ITBL, 'LON',  NCOL, ISTAT)
                        CALL TBERDR (ITBL,NROW,NCOL, ELONG,EFLAG,ISTAT)
                        IF(EFLAG.OR. ISTAT.NE.0) THEN
                            CALL QF('Enter EAST longitude (deg):',
     1                                 ELONG)
                        END IF
                        CALL TBLSER (ITBL, 'LAT',  NCOL, ISTAT)
                        CALL TBERDR (ITBL,NROW,NCOL, PHI,EFLAG,ISTAT)
                        IF(EFLAG.OR. ISTAT.NE.0) THEN
                             CALL QF('Enter Latitude (deg):', PHI)
                        END IF
                ELSE
                        CALL QF('Enter EAST longitude (deg):', ELONG)
                        CALL QF('Enter Latitude (deg):', PHI)
                END IF
                ELONG=ELONG/15.
                CALL TBTCLO(ITBL, ISTAT)
        ELSE
                CALL TV('File "esotel.tbl" not available!')
                CALL STETER(6,'Please get a copy of "esotel.tbl"')
        END IF
C
C
C       clear data storage:
C
        OBJECT=' '
        STARSKY=' '
        BAND=' '
        DIAPH=' '
        COMMENT=' '
        SIGNAL=RNULL
        ESTERR=RNULL
        EXPTIME=RNULL
        MJDOBS=DNULL
C
C       *** Prepare input buffer ***
C
        CALL TV(' ')
    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('Converting data...')
C
        OLDMJD=0.
        NRECOLD=0
        OLDLST=' '
C
C       Read data.
C
  110   READ (7,'(A80)',END=200) LINE(1),LINE(2)
C
C
C           Start reading first card:
            A=LINE(1)(:1)
            IF (A.EQ.'c') GO TO 112
            READ (LINE(1),111,ERR=301) A,NREC,DJD,LSTSTR,STATUS
  111       FORMAT(A1,I4,F12.5,2(1X,A7))
C           Convert Danish MJD to real JD.
            DJD=DJD+2440000.D0
C           Convert real JD to MJD.
            MJDOBS=DJD-2400000.5D0
C           Check that times are in order.
            IF (MJDOBS.LT.OLDMJD .OR. NREC.LT.NRECOLD .OR.
     1                (LSTSTR.LT.OLDLST .AND. LSTSTR(:2).NE.'00')) THEN
               CALL SPACE2
               CALL TV('     Sequence error:')
               CALL TV('Record    Danish JD      LST')
               CALL TVN('------   -----------   -------')
               WRITE(DATFIL,'(I4,5X,F11.5,3X,A)')
     1                      NRECOLD,OLDMJD-39999.5,OLDLST
               IF (DATFIL(10:10).EQ.' ') DATFIL(10:10)='0'
               CALL TVN(DATFIL)
               CALL TV('    is followed by')
               WRITE(DATFIL,'(I4,5X,F11.5,3X,A)')
     1                      NREC,MJDOBS-39999.5,LSTSTR
               IF (DATFIL(10:10).EQ.' ') DATFIL(10:10)='0'
               CALL TV(DATFIL)
C
               I=0
               CALL SPACE2
               IF (NREC.LT.NRECOLD) THEN
                  CALL TVN('     RECORD numbers out of order')
                  I=1
               END IF
C
               IF (MJDOBS.LT.OLDMJD) THEN
                  CALL TVN('     JDs out of order')
                  I=2
               END IF
C
               IF (LSTSTR.LT.OLDLST .AND. LSTSTR(:2).NE.'00' .AND.
     1                      OLDLST(:2).NE.'23') THEN
                  CALL TVN('     LSTs out of order')
                  I=4
               END IF
C
               IF (I.EQ.1)THEN
                  CALL TV('Bad record number?')
               ELSE IF (I.EQ.2) THEN
                  CALL TV('JD is probably wrong; others are in order.')
               ELSE IF (I.EQ.4) THEN
                  CALL TV('LST is probably wrong; others are in order.')
               END IF
            END IF
            OLDMJD=MJDOBS
            NRECOLD=NREC
            OLDLST=LSTSTR
C
            DIAPH=STATUS(2:2)
C
C
  112       IF (A.EQ.'s') THEN
C
C                       s: measurement
C
C               Finish reading first card:
                READ(LINE(1),113,ERR=392)EXPTIME,OBJECT,CODE
  113           FORMAT(40X,F3.0,1X,A9,1X,A2)
                IF (EXPTIME.EQ.0.) THEN
                   DATFIL='ZERO exposure time at MJDOBS ='
                   WRITE(DATFIL(31:),'(F12.5)') MJDOBS
                   CALL TV(DATFIL)
                   CALL TVN('   Observation rejected.')
                   GO TO 110
                END IF
C               convert MJDOBS from end to start of exposure.
                MJDOBS=MJDOBS-EXPTIME/86400.
C
C               Interpret second card:
                IF (STATUS(:1).EQ.'U')THEN
C                   uvby data:
                    READ(LINE(2),114,ERR=393)
     1                 (CODES(I),COUNT(I),RELERR(I),NBAD(I),I=1,4),END
  114               FORMAT(4(A1,F9.0,1X,F4.4,I3,1X),A1)
                    NBANDS=4
                ELSE IF (STATUS(:1).EQ.'H')THEN
C                   H-beta data:
                    READ(LINE(2),115,ERR=394)
     1                 (CODES(I),COUNT(I),RELERR(I),NBAD(I),I=1,2),END
  115               FORMAT(2(A1,F9.0,1X,F4.4,I3,1X),38X,A1)
                    IF (END.NE.'e') THEN
                       I=LWORD(LINE(2))
                       END=LINE(2)(I:I)
                    END IF
                    NBANDS=2
                ELSE
C                   unknown data:
                    CALL TV('Unknown data:')
                    CALL TV(LINE(1))
                    CALL TVN(LINE(2))
                    CALL SPACE
                    GO TO 399
                END IF
C
                IF (END.NE.'e') GO TO 395
C
C               Convert STAR/SKY flag to standard strings.
                IF (CODE.EQ.'*0') THEN
                        STARSKY='STAR'
                ELSE IF (CODE.EQ.'B0') THEN
                        STARSKY='SKY'
                ELSE
                        CALL TV(CODE)
                        CALL TV('Unexpected code in STAR/SKY column:')
                        CALL TV(LINE(1))
                        CALL TVN(LINE(2))
                        CALL SPACE
                        CALL STETER(118,'Fix data and try again.')
                END IF
C
C               Loop over bands:
C
                DO 150 I=1,NBANDS
C                  Convert band codes to band names:
                   DO 120 J=1,6
                      IF (CODES(I).EQ.BNDCOD(J)) THEN
                         BAND=BNAME(J)
                         GO TO 121
                      END IF
  120              CONTINUE
C
                   CALL TV('Non-standard band name!')
                   GO TO 399
C
  121              CONTINUE
C
                   IF (STATUS(3:3).EQ.'1') THEN
C                       OPEN position.  Go on.
                   ELSE IF (STATUS(3:3).EQ.'2') THEN
C                       CLOSED position.  Set to DARKn.
                        BAND='DARK'
                        WRITE(BAND(5:5),'(I1)') J
                   ELSE IF (STATUS(3:3).EQ.'3') THEN
C                       ND=1 position.  Append ND1.
                        BAND(LWORD(BAND)+1:)='ND1'
                   ELSE
                        DATFIL='Undefined shutter code (status(3:3)):'
                        DATFIL(39:39)=STATUS(3:3)
                        CALL TV(DATFIL)
                        CALL TV(LINE(1))
                        CALL TVN(LINE(2))
                        CALL ASK(
     1                       'Ignore this observation and continue?',A)
                        IF (A.EQ.'Y' .OR. A.EQ.'O')THEN
C                           Clear data & look for next observation.
                            GO TO 160
                        ELSE
                            CALL TV('Program cannot continue.')
                            CALLSTETER(122,'Fix data and try again.')
                        END IF
                   END IF
C
C                  Check for v & b neutral-density filters:
                   IF ((J.EQ.2 .OR. J.EQ.3) .AND.
     1                       STATUS(4:4).EQ.'G') THEN
                        IF (BAND(2:3).EQ.'ND') THEN
C                           Both ND filters.
                             BAND(4:4)='3'
                        ELSE
C                           Only the vb filter.
                            BAND(4:4)='2'
                        END IF
                   END IF
C
C                  Check for viewing optics in the way:
                   IF (STATUS(6:6).EQ.'M' .OR. STATUS(7:7).EQ.'M') THEN
                      CALL SPACE2
                      IF (STATUS(6:6).EQ.'M') THEN
                         CALL TV('Field-viewing optics in the way.')
                      ELSE IF (STATUS(7:7).EQ.'M') THEN
                         CALL TV('Viewing microscope in the way.')
                      END IF
                      CALL TV(LINE(1))
                      CALL TVN(LINE(2))
                      CALL ASK('Do you want to use this as DARK?',A)
                      IF (A.EQ.'Y' .OR. A.EQ.'O') THEN
                         BAND='DARK'
                         DATFIL=COMMENT(:LWORD(COMMENT))//
     1                                      'Optics in beam'
                         COMMENT=DATFIL(:32)
                      ELSE
                         GO TO 160
                      END IF
                   END IF
C
                   SIGNAL=COUNT(I)
C                  RELERR was read as a fraction, not %.
                   ESTERR=RELERR(I)*SIGNAL
                   IF (SIGNAL.EQ.0.) SIGNAL=RNULL
                   IF (ESTERR.EQ.0.) ESTERR=RNULL
                   CALL WRITER
  150           CONTINUE
C
C               clear data arrays:
C
  160           OBJECT=' '
                STARSKY=' '
                BAND=' '
                COMMENT=' '
                EXPTIME=RNULL
                MJDOBS=DNULL
C
                GO TO 110
C
C
C
            ELSE IF (A.EQ.'c')THEN
C
C                       c: comment
C
C               Split up comment card cleanly if possible:
                DO 186 K=34,14,-1
                IF (LINE(2)(K:K).EQ.' ') GO TO 187
  186           CONTINUE
  187           DO 188 K2=K+32,K+12,-1
                IF (LINE(2)(K2:K2).EQ.' ') GO TO 189
  188           CONTINUE
  189           IF (LINE(2)(K2+32:).EQ.' ') THEN
                        COM1=LINE(2)(3:K)
                        COM2=LINE(2)(K+1:K2)
                        COM3=LINE(2)(K2+1:)
                ELSE
                        READ (LINE(2),'(2X,2A32,A14)') COM1,COM2,COM3
                END IF
                COMMENT=COM1
                CALL WRITER
                MJDOBS=OLDMJD+1.D-6
                COMMENT=COM2
                IF (COM2.NE.' ') CALL WRITER
                MJDOBS=OLDMJD+2.D-6
                COMMENT=COM3
                IF (COM3.NE.' ') CALL WRITER
                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 399
C
            END IF
C
C
  200   CLOSE(NOUTP)
C
C       Now make format file:
C
        OPEN (NOUTP,FILE='data.fmt',STATUS='UNKNOWN')
        WRITE(NOUTP,'(A29)')'! Format file for Danish Data'
  300   FORMAT(A39)
C       Caution -- columns here MUST match FORMATs 5 & 6 in WRITER !!
        WRITE(NOUTP,300)'DEFINE/FIELD   1  10 R   F10.0 :SIGNAL '
        WRITE(NOUTP,300)'DEFINE/FIELD  11  42 C   A9    :OBJECT '
        WRITE(NOUTP,300)'DEFINE/FIELD  44  47 C   A7    :STARSKY'
        WRITE(NOUTP,300)'DEFINE/FIELD  49  56 C*8 A7    :BAND   '
        WRITE(NOUTP,300)'DEFINE/FIELD  57  68 D   F12.6 :MJD_OBS'
        WRITE(NOUTP,300)'DEFINE/FIELD  69  76 R   F8.3  :EXPTIME'
        WRITE(NOUTP,300)'DEFINE/FIELD  77 108 C   A32   :COMMENT'
        WRITE(NOUTP,300)'DEFINE/FIELD 109 118 R   F10.0 :ESTERR '
        WRITE(NOUTP,300)'DEFINE/FIELD 120 123 C   A6  :DIAPHRAGM'
        WRITE(NOUTP,'(A3)')'END'
        CLOSE(NOUTP)
C
        CALL TV('Danish is finished')
C
C
C       End MIDAS:
C
        CALL STSEPI
C
C       --------------------
C
C       Error messages:
C
  301   CALL TV('ERROR reading card at 111.')
        GO TO 399
C
  392   CALL TV('ERROR reading card at 113.')
        GO TO 399
C
  393   CALL TV('ERROR reading card at 114.')
        GO TO 399
C
  394   CALL TV('ERROR reading card at 115.')
        GO TO 399
C
  395   CALL TV('Card does not end with "e".')
        GO TO 399
C
  399   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(399,'Data not in std. format')
        END
        SUBROUTINE WRITER
C
C       writes output to uniform ascii file 'data.dat'
C
        INTEGER INULL
        REAL RNULL
        DOUBLE PRECISION DNULL
        COMMON /NULLS/ INULL, RNULL, DNULL
C
        DOUBLE PRECISION MJDOBS
        REAL SIGNAL,EXPTIME,ESTERR
        COMMON /OUTR/ SIGNAL,EXPTIME,MJDOBS,ESTERR
        CHARACTER OBJECT*9,STARSKY*4,BAND*8,COMMENT*32,DIAPH
        COMMON /OUTC/ OBJECT,STARSKY,BAND,COMMENT,DIAPH
C
        CHARACTER C*124
C
C
        WRITE(C,5) SIGNAL,OBJECT,STARSKY,BAND,MJDOBS,EXPTIME,COMMENT
    5   FORMAT        (F10.0,A9,24X,A4,1X,A8,F12.6,F8.3,A32)
        WRITE(C(109:),6) ESTERR,DIAPH
    6   FORMAT(F10.0,1X,A1)
C
C       Fix up NULL fields:
C
        IF (SIGNAL.EQ.RNULL) C(1:10)=' '
        IF (MJDOBS.EQ.DNULL) C(57:68)=' '
        IF (EXPTIME.EQ.RNULL) C(69:76)=' '
        IF (ESTERR.EQ.RNULL) C(109:118)=' '
C
        WRITE(8,'(A123)') C
C
        RETURN
        END
