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