C @(#)esodcon.for 17.1.1.1 (ES0-DMD) 01/25/02 17:17:32 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 ESODCON C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.COPYRIGHT (c) C.IDENT esodcon.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 'data.dat' that is converted C into a MIDAS table-format file, using the *.fmt file ''. 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.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 The only tricky things in this data reformatting are: C C 1. The ESO Data contain retroactive cancellation codes. C This requires a look-ahead/look-back feature, which is C handled by storing the incoming data lines in a circular C buffer, LINE(nline). The READER subroutine does the C looking back, to delete cancelled data. This involves C some tricky indexing; be sure you understand what is going C on here before you change anything! C C 2. As long as we have the line buffer available, we use it to C assign times to COMMENT cards. Times are simply interpolated C between the actual times of observations. When a COMMENT is C longer than 32 characters, the pieces are ordered by assigning C times successively 0.1 second later to the second and third C 32-byte parts. Comments need times, because the MIDAS table C can be rearranged (e.g., by sorting on some column), and only C sorting on the MJD_OBS column will restore everything to the C proper order. C C***************************************************************************** C C C BEGIN Declarations: C DOUBLE PRECISION DJD, DJZ, DJZ1, OLDMJD C INTEGER INULL REAL RNULL DOUBLE PRECISION DNULL 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 SAVE /LINES/ COMMON /BUF/LENBUF, NOW C CHARACTER A*1 CHARACTER*10 RASTR, DESTR,UTSTR, TIME CHARACTER*32 COM1,COM2,COM3, OBJNAM CHARACTER*3 MON DOUBLE PRECISION DJ C C Filter conversion table: C CHARACTER*8 FILTCD(20),BNDNAM(20) COMMON /FILTBC/ FILTCD,BNDNAM C C C Declarations for the output (must be in WRITER too!): C DOUBLE PRECISION MJDOBS COMMON /OUTR/ SIGNAL,EXPTIME,MJDOBS, GENEVAQ,GENEVAR,GENEVAG CHARACTER OBJECT*32,STARSKY*4,BAND*8,COMMENT*32 COMMON /OUTC/ OBJECT,STARSKY,BAND,COMMENT C C INTEGER LENBUF, NOW, ITBL, ISTAT, NCOLS, NROWS, NSORTC, NWPRAL, 1 NROWSAL, NCOL, NCDIAM, NROW, NLINE, I, I1, I2, M, MON2M, NTYPE, 2 ID, NFILT, NSTSK, K, K2 REAL SIGNAL, EXPTIME, GENEVAQ, GENEVAR, GENEVAG, DIAM, 1 ELONG, PHI, OLDUT, UT1, UT2, UT, TIMER, DAY, YEAR, STUTZH, 2 STUTZROT, TINT, SIGIN, FNINTS, STDDEV, GENQ, GENR, GENG, FLST 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 CHARACTER CARD*80 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 ('ESODCON') 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 ESODCON 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 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 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 6 WRITE(COM1,'('' You selected '',A8)') COM2 CALL TV (COM1) 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(3,'Please get a copy of "esotel.tbl"') END IF C C Get filter conversion table: C CALL FILTBL C C clear data storage: C OBJECT=' ' STARSKY=' ' BAND=' ' COMMENT=' ' SIGNAL=RNULL EXPTIME=RNULL GENEVAQ=RNULL GENEVAR=RNULL GENEVAG=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 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. 8 DJZ=0.D0 DJZ1=0.D0 OLDMJD=-1.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 WRITE(CARD,*)'I=',I CALL TV(CARD) CALL TVN(LINE(I)(11:19)) READ(LINE(I)(11:19),'(F9.1)',ERR=10) 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: IF (DJZ1.NE.0.D0 .AND. UT1.LT.MOD(36.-ELONG,24.))THEN C use 2nd day of double date: DJZ=DJZ+1.D0 ELSE C use 1st day of double date: END IF STUTZH=STUTZROT(DJZ)*24. C Now fix up JD zero-point to make MJD_OBS: DJZ=DJZ-2400000.5D0 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,125,130,140,140,150,160,170,180,190) 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) ID,TINT,TIME,NFILT,NSTSK,SIGIN, 1 FNINTS,STDDEV,GENQ, GENR, GENG 116 FORMAT(2X,I3,F5.1,2X,A10,I4,4X,I4,F10.1,F7.0,2F7.2,2F6.2 1) OBJECT=OBJNAM C Convert mean rate to integral count. SIGNAL=SIGIN*FNINTS C Convert exposure time to total. EXPTIME=TINT*FNINTS UT=TIMER(TIME) IF (SIDTIM) THEN FLST=UT UT=MOD((UT-ELONG-STUTZH+48.D0),24.D0)/1.00273791 IF(FLST.LT.0.00273791*24.)THEN C LST may have rolled over. IF (DJZ+UT/24.D0.LT.OLDMJD) THEN UT=UT+24./1.00273791 ELSE END IF END IF END IF C Correct time of observation from middle to start of exposure. C Remember to convert from seconds to days: MJDOBS=DJZ+(UT/24.D0) - EXPTIME*0.5/86400. IF (MJDOBS.LT.OLDMJD) THEN IF (UT.LT.3. .AND. OLDUT.GT.21.) THEN C assume we just went through 0h UT. CALL TV(' 0h UT passed by:') CALL TVN(LINE(NLINE)) DJZ=DJZ+1.D0 STUTZH=24.*STUTZROT(DJZ+2400000.5D0) ELSE 117 IF (TIMSEL) THEN CALL TV('Times out of order!') CALL TV(LINE(NLINE)) WRITE(LINE(1),118) 'old MJD =',OLDMJD, 1 '; oldut=',OLDUT 118 FORMAT(A9,F13.5,A8,F13.5) CALL TV(LINE(1)) WRITE(LINE(1),118) 'MJD =',MJDOBS, 1 '; ut=',UT CALL TVN(LINE(1)) CALL STETER(118,'Please fix data.') ELSE C See if we are using sidereal time: 119 CALL ASK('Are you using Sidereal Time?', 1 COM1) IF (MATCH(COM1,'Y'))THEN SIDTIM=.TRUE. TIMSEL=.TRUE. REWIND NDATA REWIND NOUTP NOW=0 CALL READER(NLINE) GO TO 8 ELSE IF (MATCH(COM1,'N'))THEN SIDTIM=.FALSE. TIMSEL=.TRUE. GO TO 117 ELSE CALL TV('Please reply "y" or "n".') GO TO 119 END IF END IF END IF END IF OLDMJD=MJDOBS OLDUT=UT C Convert STAR/SKY flag to standard strings. IF (NSTSK.EQ.0) THEN STARSKY='STAR' ELSE IF (NSTSK.EQ.1) THEN STARSKY='SKY' ELSE CALL TV('Unexpected value in STAR/SKY column:') CALL TV(LINE(NLINE)) CALL STETER(119,'Fix data and try again.') END IF C Convert filter position to band name: BAND=BNDNAM(NFILT+1) C Save Geneva parameters: GENEVAQ=GENQ GENEVAR=GENR GENEVAG=GENG CALL WRITER GO TO 110 C C 1: last integration results if MAGtape,All (??) 125 CONTINUE GO TO 110 C C 2: (unused) 130 CONTINUE GO TO 110 C C 3 or 4: rejects (should never occur!) 140 CONTINUE CALL VIEW('PROGRAM ERROR: kept bad data!',NLINE) GO TO 110 C C 5: Object identifier 150 CONTINUE READ (LINE(NLINE),'(2X,A32)') OBJNAM GO TO 110 C C 6: Telescope coordinates 160 CONTINUE READ (LINE(NLINE),'(5X,A10,1X,A10)') RASTR, DESTR GO TO 110 C C 7: measurement number, UT, & JD 170 CONTINUE READ (LINE(NLINE),'(2X,I5,F12.1,2A10)')M,DJ,UTSTR C lststr is truncated to nearest minute on card 7, so useless. UT=TIMER(UTSTR) IF (DJ.EQ.DJZ+2400000.5D0) THEN C OK. ELSE IF (DJ.EQ.DJZ+2400001.5D0) THEN C probably OK. IF (UT.LT.3. .AND. OLDUT.GT.21.) THEN C assume we just went through 0h UT. CALL TV('0h UT passed by:') CALL TVN(LINE(NLINE)) DJZ=DJZ+1. STUTZH=24.*STUTZROT(DJZ+2400000.5D0) ELSE CALL TV('Computed JD does not match data:') CALL TV(LINE(NLINE)) CALL STETER(176,'Please fix data.') END IF ELSE C problem: CALL TV('Computed JD does not match data:') CALL TV(LINE(NLINE)) WRITE(COMMENT,*) 'Computed was ',DJZ+2400000.5D0 CALL TV(COMMENT) CALL STETER(178,'Please fix data.') END IF OLDUT=UT GO TO 110 C C 8: Heading or comment 180 CONTINUE CALL GETUT(NLINE,UT) IF (UT.GE.0.)THEN C time found on card DJD=DJZ+(UT/24.D0) IF (DJD.LT.OLDMJD) THEN IF (UT.LT.3. .AND. OLDUT.GT.21.) THEN C assume we just went through 0h UT. DJZ=DJZ+1.D0 DJD=DJD+1.D0 STUTZH=24.*STUTZROT(DJZ+2400000.5D0) CALL TV('0h UT passed by:') CALL TVN(LINE(NLINE)) ELSE 183 IF (TIMSEL) THEN CALL TV('Times out of order!') CALL TV(LINE(NLINE)) CALL STETER(183,'Please fix data.') ELSE CALL TV('Times seem out of order.') 184 CALL ASK('Are you using UT or LST?', 1 COM1) IF (MATCH(COM1,'U')) THEN SIDTIM=.FALSE. TIMSEL=.TRUE. GO TO 183 ELSE IF (MATCH(COM1,'LST') .OR. 1 MATCH(COM1,'SID')) THEN CALL TV('Starting over....') CALL TV(' ') SIDTIM=.TRUE. TIMSEL=.TRUE. REWIND NDATA REWIND NOUTP NOW=0 CALL READER(NLINE) GO TO 8 ELSE CALL TV('Please reply "LST"') CALL TVN(' or "UT".') GO TO 184 END IF END IF END IF END IF OLDMJD=DJD OLDUT=UT ELSE C time not found on card IF (OLDMJD.EQ.-1.D0) THEN DJD=DJZ+(UT1/24.)-1.E-5*(I1-NLINE) ELSE DJD=OLDMJD+1.E-5 END IF END IF MJDOBS=DJD C Split up comment card cleanly if possible: DO 186 K=34,14,-1 IF (LINE(NLINE)(K:K).EQ.' ') GO TO 187 186 CONTINUE 187 DO 188 K2=K+32,K+12,-1 IF (LINE(NLINE)(K2:K2).EQ.' ') GO TO 189 188 CONTINUE 189 IF (LINE(NLINE)(K2+32:).EQ.' ') THEN COM1=LINE(NLINE)(3:K) COM2=LINE(NLINE)(K+1:K2) COM3=LINE(NLINE)(K2+1:) ELSE READ (LINE(NLINE),'(2X,2A32,A14)')COM1,COM2,COM3 END IF COMMENT=COM1 CALL WRITER MJDOBS=DJD+1.D-6 COMMENT=COM2 IF (COM2.NE.' ') CALL WRITER MJDOBS=DJD+2.D-6 COMMENT=COM3 IF (COM3.NE.' ') CALL WRITER GO TO 110 C C 9: End of object 190 CONTINUE OBJNAM=' ' GO TO 110 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='data.fmt',STATUS='UNKNOWN') WRITE(NOUTP,'(A26)')'! Format file for ESO Data' 200 FORMAT(A39) WRITE(NOUTP,200)'DEFINE/FIELD 1 10 R F10.1 :SIGNAL ' WRITE(NOUTP,200)'DEFINE/FIELD 11 42 C A32 :OBJECT ' WRITE(NOUTP,200)'DEFINE/FIELD 43 46 C A7 :STARSKY ' WRITE(NOUTP,200)'DEFINE/FIELD 48 55 C A8 :BAND ' WRITE(NOUTP,200)'DEFINE/FIELD 56 67 D F12.6 :MJD_OBS ' WRITE(NOUTP,200)'DEFINE/FIELD 68 75 R F8.3 :EXPTIME ' WRITE(NOUTP,200)'DEFINE/FIELD 76 107 C A32 :COMMENT ' WRITE(NOUTP,200)'DEFINE/FIELD 108 113 R F8.2 :GENEVA_Q' WRITE(NOUTP,200)'DEFINE/FIELD 114 119 R F8.2 :GENEVA_R' WRITE(NOUTP,200)'DEFINE/FIELD 120 125 R F8.2 :GENEVA_G' WRITE(NOUTP,'(A3)')'END' CLOSE(NOUTP) C CALL TV('DCON is finished') C C C End MIDAS: C CALL STSEPI 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 REAL SIGNAL, EXPTIME, GENEVAQ, GENEVAR, GENEVAG DOUBLE PRECISION MJDOBS COMMON /OUTR/ SIGNAL,EXPTIME,MJDOBS, GENEVAQ,GENEVAR,GENEVAG CHARACTER OBJECT*32,STARSKY*4,BAND*8,COMMENT*32, C*125 COMMON /OUTC/ OBJECT,STARSKY,BAND,COMMENT C C WRITE(C,5) SIGNAL, OBJECT,STARSKY,BAND,MJDOBS,EXPTIME,COMMENT, 1 GENEVAQ,GENEVAR,GENEVAG 5 FORMAT(F10.1,A32,A4,1X,A8,F12.6,F8.3,A32,3F6.2) C C Fix up NULL fields: C IF (SIGNAL.EQ.RNULL) C(1:10)=' ' IF (MJDOBS.EQ.DNULL) C(56:67)=' ' IF (EXPTIME.EQ.RNULL) C(68:75)=' ' IF (GENEVAQ.EQ.RNULL) C(108:113)=' ' IF (GENEVAR.EQ.RNULL) C(114:119)=' ' IF (GENEVAG.EQ.RNULL) C(120:125)=' ' C WRITE(8,'(A125)') C C C clear data arrays: C OBJECT=' ' STARSKY=' ' BAND=' ' COMMENT=' ' SIGNAL=RNULL EXPTIME=RNULL GENEVAQ=RNULL GENEVAR=RNULL GENEVAG=RNULL MJDOBS=DNULL 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 INTEGER MXLINE PARAMETER (MXLINE=100) C INTEGER NLINE, LENBUF, NOW, NEOF, LAST CHARACTER*80 LINE(MXLINE) COMMON /LINES/LINE SAVE /LINES/ COMMON /BUF/LENBUF, NOW 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:') DO 5 LAST=MAX(1,NOW-3),NOW 5 CALL TVN(LINE(LAST)) 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: READ (7, '(A80)',END=99) LINE(NOW) C C Test for backup (bad data): 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 SUBROUTINE VIEW(STRING,NLINE) C CHARACTER*(*) STRING C INTEGER MXLINE PARAMETER (MXLINE=100) C CHARACTER*80 LINE(MXLINE) INTEGER NLINE, LENBUF, NOW, NM1, NP1, NP2, NP3 COMMON /LINES/LINE SAVE /LINES/ COMMON /BUF/LENBUF, NOW C C CALL TV(STRING) CALL TV(' ') NM1=NLINE-1 IF (NM1.LE.0) THEN NM1=LENBUF IF(LENBUF.EQ.MXLINE) CALL TVN(LINE(NM1)) ELSE CALL TVN(LINE(NM1)) END IF CALL TVN(LINE(NLINE)) NP1=NLINE+1 IF (NP1.GT.LENBUF) NP1=1 CALL TVN(LINE(NP1)) NP2=NLINE+2 IF (NP2.GT.LENBUF) NP2=1 CALL TVN(LINE(NP2)) NP3=NLINE+3 IF (NP3.GT.LENBUF) NP3=1 CALL TVN(LINE(NP3)) C RETURN END SUBROUTINE FILTBL C C Filter conversion table: C CHARACTER*8 FILTCD(20),BNDNAM(20) COMMON /FILTBC/ FILTCD,BNDNAM C LOGICAL MATCH C CHARACTER ANS, ROW*40 CHARACTER*8 ESORCD(12),ESOBCD(12),ESORED(12),ESOBLU(12) INTEGER I C DATA ESORCD/' 0',' 1',' 2',' 3',' 4',' 5',' 6', 1 ' 7',' 8',' 9','10','11'/ C DATA ESORED/'B','U','DARK','DARK','DARK','DARK','DARK', 1 'DARK','DARK','I','R','V'/ C DATA ESOBCD/' 0',' 1',' 2',' 3',' 4',' 5',' 6', 1 ' 7',' 8',' 9','10','11'/ C DATA ESOBLU/'BETAN','BETAW','u','v','b','y','DARK', 1 'DARK','DARK','U','V','B'/ C C CALL TV(' ') 1 CALL TV('Did you use the "red" standard wheel (UBVRI),') CALL TVN(' the "blue" standard wheel (uvby, beta),') CALL TVN(' or some other arrangement?') CALL ASK('(Please reply "red", "blue", or "other"):',ANS) 2 IF (MATCH(ANS,'R')) THEN C ESO Std.red wheel. CALL TV('The standard table for this wheel is:') CALL TV(' code band') DO 3 I=1,12 WRITE(ROW,'(7X,A6,A8)') ESORCD(I),ESORED(I) CALL TV(ROW) FILTCD(I)=ESORCD(I) BNDNAM(I)=ESORED(I) 3 CONTINUE CALL ASK('Are these correct?',ANS) IF (MATCH(ANS,'Y'))THEN RETURN ELSE IF (MATCH(ANS,'N')) THEN GO TO 2 ELSE CALL TV('Please reply "yes" or "no".') CALL TV('Let''s try this again:') GO TO 1 END IF ELSE IF (MATCH(ANS,'B')) THEN C ESO Std.red wheel. CALL TV('The standard table for this wheel is:') CALL TV(' code band') DO 4 I=1,12 WRITE(ROW,'(7X,A6,A8)') ESOBCD(I),ESOBLU(I) CALL TV(ROW) FILTCD(I)=ESOBCD(I) BNDNAM(I)=ESOBLU(I) 4 CONTINUE CALL ASK('Are these correct?',ANS) IF (MATCH(ANS,'Y'))THEN RETURN ELSE IF (MATCH(ANS,'N')) THEN GO TO 2 ELSE CALL TV('Please reply "yes" or "no".') CALL TV('Let''s try this again:') GO TO 1 END IF ELSE IF (MATCH(ANS,'O')) THEN C Non-std. wheel. CALL TV('Enter the standard filter name for each place') CALL TVN('in the wheel:') DO 5 I=1,12 CALL ASK(ESORCD(I),BNDNAM(I)) 5 CONTINUE ELSE GO TO 1 END IF C RETURN END