C @(#)plantop.for 17.1.1.1 (ES0-DMD) 01/25/02 17:17:33 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 PLAN C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.COPYRIGHT (c) Andrew T. Young, 1990 C.COPYRIGHT (c) European Southern Observatory, 1992 C.IDENT program plan C.MODULE plantop.for C.AUTHOR Andrew T. Young C.KEYWORD C.LANGUAGE FORTRAN 77 C.PURPOSE Makes a photometric observing schedule C.COMMENTS C.VERSION 0.0 C 0.5 921202, KB C 4.4 930212, ATY C 4.6 930322, ATY C 4.7 930327, ATY C 4.8 930401, ATY C 5.2 930429, ATY C.RETURNS error numbers correspond to nearby statement numbers C.ENVIRONMENT MIDAS C----------------------------------------------------------------------------- C IMPLICIT NONE C C BEGIN Declarations: C C C Set up MIDAS declarations: C INTEGER MADRID(1) C INCLUDE 'MID_INCLUDE:ST_DEF.INC' C COMMON /VMR/ MADRID C C C JULY 2, 1987 -- PARTLY CLEANED OF REDUNDANT SUBROUTINES. C C PLANS PHOTOMETRIC OBSERVATIONS, USING STANDARD STARS FROM STDFIL. C C *** SYSTEM-DEPENDENT FEATURES ARE FLAGGED BY *** COMMENTS LIKE THIS. C C F I L E S : C ----------- C CHARACTER*80 STDFIL, CATFIL, OBSFIL CHARACTER*80 SAVFIL C *** LENGTH OF FILE NAMES MAY BE SYSTEM-DEPENDENT. C FULL SET FOR SUBROUTINE COMPATIBILITY. INTEGER KB, KTV, K2, K3, K4, K7, K8, K9 COMMON /FILNOS/ KB, KTV, K2, K3, K4, K7, K8, K9 C *** UNITS MAY BE SYSTEM-DEPENDENT. C C C N A M I N G C O N V E N T I O N S : C ------------------------------------ C EXTERNAL NAME SAMPLE C QUANTITY VARIABLE TYPE FOR DATA FILE VALUE C -------- -------- ---- ------------- ------ C C NAMES: C C PLACE NAME PLACE CH*20 KITT PEAK C BAND NAME BAND CH*6 C STAR NAME STAR CH*20 STAR HR 8832 C STAR CODE STRCDS CH*20 STARCD 17 C INDICES CNAMES(1,NB) CH*6 V, B-V, M1, ... -0.20 C GAIN CONTROL GCONTR(NGAIN) CH*20 COARSE C GAIN SETTING GANCOD(I,N) CH*20 GAINS1, ... ,GAINS4 2 C C COORDINATES IN RADIANS: C C LONGITUDE ELONG REAL C LATITUDE ALAT REAL C HOUR ANGLE HA REAL C RIGHT ASCENSION RA REAL C DECLINATION DEC REAL C UNIVERSAL TIME UT REAL C ZONE TIME ZT REAL C SIDEREAL TIME ST REAL C C EXTERNAL SUB-UNITS ARE NAMED AS FOLLOWS: TYPE C ---- C DEGREES 1ST 2 LETTERS OF REAL VARIABLE//'DEG' REAL C HOURS " " " " " " //'HRS' REAL C MINUTES " " " " " " //'MIN' REAL C SECONDS " " " " " " //'SEC' REAL C C SPECIAL FORMS: C ROTATIONS " " " " " " //'ROT' REAL C CHAR.STRING " " " " " " //'STR' CHARACTER*20 C SIGN " " " " " " //'SGN' CHARACTER*20 C C EXAMPLES: RAHRS, UTMIN, ELSEC, ALDEG, DESTR, DESGN C C C P E P S Y S S Y S T E M V A R I A B L E S C --------------------------------------------- C INTEGER MOBS PARAMETER (MOBS=10) CHARACTER *20 PLACE*72, PLACES(MOBS) REAL ELDEGS,ALDEGS,HIGHS DIMENSION ELDEGS(MOBS),ALDEGS(MOBS),HIGHS(MOBS) C INCLUDE 'MID_REL_INCL:mstars.inc' C PARAMETER (MSTARS=1650) C commons for star catalog: CHARACTER *32 STARS COMMON /SCATA/ STARS(MSTARS) REAL RAS, DECS, EQUINX, COLORS COMMON /SCAT/ RAS(MSTARS), DECS(MSTARS), EQUINX(MSTARS), COLORS C C CAUTION -- MBANDS IS IN SUBROUTINES RDLIST, OPNFIL, DECOLR, & EPHEM. INCLUDE 'MID_REL_INCL:mbands.inc' C PARAMETER (MBANDS=9) REAL COLORM, COLRIN, XINV,YINV INTEGER NBANDS,LENB,LENC,KX,KY COMMON /CMAGS1/ COLORM(MBANDS,MBANDS),COLRIN(MBANDS,MBANDS), 1 XINV,YINV,NBANDS,LENB,LENC,KX,KY C REAL PHOMAG,FAINTS,BRITES,SZMAX, 1 SZMIN,EXTIN,SIGTOT,TINT1,TSUGG COMMON /CMAGS2/PHOMAG(MBANDS),FAINTS(MBANDS),BRITES(MBANDS),SZMAX, 1 SZMIN,EXTIN(MBANDS),SIGTOT,TINT1,TSUGG SAVE /CMAGS1/,/CMAGS2/ C CHARACTER *8 BAND, BANDS(3*MBANDS), CNAMES(2,MBANDS) REAL TRANS,WLS,WIDTHS DIMENSION 1 TRANS(MBANDS),WLS(MBANDS),WIDTHS(MBANDS),COLORS(MBANDS,MSTARS) INTEGER KOLR DIMENSION KOLR(MBANDS) INTEGER MBM1,MBM2,MBM3,MBM4,MBM5,MBM6,MBM7 PARAMETER(MBM1=MBANDS-1,MBM2=MBANDS-2,MBM3=MBANDS-3,MBM4=MBANDS-4) PARAMETER(MBM5=MBANDS-5,MBM6=MBANDS-6,MBM7=MBANDS-7) C INTEGER MSYS PARAMETER (MSYS=8) CHARACTER*6 SYSTEM,SYSTMS(MSYS),STDFLS(MSYS),BNDS(MBANDS,MSYS) 1 ,BNDVAR(MBANDS,MSYS) INTEGER JBANDS,LENBS,LENCS, KXS,KYS REAL XINVS,YINVS,STDWLS,FWHMS,TRANSS DIMENSION JBANDS(MSYS),LENBS(MSYS),LENCS(MSYS), 1 KXS(MSYS),KYS(MSYS),XINVS(MSYS),YINVS(MSYS) DIMENSION STDWLS(MBANDS,MSYS),FWHMS(MBANDS,MSYS), 1TRANSS(MBANDS,MSYS) C C C PARAMETERS FOR RDLIST/RDBLOK. C INTEGER MGAINS,MG2,MA,MCAT,MN,MV,MGRPS,MAREST,MNREST PARAMETER (MGAINS=4, MG2=2*MGAINS) PARAMETER (MA=21+MG2+5) PARAMETER (MCAT=12+2*MBANDS,MN=MCAT+30, MV=MA+MN, MGRPS=8) PARAMETER (MAREST=MA-21-MG2, MNREST=MN-MCAT-15) C C MA = MAX. ALPHABETIC (CHARACTER) VARIABLES, AVAR IN /NAMES/ C MN = MAX. NUMERIC VARIABLES, VAR IN /VALUES/ C MV = MAX. VARIABLE NAMES, NAMES IN /NAMES/ C C COMMONS FOR RDLIST/RDBLOK. NOTE RENAMING OF ELEMENTS OF AVAR. C C THESE MA CHARACTER VARIABLES REPLACE AVAR(MA): C CHARACTER NAMES(MV)*6,TITLE*80, AVAR(MA)*20 <--REPLACED BY LIST. C CHARACTER NAMES(MV)*6,TITLE*80 CHARACTER*32 STAR CHARACTER*20 RASTR,DESTR,BAYER,CONSTL,FLAMST,BSHR,HD,DM, 1 SPECT,DESGN,DATSTR,MONTH,REM1,REM2,STSTR,ZTSTR,UTSTR, 2 FILTCD,STARCD,STRSKY,ASPARE(MAREST),GANCDN(MGAINS),DIMCDN(MGAINS) C C COMMON /NAMES/NAMES,TITLE, AVAR COMMON /NAMES/NAMES,TITLE, RASTR,DESTR,STAR,BAYER,CONSTL,FLAMST, 1 BSHR,HD,DM,SPECT,DESGN,DATSTR,MONTH,REM1,REM2,STSTR,ZTSTR,UTSTR, 2 FILTCD,STARCD,STRSKY,ASPARE,GANCDN,DIMCDN EQUIVALENCE (CNAMES,NAMES(13)) C 13 BECAUSE CVARS IS VAR(13). C C REAL VARIABLES THAT REPLACE VAR(MN): C COMMON /VALUES/ NAM1(MGRPS),NAM2(MGRPS),NGRPS,VAR(MN) C INTEGER NAM1,NAM2,NGRPS,MURAT,MURAA,MUDEC REAL RAHRS,RAMIN,RASEC, 1 DEDEG,DEMIN,DESEC,EPOCH,SIGNAL,TINT, 2 CVARS,FMM,DD,YY,YEAR,DAY, 3 UTHRS,UTMIN,UTSEC,CLKERR,STHRS,STMIN,STSEC, 4 ZTHRS,ZTMIN,ZTSEC,VSPARE COMMON /VALUES/ NAM1(MGRPS),NAM2(MGRPS),NGRPS,RAHRS,RAMIN,RASEC, 1 DEDEG,DEMIN,DESEC,EPOCH,MURAT,MURAA,MUDEC,SIGNAL,TINT, 2 CVARS(2,MBANDS),FMM,DD,YY,YEAR,DAY, 3 UTHRS,UTMIN,UTSEC,CLKERR,STHRS,STMIN,STSEC, 4 ZTHRS,ZTMIN,ZTSEC,VSPARE(MNREST) C C C COMMONS FOR SPHERICAL TRIG.: C REAL SINPHI,COSPHI,ELONG,ELROT,UTROT,STUTZ,TWOPI,ST2UT, 1 TNOON1,TNOON2,PI,DEGRAD,ALAT COMMON /SPHERE/ SINPHI,COSPHI,ELONG,ELROT,UTROT,STUTZ,TWOPI,ST2UT, 1 TNOON1,TNOON2,PI,DEGRAD,ALAT C C COMMONS FOR SUN. C REAL COSOB,SINOB,RASUN,DESUN,HASUN,SOLONG,ELMOON,BMOON COMMON /CSUN/ COSOB,SINOB,RASUN,DESUN,HASUN,SOLONG,ELMOON,BMOON C C CAUTION -- THESE APPEAR IN SUBROUTINE FILL ALSO: INTEGER MSET,MROOM,MSG,MTIM PARAMETER (MSET=MSTARS-100,MROOM=2,MSG=14,MTIM=MROOM*MSET+MSG) C C MSET IS MAX.LENGTH OF SUBSET CHOSEN FOR EXT./STD. STARS. C MTIM IS MAX.LENGTH OF EVENT TIMES. C SAVE /CFILL/,/SPHERE/,/CSUN/,/HELPS/ C REAL UTBGN,UTEND,DARKT,TIMES INTEGER NOBJS,NT COMMON /CFILL/ UTBGN,UTEND,DARKT,TIMES(MTIM),NOBJS(MTIM),NT C C TIMES(NT) IS EVENT TIME IN SCHEDULE. C NOBJS(NT) IS OBJECT NUMBER IN SUBSET OF EXT./STD.STARS. C C COMMON FOR ANNOTATIONS: CHARACTER COMENT(MSTARS)*32,SPTYPE(MSTARS)*12,EMAG(MSTARS)*16 COMMON /NOTES/COMENT,SPTYPE,EMAG C C COMMON FOR HELP COUNT: COMMON /HELPS/ NEEDH,NASSMP CHARACTER ASSMPS(8)*40,ASSUME(8)*40 COMMON /ASSUME/ ASSMPS,ASSUME CHARACTER*13 F361 COMMON /FMT361/ F361 CHARACTER*79 PAGE(21) COMMON /SCREEN/PAGE INTEGER JCONT,JLOG,JDISP COMMON /FLAGS/JCONT,JLOG,JDISP C LOGICAL PC,DC,CI,CANNED,NEEDIM,CODEDS,MOVING,DARK,FUNK,FCORN, 1 COOLED C COMMON /LOGIC/ NEEDED,DIMMED,PC,DC,CI,NEEDIM,CODEDS,DARK,FUNK, 1 FCORN,COOLED C C C CODEDS IS.TRUE.IF STARS ARE CODED IN DATA. C PC IS.TRUE.IF DATA ARE PULSE COUNTS. C DC IS.TRUE.IF DATA ARE CURRENTS. C CI IS.TRUE.IF DATA ARE CHARGE INTEGRATIONS. C CANNED IS.TRUE.IF PLACE OR STDFIL IS BUILT-IN. C NEEDIM IS.TRUE.IF OPTICAL DIMMER IS NEEDED. C MOVING IS.TRUE.IF EPHEMERIS OBJECTS EXIST. C C C L O C A L V A R I A B L E S C ----------------------------- C CHARACTER A,CARD*80,DMS*32,PNAMES(10)*20,MON*3,TL*4,FL(2)*5, 1 TWILIT(MSG+1)*27,INSTNAM*72, 2 DAT*30,ELABEL(2)*8,WLABEL(2)*8,ASSUM4(2)*40,ASSUM6(2)*40 EQUIVALENCE (ASSUM4,ASSUME(4)),(ASSUM6,ASSUME(6)) CHARACTER TEMPRH*34, RALBL*22,DECLBL*7, FILTSTAT*9 C C MSET IS MAX.LENGTH OF SUBSET CHOSEN FOR EXT./STD. STARS. C C INTEGER LOCS(10) REAL SALTS(MSG),DJS(2),XS(MSET),YS(MSET), 1 RALIMS(2),DECLIM(2) C DOUBLE PRECISION DJD C LOGICAL SYSSET,DEDSET,NEEDED,DIMMED, FEXIST,NULL LOGICAL BACK1 REAL DUM, TELCM, 1 HIGH, ELDEG, ALDEG, ELHRS, DEG10, PRAT, DRAT, SCALE, AREA, 2 SIGSQ, DECDEG, RADEG, EPHEM1, EPHEM2, DEADT, SDEDT, RATE, ZONE, 3 DDAY, YR, OLDYR, Y, DJ C INTEGER NEEDH, NASSMP, NROWSAL, KEQUINOX, KMUALPHA, KMUDELTA, 1 MTYPE, I, IOBS, ISTAT, NVALS, IUNIT, NULLS, L, KSPTYPE, KVB, 2 NCOLS, NROWS, NSORTC, NWPRAL, KTEL, KDIAM, NROW, KLON, 3 KLAT, KHI, J, JOLD, K, NEEDST, JSYS, NB, NSTAR, LASTD, ISTD, 4 KOBJ, KRA, KDEC, KEPOCH, KMAG, KCOMMENT, KVI, KUV, 5 KDATE, KMJD, LEN, NSTARS, I1, I2, INST, 6 KDET, KBAND, KDETNM, KNDET, KCOOL, KRL, KRLTYP, KMODE, KDEDT, 7 KDEDER, ITIME, NDIG, N, M C C C INTEGER FCNS.: C ------------- INTEGER LWORD, MON2M C C CHARACTER FCNS.: C ---------------- CHARACTER DEG2MS*13 C C LOGICAL FCNS.: C ------------- LOGICAL HELP,MATCH C C END Declarations. C C C BEGIN DATA statements: INCLUDE 'MID_INCLUDE:ST_DAT.INC' C C C D A T A : C --------- C C NUMERICAL VARIABLE NAMES ... (REALLY IN BLOCK DATA) C C NAMX() = 1 2 3 4 5 6 7 C DATA NAMES/'RAHRS','RAMIN','RASEC','DEDEG','DEMIN','DESEC','EPOCH' C C 8 9 10 11 12 C 1,'MURAT','MURAA','MUDEC','SIGNAL','TINT', C C 13 TO MCAT.... +1 +2 +3 +4 +5 C 2 MBANDS*' ',MBANDS*' ','MM','DD','YY','YEAR','DAY', C C MCAT + 6 +7 +8 +9 +10 +11 +12 C 3 'UTHRS','UTMIN','UTSEC','CLKERR','STHRS','STMIN','STSEC', C C MCAT+13 +14 +15 +16 TO MCAT +30 C 4 'ZTHRS','ZTMIN','ZTSEC', MNREST*' ', C C CHARACTER VARIABLE NAMES... C C MN+1 MN+2 MN+3 MN+4 MN+5 MN+6 MN+7 MN+8 MN+9 C 5 'RASTR','DESTR','STAR','BAYER','CONSTL','FLAMST','BSHR','HD','DM' C C MN+10 MN+11 MN+12 MN+13 MN+14 MN+15 MN+16 MN+17 C 6 ,'SPECT','DESGN','DATSTR','MONTH','REM1','REM2','STSTR','ZTSTR', C C MN+18 MN+19 MN+20 MN+21 MN+22 TO C 7 'UTSTR','FILTCD','STARCD','STRSKY',MGAINS*' ',MGAINS*' ', C C MN+ C 8 MAREST*' '/ C C C PLACE DATA: C DATA PLACES/'MT.LAGUNA','KITT PEAK','LOWELL','LICK','MT.WILSON', 1 'PALOMAR','CERRO TOLOLO','LAS CAMPANAS','ESO','MCDONALD'/ DATA ELDEGS/-116.4258,-111.5947,-111.6633,-121.6455,-118.0597, 1 -116.8640,-70.8059,-70.7020,-70.7296,-104.0223/ DATA ALDEGS/32.8400 ,31.95842,35.20167,37.34036,34.21653, 1 33.35622,-30.16894,-29.00361,-29.25717,30.67158/ DATA HIGHS/1859.,2064.,2210.,1283.,1742., 1 1706.,2399.,2282.,2400.,2081./ DATA PNAMES/'MT. LAGUNA','KPNO','FLAGSTAFF','MT. LOCKE', 1 'CTIO','MT.LOCKE','MT. WILSON','MT.HAMILTON','MT. HAMILTON', 2 'MOUNT HAMILTON'/ DATA LOCS/1,2,3,10,7,10,5,4,4,4/ C C SYSTEM DATA: C DATA SYSTMS/'UBV','UBVRI','UVBY','H-BETA','UVBYHB','GENEVA','DDO', 1 'OTHER'/ DATA JBANDS/ 3, 5, 4, 2, 6, 7, 6, 1 0/ C DATA STDFLS/'UBVSTD','UBVSTD','UVBYST','UVBYST','UVBYST','GENSTD', 1 'DDOSTD',' '/ C DATA LENBS/1,1,1,5,5,2,2,1/,LENCS/3,3,3,4,4,5,6,0/ C C BAND NAMES. DATA BNDS/'U','B','V','RL',MBM4*' ', 2 'U','B','V','R','I','RL',MBM6*' ', 3 'u','v','b','y',MBM4*' ', 4 'betaW','betaN',MBM2*' ', 5 'u','v','b','y','betaW','betaN',MBM6*' ', 6 'U','B','V','B1','B2','V1','G',MBM7*' ', 7 '48','45','42','41','38','35',MBM6*' ' ,MBANDS*' '/ C C MAGNITUDE AND COLOR NAMES FOR EXTERNAL LISTS. DATA BNDVAR/'V','U-B','B-V',MBM3*' ', 2 'V','U-B','B-V','V-R','R-I',MBM5*' ', 3 'V','b-y','m1','c1',MBM4*' ', 4 'BETA',MBM1*' ', 5 'V','b-y','m1','c1','BETA',MBM5*' ', 6 'VM','U-B','B-V','U-B2','B1-B2','B2-V1','V1-G',MBM7*' ', 7 'M48','C45-48','C42-45','C41-42','C38-41','C35-38',MBM6*' ', 8 MBANDS*' '/ C C EFF.WAVELENGTHS. C UBV:Buser,A.&Ap.62,411(1979); others from Dudley Obs.rept. DATA STDWLS/3652.,4417.,5505.,7000.,MBM4*0., 2 3652.,4417.,5505.,6400.,8000.,7000.,MBM6*0., 3 3425.,4110.,4670.,5510.,MBM4*0., 4 4861.,4861.,MBM2*0., 5 3425.,4110.,4670.,5510.,4861.,4861.,MBM6*0., 6 3458.,4248.,5508.,4022.,4480.,5408.,5814.,MBM7*0., 7 4886.,4517.,4257.,4166.,3815.,3460.,MBM6*0. ,MBANDS*0./ C C WIDTHS. THESE ARE ABOUT 2.64 X MU2. DATA FWHMS/535.,980.,800.,300.,MBM4*0., 2 535.,980.,800.,1400.,1700.,600.,MBM6*0., 3 375.,200.,175.,250.,MBM4*0., 4 150.,30.,MBM2*0., 5 375.,200.,175.,250.,150.,30.,MBM6*0., 6 450.,800.,800.,450.,440.,530.,540.,MBM7*0., 7 186.,76.,73.,83.,330.,383.,MBM6*0. ,MBANDS*0./ C PEAK TRANSMISSIONS. DATA TRANSS/.86,.73,.9,.9,MBM4*0., 2 .86,.73,.9,.77,.86,.9,MBM6*0., 3 .39,.49,.48,.53,MBM4*0., 4 .75,.6,MBM2*0., 5 .39,.49,.48,.53,.75,.6,MBM6*0., 6 .65,.65,.5,.5,.34,.3,.3,MBM7*0., 7 .56,.55,.53,.49,.65,.41,MBM6*0., MBANDS*0./ C C 2-COLOR DIAGRAMS. O C U U B 4 G T C U . V E + E D H C B . B T H N D E C V I Y A B V O R DATA KYS /2, 2, 4, 0, 4, 4, 2, 0/ DATA KXS /3, 3, 2, 0, 2, 6, 3, 0/ DATA YINVS/1.,1.,0.,0.,0.,1.,0.,0./ DATA XINVS/0.,0.,0.,0.,0.,0.,0.,0./ C DATA FL/'FIRST',' LAST'/ C C DATA FOR SUN/MOON SET/RISE AND TWILIGHTS: C DATA SALTS/-.0145,-.1045,-.208,-.309,-.309,-.208,-.1045,-.0145, C SUN ABOVE, MOON BELOW. 1 -.0145,-.0145,-.12,-.12,+.3,+.3/ C DATA TWILIT/'SUN SETS','END CIVIL TWILIGHT', 1 'END NAUTICAL TWILIGHT' 2,'END ASTRONOMICAL TWILIGHT','BEGIN ASTRONOMICAL TWILIGHT', 3'BEGIN NAUTICAL TWILIGHT','BEGIN CIVIL TWILIGHT','SUN RISES', C 4'MOONRISE - FAST SKY CHANGES','MOONSET -- SKY CHANGES FAST', 5'BEGIN LUNAR TWILIGHT','END LUNAR TWILIGHT', 6'SKY CHANGES MORE SLOWLY','BEGIN RAPID SKY CHANGES', 7'CHECK DARK LEVEL'/ C DATA ELABEL/' RISING',' EAST'/,WLABEL/' SETTING',' WEST'/ C DATA DECLBL/' DEC.'/, 1 TEMPRH/'TEMP.= R.H. = U.T. ='/, 2 RALBL/' <---- R.A. '/ C DATA RALIMS/24.,0./,DECLIM/0.,0./ C C END DATA statements. C C ******************** PROLOGUE ******************** C CALL STSPRO ('PLAN') C C Real program begins here: C C PROLOGUE: C C *** F361='(I7.2,2X,A32)' DUM=KTV CALL PLOT(0,DUM,0.,'U') CALL PLOT(0,79.,23.,'P') NASSMP=0 NEEDH=0 MTYPE=0 ST2UT=0.99726956633 PI=3.14159265358979D0 TWOPI=PI+PI DEGRAD=PI/180. SZMIN=1.1 SZMAX=2.36 C C Reset error flags: C CALL STECNT('GET',JCONT,JLOG,JDISP) CALL STECNT('PUT',1,2,2) C C BEGIN DIALOG. C CALL SPACE2 CALL CENTER('Welcome to PEPSYS3''s PLANNER.') CALL SPACE2 CALL ASK('Do you want Instructions?',A) IF(MATCH(A,'N')) GO TO 50 C NEEDH=2 WRITE(PAGE,3) 3 FORMAT(/ 1' PEPSYS needs information on the stars and instrument used.'/ 2' It will ask you to supply this by asking you questions.'/// 3' If you don''t understand a question, try typing "HELP" or "?"'/ 4' -- some on-line help is available.'//) DO 4 I=1,10 4 CALL TVN(PAGE(I)) WRITE(PAGE,12) 12 FORMAT(/' You can abbreviate most answers -- e.g.,'// 1 5X,' you can answer yes/no questions with just "Y" or "N".'// 2' If you want to abandon a run, reply "QUIT" to any request for'/ 3' non-numeric input.'//) DO 13 I=1,10 13 CALL TVN(PAGE(I)) 20 CALL ASK('Do you need to set up a new STAR FILE?',A) IF(MATCH(A,'Y')) CALL FILHLP C IF(HELP(A)) THEN CALL TV('Star files exist for UBV and uvby standards.') CALL TVN('You may need to set up new files for other systems, or f C convert next line to lower case: 1OR PROGRAM STARS.') GO TO 20 END IF C C LOCATE OBSERVATORY. C 50 CONTINUE OBSFIL='esotel.tbl' INQUIRE (FILE=OBSFIL,EXIST=FEXIST) 51 IF (FEXIST) THEN CALL TBTOPN (OBSFIL, 1, IOBS, ISTAT) CALL STDRDC (IOBS, 'OBSERVATORY', 1, 1, 72, 1 NVALS, PLACE, IUNIT, NULLS, ISTAT) IF(ISTAT.NE.0)THEN CALL TV('Could not find OBSERVATORY descriptor.') CALL TERROR(IOBS,51,'Please fix table file.') ELSE END IF ELSE CALL TV('The required observatory table file, "esotel.tbl",') CALL TVN('is not available. Please make sure all required') CALL TVN('files are available in your current directory.') CALL STETER(52,'Missing observatory file "esotel.tbl"') END IF L=LWORD(PLACE) IF (L.GT.42) THEN CALL SPACE CALL TV('Will the observations be made at ') TITLE=PLACE(:L)//'?' ELSE TITLE='Will the observations be made at '//PLACE(:L)//'?' END IF CALL ASK(TITLE,CARD) IF(MATCH(CARD,'NO')) THEN CALL TBTCLO(IOBS, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,55,'Could not close obs. file.') CALL TV(' ') 55 CALL TV('Do you have a table file for the OBSERVATORY') CALL ASKFIL(' where the observations will be made?',OBSFIL) IF (MATCH(OBSFIL,'yes') .OR. MATCH(OBSFIL,'YES'))THEN 56 CALL ASKFIL('Please enter the observatory FILE name:',OBSFIL) IF(INDEX(OBSFIL,'.tbl').EQ.0) THEN I=LWORD(OBSFIL) OBSFIL(I+1:)='.tbl' END IF INQUIRE (FILE=OBSFIL,EXIST=FEXIST) IF(FEXIST) GO TO 51 CALL TV('File not found. (Enter Q to quit, if necessary.)') GO TO 56 ELSE IF (MATCH(OBSFIL,'no') .OR. MATCH(OBSFIL,'NO'))THEN GO TO 103 ELSE IF(INDEX(OBSFIL,'.tbl').EQ.0) THEN I=LWORD(OBSFIL) OBSFIL(I+1:)='.tbl' END IF INQUIRE (FILE=OBSFIL,EXIST=FEXIST) IF(FEXIST) GO TO 51 CALL TV('File not found.') GO TO 55 END IF GO TO 103 END IF IF(.NOT.MATCH(CARD,'YES'))GO TO 104 IF(PLACE(:6).EQ.'MOUNT ' .OR. PLACE(:6).EQ.'Mount')THEN CARD='Mt.'//PLACE(7:) PLACE=CARD END IF C Right OBSERVATORY. Read info from OBSFIL: CALL TBIGET (IOBS, NCOLS, NROWS, NSORTC, NWPRAL, NROWSAL, ISTAT) CALL TBLSER (IOBS, 'TELESCOP', KTEL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,53,'ERROR finding TELESCOP col') IF(KTEL.EQ.-1) CALL TERROR(IOBS,53,'Could not find TELESCOP col') CALL TBLSER (IOBS, 'DIAM', KDIAM, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,54,'ERROR finding DIAM col.') IF(KDIAM.EQ.-1) CALL TERROR(IOBS,54,'Could not find DIAM col') CALL TV(' ') CALL TV('Please choose the telescope to be used:') DO 60 NROW=1,NROWS CALL TBERDC (IOBS, NROW, KTEL, CARD, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,57,'Could not read TELESCOP col') CALL TBERDR (IOBS, NROW, KDIAM, TELCM, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,58,'Could not read DIAM col.') WRITE(TITLE,'(6X,I2,'': '',A8,F6.2,'' m'')')nrow,card(:8),telcm CALL TV(TITLE) 60 CONTINUE WRITE(TITLE,'(6X,I2,'': None of these'')') NROWS+1 CALL TV(TITLE) 61 CALL QF('Enter the NUMBER (not the aperture) of your choice:', 1 HIGH) NROW=HIGH IF (NROW.LT.1 .OR. HIGH-FLOAT(NROW).NE.0.) GO TO 61 IF (NROW.GT.NROWS) GO TO 103 CALL TBLSER (IOBS, 'LON', KLON, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,61,'ERROR finding LON col.') IF(KLON.EQ.-1) CALL TERROR(IOBS,61,'Could not find LON col') CALL TBERDR (IOBS, NROW, KLON, ELDEG, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,62,'Could not read LON col.') CALL TBLSER (IOBS, 'LAT', KLAT, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,64,'ERROR finding LAT col.') IF(KLAT.EQ.-1) CALL TERROR(IOBS,64,'Could not find LAT col') CALL TBERDR (IOBS, NROW, KLAT, ALDEG, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,65,'Could not read LAT col.') CALL TBLSER (IOBS, 'HEIGHT', KHI, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,66,'ERROR finding HEIGHT col.') IF(KHI.EQ.-1) CALL TERROR(IOBS,66,'Could not find HEIGHT col.') CALL TBERDR (IOBS, NROW, KHI, HIGH, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,67,'Could not read HEIGHT col.') CALL TBERDR (IOBS, NROW, KDIAM, TELCM, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,68,'Could not read DIAM col.') TELCM=TELCM*100. CALL TBTCLO(IOBS, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,69,'Could not close obs. file.') CANNED=.TRUE. GO TO 120 C C NOT HOME. TRY AGAIN. 103 CALL ASKFIL('Observatory name?',PLACE) 104 J=INDEX(PLACE,'OBS') IF(J.GT.1) PLACE(J:)=' ' IF(PLACE(:6).EQ.'MOUNT ' .OR. PLACE(:6).EQ.'Mount')THEN CARD='Mt.'//PLACE(7:) PLACE=CARD END IF DO 106 J=1,MOBS IF(PLACE.EQ.PLACES(J)) GO TO 109 106 CONTINUE DO 107 J=1,10 IF(PLACE.EQ.PNAMES(J)) GO TO 108 107 CONTINUE GO TO 110 C 108 J=LOCS(J) 109 PLACE=PLACES(J) ELDEG=ELDEGS(J) ALDEG=ALDEGS(J) HIGH=HIGHS(J) TELCM=0. CANNED=.TRUE. GO TO 120 C C C NOT IN LIST, SO ASK FOR COORDS. 110 CALL TV('Enter (East) LONGITUDE in time or degrees:') CALL TV(' h m s o '' "') CALL ASK(' ',DMS) CANNED=.FALSE. IF(DMS(:10).EQ.' ') GO TO 113 C LONGITUDE IN HOURS. ELHRS=DEG10(DMS(:13)) IF(ELHRS.EQ.3.E33)GO TO 110 IF(INDEX(DMS,'W').NE.0) ELHRS=-ELHRS GO TO 116 C LONGITUDE IN DEGREES. CONVERT TO DECIMAL, HOURS. 113 ELDEG=DEG10(DMS(16:32)) IF(ELDEG.EQ.3.E33)GO TO 110 IF(INDEX(DMS,'W').NE.0) ELDEG=-ELDEG ELHRS=ELDEG/15. C CONVERT HOURS TO DEGREES. 116 ELDEG=ELHRS*15. 117 CALL TV('Enter LATITUDE:') CALL TV(' o '' "') CALL ASK(' ',DMS) ALDEG=DEG10(DMS(:20)) IF(ALDEG.EQ.3.E33)GOTO 117 IF(INDEX(DMS,'S').NE.0) ALDEG=-ALDEG CALL QF('Enter height (meters) above sea level:',HIGH) C C CONVERT FROM DEGREES TO RADIANS. 120 ELHRS=ELDEG/15. ELROT=ELHRS/24. ELONG=ELDEG*DEGRAD WRITE(CARD,*) 'Longitude = ',ELDEG,' deg. = ',ELONG,' radians' CALL TV(CARD) TNOON1=-ELROT-.5 TNOON2=-ELROT+.5 ALAT=ALDEG*DEGRAD WRITE(CARD,*) 'Latitude = ',ALDEG,' deg. = ', ALAT,' radians' CALL TVN(CARD) COSPHI=COS(ALAT) SINPHI=SIN(ALAT) PRAT=EXP(-HIGH/8.E3) DRAT=PRAT*PRAT C DIP OF HORIZON (P.401 OF EXPL.SUPP.) DO 121 I=1,12 121 SALTS(I)=SALTS(I)-6.16E-4*SQRT(HIGH) IF(CANNED)GO TO 125 C CARD(1:13)=DEG2MS(ELHRS) CARD(21:33)=DEG2MS(ALDEG) WRITE(PAGE,122)PLACE,CARD(1:13),CARD(21:33),HIGH 122 FORMAT(/4X,A//' LONGITUDE LATITUDE'/' h m s O 1 '' "'/2X,A13,2X,A13//' HEIGHT =',F6.0,' METERS') DO 123 I=1,8 123 CALL TVN(PAGE(I)) CALL ASK('OK?',A) IF(MATCH(A,'N')) GOTO 104 C C TELESCOPE. C 125 CONTINUE SYSSET=.FALSE. DIMMED=.FALSE. NEEDED=.FALSE. DEDSET=.FALSE. IF(TELCM.GT.0.) GO TO 128 CALL ASK('Telescope aperture?',CARD) SCALE=1. JOLD=0 126 J=INDEX(CARD,'CM') IF(J.EQ.0)J=INDEX(CARD,'CENTIMET') C IF(J.EQ.0)THEN J=INDEX(CARD,'MET') IF(J.EQ.0)J=INDEX(CARD,'M.') IF(J.EQ.0)J=INDEX(CARD,'M ') IF(J.NE.0)SCALE=100. END IF C IF(J.EQ.0)THEN J=INDEX(CARD,'IN') IF(J.NE.0)SCALE=2.54 END IF C IF(HELP(CARD))THEN CALL TV('Give number and units.') GOTO 125 END IF C IF(J.EQ.0)THEN 127 CALL ASK('UNITS?',DMS) NEEDH=NEEDH+1 IF(HELP(DMS))THEN CALL TV('cm, meters, or inches, please.') GO TO 127 END IF J=INDEX(CARD,' ') IF(JOLD.EQ.0)JOLD=J CARD(JOLD:)=DMS GO TO 126 END IF C K=INDEX(CARD,'-') IF(K.NE.0)J=MIN(J,K) CARD(J:)=' ' READ(CARD,'(BN,F12.0)',ERR=125)TELCM IF(TELCM.LE.0.)GO TO 125 TELCM=TELCM*SCALE WRITE(PAGE,'(/F9.1,'' cm.'')')TELCM CALL TV(PAGE(2)) 128 AREA=PI*TELCM*TELCM/4. C C PRECISION. C CALL TV(' ') CALL QF('What RMS precision (mags.) do you want?',SIGTOT) IF(SIGTOT.LT.0.003)THEN CALL TV( 1 'Errors below 0.003 cannot be reached with existing systems.') CALL QF('Please re-enter RMS error goal.',SIGTOT) END IF IF(SIGTOT.LE.0.) GO TO 128 IF(SIGTOT.LT.0.01)THEN NASSMP=NASSMP+1 ASSMPS(NASSMP)='Transformation error may limit precision' CALL TV(ASSMPS(NASSMP)) END IF SIGSQ=SIGTOT*SIGTOT C Assume transformation error = .015/star. NEEDST=9.E-4/SIGSQ + 4. C LET SCINT.NOISE AMPL.= HALF OF SIGTOT AT SECZ=SZMAX=2.36. TINT1=8.1E-3*DRAT/(SIGSQ*TELCM**(4./3.)) C (8.1E-3 = .09**2) C SCINT.NOISE = SIGTOT/2 IN TINT1 SEC.AT ZENITH. (SEE 173; 213.5) TINT=TINT1*(SZMAX**4) TSUGG=INT(TINT/5.)*5.+5. WRITE(PAGE,129)TINT,TSUGG 129 FORMAT(/' Use',F4.0,' sec minimum integrations for bright stars.'/ 1/4X,'Suggested integration =',F4.0,' sec') CALL TV(PAGE(2)) CALL TV(PAGE(4)) CALL ASK('OK?',A) C IF(MATCH(A,'Y')) THEN C we are OK. ELSE IF(MATCH(A,'N')) THEN CALL QF('How many sec.do you want?',TSUGG) IF(TSUGG.LT.TINT/SQRT(SZMAX))THEN C revise specs. TELCM=TELCM*(TINT/TSUGG)**0.75 SIGTOT=SIGTOT*SQRT(TINT/TSUGG) C convert next line to lower case: WRITE(PAGE,'(/'' Raise error to'',F6.3, + '' mag''/'' OR USE AT LEAST'',F6.1,'' CM TELESCOPE.'')') + SIGTOT,TELCM CALL TV(PAGE(2)) CALL TVN(PAGE(3)) GO TO 51 END IF ELSE CALL TV('Please answer "Yes" or "No".') GOTO 128 END IF C C SYSTEM. C 130 IF(SYSSET)GOTO 160 CALL TV(' ') CALL ASK('Name of Standard System?',SYSTEM) CANNED=.FALSE. DO 131 JSYS=1,MSYS IF(SYSTEM.EQ.SYSTMS(JSYS)) GO TO 132 131 CONTINUE JSYS=0 NEEDST=0 IF(MATCH(SYSTEM,'NONE')) THEN CALL ASKFIL('What file has extinction-star positions?',STDFIL) GO TO 142 END IF NEEDH=NEEDH+1 CALL TV('Choose "NONE" or one of:') WRITE(PAGE,'(10(1X,A6))') SYSTMS CALL TVN(PAGE(1)) GO TO 130 C 132 STDFIL=STDFLS(JSYS) NBANDS=JBANDS(JSYS) C to 140 for "other". IF(JSYS.EQ.MSYS)GO TO 140 IF (INDEX(SYSTEM,'RI').GT.0) THEN CALL TV('******************* CAUTION *******************') CALL TV('The R and I bands of the Johnson UBVRI system are') CALL TVN('NOT the same as those of the Kron-Cousins system.') CALL TV(' BE SURE you know which system you are using!') CALL TV(' NEVER mix standard stars from the two systems!!') END IF DO 133 NB=1,NBANDS WLS(NB)=STDWLS(NB,JSYS) WIDTHS(NB)=FWHMS(NB,JSYS) TRANS(NB)=TRANSS(NB,JSYS) C SET 2-COLOR DIAGRAM. KX=KXS(JSYS) KY=KYS(JSYS) XINV=XINVS(JSYS) YINV=YINVS(JSYS) LENB=LENBS(JSYS) LENC=LENCS(JSYS) CNAMES(1,NB)=BNDVAR(NB,JSYS) CNAMES(2,NB)='S'//BNDVAR(NB,JSYS) 133 BANDS(NB)=BNDS(NB,JSYS) CANNED=.TRUE. GO TO 150 C C OTHER. C 140 CALL ASK('Name of System?',SYSTEM) CALL ASKFIL('Name of STD.star file?',STDFIL) 142 CALLQF('Number of bands =',DUM) NBANDS=DUM LENB=0 LENC=0 IF(NBANDS.LE.0)THEN WRITE(PAGE,'(I5,'' is not legal'')')NBANDS CALL TVN(PAGE(1)) GO TO 142 END IF IF(NBANDS.LE.MBANDS) GO TO 145 CALL EXCEED(NBANDS,'MBANDS',MBANDS) CALL STETER(144, 'MBANDS EXCEEDED') C 145 DO 148 K=1,NBANDS WRITE(DMS,'(''Name of band ('',I1,'')?'')')K 146 CALL ASK(DMS,BANDS(K)) LENB=MAX(LENB,LWORD(BANDS(K))) IF(LENB.EQ.0)GOTO146 CALL QF('Center Wavelength (A)?',WLS(K)) CALL QF('Full width (A) at half peak response?',WIDTHS(K)) CALL QF('Peak transmission?',TRANS(K)) 147 CALL ASKFIL('Name of associated magnitude or color?',CNAMES(1,K)) C SET FOR FILES WITH S.D.'S OF STD.VALUES: CNAMES(2,K)='S'//CNAMES(1,K) LENC=MAX(LENC,LWORD(CNAMES(1,K))) IF(LENC.EQ.0)GOTO147 148 CONTINUE LENB=MIN(LENB,6) LENC=MIN(LENC,6) C C 2-COLOR DIAGRAM. IF(MATCH(SYSTEM,'NONE') .OR. NBANDS.LT.3)GOTO150 CALL TV('Set up 2-color diagram:') CALL ASK('Color on HORIZONTAL axis:',BAND) CALL ASK('Color on VERTICAL axis:',UTSTR) DO 149 K=1,NBANDS IF(CNAMES(1,K).EQ.BAND)KX=K IF(CNAMES(1,K).EQ.UTSTR)KY=K 149 CONTINUE XINV=0. YINV=0. PAGE(1)='Does '//CNAMES(1,KX)(:LENC)//' increase to right?' CALL ASK(PAGE(1),A) IF(MATCH(A,'N'))XINV=1. PAGE(1)='Does '//CNAMES(1,KY)(:LENC)//' increase upward?' CALL ASK(PAGE(1),A) IF(MATCH(A,'N'))YINV=1. C C DECODE COLORS. C 150 CALL DECOLR(COLORS,CNAMES,BANDS,SYSTEM,CANNED) C C ESTIMATE PHOTON NOISE. C 160 DO 168 NB=1,NBANDS C Allow for extinction. DUM=5.E3/WLS(NB) EXTIN(NB)=0.15*PRAT*DUM**4 + DRAT*0.1*DUM C .05 IS DQE. PHOMAG(NB) = 15.5 + 2.5*LOG10(SIGSQ*AREA*.05*TINT1*WIDTHS(NB)* 1 TRANS(NB)/WLS(NB)) C PHOTON NOISE = SIGSQ/4. at PHOMAG for TINT1 sec. outside atmosphere. FAINTS(NB)=3.E33 168 BRITES(NB)=-3.E33 CALL MAGSET(BANDS) IF(SYSSET)GO TO 200 C C READ STDFIL. C SYSSET=.TRUE. SAVFIL=STDFIL 170 NSTAR=1 LASTD=0 NAM1(1)=1 NAM2(1)=12+2*NBANDS NAM1(2)=MN+1 NAM2(2)=MN+11 NGRPS=2 C NGRPS CANNOT EXCEED PARAMETER (MGRPS=8). MOVING=.FALSE. C special for uvby only: IF (SYSTEM(:4).EQ.'UVBY') SYSTEM(:4)='uvby' C C OPEN Standard-star file: C 175 INQUIRE (FILE=STDFIL,EXIST=FEXIST) IF (FEXIST) THEN CALL TBTOPN(STDFIL,1, ISTD,ISTAT) IF(ISTAT.NE.0)CALLTERROR(IOBS,175,'Could not open star file.') CARD=' ... reading '//STDFIL CALL TV(CARD) IF(LASTD.EQ.0)THEN C display SYSTEM descriptor of std.-star file: CALL STDRDC (ISTD, 'SYSTEM', 1, 1, 32, 1 NVALS, CARD, IUNIT, NULLS, ISTAT) CALL TVN(CARD) IF (INDEX(CARD,SYSTEM(:LWORD(SYSTEM))).EQ.0 .AND. 1 .NOT.(SYSTEM.EQ.'H-BETA'.AND.INDEX(CARD,'HB').NE.0))THEN CALL TV( 1 'CAREFUL: this does not appear to be the right') CALL TVN('photometric system. Please check:') CALL TV('Is this REALLY a standard-star file for') CARD=SYSTEM(:LWORD(SYSTEM))//' ?' CALL ASKN(CARD,A) IF (A.EQ.'Y')THEN ELSE CALL ASKFIL('Enter the correct file name:',STDFIL) IF (MATCH(STDFIL,'no').OR.MATCH(STDFIL,'NO'))THEN GO TO 188 ELSE GO TO 175 END IF END IF END IF END IF ELSE IF(INDEX(STDFIL,'.tbl').EQ.0) THEN CARD=STDFIL(:LWORD(STDFIL))//'.tbl' STDFIL=CARD GO TO 175 END IF CARD='The requested star table file '//STDFIL CALL TV(CARD) CALL TVN('is not available. Please make sure all required') CALL TVN('files are available in your current directory.') CARD='Is '//STDFIL(:LWORD(STDFIL))//' the correct file name?' CALL ASKFIL(CARD,STDFIL) IF (MATCH(STDFIL,'YES') .OR. MATCH(STDFIL,'yes'))THEN CALL STETER(175,'Missing standard-star file') ELSEIF (MATCH(STDFIL,'NO') .OR. MATCH(STDFIL,'no'))THEN CALL ASKFIL('Please enter the correct file name:',STDFIL) GO TO 175 ELSE GO TO 175 END IF END IF C C Get columns: C CALL TBIGET(ISTD, NCOLS,NROWS,NSORTC,NWPRAL,NROWSAL,ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,175,'Could not get file info.') CALL TBLSER(ISTD,'OBJECT', KOBJ,ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,176,'ERROR finding OBJECT col.') IF(KOBJ.EQ.-1) CALL TERROR(IOBS,176,'Could not find OBJECT col.') CALL TBLSER(ISTD,'RA', KRA,ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,177,'ERROR finding RA col.') IF(KRA.EQ.-1) CALL TERROR(IOBS,177,'Could not find RA col.') CALL TBLSER(ISTD,'DEC', KDEC,ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,178,'ERROR finding DEC col.') IF(KDEC.EQ.-1) CALL TERROR(IOBS,178,'Could not find DEC col.') CALL TBLSER(ISTD,'EQUINOX', KEQUINOX,ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,179,'ERROR finding EQUINOX col.') IF(KEQUINOX.EQ.-1) THEN IF (LASTD.EQ.0) THEN CALL TERROR(IOBS,179,'Could not find EQUINOX col.') ELSE C assume moving object, referred to equinox of date. CALL TV('No EQUINOX column in this file.') CALL TVN( 1 'Assume this is an ephemeris file for moving objects.') MOVING=.TRUE. END IF END IF CALL TBLSER(ISTD,'MUALPHA', KMUALPHA,ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,179,'ERROR finding MUALPHA col.') CALL TBLSER(ISTD,'MUDELTA', KMUDELTA,ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,179,'ERROR finding MUDELTA col.') CALL TBLSER(ISTD,'EPOCH', KEPOCH,ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,179,'ERROR finding EPOCH col.') CALL TBLSER(ISTD,'SPTYPE', KSPTYPE,ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,179,'ERROR finding SPTYPE col.') CALL TBLSER(ISTD,'MAG', KMAG,ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,179,'ERROR finding MAG col.') CALL TBLSER(ISTD,'COMMENT', KCOMMENT,ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,179,'ERROR finding COMMENT col.') DO 180 K=1,NBANDS DMS=CNAMES(1,K) C special fudge for dumb MIDAS table system: IF (INDEX(DMS,'-').NE.0)DMS(INDEX(DMS,'-'):INDEX(DMS,'-'))='_' C DMS holds MIDAS-readable name; CNAMES has human-readable name. IF (CNAMES(1,K).EQ.' ') THEN KOLR(K)=-1 ELSE CALL TBLSER(ISTD,DMS, KOLR(K),ISTAT) IF(ISTAT.NE.0) THEN CARD='ERROR finding column for '//CNAMES(1,K) CALL TERROR(ISTD,180,CARD) END IF END IF IF(KOLR(K).EQ.-1) THEN C look for special cases: IF (INDEX(SYSTEM,'VRI').GT.0) THEN C special for V-I: IF (CNAMES(1,K).EQ.'R-I')THEN CALL TBLSER(ISTD,'V_I', KVI,ISTAT) IF(ISTAT.NE.0)CALL TERROR(ISTD,180, 1 'ERROR finding column V-I') IF(KVI.EQ.-1)THEN C could not find V-I either. CALL TV('Could not find column R-I or V-I') ELSE C found V-I. GO TO 180 END IF END IF ELSE IF (INDEX(SYSTEM,'uvby').GT.0) THEN C special for u-v and v-b: IF (CNAMES(1,K).EQ.'m1')THEN CALL TBLSER(ISTD,'v_b', KVB,ISTAT) IF(ISTAT.NE.0)CALL TERROR(ISTD,180, 1 'ERROR finding column v-b') IF(KVB.EQ.-1)THEN C could not find v-b either. CALL TV('Could not find column m1 or v-b') ELSE C found v-b. GO TO 180 END IF ELSE IF (CNAMES(1,K).EQ.'c1')THEN CALL TBLSER(ISTD,'u_v', KUV,ISTAT) IF(ISTAT.NE.0)CALL TERROR(ISTD,180, 1 'ERROR finding column u-v') IF(KUV.EQ.-1)THEN C could not find u-v either. CALL TV('Could not find column c1 or u-v') ELSE C found u-v. GO TO 180 END IF ELSE IF (CNAMES(1,K).EQ.'V')THEN C special for Vmag: CALL TBLSER(ISTD,'Vmag', KOLR(K),ISTAT) IF(ISTAT.NE.0)CALL TERROR(ISTD,180, 1 'ERROR finding column Vmag') IF(KOLR(K).EQ.-1)THEN C could not find Vmag either. CALL TV('Could not find column V or Vmag') ELSE C found Vmag. CALL TVN(' file has Vmag, not V') GO TO 180 END IF END IF IF(INDEX(SYSTEM,'HB').GT.0)THEN C special for H-beta: IF (CNAMES(1,K).EQ.' ') THEN GO TO 180 END IF END IF ELSE IF(SYSTEM.EQ.'H-BETA')THEN C special for H-beta: IF (CNAMES(1,K).EQ.' ') THEN GO TO 180 END IF END IF IF(LASTD.EQ.0) THEN C we are in standard stars; serious error. CARD='Could not find column for '//CNAMES(1,K) CALL TERROR(IOBS,180,CARD) ELSE C we are in program stars; forget it. END IF END IF 180 CONTINUE C IF (LASTD.GT.0) THEN C Look for ephemeris data: CALL TBLSER(ISTD,'DATE', KDATE,ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,180,'ERROR finding DATE col.') IF(KDATE.EQ.-1) THEN CALL TBLSER(ISTD,'MJD_OBS', KMJD,ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,180, 1 'ERROR finding DATE col.') IF(KMJD.EQ.-1) THEN ELSE CALL TV('MJD_OBS column found; ephemeris file.') MOVING=.TRUE. END IF ELSE WRITE(CARD,*)'DATE found in col.',KDATE CALL TV(CARD) MOVING=.TRUE. END IF ELSE END IF C C READ Standard-star file: C DO 181 NROW=1,NROWS C BACK1=.FALSE. C Here to examine data read from STDFIL. CALL TBERDR (ISTD, NROW, KDEC, DECDEG, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,181,'Could not read DEC col.') C Skip any stars that never rise. IF(ABS(ALDEG-DECDEG).GT.90.)GO TO 181 C OK, add to list. NSTAR=NSTAR+1 IF(NSTAR.GT.MSTARS) THEN CALL EXCEED(NSTAR,'MSTARS',MSTARS) CALL ASK('Do you wish to continue?',A) NSTAR=MSTARS IF(LASTD.EQ.0)LASTD=MSTARS IF(MATCH(A,'Y')) GO TO 190 CALL TERROR(ISTD,184, 'CATALOG OVERLFOW') END IF C Get R.A. CALL TBERDR (ISTD, NROW, KRA, RADEG, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,182,'Could not read RA col.') IF(NULL) BACK1=.TRUE. C note that MIDAS stores it as *degrees*! RAS(NSTAR)=RADEG*DEGRAD DECS(NSTAR)=DECDEG*DEGRAD C C Look for equinox, to precess: IF (KEQUINOX.GT.0) THEN CALL TBERDR (ISTD, NROW, KEQUINOX, EQUINX(NSTAR), NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,183,'Could not read EQUINOX col.') ELSE EQUINX(NSTAR)=0. END IF IF(NULL) BACK1=.TRUE. C C GET STAR NAME. C CALL TBERDC (ISTD, NROW, KOBJ, STARS(NSTAR), NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,184,'Could not read OBJECT col.') IF(NULL) BACK1=.TRUE. C IF(LASTD.EQ.0) THEN C TRANSFER MAG. & COLORS. DO 185 K=1,NBANDS IF(KOLR(K).EQ.-1) THEN C look for special cases: IF (INDEX(SYSTEM,'VRI').GT.0) THEN C special for V-I: IF (CNAMES(1,K).EQ.'R-I' .AND. KVI.GT.0)THEN CALL TBERDR (ISTD, NROW, KVI, 1 COLORS(K,NSTAR), NULL, ISTAT) IF(ISTAT.NE.0)CALL TERROR(ISTD,185, 1 'Could not read column V-I') IF (NULL) COLORS(K,NSTAR)=3.E33 C convert to expected index: C R-I = (V-I) - (V-R) COLORS(K,NSTAR)=COLORS(K,NSTAR)-COLORS(K-1,NSTAR) GO TO 185 END IF ELSE IF (INDEX(SYSTEM,'uvby').GT.0) THEN C special for u-v and v-b: IF (CNAMES(1,K).EQ.'m1' .AND. KVB.GT.0)THEN CALL TBERDR (ISTD, NROW, KVB, 1 COLORS(K,NSTAR), NULL, ISTAT) IF(ISTAT.NE.0)CALL TERROR(ISTD,185, 1 'Could not read column v-b') IF (NULL) COLORS(K,NSTAR)=3.E33 GO TO 185 C postpone action until u-v is read: ELSE IF (CNAMES(1,K).EQ.'c1' .AND. KUV.GT.0)THEN CALL TBERDR (ISTD, NROW, KUV, 1 COLORS(K,NSTAR), NULL, ISTAT) IF(ISTAT.NE.0)CALL TERROR(ISTD,185, 1 'Could not read column u-v') IF (NULL) COLORS(K,NSTAR)=3.E33 C now convert to expected indices: C c1 = (u-v) - (v-b) COLORS(4,NSTAR)=COLORS(4,NSTAR) - COLORS(3,NSTAR) C m1 = (v-b) - (b-y) COLORS(3,NSTAR)=COLORS(3,NSTAR) - COLORS(2,NSTAR) GO TO 185 END IF IF(INDEX(SYSTEM,'HB').GT.0)THEN C special for H-beta: IF (CNAMES(1,K).EQ.' ') THEN GO TO 185 END IF END IF ELSE IF(SYSTEM.EQ.'H-BETA')THEN C special for H-beta: IF (CNAMES(1,K).EQ.' ') THEN GO TO 185 END IF END IF CARD='Missing column: '//CNAMES(1,K) CALL TV(CARD) ELSE C normal case: CALL TBERDR (ISTD, NROW, KOLR(K), 1 COLORS(K,NSTAR), NULL, ISTAT) IF(ISTAT.NE.0) THEN CARD='Could not read '//CNAMES(1,K)//' column' CALL TERROR(IOBS,185,CARD) END IF IF (NULL) COLORS(K,NSTAR)=3.E33 END IF 185 CONTINUE ELSE C fill in dummy values for pgm.objects. COLORS(1,NSTAR)=3.E33 COLORS(2,NSTAR)=3.E33 COLORS(3,NSTAR)=3.E33 COLORS(4,NSTAR)=3.E33 END IF C C DO EPHEMERIS FILES. C IF(KDATE.GT.0 .OR. KMJD.GT.0)THEN C This is an ephemeris file. C IF (KDATE.GT.0) THEN CALL TBERDC (ISTD, NROW, KDATE, DATSTR, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,185,'Could not read DATE col.') C DATE exists. Get it. IF(DATSTR.NE.' ') CALL GETJD(DJD) DJD=DJD-2400000.D0 ELSE IF (KMJD.GT.0) THEN C MJD exists. Get it. CALL TBERDD (ISTD, NROW, KMJD, DJD, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,185,'Could not read MJD col.') DJD=DJD+0.5D0 END IF C C PUT MJD IN COLORS(MBANDS). COLORS(MBANDS,NSTAR)=DJD C PUT X,Y,Z IN COLORS(MBM1,MBM2,MBM3)... COLORS(MBM1,NSTAR)=COS(RAS(NSTAR))*COS(DECS(NSTAR)) COLORS(MBM2,NSTAR)=SIN(RAS(NSTAR))*COS(DECS(NSTAR)) COLORS(MBM3,NSTAR)=SIN(DECS(NSTAR)) C POINT TO END OF TABLE. DO 186 I=NSTAR-1,1,-1 IF(STARS(I).NE.STARS(NSTAR)) GO TO 187 186 CONTINUE I=0 187 COLORS(MBM4,I+1)=NSTAR C END IF C C END EPHEMERIS FILE. C C Now get COMMENTS, etc. C IF (KCOMMENT.NE.-1) THEN CALL TBERDC(ISTD, NROW, KCOMMENT, COMENT(NSTAR), NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IOBS,181,'Could not read COMMENT col.') ELSE COMENT(NSTAR)=' ' END IF C LEN=LWORD(COMENT(NSTAR)) IF (LASTD.EQ.0)THEN C std.star IF (LEN.EQ.0) THEN COMENT(NSTAR)='Standard star ******************' ELSE COMENT(NSTAR)(LEN:)=' STD.* ************' END IF ELSE C pgm.star IF (LEN.EQ.0) THEN COMENT(NSTAR)='Program star ...................' ELSE COMENT(NSTAR)(LEN:)=' Pgm.* ............' END IF END IF C IF (KSPTYPE.NE.-1) THEN CALL TBERDC (ISTD, NROW, KSPTYPE, SPTYPE(NSTAR), NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IOBS,181,'Could not read SPTYPE col.') ELSE SPTYPE(NSTAR)=' ' END IF C IF (KMAG.NE.-1) THEN CALL TBERDC (ISTD, NROW, KMAG, EMAG(NSTAR), NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,181,'Could not read MAG col.') ELSE EMAG(NSTAR)=' ' END IF C IF(BACK1) NSTAR=NSTAR-1 181 CONTINUE C CALL TBTCLO(ISTD, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IOBS,188,'Could not close star file.') CARD='Closing star file '//STDFIL CALL TV(CARD) C C END CATALOG. C 188 WRITE(PAGE,'(/I8,'' TOTAL STARS''/I8,'' SLOTS FREE'')')NSTAR, 1MSTARS-NSTAR CALL TV(PAGE(2)) CALL TVN(PAGE(3)) C IS CAT.FULL? IF(NSTAR.EQ.MSTARS)GO TO 190 C--- IF(LASTD.EQ.0)THEN C IF(JSYS.NE.0)THEN IF(NEEDH.GT.3)CALL TV(' Additional Standards:') CALL ASKFIL('Any other STANDARD-star files?',CATFIL) ELSE CALL ASKFIL('Any more EXTINCTION-star files?',CATFIL) END IF C C Y: goes to end of outer IF-block. IF(MATCH(CATFIL,'NO').OR.MATCH(CATFIL,'no'))THEN C transition to pgm.stars. LASTD=NSTAR MOVING=.FALSE. IF(NEEDH.GT.1)CALL TV(' Program Stars:') CALL ASKFIL('Any PROGRAM-star files?',CATFIL) IF(MATCH(CATFIL,'NO').OR.MATCH(CATFIL,'no'))GO TO 190 C EXPAND GROUPS TO INCLUDE EPHEMERIS VARIABLES. NAM2(1)=MN NAM2(2)=MN+13 END IF C ELSE C CALL ASKFIL('More PROGRAM-star files?',CATFIL) IF(MATCH(CATFIL,'NO').OR.MATCH(CATFIL,'no'))GO TO 190 C END IF C--- IF(MATCH(CATFIL,'YES').OR.MATCH(CATFIL,'yes')) 1 CALL ASKFIL('Name of supplemental star file?',CATFIL) C C Enter "keyboard" or "keys" to read from keyboard: IF(MATCH(CATFIL,'KEY').OR.MATCH(CATFIL,'key'))THEN C MANUAL ENTRY. NSTAR=NSTAR+1 CALL ASKFIL('Enter Star name:',STARS(NSTAR)) CALL ADDSTR(EQUINX(NSTAR),RAS(NSTAR),DECS(NSTAR)) C flag missing Equinox. IF(EQUINX(NSTAR).EQ.0.) EQUINX(NSTAR)=3.E33 DO 189 I=1,NBANDS C $$$ NEEDS TO READ COLOR DATA. 189 COLORS(I,NSTAR)=3.E33 GO TO 188 END IF C C SET UP NEXT CATALOG FILE. IF(HELP(CATFIL))THEN CALL TV('If you made a mistake, you can re-start catalogs.') CALL ASK('Do you want to re-do the star catalogs?',A) IF (A.EQ.'Y') THEN CALL TV('Re-enter catalog data.') STDFIL=SAVFIL GO TO 170 ELSE IF (A.EQ.'N') THEN C go on. ELSE CALL TV(' ... ambiguous reply ...') GOTO 188 END IF END IF STDFIL=CATFIL GO TO 175 C 190 NSTARS=NSTAR C C CHECK INTERPOLATION TABLES: IF(MOVING)THEN EPHEM1=0. EPHEM2=3.E33 I1=1 191 DO 192 I=I1,NSTARS IF(EQUINX(I).NE.3.E33 .AND. EQUINX(I).GT.3.E3) GO TO 193 192 CONTINUE GO TO 200 C HERE FOR MOVER. 193 STAR=STARS(I) I1=I I2=COLORS(MBM4,I) C FIND LATEST START, FIRST END. EPHEM1=MAX(EPHEM1,EQUINX(I1)) EPHEM2=MIN(EPHEM2,EQUINX(I2)) IF(I2.LT.I1+4) GO TO 199 CALL TV('Please check plots for jumps due to bad data.') C PLOT RA(TIME). J=0 DO 194 I=I1,I2 J=J+1 XS(J)=EQUINX(I)-EQUINX(I1) 194 YS(J)=RAS(I)-RAS(I1) CARD=' R.A. of '//STAR CALL TV(CARD) CALL JD2DAT(EQUINX(I1)+2400000.,DAT) WRITE(CARD,'(8X,''days from '',A30)')DAT DO 196 K=1,2 CALL PLOT(J,XS,YS,'*') CALL RTNCON(CARD,40) C DEC(TIME). J=0 DO 195 I=I1,I2 J=J+1 195 YS(J)=DECS(I)-DECS(I1) 196 CARD=' Dec.of '//STAR CALL TV(CARD) C PLOT ON SKY. CALL PLOT(0,1.,0.,'I') DO 197 J=1,40 DUM=EQUINX(I1)+J*(EQUINX(I2)-EQUINX(I1))/40. CALL EPHEM(I1,DUM,COLORS,XS(J),YS(J)) IF(XS(J).LT.0.) XS(J)=XS(J)+TWOPI XS(J)=XS(J)-RAS(I1) 197 YS(J)=YS(J)-DECS(I1) CALL PLOT(40,XS,YS,'*') J=INDEX(STAR//' ',' ') WRITE(CARD,'(5X,''PATH OF '',A,''ON SKY'')') STAR(:J) CALL RTNCON(CARD,40) C RESTORE NORMAL X-AXIS. CALL PLOT(0,0.,0.,'I') 199 I1=I2+1 GO TO 191 END IF C C MEASUREMENT TECHNIQUE. C 200 CONTINUE PC=.FALSE. DC=.FALSE. CI=.FALSE. CALL TV(' ') CALL ASKFIL('What MIDAS table file describes the instrument?', 1 STDFIL) IF (MATCH(STDFIL,'none') .OR. MATCH(STDFIL,'NONE')) GO TO 201 IF(INDEX(STDFIL,'.tbl').EQ.0) THEN I=LWORD(STDFIL) STDFIL(I+1:)='.tbl' END IF C Open instrument file: INQUIRE (FILE=STDFIL,EXIST=FEXIST) IF (FEXIST) THEN C OK. ELSE CARD='The requested instrument table file '//STDFIL CALL TV(CARD) CALL TVN('is not available. Please make sure all required') CALL TVN('files are available in your current directory.') CARD='Is '//STDFIL(:LWORD(STDFIL))//' the correct file name?' CALL ASK(CARD,STDFIL) IF (MATCH(STDFIL,'YES'))THEN CALL STETER(200,'Missing instrument file') ELSE GO TO 200 END IF END IF CALL TBTOPN(STDFIL,1, INST,ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,200, 1 'Could not open instrument-description file.') CALL TBIGET (INST, NCOLS, NROWS, NSORTC, NWPRAL, NROWSAL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST, 200, 1 'Could not get basic table data.') CALL STDRDC (INST, 'INSTNAM', 1, 1, 72, 1 NVALS, INSTNAM, IUNIT, NULLS, ISTAT) IF(ISTAT.NE.0)THEN CALL TV('Could not find INSTNAM descriptor.') CALL TERROR(INST,200,'Please fix instrument table file.') END IF CALL TV('Instrument identification:') CALL TV(INSTNAM) CALL TVN(' ') CALL STDRDC (INST, 'FILTSTAT', 1, 1, 9, 1 NVALS, FILTSTAT, IUNIT, NULLS, ISTAT) IF(ISTAT.NE.0)THEN CALL TV('Could not find FILTSTAT descriptor.') CALL TERROR(INST,200,'Please fix instrument table file.') END IF C C Get required-column pointers: C CALL TBLSER (INST, 'DET', KDET, ISTAT) IF (ISTAT.NE.0 .OR. KDET.EQ.-1) 1 CALL TERROR(INST,200,'Could not find column DET') CALL TBLSER (INST, 'BAND', KBAND, ISTAT) IF (ISTAT.NE.0) CALL TERROR(INST,200,'Could not find column BAND') CALL TBLSER (INST, 'DETNAME', KDETNM, ISTAT) IF(ISTAT.NE.0)CALLTERROR(INST,200,'Could not find column DETNAME') CALL TBLSER (INST, 'NDET', KNDET, ISTAT) IF (ISTAT.NE.0) CALL TERROR(INST,200,'Could not find column NDET') CALL TBLSER (INST, 'COOLING', KCOOL, ISTAT) IF(ISTAT.NE.0)CALLTERROR(INST,200,'Could not find column COOLING') C C see if we need to check DARK: CALL TBESRC (INST, KCOOL, 'REGULATED', 1, 12, 1, NROW, ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,200, 1 'Could not search COOLING column for "REGULATED"') IF (NROW.GT.0) THEN DARK=.FALSE. ELSE DARK=.TRUE. END IF C C see if we need to remind user about cooling: CALL TBESRC (INST, KCOOL, 'NONE', 1, 12, 1, NROW, ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,200, 1 'Could not search COOLING column for "NONE"') IF (NROW.GT.0) THEN COOLED=.FALSE. ELSE COOLED=.TRUE. END IF C FUNK=.FALSE. FCORN=.FALSE. C see if we measure redleaks: CALL TBLSER (INST, 'REDLEAK', KRL, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(INST,200,'Could not find column REDLEAK') CALL TBESRC (INST, KRL, 'MEASURED', 1, 3, 1, NROW, ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,200, 1 'Could not search REDLEAK column for "MEASURED"') IF (NROW.GT.0) THEN C see if we know RLTYPE: CALL TBLSER (INST, 'RLTYPE', KRLTYP, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(INST,200,'Could not find column RLTYPE') CALL TBESRC (INST, KRLTYP, 'UNKNOWN', 1, 3, 1, NROW, ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,200, 1 'Could not search RLTYPE column for "UNKNOWN"') IF (NROW.GT.0) THEN FUNK=.TRUE. END IF C see if we know MAKER: CALL TBLSER (INST, 'MAKER', KRLTYP, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(INST,200,'Could not find column MAKER') CALL TBESRC (INST, KRLTYP, 'UNKNOWN', 1, 3, 1, NROW, ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,200, 1 'Could not search MAKER column for "UNKNOWN"') IF (NROW.GT.0) THEN FCORN=.TRUE. END IF END IF C C C Look at detectors: C C see if PMT is used: CALL TBESRC (INST, KDET, 'PMT', 1, 3, 1, NROW, ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,200, 1 'Could not search DET column for "PMT"') IF(NROW.GT.0) THEN C get mode: CALL TBLSER (INST, 'MODE', KMODE, ISTAT) IF(ISTAT.NE.0 .OR. KMODE.EQ.-1)THEN CALL TV('Could not find MODE column.') CALL TERROR(INST,200,'Please fix instrument table file.') END IF CALL TBERDC (INST, NROW, KMODE, DMS, NULL, ISTAT) IF(ISTAT.NE.0 .OR. NULL) 1 CALL TERROR(INST,200,'Could not read MODE column.') C DMS now holds mode. IF (DMS(:2).EQ.'PC') THEN C Pulse-counting. Get dead-time: CALL TBLSER (INST, 'DEADTIME', KDEDT, ISTAT) IF(ISTAT.NE.0 .OR. KDEDT.EQ.-1)THEN CALL TV('Could not find DEADTIME column.') CALL TERROR(INST,200, 1 'Please fix instrument table file.') END IF CALL TBERDR (INST, NROW, KDEDT, DEADT, NULL, ISTAT) IF(ISTAT.NE.0 .OR. NULL) 1 CALLTERROR(INST,200,'Could not read DEADTIME column.') C nd deadtime error: CALL TBLSER (INST, 'DEADTIMEERROR', KDEDER, ISTAT) IF(ISTAT.NE.0 .OR. KDEDER.EQ.-1)THEN CALL TV('Could not find DEADTIMEERROR column.') CALL TERROR(INST,200, 1 'Please fix instrument table file.') END IF CALL TBERDR (INST, NROW, KDEDER, SDEDT, NULL, ISTAT) IF(ISTAT.NE.0 .OR. NULL) 1 CALL TERROR(INST,200, 2 'Could not read DEADTIMEERROR column.') PC=.TRUE. MTYPE=1 GOTO 212 ELSE IF (DMS(:2).EQ.'DC') THEN C PMT, DC. CALL TBTCLO(INST, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,201,'Could not close inst. file.') GO TO 220 ELSE IF (DMS(:2).EQ.'CI') THEN C PMT, CI. CALL TBTCLO(INST, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,201,'Could not close inst. file.') GO TO 222 ELSE MTYPE=0 CALL TV('Mode of operation not given in table file.') END IF C END IF CALL TBTCLO(INST, ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,201,'Could not close inst. file.') 201 IF(MTYPE.NE.0) GOTO 265 CALL TV(' ') CALLASK('Are data Pulse Counts, DC, Charge Integration, or mixed?' 1,A) IF(MATCH(A,'P')) GO TO 204 IF(MATCH(A,'D')) GO TO 220 IF(MATCH(A,'C')) GO TO 222 IF(MATCH(A,'M')) GO TO 240 GO TO 201 C C PULSE COUNTS. C 204 MTYPE=1 IF(DEDSET)GO TO 213 205 CALL ASK('Do you know the Dead Time (ns)?',DMS) PC=.TRUE. IF(MATCH(DMS,'NO'))THEN CALL TV(ASSUME(2)) NASSMP=NASSMP+1 ASSMPS(NASSMP)=ASSUME(2) WRITE(PAGE, 1'(/'' Keep rate below'',F3.0,''MHz to avoid gain shift.'')') 2 SIGTOT/.0016 CALL TV(PAGE(2)) DEADT=16. SDEDT=DEADT GO TO 211 END IF IF(MATCH(DMS,'YES')) CALL ASK('Dead time (nanoseconds) =',DMS) 210 CALL FINDPM(DMS,DEADT,SDEDT) WRITE(PAGE,'(/'' Dead time ='',F6.1,'' +/-'',F6.1,'' ns'')')DEADT, 1SDEDT CALL TV(PAGE(2)) CALL ASK('OK?',A) IF(MATCH(A,'N'))GOTO 205 211 SDEDT=SDEDT*1.E-9 DEADT=DEADT*1.E-9 212 DEDSET=.TRUE. IF(DEADT.EQ.0. .OR. SDEDT.EQ.0.)GOTO 210 C IF(SDEDT/DEADT.GT.0.1)THEN C allow D.T.corrections to be 10 x precision. NASSMP=NASSMP+1 ASSMPS(NASSMP)=ASSUME(3) CALL TV(ASSUME(3)) SDEDT=0.1*DEADT NEEDED=.TRUE. CALL TV(' EXTRA STARS will be added to allow improvement.') END IF C 213 CALL TV( 1 'Uncertainty of dead-time correction = half of total error at:') NEEDIM=.FALSE. RATE=1./(SIGSQ*TINT1) DO 215 NB=1,NBANDS BRITES(NB)=PHOMAG(NB)-2.5*LOG10(SIGTOT/(2.*SDEDT*RATE)) C count rate at phomag is 'RATE'. WRITE(PAGE,214)BRITES(NB),BANDS(NB) 214 FORMAT(/3X,F5.1,' IN ',A6) CALL TV(PAGE(2)) IF(BRITES(NB).GT.FAINTS(NB) .AND. .NOT.DC)THEN CALL TV('TOO MANY PHOTONS -- You need an optical attenuator.') NEEDIM=.TRUE. END IF 215 CONTINUE IF(DC) GO TO 265 IF(NEEDIM)GO TO 217 216 CALL ASK('No BRIGHTER stars will be used. OK?',A) IF(MATCH(A,'Y') .OR. MATCH(A,'O')) GO TO 265 C C Ask for dimmer & return to 216 after revising BRITES. 217 CALL BRITEN(BANDS,DIMMED) C here if revision failed, or not needed. IF(DIMMED .OR. .NOT.NEEDIM)GO TO 216 C WRITE(ASSMPS(8),'(''Requested precision is'',F6.3,'' mag.'')') 1 SIGTOT CALL TV(ASSMPS(8)) CALL ASK('Will you accept larger errors?',A) MTYPE=0 NEEDH=NEEDH-1 IF(MATCH(A,'Y') .OR. MATCH(A,'O'))GO TO 128 CALL TV('You require a SMALLER TELESCOPE, or a DC photometer.') NASSMP=0 CALL TVN(' ') CALL TV('Starting over...') GO TO 51 C C DC. 220 MTYPE=2 DC=.TRUE. CALL TV( 1' Use double integrations to allow for chart-reading error.') GO TO 265 C C CHARGE INTEGRATION. 222 MTYPE=3 CI=.TRUE. C READ GAINS. GO TO 265 C C MIXED. 240 MTYPE=4 DC=.TRUE. CALL ASK('Any Pulse-Counting?',A) IF(MATCH(A,'Y'))GO TO 205 C MTYPE=5 IF NO PC. MTYPE=5 CI=.TRUE. C C Time scale? C 265 CALL ASK('Do you want UT, Zone Time, or Local Sidereal Time?',A) C ITIME = 1 2 3 ITIME=0 ZONE=0. C IF(MATCH(A,'U')) THEN ITIME=1 TL='U.T.' ELSE IF(MATCH(A,'Z')) THEN C ZONE TIME. ITIME=2 CALL ASK('Name of Time Zone? (MST, PDT,...-- 4 letters max.)',TL) CALL QF('What U.T. is Zero hours Zone Time?',ZONE) C UT = STD.time + Zone; convert to rotations. ZONE=ZONE/24. ELSE IF(MATCH(A,'L') .OR. MATCH(A,'S')) THEN C LST. ITIME=3 TL='LST' ELSE GO TO 265 END IF C TEMPRH(29:32)=TL C C Names or codes? C 270 CALL TV('Will your data files identify stars by') CALL ASKN('Full Names, or Codes?',A) CODEDS=.FALSE. C IF(MATCH(A,'C')) THEN CODEDS=.TRUE. 275 CALL QF('How many digits in your star code?',DUM) NDIG=DUM IF(NDIG.LT.1 .OR. NDIG.GT.6)THEN CALL TV('Sorry, PEPSYS uses only 1 to 6.') GO TO 275 END IF WRITE(F361(5:5),'(I1)')NDIG ELSE IF(A.EQ.'F' .OR. A.EQ.'N')THEN C no action needed. ELSE CALL TV( 1 'If your data system uses numerical labels, say "Codes".') GO TO 270 END IF C C DATE: C IF(MOVING)THEN CALL JD2DAT(2400000.+EPHEM1,DATSTR) CALL JD2DAT(2400000.+EPHEM2,MONTH) WRITE(PAGE,'(/4X,''Ephemeris data span only '',A11,'' to '',A11)') 1 DATSTR,MONTH CALL TV(PAGE(2)) END IF C CALL TVN(' ') CALL TV('Enter dates (please spell month name):') IF(NEEDH.GT.2)CALL TV(' Use double date - e.g., May 8/9, 1986') C 305 DO 320 N=1,2 311 PAGE(1)='Enter '//FL(N)//' date of run:' CALL ASK(PAGE(1),CARD) IF(N.EQ.2 .AND. CARD.EQ.'SAME') GO TO 315 CALL MDY(CARD,MON,DDAY,YR) IF(YR.EQ.0.)THEN IF(N.EQ.2)THEN C user forgot year on 2nd date: YR=OLDYR ELSE CALL QF('Year?',YR) END IF END IF IF(YR.LT.100.)YR=YR+1900. OLDYR=YR CALL TV(' Night begins on') WRITE(PAGE,'(4X,A3,I3,'','',I5)')MON,INT(DDAY),INT(YR) CALL TVN(PAGE(1)) IF(DDAY.GT.33.)GOTO 313 DDAY=DDAY+1. C NEAREST UT DATE TO LOCAL MIDNIGHT. M=MON2M(MON) IF(M.GT.0)GO TO 315 WRITE(PAGE,*)MON,' is not the name of a month.' CALL TVN(PAGE(1)) 313 CALL TV(' Please correct DATE:') GO TO 311 C J.D.: SEE SKY & TEL.61,312 (1981). 315 Y=YR IF(M.GT.2)GO TO 316 M=M+12 Y=Y-1 316 DJ=AINT(365.25*Y) + AINT(30.6001*(M+1)) + DDAY + 1720981.5D0 320 DJS(N)=DJ C IF(DJS(2).LT.DJS(1))THEN CALL TV('Days are in wrong order.') GO TO 305 ELSE IF(DJS(2)-DJS(1).GT.10.)THEN WRITE(PAGE,'(/F8.0,'' day interval'')')DJS(2)-DJS(1) CALL TV(PAGE(2)) CALL TV('Please keep interval less than 1 week.') GO TO 305 END IF C CALL PLANBOT(DJS,LASTD,NSTARS,NEEDST,JSYS,DRAT,BANDS,SALTS, 1 PLACE(:20),TELCM,TL,ITIME,ZONE) C END