C @(#)danish.for	19.1 (ES0-DMD) 02/25/03 13:29:07
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 DANISH
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT (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.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 '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 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,  COM2, EFLAG, 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,  COM2,EFLAG,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,  COM2, EFLAG, 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
