C @(#)danish.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 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