C @(#)reduce.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 REDUCE C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.COPYRIGHT (c) Andrew T. Young, 1990 C.COPYRIGHT (c) European Southern Observatory, 1992, 1993 C.IDENT program reduce C.MODULE reduce.for C.AUTHOR Andrew T. Young C.KEYWORD C.LANGUAGE FORTRAN 77 C.PURPOSE Does photometric reductions interactively C.COMMENTS C.VERSION 5.9 C.RETURNS error numbers correspond to nearby statement numbers C.ENVIRONMENT MIDAS C----------------------------------------------------------------------------- C C Note: the first part of this program is cannibalized from the PLAN C program (see "plantop.for"). Hence there may be some C useless variables and COMMON blocks that are kept for C compatibility with the common subroutines. Most of the C same files are read to start up both programs, so they C are rather similar up to about statement 300 or so. C C As this is a big program, here is a general guide as to what is C happening where (by statement numbers): C C 50 - 128 read observatory data C 130 - 154 get photometric system set up C 156 - 200 read star catalogs C 200 - 240 read instrument file C 300 - 395 read data files C 400 - 480 start reductions: subtract dark & sky C 501 - 590 estimate starting values for solution C 600 - 670 set up for DLSQ C 675 - 800 assess solution C 800 - 850 plot residuals C 900 -1000 report parameters solved for C 1000 -1100 report individual results C C C Storage maps: C C 225 ND filter names & values C 240 Instrument parameters C 328 Star names C 355 Timing C 390 Input data C 400 ND cross-indexing C 600 Data + Parameters for DLSQ C 610 Star cross-indexing C C C To add new features: (1) allocate space in the P's; C (2) add the required partial derivatives to YPSTD; C (3) add o/p stuff to REPORT; C (4) include in individual reductions at end. C C C BEGIN Declarations: C C IMPLICIT NONE C C Set up MIDAS declarations: C INTEGER MADRID(1) C INCLUDE 'MID_INCLUDE:ST_DEF.INC' C COMMON /VMR/ MADRID C C INCLUDE 'MID_REL_INCL:obs.inc' C C *** SYSTEM-DEPENDENT FEATURES ARE FLAGGED BY *** COMMENTS LIKE THIS. C C C F I L E S : C ----------- C CHARACTER*80 STDFIL, CATFIL, DATFIL, DATFILS(MXNITE), OBSFIL CHARACTER*80 SAVFIL, STDFILS(20) C *** LENGTH OF FILE NAMES MAY BE SYSTEM-DEPENDENT. C FULL SET FOR SUBROUTINE COMPATIBILITY. C 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*8 C STAR NAME STAR CH*32 STAR HR 8832 C INDICES CNAMES(1,NB) CH*8 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 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(MOBS),ALDEGS(MOBS),HIGHS(MOBS) C INCLUDE 'MID_REL_INCL:mstars.inc' C PARAMETER (MSTARS=1650) C MSTARS is max.number of star-catalog entries. C CAUTION: modify Subroutine NBIN if this exceeds 2048! C SCAT* commons for Star CATalog: CHARACTER *32 STARS COMMON /SCATA/ STARS(MSTARS) C C CAUTION -- MBANDS IS IN SUBROUTINES RDLIST, DECOLR, & EPHEM. INCLUDE 'MID_REL_INCL:mbands.inc' C PARAMETER (MBANDS=9) REAL RAS, DECS, EQUINX, COLORS(MBANDS,MSTARS) COMMON /SCAT/ RAS(MSTARS), DECS(MSTARS), EQUINX(MSTARS), COLORS INTEGER ISTAR, JSTAR COMMON /SCATI/ ISTAR(MSTARS), JSTAR(MSTARS) C C Proper-motion info: REAL ALPMUS(MSTARS),DELTMUS(MSTARS),EPOCHS(MSTARS) C INTEGER L2N(MSTARS), N2L(MSTARS) C C Common block /CMAGS1/ is used in DECOLR; used by PLAN also. C REAL COLORM, COLRIN, XINV,YINV INTEGER NBANDS,LENB,LENC,KX1,KY1 COMMON /CMAGS1/ COLORM(MBANDS,MBANDS),COLRIN(MBANDS,MBANDS), 1 XINV,YINV,NBANDS,LENB,LENC,KX1,KY1 SAVE /CMAGS1/ REAL PHOMAG(MBANDS),EXTIN(MBANDS) C INTEGER MXCOLR PARAMETER (MXCOLR=3*MBANDS) CHARACTER *8 BAND, BANDS(MXCOLR), CNAMES(2,MBANDS) REAL TRANS(MBANDS),WLS(MBANDS),WIDTHS(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(MSYS),LENBS(MSYS),LENCS(MSYS), KXS(MSYS),KYS(MSYS) REAL XINVS(MSYS),YINVS(MSYS) REAL STDWLS(MBANDS,MSYS),FWHMS(MBANDS,MSYS), TRANSS(MBANDS,MSYS) C C C Common for red leaks: C COMMON /REDLK/ NBRL(MXCOLR), RLFACT(MXCOLR) C C C PARAMETERS FOR RDLIST/RDBLOK. C INTEGER MGAINS,MG2 PARAMETER (MGAINS=4, MG2=2*MGAINS) INTEGER MA,MCAT,MN,MV,MGRPS,MAREST,MNREST 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 block /NAMES/ is used in GETJD; used by PLAN also. 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 C COMMONS FOR SPHERICAL TRIG.: C REAL SINPHI, COSPHI, ELONG, ELROT, UTROT, STUTZ, 1 TWOPI, ST2UT, 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 Star-Catalog ANNOTATIONS: CHARACTER COMENT(MSTARS)*32,SPTYPE(MSTARS)*12,EMAG(MSTARS)*16 COMMON /NOTES/COMENT,SPTYPE,EMAG C C Common for name matching: INTEGER MSTARK PARAMETER (MSTARK=2*MSTARS) CHARACTER*20 STDNAMES(MSTARK), STAR5(5) COMMON /STDNAM/ STDNAMES,STAR5 INTEGER KSTARS,NSTDNM, NUMBER COMMON /KSTDNM/ KSTARS(MSTARK),NSTDNM, NUMBER C C COMMON for HELP count: COMMON /HELPS/ NEEDH,NASSMP CHARACTER ASSMPS(8)*40,ASSUME(8)*40 COMMON /ASSUME/ ASSMPS,ASSUME C C Common for long comments: C CHARACTER*79 PAGE(21) COMMON /SCREEN/PAGE C COMMON /FLAGS/JCONT,JLOG,JDISP C C C plotting symbols: CHARACTER*75 PLTSYM INTEGER MCODES PARAMETER (MCODES=75) C C Scratch arrays for robust estimation: C REAL XDUM,YDUM,ZDUM COMMON /SCRAT/ XDUM(MXOBS), YDUM(MXOBS), ZDUM(MXOBS) C C C stuff for DLSQ: C INCLUDE 'MID_REL_INCL:kingfit.inc' INCLUDE 'MID_REL_INCL:dlsq.inc' C INTEGER KMIN, KMAX, NKS, KMINM1, MPPN, MPPKN, NITEZ, MSYSTZ INTEGER NSYSTP, NDZ, NDEDTZ, NTRANS INTEGER MTRANZ, MTR2Z, MTRZ, MT1Z, MT2Z, MRHZ C C C Caution: KDUM is currently dimensioned 24. C EQUIVALENCE (KMIN,KDUM(1)), (KMAX,KDUM(2)), (NKS,KDUM(3)) EQUIVALENCE (KMINM1,KDUM(4)), (MPPN,KDUM(5)), (MPPKN,KDUM(6)) EQUIVALENCE (NITEZ,KDUM(7)), (MSYSTZ,KDUM(8)), (NSYSTP,KDUM(9)) EQUIVALENCE (NUMNDS,KDUM(10)), (NDZ,KDUM(11)), (NDEDTZ,KDUM(12)) EQUIVALENCE (NTRANS,KDUM(13)) EQUIVALENCE (MTRANZ,KDUM(14)), (MTR2Z,KDUM(15)), (MTRZ,KDUM(16)) EQUIVALENCE (MT1Z,KDUM(17)), (MT2Z,KDUM(18)), (MRHZ,KDUM(19)) C C Base addresses: NITEZ for night parameters C MSYSTZ for system parameters (W's, trans. coeffs., etc.) C MTRANZ for main transformation coeffs. C MTR2Z for 2nd transformation coeffs. C MTRZ for global zero-points C MT1Z for first temp. coeff. C MT2Z for 2nd temp. coeff. C MRHZ for R.H. coeff. C NDZ for ND filter coeff. C C C Common for estimated parameters: C REAL ZPT, AEXT, XMAG, TRCOEF COMMON /PARMS/ ZPT(MBANDS,MXNITE),AEXT(MBANDS,MXNITE), 1 XMAG(MBANDS,MSTARS),TRCOEF(MBANDS) C C Common for solution flags (appears in REDUCE, YPSTD & REPORT): C LOGICAL USE3PT, USES3PTS COMMON /SOLFLG/ USE3PT(MBANDS), USES3PTS C C Common for time dependences: C REAL TIMID(MXNITE) INTEGER NAT(MBANDS,MXNITE),NZT(MBANDS,MXNITE) LOGICAL TIMFLGA, TIMFLGZ COMMON /TIMDEP/ TIMID, NAT,NZT, TIMFLGA,TIMFLGZ C C C Common for plot limits: C REAL XLIM(2), YLIM(2) COMMON /PLTLIM/ XLIM, YLIM C C C Common for color baselines: C INTEGER K1S(MBANDS),K2S(MBANDS) COMMON /K12S/ K1S, K2S C C C Commons for 12 Diaphragms: C INTEGER NP2NDIA(12*MBANDS) INTEGER NDIA2NP(12,MBANDS), NDIAS,NDIA C indices: NDIA,K REAL XNDIA(12,MBANDS) COMMON /DIACOM/XNDIA,NP2NDIA,NDIA2NP,NDIAS,NDIA C CHARACTER DIANAM(12)*4 COMMON /DIACH/DIANAM C C C Commons for ND filters: C INTEGER NUM2ND(MBANDS),NP2ND(MBANDS*MBANDS),NP2K(MBANDS*MBANDS) INTEGER ND2NP(MBANDS,MBANDS), NUMNDS,NDK,NDS C indices: ND,K REAL XND(MBANDS,MBANDS) COMMON /NDJUNK/XND,NUM2ND,NP2ND,NP2K,ND2NP,NDS C CHARACTER NDNAME(MBANDS)*4 COMMON /NDC/NDNAME C C Common for dead-time corrections: C REAL DEDTS(MXCOLR),SDEDTS(MXCOLR) INTEGER NDT2NP(MXCOLR) LOGICAL PC(MXCOLR),DC(MXCOLR),CI(MXCOLR) COMMON /NDTX/NDT2NP,DEDTS,SDEDTS,PC,DC,CI C 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 CHARACTER DETNAME(MXCOLR)*16 COMMON /NDTNAM/ DETNAME C C Common for detector limits (used in REPORT): C INTEGER MINDET,MAXDET COMMON /MDETS/ MINDET,MAXDET C C C Arrays for INSTRUMENT info: C INTEGER NDTUSD(MXCOLR) CHARACTER COOL(MXCOLR)*12, DEDTYP(MXCOLR)*3 C LOGICAL CANNED,NEEDGN,MOVING, 1 DARK,FUNK(MXCOLR),FCORN(MXCOLR),COOLED(MXCOLR), 2 HASDTMP(MXCOLR) C C CANNED IS.TRUE.IF PLACE OR STDFIL IS BUILT-IN. 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 C C DTYPE identifies Data type (Star, skY, or Dark) C C DTYPE = 'S' for Star C DTYPE = 'Y' for skY C DTYPE = 'D' for Dark C CHARACTER DTYPE(MXOBS), STYPE(MSTARS) C C STYPE identifies Star type (Std., eXt., Pgm., or Var.) C C STYPE = 'S' for Std. star (assumed const.) C STYPE = 'X' for eXt. star (assumed const.) C STYPE = 'P' for Pgm. star C STYPE = 'V' for Var. star C C C the dictionary of additional star names and references: INTEGER MDICT PARAMETER (MDICT=64) CHARACTER*32 DICT(MDICT) INTEGER NDICT(MDICT), LTOK(10) CHARACTER TOKEN(10)*20, SNAME1(4)*24, SNAME2(4)*24 C tokens for name analysis. C CHARACTER A1,CARD*80,DMS*32,PNAMES(10)*20,STARSKY*4, 1 OBJNAM*32,GAINTBL*72,INSTNAM*72,DET*8,COOLING*12,C8*8, 2 DAT*30,ASSUM4(2)*40,ASSUM6(2)*40, C1 EQUIVALENCE (ASSUM4,ASSUME(4)),(ASSUM6,ASSUME(6)) CHARACTER FILTSTAT*9, CONDITION*7 C CHARACTER*8 BNDREJ(MBANDS) INTEGER NBREJ C C C INTEGER LOCS(10), LBAND(MBANDS), JPRE(MBANDS), JPOST(MBANDS) REAL SALTS(MSG) C DOUBLE PRECISION DJD, DJZ, HJD, TIMAX, TIMIN, DJZPLT C REAL AIRKN(MBANDS,MXNITE),AIRKNS(MBANDS,MXNITE) REAL AIRKN2(MBANDS,MXNITE) REAL AIRKI(MBANDS,MSTARS),AIRKIS(MBANDS,MSTARS) C REAL VARK(MBANDS) C C C Pointers to OBSERVATORY table-file columns: C INTEGER KTEL,KDIAM,KLON,KLAT,KHI C C C Pointers to STAR-CATALOG columns: C INTEGER KOBJ,KRA,KDEC,KEQUINOX,KMUALPHA,KMUDELTA,KEPOCH, 1 KSPTYPE,KMAG,KCOMMENT,KVI,KVB,KUV,KOLR(MBANDS),KDATE,KMJD C C C Pointers to INSTRUMENT-table columns: C INTEGER KBAND,KNBAND,KRL,KDET,KNDET,KCOOL,KNDVAL,KRLTYP, 1 KMAKER,KDETNM,KSNUMB,KMODE,KDEDTYP,KDEDTIM,KDEDER,KDTEMP, 2 KBLUER,KNDTUSE C C C Pointers to DATA table columns: C INTEGER KOBJECT,KSIGNAL,KRAWMAG,KSTARSKY,KMJDOBS,KEXPTIME, 1 KOFSRA,KOFSDEC,KSKYRA,KSKYDEC,KFILTTEMP,KDETTEMP, 2 KDOMETEMP,KRELHUM,KPRESSURE,KDIAPHRAGM,KPMTVOLTS, 3 KGENEVAQ,KGENEVAR,KGENEVAG,KSEEING,KESTERR C C C Pointers to RESULTS table columns: C INTEGER KHJD C C C C Miscellaneous junk: C INTEGER MAXKS, NBRL, NEEDH, NASSMP, JCONT, LVARS, JLOG, JDISP, 3 MTYPE, I, IOBS, ISTAT, NVALS, K1I, K2I,ISP, 4 IUNIT, L, NCOLS, NROWS, NSORTC, NWPRAL, NROWSAL,NROW, J, 5 JOLD, K, JSYS, NB, NSTAR, LASTD, NSTDFILS,ISTD, 6 NSTARS, I1, I2, INST, NDETS, KOLOR, ND, KOLORS, NDET, NDATFIL, 7 LDICT, NIGHT, LASTK, IDAT, NBIN, LSTAR, NTOKEN, MAXHITS, NBEST, 8 NHITS, KK, NUM, NSTDS, NEXTS, NPGMS, NVARS, NSTDOBS, NBESTI, 9 NBESTS, NCYCLE, NSETOLD,N, NSET, K1, K2, L1, L2, LSTDS, LEXT2S, A LPGM2S, LMAX, NPTS, NONSTD, NPARMS, NIX, NIXOLD, JBGN, JEND, B NP, NREJ1, NREJ2, LOOPMX, LOOP, JJ, KN, NPTOT, KMID, NEXTOBS C REAL RLFACT, TELCM, HIGH, ELDEG, 5 ALDEG, ELHRS, PRAT, DRAT, AREA, ZSCINT, ZSCSQ, DECDEG, 6 RADEG, DETOL, EPHEM1, EPHEM2, OLDEP, OLDEQX, T, EPOCH, RA, DEC, 7 OFSRA, OFSDEC, UTRAD, HA, COSDEL, SINDEL, COSHA, COSZ, XSTAR, 8 YSTAR, ARG, RAWMAG, FILTTEMP, DETTEMP, DOMETEMP, RELHUM, 9 PRESSURE, GENEVAQ, GENEVAR, GENEVAG, ESTERR, SUMBESTI, A SUMBESTS, UNMOD, XMIN, XMAX, YMIN, YMAX, SUMNI, SUMNS, CUTOFF, B XBAR, YBAR, SLOPE, OLDX, AIRMAX, SCINTSQ, AIR, SEPN, REASON, C TERM, USQ, BIWVAR, UNMOD2, REALF, PSEUDOF, FCUT, TIME, HELCOR C DOUBLE PRECISION SUMX, SUMY, SUMXX, SUMXY, SUMYY C REAL BETAZ, COVAR, DJMAX,DJMIN C INTEGER NULLS, NSLOT, NLPP, KTRANS, KOFF C LOGICAL SYSSET,DEDSET,FEXIST,NULL,FLAGGED, STDF C LOGICAL BACK1,FIRST,STABLE,ONEZPT, EXTEND, CUTSET, DONE, OFFER LOGICAL COMPLETE, CONTIG, USES4X, CATALOG C C Flags for interpolation: LOGICAL NEEDFTI, NEDDTI, NEDDMI, NEEDRHI C C Flags for reductions: LOGICAL HASFILTT, HASDOMT, HASRH, HASMAGS C C C REAL FCNS.: C ---------------- REAL DEG10 EXTERNAL DEG10 C C C INTEGER FCNS.: C ---------------- INTEGER LWORD EXTERNAL LWORD C C C CHARACTER FCNS.: C ---------------- CHARACTER DEG2MS*13 EXTERNAL DEG2MS C C LOGICAL FCNS.: C ------------- LOGICAL HELP,MATCH C C EXTERNAL YPSTD C C C C ***** END Declarations. C 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 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 C Data for plotting symbols: DATA PLTSYM/ 1'123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+=*/ 2$#@%&I:?<>()'/ C C C END DATA statements. C C C ******************** PROLOGUE ******************** C CALL STSPRO ('REDUCE') C C Real program begins here: C C PROLOGUE: C C *** force std.out. CALL PLOT(0,6.,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. C C Reset error flags: C CALL STECNT('GET',JCONT,JLOG,JDISP) CALL STECNT('PUT',1,2,2) C C C BEGIN DIALOG. C CALL SPACE2 CALL CENTER('Welcome to PEPSYS3''s REDUCTIONS.') CALL SPACE2 C CALL ASK('Do you want Instructions?',A1) C IF(MATCH(A1,'N')) GO TO 50 C 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,9 13 CALL TVN(PAGE(I)) 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.45)THEN CALL SPACE CALL TV('Were the observations made at ') TITLE=PLACE(:L)//'?' ELSE TITLE='Were the observations 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 SPACE2 55 CALL TV('Do you have a table file for the OBSERVATORY') CALL ASKFIL(' where the observations were 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 ELSE IF (MATCH(CARD,'YES')) THEN C OK. ELSE IF (LWORD(CARD).GT.5) THEN C Assume a place name. GO TO 104 ELSE CALL TV('Please reply YES or NO.') CALL TBTCLO(IOBS, ISTAT) GO TO 50 END IF IF(PLACE(:6).EQ.'MOUNT ' .OR. PLACE(:6).EQ.'Mount')THEN CARD='Mt.'//PLACE(7:) PLACE=CARD(:64) 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 SPACE2 CALL TV('Please indicate which telescope was 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. .OR. 1 NROW.GT.NROWS+1) GO TO 61 IF (NROW.EQ.NROWS+1) 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(:64) 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 NOT IN LIST, SO ASK FOR COORDS. 110 CALL TV('Enter (East) LONGITUDE in time or degrees:') CALL TV(' h m s o '' "') CALL ASKN(' ',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 ASKN(' ',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. 119 FORMAT(A,F9.5,' deg. =',F9.5,' radians') 120 ELHRS=ELDEG/15. ELROT=ELHRS/24. ELONG=ELDEG*DEGRAD WRITE(CARD,119) 'Longitude = ',ELDEG,ELONG CALL TV(CARD) TNOON1=-ELROT-.5 TNOON2=-ELROT+.5 ALAT=ALDEG*DEGRAD WRITE(CARD,119) 'Latitude = ',ALDEG, ALAT 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?',A1) IF(MATCH(A1,'N')) GOTO 104 C C TELESCOPE. C 125 CONTINUE SYSSET=.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 Zenith scintillation amplitude for 1-sec. integration: C C 0.707 is sqrt(1/2), as in (1/2*tau). ZSCINT=(0.09/0.707)*PRAT/(TELCM**(2./3.)) ZSCSQ=ZSCINT*ZSCINT WRITE(CARD,'(''Zenith scint. is about'',F6.3,'' for 1 sec. int.'') 1') ZSCINT CALL TV(CARD) C C SYSTEM. C 130 IF(SYSSET)GOTO 152 CALL SPACE2 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 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 C C SET 2-COLOR DIAGRAM. KX1=KXS(JSYS) KY1=KYS(JSYS) XINV=XINVS(JSYS) YINV=YINVS(JSYS) C LENB=LENBS(JSYS) LENC=LENCS(JSYS) C DO 133 NB=1,NBANDS WLS(NB)=STDWLS(NB,JSYS) WIDTHS(NB)=FWHMS(NB,JSYS) TRANS(NB)=TRANSS(NB,JSYS) CNAMES(1,NB)=BNDVAR(NB,JSYS) CNAMES(2,NB)='S'//BNDVAR(NB,JSYS) BANDS(NB)=BNDS(NB,JSYS) LBAND(NB)=LWORD(BANDS(NB)) 133 CONTINUE C 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 CALL QF('Number of bands =',ARG) NBANDS=ARG 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)) LBAND(K)=LWORD(BANDS(K)) LENB=MAX(LENB,LBAND(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)(:7) 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)KX1=K IF(CNAMES(1,K).EQ.UTSTR)KY1=K 149 CONTINUE XINV=0. YINV=0. PAGE(1)='Does '//CNAMES(1,KX1)(:LENC)//' increase to right?' CALL ASK(PAGE(1),A1) IF(MATCH(A1,'N'))XINV=1. PAGE(1)='Does '//CNAMES(1,KY1)(:LENC)//' increase upward?' CALL ASK(PAGE(1),A1) IF(MATCH(A1,'N'))YINV=1. C C DECODE COLORS. C C DECOLR makes & copies COLORM matrix to COLORS(I,J); then C forms inverse in COLRIN. Matrices are in /CMAGS1/: C 150 CALL DECOLR(COLORS,CNAMES,BANDS,SYSTEM,CANNED) C C ESTIMATE PHOTON NOISE. C 152 DO 154 NB=1,NBANDS C Allow for extinction. DUM(1)=5.E3/WLS(NB) EXTIN(NB)=0.15*PRAT*DUM(1)**4 + DRAT*0.1*DUM(1) C .05 is assumed DQE. PHOMAG(NB) = 15.5 + 2.5*LOG10(ZSCSQ*AREA*.05*WIDTHS(NB)* 1 TRANS(NB)/WLS(NB)) C PHOTON NOISE = ZSCINT/4. at PHOMAG(NB) for 1 sec. outside atmosphere. 154 CONTINUE C IF(SYSSET)GO TO 200 C C Read STDFIL: initialize for STAR CATALOGs. C STDF=.TRUE. SYSSET=.TRUE. SAVFIL=STDFIL 156 NSTAR=0 LASTD=0 NSTDNM=0 NSTDFILS=0 MOVING=.FALSE. CATALOG=.FALSE. HASMAGS=.TRUE. C special for uvby & uvbyHB only: IF (SYSTEM(:4).EQ.'UVBY') SYSTEM(:4)='uvby' C C OPEN Standard-star file: C 160 INQUIRE (FILE=STDFIL,EXIST=FEXIST) IF (FEXIST) THEN C make sure it is a table file: IF (INDEX(STDFIL,'.tbl').EQ.0) THEN CARD=STDFIL(:LWORD(STDFIL))//' is not a table file.' CALL TV(CARD) CALL ASKFIL('Please enter correct file name:',STDFIL) GO TO 160 END IF CALL TBTOPN(STDFIL,1, ISTD,ISTAT) IF(ISTAT.NE.0)CALLTERROR(ISTD,160,'Could not open star file.') CARD=' ... reading '//STDFIL(:66) 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) CARD(33:)=' ' 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,A1) IF (A1.EQ.'Y')THEN CARD='Please change the SYSTEM descriptor to use ' 1 //SYSTEM CALL TV(CARD) ELSE CALL ASKFIL('Enter the correct file name:',STDFIL) IF (MATCH(STDFIL,'no').OR.MATCH(STDFIL,'NO'))THEN CALL TBTCLO(ISTD, ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,161, 1 'Could not close star file.') GO TO 188 ELSE GO TO 160 END IF END IF END IF END IF ELSE IF (HELP(STDFIL)) THEN CALL TV('Enter RESTART to re-start star catalogs.') CALL ASK('Enter NONE if there are no more files.',CARD) IF (MATCH(CARD,'NONE') .OR. MATCH(CARD,'none')) THEN GO TO 190 ELSE IF (MATCH(CARD,'RESTART')) THEN STDFIL=SAVFIL GO TO 156 END IF ELSE IF (MATCH(STDFIL,'NONE') .OR. MATCH(STDFIL,'none'))THEN GO TO 190 END IF IF(INDEX(STDFIL,'.tbl').EQ.0) THEN CARD=STDFIL(:LWORD(STDFIL))//'.tbl' STDFIL=CARD GO TO 160 END IF CARD='The requested star table file '//STDFIL(:50) 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(162,'Missing standard-star file') ELSEIF (MATCH(STDFIL,'NO') .OR. MATCH(STDFIL,'no'))THEN CALL ASKFIL('Please enter the correct file name:',STDFIL) GO TO 160 ELSE GO TO 160 END IF END IF C C Get columns: C CALL TBIGET(ISTD, NCOLS,NROWS,NSORTC,NWPRAL,NROWSAL,ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,163,'Could not get file info.') CALL TBLSER(ISTD,'OBJECT', KOBJ,ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,164,'ERROR finding OBJECT col.') IF(KOBJ.EQ.-1) CALL TERROR(ISTD,164,'Could not find OBJECT col.') CALL TBLSER(ISTD,'RA', KRA,ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,165,'ERROR finding RA col.') IF(KRA.EQ.-1) THEN CARD='Could not find RA column in '//STDFIL(:52) CALL TV(CARD) CALL TVN('Might be a data file...') CALL ASK('Is this really a STAR file??',A1) IF (A1.EQ.'Y') THEN CALL TERROR(ISTD,165,'Could not find RA col.') ELSE CARD='Closing '//STDFIL(:70) CALL TV(CARD) CALL SPACE2 CALL TBTCLO(ISTD, ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,165,'Could not close file.') GO TO 188 END IF END IF CALL TBLSER(ISTD,'DEC', KDEC,ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,166,'ERROR finding DEC col.') IF(KDEC.EQ.-1) CALL TERROR(ISTD,166,'Could not find DEC col.') CALL TBLSER(ISTD,'EQUINOX', KEQUINOX,ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,167,'ERROR finding EQUINOX col.') IF(KEQUINOX.EQ.-1) THEN IF (LASTD.EQ.0) THEN CALL TERROR(ISTD,167,'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(ISTD,168,'ERROR finding MUALPHA col.') CALL TBLSER(ISTD,'MUDELTA', KMUDELTA,ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,169,'ERROR finding MUDELTA col.') CALL TBLSER(ISTD,'EPOCH', KEPOCH,ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,169,'ERROR finding EPOCH col.') CALL TBLSER(ISTD,'SPTYPE', KSPTYPE,ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,169,'ERROR finding SPTYPE col.') CALL TBLSER(ISTD,'MAG', KMAG,ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,169,'ERROR finding MAG col.') CALL TBLSER(ISTD,'COMMENT', KCOMMENT,ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,169,'ERROR finding COMMENT col.') DO 170 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,170,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,170, 1 'ERROR finding column V-I') IF(KVI.EQ.-1)THEN C could not find V-I either. IF(STDF)CALLTV('Could not find column R-I or V-I') ELSE C found V-I. GO TO 170 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,170, 1 'ERROR finding column v-b') IF(KVB.EQ.-1)THEN C could not find v-b either. IF(STDF)CALLTV('Could not find column m1 or v-b') ELSE C found v-b. GO TO 170 END IF ELSE IF (CNAMES(1,K).EQ.'c1')THEN CALL TBLSER(ISTD,'u_v', KUV,ISTAT) IF(ISTAT.NE.0)CALL TERROR(ISTD,170, 1 'ERROR finding column u-v') IF(KUV.EQ.-1)THEN C could not find u-v either. IF(STDF)CALLTV('Could not find column c1 or u-v') ELSE C found u-v. GO TO 170 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,170, 1 'ERROR finding column Vmag') IF(KOLR(K).EQ.-1)THEN C could not find Vmag either. IF(STDF)CALLTV('Could not find column V or Vmag') ELSE C found Vmag. CALL TV(' file has Vmag, not V') GO TO 170 END IF END IF IF(INDEX(SYSTEM,'HB').GT.0)THEN C special for H-beta: IF (CNAMES(1,K).EQ.' ') THEN HASMAGS=.FALSE. GO TO 170 END IF END IF ELSE IF(SYSTEM.EQ.'H-BETA')THEN C special for H-beta: IF (CNAMES(1,K).EQ.' ') THEN HASMAGS=.FALSE. GO TO 170 END IF END IF C IF(LASTD.EQ.0) THEN C we are in standard stars; serious error. CARD='Could not find column for '//CNAMES(1,K) CALL TERROR(ISTD,170,CARD) ELSE C we are in program stars; forget it. END IF END IF 170 CONTINUE C IF (LASTD.GT.0) THEN C CARD='Does '//STDFIL(:LWORD(STDFIL))//' contain:' CALL TV(CARD) CALL SPACE CALL TV (' only Constant stars;') CALL TV (' only Variable stars;') CALL TV (' or a Mixture?') CALL SPACE CALL ASK('(reply C, V, or M): ',A1) C IF (A1.EQ.'C') THEN C1='X' ELSE IF (A1.EQ.'V')THEN C1='V' ELSE IF (A1.EQ.'M')THEN C1='P' CALL TV('Program will try to figure out which are which.') ELSE IF (A1.EQ.'S')THEN CALL ASK('Do you really mean Standard stars?',A1) IF (A1.EQ.'Y') THEN C1='S' LASTD=0 ELSE C1='P' END IF ELSE C1='P' CALL TV('Program will try to figure out which are which.') END IF C C Look for ephemeris data: CALL TBLSER(ISTD,'DATE', KDATE,ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,170,'ERROR finding DATE col.') IF(KDATE.EQ.-1) THEN CALL TBLSER(ISTD,'MJD_OBS', KMJD,ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,170, 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.'',I3)') KDATE CALL TV(CARD) MOVING=.TRUE. END IF ELSE END IF C C READ Standard-star file: C C ***** BEGIN loop over rows ***** DO 187 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(ISTD,171,'Could not read DEC col.') C Skip any stars that never rise. IF(ABS(ALDEG-DECDEG).GT.90.)GO TO 187 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?',A1) NSTAR=MSTARS IF(LASTD.EQ.0)LASTD=MSTARS IF(MATCH(A1,'Y')) GO TO 190 CALL TERROR(ISTD,171, 'CATALOG OVERLFOW') END IF ISTAR(NSTAR)=0 JSTAR(NSTAR)=0 C Get R.A. CALL TBERDR (ISTD, NROW, KRA, RADEG, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,171,'Could not read RA col.') IF(NULL) THEN BACK1=.TRUE. CALL TBERDC (ISTD, NROW, KOBJ, STARS(NSTAR), NULL, ISTAT) CARD='No position for '//STARS(NSTAR) CALL TV(CARD) CALL TVN(' *** Please fix star table.') END IF C note that MIDAS stores it as *degrees*! RAS(NSTAR)=RADEG*DEGRAD DECS(NSTAR)=DECDEG*DEGRAD C C Look for equinox, to precess: C IF (KEQUINOX.GT.0) THEN CALL TBERDR (ISTD, NROW, KEQUINOX, EQUINX(NSTAR), NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,172,'Could not read EQUINOX col.') ELSE EQUINX(NSTAR)=0. END IF C IF (EQUINX(NSTAR).GT.0. .AND. EQUINX(NSTAR).LT.1850. .OR. 1 EQUINX(NSTAR).GT.2100.) THEN WRITE(CARD,'(A,'' is referred to Equinox'',F6.0)') 1 STARS(NSTAR),EQUINX(NSTAR) CALL TV(CARD) CALL ASK('Is that right?',A1) IF (A1.EQ.'Y') THEN C accept it. ELSE CALL STETER(171,'Please fix star table.') END IF END IF C IF(NULL) THEN BACK1=.TRUE. CALL TBERDC (ISTD, NROW, KOBJ, STARS(NSTAR), NULL, ISTAT) CARD='No equinox for '//STARS(NSTAR) CALL TV(CARD) CALL TVN(' *** Please fix star table.') END IF C C Look for proper-motion components: C IF (KMUALPHA.GT.0 .AND. KMUDELTA.GT.0 .AND. KEPOCH.GT.0) THEN CALL TBERDR (ISTD, NROW, KMUALPHA, ALPMUS(NSTAR), NULL, ISTAT) IF(ISTAT.NE.0)CALLTERROR(ISTD,172,'Could not read MUALPHA col.') IF (NULL) ALPMUS(NSTAR)=0. CALL TBERDR (ISTD, NROW, KMUDELTA, DELTMUS(NSTAR), NULL, ISTAT) IF(ISTAT.NE.0)CALLTERROR(ISTD,172,'Could not read MUDELTA col.') IF (NULL) DELTMUS(NSTAR)=0. CALL TBERDR (ISTD, NROW, KEPOCH, EPOCHS(NSTAR), NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,172,'Could not read EPOCH col.') IF (NULL) THEN ALPMUS(NSTAR)=0. DELTMUS(NSTAR)=0. EPOCHS(NSTAR)=0. END IF ELSE ALPMUS(NSTAR)=0. DELTMUS(NSTAR)=0. EPOCHS(NSTAR)=0. END IF C C C Get star name: C CALL TBERDC (ISTD, NROW, KOBJ, STARS(NSTAR), NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,172,'Could not read OBJECT col.') IF(NULL)THEN BACK1=.TRUE. ELSE C IF (STARS(NSTAR)(:1).EQ.' ') THEN C Left-justify star name. DO 1705 K=2,31 IF (STARS(NSTAR)(K:K).NE.' ') GO TO 1706 1705 CONTINUE K=32 1706 CARD(:32)=STARS(NSTAR)(K:) STARS(NSTAR)=CARD(:32) END IF C C Save name in case STDNAME changes it. STAR=STARS(NSTAR) CALL STDNAME(STARS(NSTAR), NUMBER) IF (STAR.NE.STARS(NSTAR) .AND. NUMBER.LT.5)THEN C STDNAME changed it. Add original unparsable name to list: NUMBER=NUMBER+1 STAR5(NUMBER)=STAR END IF DO 172 K=1,NUMBER NSTDNM=NSTDNM+1 IF (NSTDNM.GT.MSTARK) THEN CALL EXCEED(NSTDNM,'MSTARK',MSTARK) CALL STETER(172,'Increase parameter MSTARS, recompile') END IF STDNAMES(NSTDNM)=STAR5(K) KSTARS(NSTDNM)=NSTAR 172 CONTINUE END IF C C Check for duplicates: C C Pre-compute rough limits for efficiency. XLIM(1)=DECS(NSTAR)-0.015 XLIM(2)=DECS(NSTAR)+0.015 C C NOTE: The aim here is to check whether two star files contain the C same star disguised under an alias. Only STD. stars can be C checked, as pgm. stars can be crowded, and are assumed C distinct if they have distinct names. C DO 180 I=1,NSTAR-1 IF (DECS(I).LT.XLIM(1) .OR. DECS(I).GT.XLIM(2)) GO TO 180 C get rid of most non-coincidences cheaply. DETOL=ABS(EQUINX(NSTAR)-EQUINX(I))*1.E-4 + 0.0015 C annual prec.in radians + 5 arcmin IF (ABS(DECS(NSTAR)-DECS(I)).LT.DETOL) THEN C same zone. IF (ABS(RAS(NSTAR)-RAS(I)).LT.DETOL*2.52) THEN C same patch of sky. FLAGGED=.FALSE. C Check names: IF (STARS(NSTAR).EQ.STARS(I)) THEN C Name already in use; stars probably the same. CARD='You already have '//STARS(I) CALL TV (CARD) CALL TVN('in the star catalog! Please check tables.') FLAGGED=.TRUE. GO TO 175 ELSE C See if a pair of aliases match: CALL SPLIT(STARS(I), K1,SNAME1) CALL SPLIT(STARS(NSTAR), K2,SNAME2) C aliases now separated. DO 173 L1=1,K1 DO 173 L2=1,K2 IF (SNAME1(L1).EQ.SNAME2(L2)) THEN C Aliases match. CARD=STARS(NSTAR)//' identified as' CALL TV(CARD) CALL TVN(STARS(I)) FLAGGED=.TRUE. GO TO 175 ELSE C No match. END IF 173 CONTINUE C C No match found. IF (LASTD.EQ.0) THEN C We are still reading STD. stars. Assume distinct. ELSE IF (STYPE(I).EQ.'S' .AND. .NOT.FLAGGED) THEN C No match found, so ask user if this is a std.: C (Can't check pgm. stars, as they can be crowded.) C CALL SPACE CARD='Are '//STARS(I) CALL TV(CARD) CARD='and '//STARS(NSTAR) CALL TVN(CARD) CALL ASKN('the SAME star?',A1) IF (A1.EQ.'Y') THEN FLAGGED=.TRUE. ELSE END IF END IF END IF C 175 IF (FLAGGED) THEN C Names match. Combine entries. IF (STARS(I).EQ.STARS(NSTAR)) THEN ELSE CARD='Using the values of '//STARS(I) CARD(LWORD(CARD)+1:)=' for '//STARS(NSTAR) CALL TV(CARD) CALL SPACE END IF CALL ADDALIAS(NSTAR,I) GO TO 187 ELSE C Names don't match. Go on. END IF END IF END IF 180 CONTINUE C IF(LASTD.EQ.0) THEN STYPE(NSTAR)='S' C Transfer mag. & colors from table to catalog. DO 182 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,182, 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 182 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,182, 1 'Could not read column v-b') IF (NULL) COLORS(K,NSTAR)=3.E33 GO TO 182 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,182, 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 182 END IF IF(INDEX(SYSTEM,'HB').GT.0)THEN C special for H-beta: IF (CNAMES(1,K).EQ.' ') THEN GO TO 182 END IF END IF ELSE IF(SYSTEM.EQ.'H-BETA')THEN C special for H-beta: IF (CNAMES(1,K).EQ.' ') THEN GO TO 182 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(ISTD,182,CARD) END IF IF (NULL) COLORS(K,NSTAR)=3.E33 END IF 182 CONTINUE ELSE C fill in STYPE as specified at 189-190. STYPE(NSTAR)=C1 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(ISTD,182,'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(ISTD,182,'Could not read MJD col.') DJD=DJD+0.5D0 END IF C DJD is now true JD - 2400000. C STYPE(NSTAR)='V' 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 183 I=NSTAR-1,1,-1 IF(STARS(I).NE.STARS(NSTAR)) GO TO 184 183 CONTINUE I=0 184 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(ISTD,187,'Could not read COMMENT col.') ELSE COMENT(NSTAR)=' ' END IF C IF (KSPTYPE.NE.-1) THEN CALL TBERDC (ISTD, NROW, KSPTYPE, SPTYPE(NSTAR), NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(ISTD,187,'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(ISTD,187,'Could not read MAG col.') ELSE EMAG(NSTAR)=' ' END IF C IF(BACK1) NSTAR=NSTAR-1 C ***** END loop over rows ***** 187 CONTINUE C CALL TBTCLO(ISTD, ISTAT) IF(ISTAT.NE.0) CALL TERROR(ISTD,188,'Could not close star file.') CALL SPACE CARD='Closing star file '//STDFIL(:62) CALL TV(CARD) NSTDFILS=NSTDFILS+1 IF (NSTDFILS.GT.20) THEN CALL EXCEED(NSTDFILS,'20 ',20) CALL STETER(188,'Increase dimension of STDFILS') END IF STDFILS(NSTDFILS)=STDFIL 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 CALL TV('Star files read so far:') WRITE(PAGE,'(5X,A70)') STDFILS(1) CALL TV(PAGE(1)) DO 1889 K=2,NSTDFILS WRITE(PAGE,'(5X,A70)') STDFILS(K) 1889 CALL TVN(PAGE(1)) IF(CATALOG) GO TO 1897 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. STDF=.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. 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. C 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?',A1) IF (A1.EQ.'Y') THEN CALL TV('Re-enter catalog data.') STDFIL=SAVFIL GO TO 156 ELSE IF (A1.EQ.'N') THEN C go on. ELSE CALL TV(' ... ambiguous reply ...') GOTO 188 END IF ELSE DO 1895 K=1,NSTDFILS IF (CATFIL.EQ.STDFILS(K)) THEN CARD=STDFILS(K)(:LWORD(STDFILS(K)))//' already read !' CALL TV(CARD) GO TO 188 END IF 1895 CONTINUE END IF C C Check for catalog status: C 1897 IF (CATALOG) THEN C Set STDFIL to next catalog entry: CALL STCGET (CATFIL, 0, STDFIL, CARD, J, ISTAT) C Make sure we are not at end of catalog: IF (STDFIL(:1).EQ.' ') THEN C EOF in CATFIL. CATALOG=.FALSE. C Ask user for a new name: GO TO 188 ELSE C OK. Use entry: GO TO 160 END IF ELSE C See if this is a catalog file: IF (INDEX(CATFIL,'.cat').GT.1 .OR. 1 INDEX(CATFIL,'.CAT').GT.1)THEN C Initialize new catalog: CATALOG=.TRUE. J=0 CALL STCGET (CATFIL, 0, STDFIL, CARD, J, ISTAT) ELSE C Set STDFIL to name read in: STDFIL=CATFIL END IF GO TO 160 END IF C C NSTARS is total number of stars in catalog. 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(1)=EQUINX(I1)+J*(EQUINX(I2)-EQUINX(I1))/40. CALL EPHEM(I1,DUM(1),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 200 CONTINUE C C sort star dictionary: C CALL SRTNAM(STDNAMES,KSTARS,NSTDNM) C C and check for duplicated names: DO 205 I=2,NSTDNM IF (STDNAMES(I).EQ.STDNAMES(I-1))THEN C Name appears twice. See if positions are similar: I1=KSTARS(I-1) I2=KSTARS(I) DETOL=ABS(EQUINX(I1)-EQUINX(I2))*1.E-4 + 0.0015 C annual prec.in radians + 5 arcmin IF (ABS(DECS(I1)-DECS(I2)).LT.DETOL) THEN C same zone. IF (ABS(RAS(I1)-RAS(I2)).LT.DETOL*2.52) THEN C same patch. IF (STARS(I1).EQ.STARS(I2)) GO TO 205 C (accept apparent identity; otherwise, notify user.) 201 CALL SPACE2 CARD='The stars '//STARS(I1) CALL TV(CARD) CARD=' and '//STARS(I2) CALL TVN(CARD) CALL TV('appear to be the same star.') CALL ASK(' Are they?',A1) IF (A1.EQ.'Y') THEN C See which position is preferred: CALL TV('The names differ:') CALL SHOPOS(CARD,I1,I2) CALL ASK( 1 'Which position and name do you prefer, 1 or 2?' 2 ,A1) IF (A1.EQ.'2') THEN CALL TV('Program will use 2.') STARS(I1)=STARS(I2) RAS(I1)=RAS(I2) DECS(I1)=DECS(I2) EQUINX(I1)=EQUINX(I2) ELSE IF (HELP(A1)) THEN CALL SPACE CALL TV('If stars are distinct, reply NO.') CALL TVN('If entries are wrong, use Q to quit.') GO TO 201 ELSE CALL TV('Program will use 1.') STARS(I2)=STARS(I1) RAS(I2)=RAS(I1) DECS(I2)=DECS(I1) EQUINX(I2)=EQUINX(I1) END IF ELSE IF (A1.EQ.'N') THEN C Stars are distinct; no change. CALL TV('OK.') ELSE CALL TV(' *** Please reply "YES" or "NO".') GO TO 201 END IF C Must jump to 205 to avoid stuff below. GO TO 205 ELSE C R.A.s don't match. END IF END IF C C Here if names are similar, but positions are not. 202 CALL SPACE2 CARD='Are '//STARS(I1) CALL TV(CARD) CARD='and '//STARS(I2) CALL TVN(CARD) CALL ASK('intended to be the same star?',A1) IF (A1.EQ.'Y') THEN CALL SPACE CALL TV('But the positions disagree!') 203 CALL SHOPOS(CARD,I1,I2) CALL ASK('Which is correct, 1 or 2?',A1) IF (A1.EQ.'1') THEN KSTARS(I)=0 CALL TV('Other entry disabled.') ELSE IF (A1.EQ.'2') THEN KSTARS(I-1)=0 CALL TV('Other entry disabled.') ELSE IF (A1.EQ.'N') THEN KSTARS(I-1)=0 KSTARS(I)=0 CALL TV('Both entries disabled.') ELSE IF (HELP(A1)) THEN CALL SPACE2 CALL TV('Reply 1, 2, Neither, or Both:') CALL SPACE GO TO 203 ELSE CALL TV('Program may confuse them.') END IF ELSE IF(A1.EQ.'N') THEN C OK, go on. CALL TV('OK.') ELSE CALL TV(' *** Please reply "YES" or "NO".') GO TO 202 END IF END IF 205 CONTINUE C DO 208 J=1,MBANDS C Clear ND arrays: NDNAME(J)='xxxx' DO 207 I=1,MBANDS XND(I,J)=0. 207 CONTINUE C Clear XMAG: DO 208 I=1,NSTARS XMAG(J,I)=0. 208 CONTINUE NDS=0 C C C ******************** Instrument file ******************** C C CALL SPACE2 210 CALL ASKFIL('What MIDAS table file describes the instrument?', 1 STDFIL) IF (MATCH(STDFIL,'none') .OR. MATCH(STDFIL,'NONE')) THEN STDFIL='NONE' CALL TV('Please use the command MAKE/PHOTOMETER') CALL TVN('to make an instrument-description file.') CALL STSEPI END IF C IF(INDEX(STDFIL,'.tbl').EQ.0) THEN I=LWORD(STDFIL) STDFIL(I+1:)='.tbl' END IF C C Check instrument file: INQUIRE (FILE=STDFIL,EXIST=FEXIST) C IF (FEXIST) THEN C OK. ELSE CARD='The requested instrument table file '//STDFIL(:44) 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(206,'Missing instrument file') ELSE GO TO 210 END IF END IF C C Open instrument file: C CALL TBTOPN(STDFIL,1, INST,ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,207, 1 'Could not open instrument-description file.') C CALL TBIGET (INST, NCOLS, NROWS, NSORTC, NWPRAL, NROWSAL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST, 208, 1 'Could not get basic table data.') IF (NROWS.GT.MXCOLR)THEN CALL TV('Too many rows in instrument table.') C Maybe it is a data table? Look for OBJECT column. CALL TBLSER (INST, 'OBJECT', KOBJECT, ISTAT) IF (KOBJECT.EQ.-1) THEN C No; must be instrument. CALL TVN('Try splitting it into separate tables') CALL TVN(' for different photometric systems.') CALL TERROR(INST,209,'Dimension conflict.') ELSE C Yes: complain and try again. CALL TV('That seems to be a data table.') CALL TBTCLO(INST, ISTAT) GO TO 210 END IF END IF C C Get instrument descriptors: C 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,210,'Please fix instrument table file.') END IF CALL TV('Instrument identification:') CALL TV(INSTNAM) CALL SPACE C C Filtstat: 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,210,'Please fix instrument table file.') END IF IF (FILTSTAT.NE.'REGULATED') STABLE=.FALSE. C C Condition: CALL STDRDC (INST, 'CONDITION', 1, 1, 7, 1 NVALS, CONDITION, IUNIT, NULLS, ISTAT) IF(ISTAT.NE.0)THEN CALL TV('Could not find CONDITION descriptor.') CALL TERROR(INST,210,'Please fix instrument table file.') END IF C C NDETS: CALL STDRDI (INST, 'NDETS', 1, 1, 1 NVALS, NDETS, IUNIT, NULLS, ISTAT) IF(ISTAT.NE.0)THEN CALL TV('Could not find NDETS descriptor.') CALL TERROR(INST,210,'Please fix instrument table file.') END IF C C Get REQUIRED-COLUMN pointers: C C BAND: CALL TBLSER (INST, 'BAND', KBAND, ISTAT) IF (ISTAT.NE.0 .OR. KBAND.EQ.-1) 1 CALL TERROR(INST,211,'Could not find column BAND') C NBAND: CALL TBLSER (INST, 'NBAND', KNBAND, ISTAT) IF (ISTAT.NE.0 .OR. KNBAND.EQ.-1) 1 CALL TERROR(INST,211,'Could not find column NBAND') C REDLEAK: CALL TBLSER (INST, 'REDLEAK', KRL, ISTAT) IF (ISTAT.NE.0 .OR. KRL.EQ.-1) 1 CALL TERROR(INST,211,'Could not find column REDLEAK') C DET: CALL TBLSER (INST, 'DET', KDET, ISTAT) IF (ISTAT.NE.0 .OR. KDET.EQ.-1) 1 CALL TERROR(INST,211,'Could not find column DET') C NDET: CALL TBLSER (INST, 'NDET', KNDET, ISTAT) IF (ISTAT.NE.0 .OR. KNDET.EQ.-1) 1 CALL TERROR(INST,211,'Could not find column NDET') C COOLING: CALL TBLSER(INST, 'COOLING', KCOOL, ISTAT) IF(ISTAT.NE.0 .OR. KCOOL.EQ.-1) 1 CALL TERROR(INST,211,'Could not find column COOLING') C C Get OPTIONAL-COLUMN pointers: C C NDVALUE: CALL TBLSER (INST, 'NDVALUE', KNDVAL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,212,'Could not find column NDVALUE') C RLTYPE: CALL TBLSER (INST, 'RLTYPE', KRLTYP, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,212,'Could not find column RLTYPE') C MAKER: CALL TBLSER (INST, 'MAKER', KMAKER, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,212,'Could not find column MAKER') C DETNAME: CALL TBLSER (INST, 'DETNAME', KDETNM, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,212,'Could not find column DETNAME') C SNUMBER: CALL TBLSER (INST, 'SNUMBER', KSNUMB, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,212,'Could not find column SNUMBER') C MODE: CALL TBLSER (INST, 'MODE', KMODE, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,212,'Could not find column MODE') C DEADTYPE: CALL TBLSER (INST, 'DEADTYPE', KDEDTYP, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,212,'Could not find column DEADTYPE') C DEADTIME: CALL TBLSER (INST, 'DEADTIME', KDEDTIM, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,212,'Could not find column DEADTIME') C DEADTIMEERROR: CALL TBLSER (INST, 'DEADTIMEERROR', KDEDER, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,212,'Could not find column DEADTIMEERROR') C DETTEMP: CALL TBLSER (INST, 'DETTEMP', KDTEMP, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,212,'Could not find column DETTEMP') C BLUERESP: CALL TBLSER (INST, 'BLUERESP', KBLUER, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,212,'Could not find column BLUERESP') C C NDET: CALL TBLSER (INST, 'NDET', KNDET, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(INST,212,'Could not open column NDET') IF(NDETS.GT.1 .AND. KNDET.EQ.-1) 1 CALL TERROR(INST,212,'Could not find column NDET') C NDETUSED: CALL TBLSER (INST, 'NDETUSED', KNDTUSE, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(INST,213,'Could not open column NDETUSED') IF (NDETS.GT.1 .AND. KNDTUSE.EQ.-1) 1 CALL TERROR(INST,213,'Could not find column NDETUSED') C C CALL SPACE C C **** BEGIN loop over passbands **** C MAXKS=NBANDS KOLOR=0 DO 220 NB=1,NBANDS C Verify that each passband can be measured: CALL TBESRC (INST, KBAND, BANDS(NB), 1, 8, 1, NROW, ISTAT) IF(ISTAT.NE.0) THEN CARD='Could not search BAND column for '//BANDS(NB) CALL TERROR(INST,214,CARD) END IF C IF(NROW.GT.0)THEN C found it. KOLOR=KOLOR+1 C C Identify detector used: C IF(KNDTUSE.GT.0)THEN CALL TBERDI (INST, NROW, KNDTUSE, NDTUSD(NB), NULL, ISTAT) IF(ISTAT.NE.0 .OR. NULL)CALL TERROR(INST,215, 1 'Could not read column NDETUSED') ELSE NDTUSD(NB)=1 END IF FUNK(NB)=.FALSE. FCORN(NB)=.FALSE. C C see if we measure REDLEAKs: C CALL TBERDC (INST, NROW, KRL, C8, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,216, 1 'Could not read REDLEAK column') C IF (C8.EQ.'MEASURED') THEN C C see if we know RLTYPE: C IF (KRLTYP.EQ.-1) 1 CALL TERROR(INST,217,'Could not find column RLTYPE') CALL TBERDC (INST, NROW, KRLTYP, C8, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,217, 1 'Could not read RLTYPE column') RLFACT(NB)=1. C IF (C8.EQ.'CEMENTED') THEN C we are OK. ELSE IF (C8.EQ.'LOOSE') THEN RLFACT(NB)=1.08 ELSE IF (C8.EQ.'UNKNOWN') THEN FUNK(NB)=.TRUE. RLFACT(NB)=1.04 END IF C C see if we know MAKER: C IF (KMAKER.EQ.-1) 1 CALL TERROR(INST,218,'Could not find column MAKER') CALL TBERDC (INST, NROW, KMAKER, C8, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,218, 1 'Could not read MAKER column') C IF (C8.EQ.'SCHOTT') THEN C we are OK. ELSE IF (C8.EQ.'CORNING') THEN RLFACT(NB)=RLFACT(NB)*1.06 ELSE IF (C8.EQ.'UNKNOWN') THEN FCORN(NB)=.TRUE. RLFACT(NB)=RLFACT(NB)*1.03 END IF C C look for the red-leak filter position: C BANDS(MAXKS+1)=BANDS(NB)(:LWORD(BANDS(NB)))//'RL' CALL TBESRC (INST, KBAND, BANDS(MAXKS+1),1,8,1, NROW,ISTAT) C IF(ISTAT.NE.0) THEN CARD='Could not search BAND column for '//BANDS(MAXKS+1) CALL TERROR(INST,219,CARD) END IF C IF(NROW.GT.0)THEN MAXKS=MAXKS+1 KOLOR=KOLOR+1 NBRL(MAXKS)=NB ELSE CARD='Could not find expected red-leak filter '// 1 BANDS(MAXKS+1) CALL TV(CARD) END IF ELSE NBRL(NB)=0 END IF C ELSE C not found. CARD=' Instrument cannot measure '//BANDS(NB) CALL TVN(CARD) END IF 220 CONTINUE C C **** END loop over passbands **** C C C Set up ND filter info, if present. IF (KNDVAL.GT.0) THEN C Look for ND filter info. C C **** BEGIN loop over rows **** C DO 228 NROW=1,NROWS CALL TBERDC(INST,NROW,KBAND, BAND,NULL,ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,222,'Could not read BAND column.') C Pick off ND name: L=INDEX(BAND,'ND') IF (L.EQ.0) THEN C No ND filter. NDFILT(1)=' ' ELSE C Split out ND filter. NDFILT(1)=BAND(L:) BAND(L:)=' ' END IF C BAND is now free of ND name, which is in NDFILT(1). 223 DO 224 K=1,NBANDS IF (BANDS(K).EQ.BAND) GO TO 225 224 CONTINUE C Unidentified; but might be an RL, or in another system. L=INDEX(BAND,'RL') IF (L.GT.0) THEN C RL. Try again: BAND(L:)=' ' GO TO 223 ELSE C Not RL; band probably is in another system. Give up. GO TO 228 END IF C C Band identified as K. Identify ND position: C C NDS is total number of ND codes available C NDNAME(nd) is ND-th code C XND(nd,k) is value (>= 1) of attenuation for nd-th code C in band k C NDFILT(ndata) is code for observation number NDATA C 225 CONTINUE DO 226 ND=1,NDS IF (NDFILT(1).EQ.NDNAME(ND)) GO TO 227 226 CONTINUE C Neutral filter not identified; add to list. NDS=NDS+1 IF (NDS.GT.MBANDS)THEN CALL TV('Too many neutral-density filters !') CALL EXCEED(NDS,'MBANDS',MBANDS) CALL STETER(227,'Split table into 2 files.') END IF ND=NDS NDNAME(ND)=NDFILT(1) 227 CONTINUE C Read ND value: CALL TBERDR(INST,NROW,KNDVAL, XND(ND,K),NULL,ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,228,'Could not read NDVALUE column.') 228 CONTINUE ELSE C Set up defaults, if no ND filters available. NDS=1 NDNAME(1)=' ' DO 230 K=1,NBANDS XND(1,K)=1. 230 CONTINUE END IF C C **** END loop over rows **** C C KOLORS=KOLOR NEEDGN=.FALSE. STABLE=.TRUE. C C C **** BEGIN loop over detectors **** C DO 240 NDET=1,NDETS C C Find row for this det: CALL TBESRI (INST, KNDET, NDET, 0, 1, NROW, ISTAT) C IF (ISTAT.NE.0) THEN WRITE(CARD,'(''Could not search NDET Column for'',I3)') NDET CALL TERROR(INST,230,CARD) END IF C IF (KDETNM.GT.0) THEN CALL TBERDC(INST, NROW, KDETNM, DETNAME(NDET), NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(INST,230,'Could not read DETNAME column') ELSE IF (NDETS.EQ.1) THEN DETNAME(1)='Detector' ELSE WRITE(DETNAME(NDET),'(''Detector no.'',I3)') NDET END IF END IF C C C see if we need to remind user about cooling: C C if COOLING = REGULATED look for DETTEMP col. in THIS file. C C if COOLING = UNREGULATED or C ICE or DRYICE temp. is variable and unknown. C C if COOLING = MEASURED look for DETTEMP col. in DATA files. C C if COOLING = NONE try using DOMETEMP in data files. C C CALL TBERDC (INST, NROW, KCOOL, COOLING, NULL, ISTAT) IF(ISTAT.NE.0)CALLTERROR(INST,231,'Could not read COOLING column') COOL(NDET)=COOLING C IF (COOLING.EQ.'NONE') THEN COOLED(NDET)=.FALSE. HASDTMP(NDET)=.FALSE. ELSE COOLED(NDET)=.TRUE. IF (COOLING.EQ.'MEASURED')THEN HASDTMP(NDET)=.TRUE. ELSE HASDTMP(NDET)=.FALSE. END IF END IF C IF (COOLING.NE.'REGULATED') STABLE=.FALSE. C C C Look at detectors: C PC(NDET)=.FALSE. DC(NDET)=.FALSE. CI(NDET)=.FALSE. C see if PMT is used: CALL TBERDC (INST, NROW, KDET, DET, NULL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,232,'Could not read DET column') IF(NULL) GOTO 240 C IF(DET.EQ.'PMT')THEN C get mode: IF(KMODE.EQ.-1)THEN CALL TV('Could not find MODE column.') CALL TERROR(INST,233,'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,234,'Could not read MODE column.') C DMS now holds mode. IF (DMS(:2).EQ.'PC') THEN C Pulse-counting. Get dead-time: IF(KDEDTIM.EQ.-1)THEN CALL TV('Could not find DEADTIME column.') CALL TERROR(INST,235, 1 'Please fix instrument table file.') END IF CALL TBERDR (INST, NROW, KDEDTIM, DEDTS(NDET),NULL,ISTAT) IF(ISTAT.NE.0 .OR. NULL) 1 CALLTERROR(INST,236,'Could not read DEADTIME column.') C and deadtime error: IF(KDEDER.EQ.-1)THEN CALL TV('Could not find DEADTIMEERROR column.') CALL TERROR(INST,237, 1 'Please fix instrument table file.') END IF CALL TBERDR (INST, NROW, KDEDER, SDEDTS(NDET),NULL,ISTAT) IF(ISTAT.NE.0 .OR. NULL) 1 CALL TERROR(INST,238, 2 'Could not read DEADTIMEERROR column.') CALL TBERDC (INST, NROW, KDEDTYP, DMS, NULL, ISTAT) IF(ISTAT.NE.0 .OR. NULL) 1 CALL TERROR(INST,239, 2 'Could not read DEADTYPE column.') DEDTYP(NDET)=DMS(:3) PC(NDET)=.TRUE. MTYPE=1 ELSE IF (DMS(:2).EQ.'DC') THEN C PMT, DC. DC(NDET)=.TRUE. NEEDGN=.TRUE. MTYPE=2 ELSE IF (DMS(:2).EQ.'CI') THEN C PMT, CI. CI(NDET)=.TRUE. NEEDGN=.TRUE. MTYPE=3 ELSE MTYPE=0 CALL TV('Mode of operation not given in table file.') END IF C END IF C 240 CONTINUE C IF (NDETS.EQ.1) NDET=1 C C **** END loop over detectors **** C C C Instrument parameters are stored as follows: C C C Ch*9 FILTSTAT filter thermostating C Ch*7 CONDITION condition of optics C C I NDETS number of detector channels C I NDTUSD(nb) number of det. used for band NB C I MINDET min.det.number C I MAXDET max.det.number C C Ch*8 BANDS(nb) name of band number NB C L FUNK(nb) true if RLTYPE is unknown for band NB C L FCORN(nb) true if unknown RL glass used for band NB C I KOLORS total number of filters used, incl. red leaks C C Ch*16 DETNAME(ndet) holds name string for det. NDET C Ch*12 COOL(ndet) holds COOLING string for det. NDET C L COOLED(ndet) true if detector NDET is cooled. C L DC(ndet) true if detector NDET uses DC C L CI(ndet) true if detector NDET uses charge-integration C L PC(ndet) true if detector NDET uses pulse-counting C R DEDTS(ndet) dead-time for detector NDET C R SDEDTS(ndet) dead-time error for detector NDET C Ch*3 DEDTYP(ndet) dead-time type for det. NDET C C CALL TBTCLO(INST, ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,301,'Could not close inst. file.') C C C ********************** Read DATA files: ************************** C C C Initialize data counts: C NDATFIL=0 NDATA=0 LDICT=0 NIGHT=0 NIGHTS=0 ISTARS=0 KMAX=0 LASTK=0 NBREJ=0 NDIAS=0 C Clear arrays for ND filter info: NUMNDS=0 DO 290 I=1,MBANDS NUM2ND(I)=0 NP2ND(I)=0 NP2K(I)=0 DO 290 J=1,MBANDS ND2NP(J,I)=0 290 CONTINUE C KMIN=MXCOLR OLDEP=0. OLDEQX=0. TIMAX=0.D0 TIMIN=3.E33 C C Clear some flags: C HASFILTT=.FALSE. HASDOMT=.FALSE. HASRH=.FALSE. DARK=.FALSE. NEEDFTI=.FALSE. NEDDTI=.FALSE. NEDDMI=.FALSE. NEEDRHI=.FALSE. CATALOG=.FALSE. USES3PTS=.FALSE. DO 291 I=1,MBANDS USE3PT(I)=.FALSE. 291 CONTINUE C use DMS as temporary word buffer... DMS='first' C C Loop back to here for new file... C 302 WRITE(CARD,'(''What is the name of the '',A,'' data file?'')') 1 DMS(:LWORD(DMS)) C DMS is now free (use it around 330 for name buffer). CALL ASKFIL(CARD,DATFIL) C Check data file: 303 INQUIRE (FILE=DATFIL,EXIST=FEXIST) C C Check for catalog status: C IF (CATALOG) THEN C Set DATFIL to next catalog entry: CALL STCGET (CATFIL, 0, DATFIL, CARD, N, ISTAT) C Make sure we are not at end of catalog: IF (DATFIL(:1).EQ.' ') THEN C EOF in CATFIL. CATALOG=.FALSE. CARD=' ' C Ask user for a new name: DMS='next' GO TO 302 ELSE C OK. Use entry. END IF ELSE C See if this is a catalog file: IF ( (INDEX(DATFIL,'.cat').GT.1 .OR. 1 INDEX(DATFIL,'.CAT').GT.1) .AND. FEXIST)THEN C Initialize new catalog: CATALOG=.TRUE. C save the name. CATFIL=DATFIL N=0 CALL TV('Open catalog '//CATFIL) CALL SPACE CALL STCGET (CATFIL, 0, DATFIL, CARD, N, ISTAT) ELSE C Use DATFIL name read in. END IF END IF C IF (CATALOG) THEN CARD='Got '//DATFIL(:LWORD(DATFIL))//' from catalog' CALL TV(CARD) CALL SPACE INQUIRE (FILE=DATFIL,EXIST=FEXIST) END IF C C IF (FEXIST) THEN C OK. DO 305 I=1,NDATFIL IF(DATFIL.EQ.DATFILS(I))THEN CALL TV('!! You already read that one!!!!') GO TO 391 END IF 305 CONTINUE NDATFIL=NDATFIL+1 IF (NDATFIL.GT.MXNITE) THEN CALL EXCEED(NDATFIL,'MXNITE',MXNITE) CALL STETER(305,'Increase parameter MXNITE') END IF DATFILS(NDATFIL)=DATFIL ELSE IF(INDEX(DATFIL,'.tbl').EQ.0) THEN CARD=DATFIL(:LWORD(DATFIL))//'.tbl' DATFIL=CARD GO TO 303 END IF CARD='The requested data file '//DATFIL(:56) CALL TV(CARD) CALL TVN('is not available. Please make sure all required') CALL TVN('files are available in your current directory.') 306 CARD='Is '//DATFIL(:LWORD(DATFIL))//' the correct file name?' CALL ASKFIL(CARD,DATFIL) IF (MATCH(DATFIL,'YES') .OR. MATCH(DATFIL,'yes'))THEN CALL ASK('Are you sure? (Program cannot continue.)',A1) IF (A1.EQ.'Y') THEN CALL STETER(306,'Missing data file') ELSE CALL TV('Enter HELP for help.') CALL TV('Enter NONE if there are no more files.') END IF GO TO 306 ELSE IF (DATFIL.EQ.'NONE' .OR. DATFIL.EQ.'none')THEN GO TO 395 ELSE IF (MATCH(DATFIL,'NO') .OR. MATCH(DATFIL,'no')) THEN CALL ASKFIL('Please enter the correct file name:',DATFIL) IF (DATFIL.EQ.'NONE' .OR. DATFIL.EQ.'none') GO TO 395 GO TO 303 ELSE IF (MATCH(DATFIL,'HELP') .OR. MATCH(DATFIL,'help')) THEN CALL TV('Enter the file name, or NONE if no more files.') CALL ASKFIL('?',DATFIL) IF (DATFIL.EQ.'NONE' .OR. DATFIL.EQ.'none') GO TO 395 GO TO 303 ELSE GO TO 303 END IF END IF C C Check on file: C IF (INDEX(DATFIL,'.tbl').EQ.0) THEN CARD=DATFIL(:LWORD(DATFIL))//' is not a table file.' CALL TV(CARD) NDATFIL=NDATFIL-1 DMS='next' GO TO 302 END IF C C Open data file: C CALL TBTOPN(DATFIL,1, IDAT,ISTAT) IF(ISTAT.NE.0) CALL TERROR(INST,307,'Could not open data file.') CALL TBIGET (IDAT, NCOLS, NROWS, NSORTC, NWPRAL, NROWSAL, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IDAT, 308, 1 'Could not get basic table data.') NIGHT=NIGHT+1 IF (NIGHT.GT.MXNITE) THEN CALL EXCEED(NIGHT,'MXNITE',MXNITE) CALL STETER(309,'Try reducing smaller groups of nights.') END IF FIRST=.TRUE. IF (NEEDGN) THEN CALL STDRDC (IDAT, 'GAINTBL', 1, 1, 72, 1 NVALS, GAINTBL, IUNIT, NULLS, ISTAT) IF(ISTAT.NE.0)THEN CALL TV('Could not find GAINTBL descriptor.') CALL TERROR(INST,309,'Please fix data file.') END IF END IF C C get required columns: C C OBJECT: CALL TBLSER (IDAT, 'OBJECT', KOBJECT, ISTAT) IF (ISTAT.NE.0 .OR. KOBJECT.EQ.-1) 1 CALL TERROR(IDAT,310,'Could not find column OBJECT') C C SIGNAL: CALL TBLSER (IDAT, 'SIGNAL', KSIGNAL, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,310,'Could not find column SIGNAL') IF (KSIGNAL.EQ.-1) THEN C look for RAWMAG instead: CALL TBLSER(IDAT, 'RAWMAG', KRAWMAG, ISTAT) IF (ISTAT.NE.0 .OR. KRAWMAG.EQ.-1) THEN C See if this is a star file instead of a data file: CALL TBLSER(IDAT, 'RA', KRA, ISTAT) IF (KRA.GT.0) THEN C Star file. ISP = LWORD(DATFIL) ! RHW 4/10/1993 IF (ISP.GT.40) THEN CALL TV(DATFIL) CALL TV(' appears to be a STAR file, not DATA.') ELSE CARD=DATFIL(1:ISP)// 2 ' appears to be a STAR file, not DATA.' CALL TV(CARD) ENDIF ELSE C Not a star file. CARD='Could not find either column SIGNAL or RAWMAG in' CALL TV(CARD) CALL TVN(DATFIL) CARD='Is '//DATFIL(:LWORD(DATFIL))//' the right name?' CALL ASK(CARD,A1) IF (A1.EQ.'Y') THEN CALL TERROR(IDAT,310,'Please fix data.') ELSE END IF END IF NIGHT=NIGHT-1 DMS='next' GO TO 302 END IF ELSE C STARSKY: CALL TBLSER (IDAT, 'STARSKY', KSTARSKY, ISTAT) IF (ISTAT.NE.0 .OR. KSTARSKY.EQ.-1) 1 CALL TERROR(IDAT,310,'Could not find column STARSKY') END IF C C BAND: CALL TBLSER (IDAT, 'BAND', KBAND, ISTAT) IF (ISTAT.NE.0 .OR. KBAND.EQ.-1) 1 CALL TERROR(IDAT,310,'Could not find column BAND') C MJD_OBS: CALL TBLSER (IDAT, 'MJD_OBS', KMJDOBS, ISTAT) IF (ISTAT.NE.0 .OR. KMJDOBS.EQ.-1) 1 CALL TERROR(IDAT,310,'Could not find column MJD_OBS') C EXPTIME: CALL TBLSER (IDAT, 'EXPTIME', KEXPTIME, ISTAT) IF (ISTAT.NE.0 .OR. KEXPTIME.EQ.-1) 1 CALL TERROR(IDAT,310,'Could not find column EXPTIME') C C look for optional columns: C C COMMENT: CALL TBLSER (IDAT, 'COMMENT', KCOMMENT, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.COMMENT') C MJD_OBS: C OFSRA: CALL TBLSER (IDAT, 'SKYOFFSETRA', KOFSRA, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.SKYOFFSETRA') C OFSDEC: CALL TBLSER (IDAT, 'SKYOFFSETDEC', KOFSDEC, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.SKYOFFSETDEC') C SKYRA: CALL TBLSER (IDAT, 'SKYRA', KSKYRA, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.SKYRA') C SKYDEC: CALL TBLSER (IDAT, 'SKYDEC', KSKYDEC, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.SKYDEC') C FILTTEMP: CALL TBLSER (IDAT, 'FILTTEMP', KFILTTEMP, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.FILTTEMP') CALL KOLCHK(IDAT,'FILTTEMP',KFILTTEMP,HASFILTT,NDATFIL) C C DETTEMP: CALL TBLSER (IDAT, 'DETTEMP', KDETTEMP, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.DETTEMP') C C DOMETemp: CALL TBLSER (IDAT, 'DOMETEMP', KDOMETEMP, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.DOMETEMP') CALL KOLCHK(IDAT,'DOMETEMP',KDOMETEMP,HASDOMT,NDATFIL) C C RELHUM: CALL TBLSER (IDAT, 'RELHUM', KRELHUM, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.RELHUM') CALL KOLCHK(IDAT,'RELHUM',KRELHUM,HASRH,NDATFIL) C C PRESSURE: CALL TBLSER (IDAT, 'PRESSURE', KPRESSURE, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.PRESSURE') C DIAPHRAGM: CALL TBLSER (IDAT, 'DIAPHRAGM', KDIAPHRAGM, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.DIAPHRAGM') C PMTVOLTS: CALL TBLSER (IDAT, 'PMTVOLTS', KPMTVOLTS, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.PMTVOLTS') C GENEVA_Q: CALL TBLSER (IDAT, 'GENEVA_Q', KGENEVAQ, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.GENEVA_Q') C GENEVA_R: CALL TBLSER (IDAT, 'GENEVA_R', KGENEVAR, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.GENEVA_R') C GENEVA_G: CALL TBLSER (IDAT, 'GENEVA_G', KGENEVAG, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.GENEVA_G') C SEEING: CALL TBLSER (IDAT, 'SEEING', KSEEING, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.SEEING') C ESTERR: CALL TBLSER (IDAT, 'ESTERR', KESTERR, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,311,'ERROR looking for col.ESTERR') C C read data: C C ***** BEGIN Data-Reading loop ***** C *** DO 390 NROW=1,NROWS C *** CALL TBERDC (IDAT, NROW, KOBJECT, OBJNAM, NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,324,'Could not read OBJECT column.') C IF (NULL) THEN C skip comments. OBJNAM=' ' GO TO 390 END IF C C Make sure name is left-justified: IF (OBJNAM(:1) .EQ.' ') THEN DO 320 I=2,32 IF (OBJNAM(I:I).NE.' ') GO TO 321 320 CONTINUE C Name is all blanks: CALL TV('UNIDENTIFIED OBSERVATION') GO TO 390 C Name is indented: 321 CARD(:32)=OBJNAM(I:) OBJNAM=CARD(:32) END IF C C Look for special names: IF (OBJNAM(:4).EQ.'DARK') THEN DARK=.TRUE. NSTAR=-1 GO TO 353 ELSE IF (OBJNAM.EQ.'FILTTEMP') THEN NEEDFTI=.TRUE. NSTAR=-2 GO TO 353 ELSE IF (OBJNAM.EQ.'DETTEMP') THEN NEDDTI=.TRUE. NSTAR=-3 GO TO 353 ELSE IF (OBJNAM.EQ.'DOMETEMP') THEN NEDDMI=.TRUE. NSTAR=-4 GO TO 353 ELSE IF (OBJNAM.EQ.'RELHUM') THEN NEEDRHI=.TRUE. NSTAR=-5 GO TO 353 END IF C C Identify star: C C STARS(nstar) is name of nstar-th catalog entry. C NSTARS is total number of catalog entries. C NSTAR is index into star catalog for names, RAS, DECS, etc. C C STDNAMES is list of STD.names in canonical form; C NSTDNM is length of STDNAMES. C KSTARS(J) contains NSTAR value for std.name STDNAMES(J). C C LSTAR is index into supplemental name list, DICT; C LDICT is length of DICT. C NDICT(L) contains NSTAR value for LSTAR(L), C or 0 if star is to be ignored. C also: C ISTAR(nstar) is running number of star for reduction; C JSTAR(ISTAR(nstar))=NSTAR is reverse index. C ISTARS is max.value of ISTAR. C C try to identify star from name in catalogs: J=NBIN(OBJNAM, STDNAMES, NSTDNM) C 329 IF (J.GT.0) THEN C convert position J in STDNAMES list back to catalog number: NSTAR=KSTARS(J) C skip stars flagged to be ignored. IF (NSTAR.EQ.0) GO TO 390 C note that DMS will be set to some form of OBJNAM below. IF (DMS.NE.OBJNAM .AND. OBJNAM.NE.STARS(NSTAR)) THEN C DMS was changed below, then control looped back here. CARD=OBJNAM(:LWORD(OBJNAM))//' identified as '//STARS(NSTAR) CALL TVN(CARD) END IF DMS=OBJNAM GO TO 350 ELSE C not in STDNAMES; try to identify star from dictionary: C DO 330 LSTAR=1,LDICT IF(OBJNAM.EQ.DICT(LSTAR))THEN NSTAR=NDICT(LSTAR) C skip stars flagged to be ignored. IF (NSTAR.EQ.0) GO TO 390 C use identified star. GO TO 350 END IF 330 CONTINUE C not in dictionary either. C C try converting non-alphanumerics to blanks, and re-try: FLAGGED=.FALSE. DO 331 I=1,32 A1=OBJNAM(I:I) IF ( (A1.GE.'0' .AND. A1.LE.'9' .OR. 1 A1.GE.'A' .AND. A1.LE.'z') .AND. A1.NE.'_')THEN C alphanumeric; keep. DMS(I:I)=A1 ELSE DMS(I:I)=' ' IF (A1.NE.' ') FLAGGED=.TRUE. END IF 331 CONTINUE C Save name in case STDNAME changes DMS: STAR=DMS C DMS now has name, modified if FLAGGED; tokenize. C C Convert to canonical form: CALL STDNAME(DMS, NTOKEN) C Caution: DMS will be changed by STDNAME if it cannot be parsed! DO 332 K=1,NTOKEN TOKEN(K)=STAR5(K) LTOK(K)=LWORD(STAR5(K)) 332 CONTINUE C C got all the tokens now. C C again try to identify observed star from name in catalogs: J=NBIN(OBJNAM, STDNAMES, NSTDNM) IF (J.GT.0)THEN C Got a candidate. C convert position in STDNAMES list back to catalog number: NSTAR=KSTARS(J) C skip if this star is ignored: IF (NSTAR.EQ.0) GO TO 390 I=INDEX(OBJNAM,'=') C IF (I.EQ.0) THEN C no aliases in OBJNAM. IF (FLAGGED) GO TO 336 C Here if name was NOT fudged; DMS is still OBJNAM. I=LWORD(OBJNAM) ELSE C there are " = " aliases in OBJNAM. Check the 1st one: I=I-1 END IF C K=INDEX(STARS(NSTAR),OBJNAM(:I)) C IF (K.GT.0) THEN C Full object name (or 1st alias) is substring of candidate. GO TO 329 ELSE END IF C C Ask for help: 336 CARD='Is '//OBJNAM(:LWORD(OBJNAM))//' the same as ' CALL TV(CARD) CARD=STARS(NSTAR)(:LWORD(STARS(NSTAR)))//' ?' CALL ASKN(CARD,A1) IF (A1.EQ.'Y') THEN GO TO 329 ELSE IF (A1.EQ.'N') THEN C go on. ELSE CALL TV(' *** Please reply "YES" or "NO".') GO TO 336 END IF END IF C MAXHITS=0 NBEST=0 JOLD=0 DO 340 I=1,NSTDNM NHITS=0 JJ=0 DO 338 J=1,NTOKEN IF (INDEX(STDNAMES(I),TOKEN(J)(:LTOK(J))).GT.0) THEN NHITS=NHITS+LTOK(J)+1 IF (STDNAMES(I).EQ.TOKEN(J)) JJ=J C for debugging: C CALL TV(TOKEN(J)//' matched '//STDNAMES(I)) C CALL TVN(STARS(KSTARS(I))) END IF 338 CONTINUE IF (NHITS.GT.MAXHITS) THEN NBEST=I MAXHITS=NHITS JOLD=JJ END IF 340 CONTINUE C debugging: C WRITE(CARD,609)'nbest=',NBEST C CALL TV(CARD) C WRITE(CARD,609)'nhits=',NHITS C CALL TV(CARD) C IF (NBEST.GT.0) THEN C got a candidate. IF (JOLD.GT.0) THEN CARD=OBJNAM(:LWORD(OBJNAM))//' identified as '// 1 STDNAMES(NBEST) CALL TV(CARD) CALL SPACE A1='Y' ELSE CALL SPACE2 CARD='Is '//OBJNAM(:LWORD(OBJNAM))//' the same as '// 1 STDNAMES(NBEST)(:LWORD(STDNAMES(NBEST)))//' ?' CALL TV(CARD) CALL ASK(' ? ',A1) END IF K=KSTARS(NBEST) IF (A1.EQ.'Y') THEN LDICT=LDICT+1 IF (LDICT.GT.MDICT) THEN CALL EXCEED(LDICT,'MDICT ',MDICT) CALL STSEPI END IF DICT(LDICT)=OBJNAM NSTAR=K NDICT(LDICT)=NSTAR C standardize name... IF (FLAGGED .AND. DMS.EQ.STAR) THEN C name is new. Parse: CALL STDNAME(OBJNAM,NUMBER) ELSE C name already standardized at 332. NUMBER=NTOKEN END IF C ...then add to list & re-sort. DO 344 I=1,NUMBER NSTDNM=NSTDNM+1 IF (NSTDNM.GT.MSTARK) THEN CALL EXCEED(NSTDNM,'MSTARK',MSTARK) CALL STETER(344, 1 'Increase parameter MSTARS, recompile') END IF KSTARS(NSTDNM)=NSTAR STDNAMES(NSTDNM)=STAR5(I) 344 CONTINUE CALL SRTNAM(STDNAMES,KSTARS,NSTDNM) GO TO 350 ELSE END IF ELSE C no candidate. CALL SPACE CARD='No matches at all for '//OBJNAM CALL TV(CARD) END IF END IF C LDICT=LDICT+1 IF (LDICT.GT.MDICT) THEN CALL EXCEED(LDICT,'MDICT ',MDICT) CALL STSEPI END IF DICT(LDICT)=OBJNAM C CARD=OBJNAM(:LWORD(OBJNAM))//' not found' CALL TV(CARD) CALL ASK('Do you want to ignore this star?',A1) IF (A1.EQ.'Y') THEN C Add to list of rejects. NDICT(LDICT)=0 GO TO 390 ELSE C solicit stellar data here. NSTARS=NSTARS+1 NSTAR=NSTARS C see if there is room: IF (NSTAR.GT.MSTARS) THEN CALL EXCEED(NSTAR,'MSTARS',MSTARS) NSTARS=NSTARS-1 CALL TV('Too many stars -- ignored.') GO TO 390 END IF C add names to lists: NDICT(LDICT)=NSTAR C standardize name... CALL STDNAME(OBJNAM,NUMBER) C ...then add to list & re-sort. DO 346 I=1,NUMBER NSTDNM=NSTDNM+1 IF (NSTDNM.GT.MSTARK) THEN CALL EXCEED(NSTDNM,'MSTARK',MSTARK) CALL STETER(346, 1 'Increase parameter MSTARS, recompile') END IF KSTARS(NSTDNM)=NSTAR STDNAMES(NSTDNM)=STAR5(I) 346 CONTINUE CALL SRTNAM(STDNAMES,KSTARS,NSTDNM) CALL SPACE2 C Get the rest of the stuff: CARD='Please enter information for: '//OBJNAM CALL TV(CARD) STARS(NSTAR)=OBJNAM CALL ADDSTR(EQUINX(NSTAR),RAS(NSTAR),DECS(NSTAR)) IF(EQUINX(NSTAR).EQ.0.) EQUINX(NSTAR)=3.E33 348 CALL SPACE CALL TV('Is this a Standard, Constant, Variable, or') CALL ASKN(' unclassified Program star?',A1) IF(A1.EQ.'S' .OR. A1.EQ.'C' .OR. A1.EQ.'V' .OR. A1.EQ.'P')THEN STYPE(NSTAR)=A1 ELSE CALL TV('Please enter one of the capitalized letters.') GO TO 348 END IF END IF C C ***** Star identified. Read data values: ***** C 350 CONTINUE C see if it is already in list: DO 351 I=1,ISTARS IF (JSTAR(I).EQ.NSTAR) GO TO 352 351 CONTINUE C Not in list, so add it: ISTARS=ISTARS+1 IF(NSTAR.GT.MSTARS) THEN CALL EXCEED(NSTAR,'MSTARS',MSTARS) CALL STETER(351,'Too many star names') END IF ISTAR(NSTAR)=ISTARS JSTAR(ISTARS)=NSTAR 352 CONTINUE C 353 NDATA=NDATA+1 IF (NDATA.GT.MXOBS) THEN CALL EXCEED(NDATA,'MXOBS ',MXOBS) CALL STSEPI END IF NSTR(NDATA)=NSTAR NITE(NDATA)=NIGHT C C get observational data from table file: C C C *** Begin with REQUIRED data... *** C C C Timing data: type location C ---- -------- C DJD is MJDOBS read from data file DP local C DJZ is zero-point for whole data set DP local C DTZERO(n) is start of night n DP obs.inc C T is time in Julian centuries from J2000. sp local C DJOBS(ndata) is offset from DTZERO(n) to datum sp obs.inc C C To reconstruct MJDOBS of datum, add DTZERO(n) + DJOBS(ndata) C C C MJD_OBS: C CALL TBERDD (IDAT, NROW, KMJDOBS, DJD, NULL, ISTAT) IF(ISTAT.NE.0 .OR. NULL) 1 CALL TERROR(IDAT,353,'Could not read MJD_OBS column.') C IF (FIRST) THEN C first record of current data file (night). DTZERO(NIGHT)=DINT(DJD) IF (NDATA.EQ.1) DJZ=DINT(DJD)+1.D0 DJMIN=DJD-DTZERO(NIGHT) C set STUTZ in COMMON/SPHERE/: T=(DTZERO(NIGHT)-51544.5)/36525. C Julian centuries from J2000.0 CALL STUTZR(T) EPOCH=2000.+T*100. TIMIN=MIN(TIMIN,DTZERO(NIGHT)) FIRST=.FALSE. ELSE C set end of time scale. TIMAX=MAX(TIMAX,DJD) END IF C DJOBS(NDATA)=DJD-DTZERO(NIGHT) DJMAX=DJD-DTZERO(NIGHT) C IF (NSTAR.LT.0) THEN C dark, temp. or RH. IF (NSTAR.EQ.-1) THEN C dark. IF (NDETS.GT.1) GO TO 360 GO TO 367 ELSE C don't need signal for temps & RH. GO TO 370 END IF END IF C C ** IF (KSIGNAL.GT.0)THEN C ** C STAR/SKY flag (stored in DTYPE): C CALL TBERDC (IDAT, NROW, KSTARSKY, STARSKY, NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,350,'Could not read STARSKY column.') C C Set RA & DEC here for star & sky separately: C IF(STARSKY.EQ.'STAR') THEN DTYPE(NDATA)='S' RA=RAS(NSTAR) DEC=DECS(NSTAR) ELSE IF (STARSKY.EQ.'SKY') THEN DTYPE(NDATA)='Y' C get sky position... IF (KOFSRA.GT.0) THEN CALL TBERDR(IDAT, NROW, KOFSRA, OFSRA, NULL, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,351,'Could not read SKYOFFSETRA column.') RA=RAS(NSTAR)+OFSRA/206265. ELSE IF (KSKYRA.GT.0) THEN CALL TBERDR(IDAT, NROW, KSKYRA, RA, NULL, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,351,'Could not read SKYRA column.') ELSE RA=RAS(NSTAR) END IF C Note that ALT/AZ offsets are not implemented.... C IF (KOFSDEC.GT.0) THEN CALL TBERDR(IDAT, NROW, KOFSDEC, OFSDEC, NULL, ISTAT) IF (ISTAT.NE.0) 1 CALLTERROR(IDAT,351,'Could not read SKYOFFSETDEC column.') DEC=DECS(NSTAR)+OFSDEC/206265. ELSE IF (KSKYDEC.GT.0) THEN CALL TBERDR(IDAT, NROW, KSKYDEC, DEC, NULL, ISTAT) IF (ISTAT.NE.0) 1 CALL TERROR(IDAT,351,'Could not read SKYDEC column.') ELSE DEC=DECS(NSTAR) END IF C ELSE IF(STARSKY.EQ.'DIFF') THEN DTYPE(NDATA)='S' RA=RAS(NSTAR) DEC=DECS(NSTAR) ELSE CALL TERROR (IDAT, 352, 'Illegal STAR/SKY value.') END IF C ** ELSE IF (KRAWMAG.GT.0) THEN C ** IF (NSTAR.LT.0) GO TO 370 IF(STARSKY.EQ.'DIFF') THEN DTYPE(NDATA)='S' RA=RAS(NSTAR) DEC=DECS(NSTAR) ELSE IF (STARSKY.EQ.'SKY') THEN DTYPE(NDATA)='Y' END IF C ** ELSE C ** CALL TERROR (IDAT, 352, 'No intensity data!') C ** END IF C ** C C C Update position: C C C See if p.m. is available: C IF (KMUALPHA.GT.0 .AND. KMUDELTA.GT.0 .AND. KEPOCH.GT.0) THEN C Correct position for p.m. C muALPHA is seconds of TIME per annum. RA=RA+ALPMUS(NSTAR)*(EPOCH-EPOCHS(NSTAR))/(206265./15.) C muDELTA is seconds of ARC per annum. DEC=DEC+DELTMUS(NSTAR)*(EPOCH-EPOCHS(NSTAR))/206265. END IF C C Precess position to current epoch: IF (OLDEP.EQ.EPOCH .AND. OLDEQX.EQ.EQUINX(NSTAR)) THEN CALL PRECST(RA,DEC) ELSE CALL PRECEP(EQUINX(NSTAR),EPOCH,RA,DEC) WRITE(CARD,'(2(A,F8.2))')'Precess from',EQUINX(NSTAR), 1 ' to',EPOCH CALL TV(CARD) CALL SPACE OLDEP=EPOCH OLDEQX=EQUINX(NSTAR) END IF C UTRAD=(DJD-DTZERO(NIGHT))*TWOPI HA=STUTZ+(UTRAD*1.00273791)+ELONG-RA COSDEL=COS(DEC) SINDEL=SIN(DEC) COSHA=COS(HA) COSZ=SINPHI*SINDEL+COSPHI*COSDEL*COSHA C IF (COSZ.LT.-0.005) THEN CARD='Problem with '//OBJNAM CALL TV(CARD) WRITE(CARD,'(''at MJD '',F12.4)')DTZERO(NIGHT)+DJOBS(NDATA) CALL TVN(CARD) CALL TVN('ERROR: position below horizon!') CALL TVN(' (Datum ignored.)') NDATA=NDATA-1 GO TO 390 ELSE AIRM(NDATA)=(.0096467+COSZ*(.148386+1.002432*COSZ))/ 1 (.000303978+COSZ*(.0102963+COSZ*(.149864+COSZ))) XSTAR= - COSDEL*SIN(HA) YSTAR=SINDEL*SINPHI-COSDEL*COSPHI*COSHA AZIM(NDATA)=ATAN2(YSTAR,XSTAR) END IF C C C BAND (and NDFILT) : C 360 CONTINUE CALL TBERDC (IDAT, NROW, KBAND, BAND, NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,360,'Could not read BAND column.') IF (NULL) THEN CARD='Missing BAND info for '//OBJNAM(:LWORD(OBJNAM)) WRITE(CARD(:LWORD(CARD)+1),'('' at MJD ='',F12.5)') DJD CALL TV(CARD) NDATA=NDATA-1 GO TO 390 END IF C L=INDEX(BAND,'ND') J=INDEX(BAND,'RL') DO 361 K=1,NBANDS C check for RL suffix: IF (J.NE.0) THEN IF (BAND(:J-1).EQ.BANDS(K)(:LENB)) GO TO 363 ELSE C check for ND suffix: IF (L.EQ.0) THEN C No ND filter. See if full name matches. IF (BAND.EQ.BANDS(K)(:LENB)) GO TO 363 ELSE C Split out ND filter. IF (BAND(:L-1).EQ.BANDS(K)(:LENB)) GO TO 363 END IF END IF 361 CONTINUE C IF (BAND.EQ.' ') THEN NDATA=NDATA-1 GO TO 390 ELSE IF (NDETS.GT.1 .AND. BAND(:4).EQ.'DARK') THEN C extract detector number. READ (BAND(5:6),'(BN,I2)')NDET C Dark, so store ndet in filter. KBND(NDATA)=NDET GO TO 367 ELSE IF (NDETS.EQ.1 .AND. BAND(:4).EQ.'DARK') THEN C Dark, so store ndet in filter. KBND(NDATA)=1 GO TO 367 END IF C DO 362 NB=1,NBREJ IF (BAND.EQ.BNDREJ(NB)) THEN NDATA=NDATA-1 GO TO 390 END IF 362 CONTINUE C CARD(:9)=BAND CARD(10:)='unknown in system '//SYSTEM CALL TV(CARD) CALL ASK('Do you want to ignore all data in this band?',A1) IF (A1.EQ.'Y') THEN NBREJ=NBREJ+1 BNDREJ(NBREJ)=BAND NDATA=NDATA-1 GO TO 390 ELSE CALL TERROR (IDAT,363,'Unknown band name.') END IF C 363 CONTINUE C We now have filter band identified as K. Save ND data: IF (L.EQ.0) THEN C No ND filter. NDFILT(NDATA)=' ' ELSE C Split out ND filter. NDFILT(NDATA)=BAND(L:) END IF C C Identify ND setting: (see 225 for ND info) DO 364 ND=1,NDS IF (NDFILT(NDATA).EQ.NDNAME(ND)) GO TO 366 364 CONTINUE C Neutral filter not identified; add to list. NDS=NDS+1 IF (NDS.GT.MBANDS)THEN CALL TV('Too many neutral-density filters !') CALL EXCEED(NDS,'MBANDS',MBANDS) CALL STSEPI END IF C Handle default case: IF (NDFILT(NDATA).EQ.' ') THEN GO TO 366 END IF ND=NDS NDNAME(ND)=NDFILT(NDATA) CALL SPACE2 CALL TV('By what factor should signals measured through') CARD='neutral filter '//NDFILT(NDATA)//' be multiplied?' CALL QF(CARD,XND(ND,K)) DO 365 KK=1,NBANDS XND(ND,KK)=XND(ND,K) 365 CONTINUE C 366 KBND(NDATA)=K KMIN=MIN(KMIN,K) KMAX=MAX(KMAX,K) IF (K.LE.NBANDS) LASTK=MAX(LASTK,K) IF (NDETS.GT.1) NDET=NDTUSD(K) C 367 CONTINUE C C C SIGNAL and EXPTIME: C C Get exposure time first: CALL TBERDR (IDAT, NROW, KEXPTIME, EXPTIM(NDATA), NULL, ISTAT) IF(ISTAT.NE.0 .OR. NULL) 1 CALL TERROR(IDAT,367,'Could not read EXPTIME column.') IF (EXPTIM(NDATA).LE.0.) THEN CALL SPACE WRITE(CARD,'(''EXPTIME = '',G12.2,'' for'')') EXPTIM(NDATA) CALL TV(CARD) WRITE(CARD,'(A32,'' at '',F12.5)') STARS(NSTAR),DJD CALL TVN(CARD) CALL TV('Do you wish to Ignore this datum and continue (I),') CALL ASKN(' or to Quit (Q)?',A1) C ASKN kills pgm.on Q. CALL TV('Datum will be ignored. Please correct data file.') NDATA=NDATA-1 GO TO 390 END IF C C ** IF (KSIGNAL.GT.0)THEN C ** CALL TBERDR (IDAT, NROW, KSIGNAL, SIGNAL(NDATA), NULL, ISTAT) IF(ISTAT.NE.0 .OR. NULL) 1 CALL TERROR(IDAT,368,'Could not read SIGNAL column.') C convert SIGNAL to intensity units (count RATE). SIGNAL(NDATA)=SIGNAL(NDATA)/EXPTIM(NDATA) C save photon variance in PHVAR = I/t. PHVAR(NDATA)=SIGNAL(NDATA)/EXPTIM(NDATA) C IF (PC(NDET)) THEN C Correct for NOMINAL dead time. ARG=SIGNAL(NDATA)*DEDTS(NDET) IF (DEDTYP(NDET).EQ.'EXT')THEN SIGNAL(NDATA)=SIGNAL(NDATA)/(1.-ARG*(1.+0.5*ARG)) ELSE IF (DEDTYP(NDET).EQ.'NON')THEN SIGNAL(NDATA)=SIGNAL(NDATA)/(1.-ARG) ELSE IF (DEDTYP(NDET).EQ.'UNK')THEN SIGNAL(NDATA)=SIGNAL(NDATA)/(1.-ARG*(1.+0.25*ARG)) END IF END IF C C ** ELSE IF (KRAWMAG.GT.0) THEN C ** CALL TBERDR (IDAT, NROW, KRAWMAG, RAWMAG, NULL, ISTAT) IF(ISTAT.NE.0 .OR. NULL) 1 CALL TERROR(IDAT,368,'Could not read RAWMAG column.') C convert SIGNAL to intensity units. SIGNAL(NDATA)=10.**(-0.4*RAWMAG) C ** ELSE C ** CALL TERROR (IDAT, 369, 'No intensity data!') C ** END IF C ** C C Correct intensity for nominal ND filter values: IF (NSTR(NDATA).GT.0) SIGNAL(NDATA)=SIGNAL(NDATA)*XND(ND,K) C C Collect ND info: C C increment count. ND2NP(ND,K)=ND2NP(ND,K)+1 C Is ND in NUM2ND index? DO 369 NUM=1,NUMNDS IF (ND.EQ.NUM2ND(NUM)) GO TO 370 369 CONTINUE C C No. Add to list. NUMNDS=NUMNDS+1 NUM2ND(NUMNDS)=ND NUM=NUMNDS C C Yes. C 370 CONTINUE C C *** Now for optional independent variables: *** C C C FILTTEMP: C IF (KFILTTEMP.GT.0) THEN CALL TBERDR (IDAT, NROW, KFILTTEMP, FILTTEMP, NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,370,'Could not read FILTTEMP column.') IF (NULL .AND. NSTAR.EQ.-2) THEN CALL TERROR(IDAT,370,'Expected FILTTEMP, but no datum.') ELSE FTMP(NDATA)=FILTTEMP END IF END IF C C DETTEMP: C IF (KDETTEMP.GT.0) THEN CALL TBERDR (IDAT, NROW, KDETTEMP, DETTEMP, NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,371,'Could not read DETTEMP column.') IF (NULL .AND. NSTAR.EQ.-3) THEN CALL TERROR(IDAT,371,'Expected DETTEMP, but no datum.') ELSE DTMP(NDATA)=DETTEMP END IF END IF C C DOMETEMP: C IF (KDOMETEMP.GT.0) THEN CALL TBERDR (IDAT, NROW, KDOMETEMP, DOMETEMP, NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,372,'Could not read DOMETEMP column.') IF (NULL .AND. NSTAR.EQ.-4) THEN CALL TERROR(IDAT,372,'Expected DOMETEMP, but no datum.') ELSE DOME(NDATA)=DOMETEMP END IF END IF C C RELHUM: C IF (KRELHUM.GT.0) THEN CALL TBERDR (IDAT, NROW, KRELHUM, RELHUM, NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,373,'Could not read RELHUM column.') IF (NULL .AND. NSTAR.EQ.-5) THEN CALL TERROR(IDAT,373,'Expected RELHUM, but no datum.') ELSE RELH(NDATA)=RELHUM END IF END IF C C PRESSURE: C IF (KPRESSURE.GT.0) THEN CALL TBERDR (IDAT, NROW, KPRESSURE, PRESSURE, NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,374,'Could not read PRESSURE column.') IF (NULL) THEN C forget it. ELSE PRESS(NDATA)=PRESSURE END IF END IF C C DIAPHRAGM: C IF (KDIAPHRAGM.GT.0) THEN CALL TBERDC (IDAT, NROW, KDIAPHRAGM, DIAPH(NDATA), NULL,ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,375,'Could not read DIAPHRAGM column.') IF (NULL) THEN C forget it. ELSE C Identify diaphragm: DO 375 NDIA=1,NDIAS IF (DIAPH(NDATA).EQ.DIANAM(NDIA)) GO TO 376 375 CONTINUE C Here for new diaphragm: NDIAS=NDIAS+1 IF (NDIAS.GT.MBANDS) THEN CALL TV('Too many diaphragms!') CALL EXCEED(NDIAS,'MBANDS',MBANDS) CALL STSEPI END IF NDIA=NDIAS DIANAM(NDIA)=DIAPH(NDATA) NP2NDIA(NDIA)=0 C Diaphragm is NDIA. Increment count in NP2NDIA: 376 NP2NDIA(NDIA)=NP2NDIA(NDIA)+1 END IF END IF C C PMTVOLTS: C IF (KPMTVOLTS.GT.0) THEN CALL TBERDC (IDAT, NROW, KPMTVOLTS, PMTV(NDATA), NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,376,'Could not read PMTVOLTS column.') END IF C C C GENEVAQ: C IF (KGENEVAQ.GT.0) THEN CALL TBERDR (IDAT, NROW, KGENEVAQ, GENEVAQ, NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,377,'Could not read GENEVA_Q column.') IF (NULL) THEN C forget it. ELSE GENQ(NDATA)=GENEVAQ END IF END IF C C GENEVAR: C IF (KGENEVAR.GT.0) THEN CALL TBERDR (IDAT, NROW, KGENEVAR, GENEVAR, NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,378,'Could not read GENEVA_R column.') IF (NULL) THEN C forget it. ELSE GENR(NDATA)=GENEVAR END IF END IF C C GENEVAG: C IF (KGENEVAG.GT.0) THEN CALL TBERDR (IDAT, NROW, KGENEVAG, GENEVAG, NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,379,'Could not read GENEVA_G column.') IF (NULL) THEN C forget it. ELSE GENG(NDATA)=GENEVAG END IF END IF C C SEEING: C IF (KSEEING.GT.0) THEN CALL TBERDC (IDAT, NROW, KSEEING, SEEING(NDATA), NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,380,'Could not read SEEING column.') END IF C C ESTERR: C IF (KESTERR.GT.0) THEN CALL TBERDR (IDAT, NROW, KESTERR, ESTERR, NULL, ISTAT) IF(ISTAT.NE.0) 1 CALL TERROR(IDAT,381,'Could not read ESTERR column.') IF (NULL) THEN C forget it. ESTER(NDATA)=0. ELSE IF (KSIGNAL.GT.0) THEN C exposure read in; convert to intensity. ESTER(NDATA)=ESTERR*XND(ND,K)/EXPTIM(NDATA) ELSE C magnitudes read in; convert error to intensity. ESTER(NDATA)=ESTERR*SIGNAL(NDATA) END IF END IF ELSE ESTER(NDATA)=0. END IF C C C END of data-reading loop. C C C We now have: C C star number in NSTR(ndata) C night number in NITE(ndata) C band number in KBND(ndata) (NDET = NDTUSD(KBND(ndata)) ) C (NDET = KBND(ndata) if nstr < 0 ) C JD of 0h UT in DTZERO(night) (integer day) C JD offset in DJOBS(ndata) (real day fraction) C JD zero in DJZ (for whole set) C air mass in AIRM(ndata) C azimuth in AZIM(ndata) C Star/skY in DTYPE(ndata) (single char.) C exp.time in EXPTIM(ndata) C intensity in SIGNAL(ndata) C photon noise in PHVAR(ndata) C and: C filt.temp. in FTMP(ndata) C det. temp. in DTMP(ndata) C dome temp. in DOME(ndata) C relative hum.in RELH(ndata) C pressure in PRESS(ndata) C seeing in SEEING(ndata) C diaphragm in DIAPH(ndata) C PMT volts in PMTV(ndata) C ND filter in NDFILT(ndata) (name, not number) C Geneva Q in GENQ(ndata) C Geneva R in GENR(ndata) C Geneva G in GENG(ndata) C error est. in ESTER(ndata) C C C ***** END of Data-Reading loop ***** C C *** 390 CONTINUE C *** C TIMID(NIGHT)=(DJMAX+DJMIN)*0.5 C C close data file: C CALL TBTCLO(IDAT, ISTAT) IF(ISTAT.NE.0) CALL TERROR(IDAT,389,'Could not close data file.') C C 391 CALL SPACE2 CALL TV('The following data files have been read:') CALL SPACE DO 392 I=1,NDATFIL CARD=' '//DATFILS(I)(:75) 392 CALL TVN(CARD) CALL SPACE WRITE(CARD,'(I5,'' data read'')') NDATA CALL TV(CARD) WRITE(CARD,'(I5,'' spaces remain'')') MXOBS-NDATA CALL TVN(CARD) CALL SPACE IF (CATALOG) THEN GO TO 303 ELSE CALL ASKFIL('Another data file?',DATFIL) END IF C 395 IF (MATCH(DATFIL,'YES') .OR. MATCH(DATFIL,'yes'))THEN C go back to using DMS as word buffer. DMS='next' GO TO 302 ELSE IF (MATCH(DATFIL,'NO') .OR. MATCH(DATFIL,'no'))THEN C go on. ELSE GO TO 303 END IF C C ***** END of DATA files !! ***** C C C Summarize data and build ND indices: C NDK=0 DO 400 ND=1,NDS C For each position used, see which bands are affected: DO 400 K=KMIN,KMAX IF (ND2NP(ND,K).GT.0) THEN C if usage is nonzero, replace with running index. NDK=NDK+1 NP2ND(NDK)=ND NP2K(NDK)=K ND2NP(ND,K)=NDK END IF 400 CONTINUE C C NDK is the running index for the (ND,K) combinations used. C ND2NP(nd,k) contains NDK for each (ND,K) combination. C (was usage count previously) C NP2ND(ndk) contains ND for each NDK value. C C C C Find range of detector numbers used: C MINDET=999 MAXDET=0 DO 401 K=KMIN,KMAX NDET=NDTUSD(K) MINDET=MIN(MINDET,NDET) MAXDET=MAX(MAXDET,NDET) 401 CONTINUE C CALL SPACE WRITE(CARD,'(I4,A)') NUMNDS,' neutral-density positions used.' CALL TV(CARD) C WRITE(CARD,'(I4,A)') NDIAS,' diaphragm positions used.' IF (NDIAS.GT.0) THEN CALL TV(CARD) CARD='***** CAUTION: Diaphragms are NOT correctly treated' CARD(54:)='in this version!' CALL TV(CARD) END IF C C DONE=.FALSE. TIMFLGA=.FALSE. TIMFLGZ=.FALSE. C C C Summarize stars: C CALL SPACE CARD='List of stars observed: Type (S=Std, X=eXt, P=Pgm)' CALL TV(CARD) CALL SPACE NSTDS=0 NEXTS=0 NPGMS=0 NVARS=0 DO 402 I=1,ISTARS J=JSTAR(I) IF (STYPE(J).EQ.'S')THEN NSTDS=NSTDS+1 ELSE IF (STYPE(J).EQ.'X')THEN NEXTS=NEXTS+1 ELSE IF (STYPE(J).EQ.'P')THEN NPGMS=NPGMS+1 ELSE IF (STYPE(J).EQ.'V')THEN NVARS=NVARS+1 ELSE CARD='Unknown STYPE for '//STARS(J) CALL TV(CARD) END IF WRITE(CARD,'(I4,'': '',A32,2X,A1)') I,STARS(J),STYPE(J) CALL TVN(CARD) 402 CONTINUE C CALL SPACE2 WRITE (CARD,'(I5,'' total data'')') NDATA CALL TV(CARD) NIGHTS=NIGHT WRITE (CARD,'(I5,'' nights'')') NIGHTS IF (NIGHTS.EQ.1) CARD(12:12)=' ' CALL TV(CARD) WRITE (CARD,'(I5,'' stars'')') ISTARS CALL TV(CARD) CALL SPACE2 WRITE (CARD,'(I5,'' STD. stars'')') NSTDS IF (NSTDS.EQ.1) CARD(20:)='<-- !!! ???' CALL TV(CARD) WRITE (CARD,'(I5,'' EXT. stars'')') NEXTS IF (NEXTS.EQ.1) CARD(16:16)=' ' CALL TV(CARD) WRITE (CARD,'(I5,'' PGM. stars'')') NPGMS IF (NPGMS.EQ.1) CARD(16:16)=' ' CALL TV(CARD) WRITE (CARD,'(I5,'' VAR. stars'')') NVARS IF (NVARS.EQ.1) CARD(16:16)=' ' CALL TV(CARD) CALL SPACE2 CALL RTNCON(' ',1) C C C Indicate points outside plots. CALL PLOT(0,0.,1.,'O') C C C see if MeteorologicaL data need interpolation: C IF (NEEDFTI) THEN CALL POLYGON(FTMP,-2,'FILTER Temperature vs. time') END IF C IF (NEDDTI) THEN CALL SPACE2 CALL POLYGON(DTMP,-3,'DETECTOR Temperature vs. time') END IF C IF (NEDDMI) THEN CALL SPACE2 CALL POLYGON(DOME,-4,'DOME Temperature vs. time') IF (KFILTTEMP.LT.0) THEN C use dome temp for filters. DO 418 I=1,NDATA FTMP(I)=DOME(I) 418 CONTINUE END IF IF (KDETTEMP.LT.0) THEN C use dome temp for detectors. DO 419 I=1,NDATA DTMP(I)=DOME(I) 419 CONTINUE END IF END IF C IF (NEEDRHI) THEN CALL SPACE2 CALL POLYGON(RELH,-5,'Relative Humidity vs. time') END IF C C (END of MeteorologicaL interpolations.) C C C C Subtract DARK: C IF (DARK) THEN C C look for DETTEMP: C DO 440 NDET=MINDET,MAXDET C loop over detectors: C IF (COOL(NDET)(:4).EQ.'MEAS' .OR. C measured. 1 COOL(NDET)(:4).EQ.'NONE' .AND. KDOMETEMP.GT.0) THEN C dome temp.used. CALL DARKFIT(NDET,NDTUSD,DETNAME(NDET)) ELSE IF (COOL(NDET)(:4).EQ.'REGU') THEN C regulated. CALL TV('As detector temperature is REGULATED,') CALL TVN('you should probably select a Constant or') CALL TVN('Linear fit for each night.') CALL SPACE CALL RTNCON(' (not a polygon fit)',21) CALL DARKPOLY(NDET,NDTUSD,DETNAME(NDET)) ELSE CALL DARKPOLY(NDET,NDTUSD,DETNAME(NDET)) END IF C 440 CONTINUE C ELSE C CALL SPACE2 CALL TV(' No DARK data available.') CALL TVN(' ======================') C END IF C C (END of DARK subtraction.) C C C Subtract SKY: C IF (KSIGNAL.NE.-1) THEN C expect sky data to subtract, if intensities instead of RAWMAG. CALL SKYSUB(BANDS,KMIN,KMAX,DTYPE,KDIAPHRAGM,EXTIN) C Restore normal plotting. CALL PLOT(0,0.,0.,'O') C END IF C C (END of SKY subtraction.) C C IF (KMAX.GT.NBANDS) THEN C C Subtract RED LEAKS: C CALL REDSUB(BANDS,KMIN,KMAX,LASTK,MAXKS,DTYPE) C ELSE IF (MAXKS.GT.NBANDS) THEN C expected to measure red leaks, but found no data. CALL TV(' No red-leak data!') CALL TVN(' ================') END IF C C (END of RED-LEAK subtraction.) C KMAX=LASTK C C Set parameters we need later: KMINM1=KMIN-1 C NKS is number of colors actually used. NKS=KMAX-KMINM1 KMID=(KMIN+KMAX+1)/2 C C C Now squeeze out non-stellar data, as we are done with them: C NPT=0 DO 460 J=1,NDATA IF (NSTR(J).LE.0 .OR. DTYPE(J).NE.'S' .OR. C also discard red-leak data. 1 KBND(J).GT.LASTK) GO TO 460 NPT=NPT+1 NSTR(NPT)=NSTR(J) NITE(NPT)=NITE(J) KBND(NPT)=KBND(J) AIRM(NPT)=AIRM(J) AZIM(NPT)=AZIM(J) DJOBS(NPT)=DJOBS(J) EXPTIM(NPT)=EXPTIM(J) SIGNAL(NPT)=SIGNAL(J) PHVAR(NPT)=PHVAR(J) FTMP(NPT)=FTMP(J) DTMP(NPT)=DTMP(J) DOME(NPT)=DOME(J) RELH(NPT)=RELH(J) PRESS(NPT)=PRESS(J) SEEING(NPT)=SEEING(J) DIAPH(NPT)=DIAPH(J) PMTV(NPT)=PMTV(J) NDFILT(NPT)=NDFILT(J) GENQ(NPT)=GENQ(J) GENR(NPT)=GENR(J) GENG(NPT)=GENG(J) ESTER(NPT)=ESTER(J) 460 CONTINUE C revise effective data count. NDATA=NPT C C C Convert std. indices in star catalog to magnitudes: C DO 480 I=1,NSTARS DO 476 K=KMIN,KMAX ZDUM(K)=0. DO 475 KK=1,NBANDS ZDUM(K)=ZDUM(K) + COLORS(KK,I)*COLRIN(KK,K) 475 CONTINUE 476 CONTINUE DO 478 K=1,NBANDS IF (ABS(ZDUM(K)).LT.1.E33)THEN COLORS(K,I)=ZDUM(K) ELSE COLORS(K,I)=3.E33 END IF 478 CONTINUE 480 CONTINUE C C C Remark: We have to wait until indices are converted to mags, as we C need COLORS below, but input values may be CURVATURES (as in uvby). C C See if we can use 3-pt. interpolation for gradients: C IF (KMAX-KMIN.GT.1 .AND. NSTDS.GT.9) THEN C there are enough data to consider this. CALL SPACE2 CALL PLOT(0,59.,22.,'P') C BEGIN loop over colors. DO 490 K=KMIN,KMAX K1=MAX(K-1,KMIN) IF (K.EQ.KMAX) K1=KMAX-2 K2=K1+2 C prepare to compute correlation coeff. between colors: C (use dumb brute-force method; salvage with double-precision.) C (This is possible because indexes are near zero, in general.) N=0 SUMX=0. SUMY=0. SUMXX=0. SUMXY=0. SUMYY=0. DO 485 I=1,ISTARS J=JSTAR(I) IF (STYPE(J).EQ.'S' .AND. COLORS(K1,J).NE.3.E33 .AND. 1 COLORS(K1+1,J).NE.3.E33 .AND. COLORS(K1+2,J).NE.3.E33)THEN C std.star J in catalog has data. N=N+1 XBAR=COLORS(K1,J)-COLORS(K1+1,J) YBAR=COLORS(K1+1,J)-COLORS(K1+2,J) SUMX=SUMX+XBAR SUMY=SUMY+YBAR SUMXX=SUMXX+XBAR*XBAR SUMXY=SUMXY+XBAR*YBAR SUMYY=SUMYY+YBAR*YBAR XS(N)=XBAR YS(N)=YBAR END IF 485 CONTINUE L1=LWORD(BANDS(K1)) L=LWORD(BANDS(K1+1)) L2=LWORD(BANDS(K1+2)) CALL NEED(24) COVAR=(N*SUMXY - SUMX*SUMY)/ 1 SQRT((N*SUMXX - SUMX*SUMX) * (N*SUMYY - SUMY*SUMY)) CARD='Covariance between ('// 1 BANDS(K1)(:L1)//' - '//BANDS(K1+1)(:L)//') and ('// 2 BANDS(K1+1)(:L)//' - '//BANDS(K1+2)(:L2)//') =' WRITE(CARD(LWORD(CARD)+1:),'(F6.3)') COVAR CALL CENTER(CARD) C print Y-axis label: CARD=' ('//BANDS(K1+1)(:L)//' - '//BANDS(K1+2)(:L2)//')' CALL TVN(CARD) CALL PLOT(N,XS,YS,'*') C print X-axis label: CARD=' ('//BANDS(K1)(:L1)//' - '//BANDS(K1+1)(:L)//')' CALL TVN(CARD) 488 CARD='Do you want to use both colors in transforming '// 1 BANDS(K) CARD(LWORD(CARD)+2:)='?' CALL ASKN(CARD,A1) IF (A1.EQ.'Y') THEN USE3PT(K)=.TRUE. USES3PTS=.TRUE. ELSE IF (A1.EQ.'N') THEN C flag was already set .FALSE. ELSE IF (HELP(A1)) THEN C offer advice: CALL SPACE CARD(4:25)='The second color adds' WRITE(CARD(26:31),'(F5.1)') SQRT(1.-ABS(COVAR))*100. CARD(32:)='% as much information as the first.' IF (ABS(COVAR).GT.0.99) THEN PAGE(1)=CARD(26:) CARD(26:31)='only' CARD(32:)=PAGE(1) END IF CALL TV(CARD) IF (COVAR.LT.0.9) THEN CALL TV(' Looks good; say YES.') ELSE IF (COVAR.LT.0.98) THEN CALL TV(' May be helpful.') ELSE IF (COVAR.LT.0.994) THEN CALL TV(' Marginal; hard to say.') ELSE CALL TV(' Looks pretty hopeless. Say NO.') END IF GO TO 488 ELSE CALL TV('Please reply Yes, No, or Help.') GO TO 488 END IF 490 CONTINUE C END loop over colors. CALL PLOT(0,79.,23.,'P') END IF C C C Convert intensities to magnitudes, preserving info on neg.values: C NSTDOBS=0 NEXTOBS=0 N=0 DO 510 I=1,NDATA J=NSTR(I) IF (STYPE(J).EQ.'S') NSTDOBS=NSTDOBS+1 IF (STYPE(J).EQ.'X') NEXTOBS=NEXTOBS+1 C IF (SIGNAL(I)) 501, 502, 503 C C Negative: 501 SIGNAL(I)=100.-2.5*LOG10(-SIGNAL(I)) CARD='Net intensity is NEGATIVE for '//STARS(J) WRITE(CARD(61:),'(''at MJD'',F12.4)')DTZERO(NITE(I))+DJOBS(I) CALL TV(CARD) N=N+1 GO TO 510 C C Zero: 502 SIGNAL(I)=200. GO TO 510 C C Positive: 503 PHVAR(I)=PHVAR(I)*(1.086/SIGNAL(I))**2 C Photon variance now in magnitudes. IF (KESTERR.GT.0) THEN C Use ESTER. ESTER(I)=ESTER(I)/SIGNAL(I) END IF C Correct signal for differential refraction, & convert to mags.: C (see ATY in NPC, p.139 for details.) SIGNAL(I)=-2.5*LOG10(SIGNAL(I)*(1.+(2.7E-4*PRAT)*AIRM(I)**2)) 510 CONTINUE C IF (N.GT.0) THEN CALL SPACE WRITE (CARD,'(I5,'' negative intensities.'')') N CALL TV(CARD) CALL TVN('Please check data: possible STAR/SKY confusion.') CALL ASK('Continue or Quit?',A1) END IF C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C Re-start reductions here, if necessary: C 512 ONEZPT=STABLE CALL SPACE2 CALL CENTER('INITIALIZING solution ...') CALL SPACE2 CALL RTNCON(' ',1) IF (NIGHTS.EQ.1) ONEZPT=.FALSE. C NBESTI=0 NBESTS=0 SUMBESTI=0. SUMBESTS=0. UNMOD=1.E-5 C C Plot airmass vs. time for each night: C DO 520 NIGHT=1,NIGHTS C C clear some parameters first... DO 514 K=KMIN,KMAX ZPT(K,NIGHT)=0. AEXT(K,NIGHT)=0. NAT(K,NIGHT)=0. NZT(K,NIGHT)=0. 514 CONTINUE XMIN=3.E33 XMAX=-3.E33 YMIN=3.E33 YMAX=-3.E33 K=0 DO 516 I=1,NDATA IF (NITE(I).NE.NIGHT) GO TO 516 K=K+1 XMIN=MIN(XMIN,DJOBS(I)) XMAX=MAX(XMAX,DJOBS(I)) YMIN=MIN(YMIN,AIRM(I)) YMAX=MAX(YMAX,AIRM(I)) 516 CONTINUE IF (K.LT.2*NKS .OR. (NSTDS+NEXTS).EQ.0) GO TO 520 XS(1)=XMIN YS(1)=YMIN XS(2)=XMAX YS(2)=YMAX CALL PLOT(0,XS,YS,'L') CALL CENTER('Distribution of Std. & eXt. stars') CALL NEED(24) JOLD=0 SUMNI=0. SUMNS=0. DO 519 I=1,NDATA IF (NITE(I).NE.NIGHT) GO TO 519 J=NSTR(I) IF (STYPE(J).EQ.'V' .OR. STYPE(J).EQ.'P' .OR. 1 STYPE(J).EQ.'p') THEN C skip variable and unknown program stars. GO TO 519 ELSE IF (STYPE(J).EQ.'S') THEN SUMNS=SUMNS+1. ELSE IF (STYPE(J).EQ.'X') THEN SUMNI=SUMNI+1. END IF C avoid overplotting multiple deflections: IF (J.NE.JOLD) CALL PLOT(-1,DJOBS(I),AIRM(I),STYPE(J)) JOLD=J 519 CONTINUE CALL JD2DAT(REAL(2400000.5D0+DTZERO(NIGHT)),DAT) WRITE(CARD,'(''Airmass vs. time for '',A30)') DAT IF (YMAX.GT.3.) WRITE(CARD(42:),'(A32,F5.2)') 1 'C A U T I O N : Max. airmass =',YMAX CALL TV(CARD) CALL PLOT(1,3.E33,3.E33,' ') CALL RTNCON(' TIME (decimal days) -->',28) C IF (SUMNI.GT.SUMBESTI) THEN NBESTI=NIGHT SUMBESTI=SUMNI END IF C IF (SUMNS.GT.SUMBESTS) THEN NBESTS=NIGHT SUMBESTS=SUMNS END IF C 520 CONTINUE C IF (NBESTI.EQ.0) THEN CALL TV('You may not be able to determine extinction.') NBESTI=1 END IF IF (NBESTS.EQ.0) THEN CALL TV('Problem with NBESTS') NBESTS=1 END IF C C NBESTI now has number of best night for instr. ext. determination. C NBESTS now has number of best night for ext. determination from stds. C C C ***** BEGIN starting values ***** C C CALL CENTER('Estimate starting values') C EXTEND=.FALSE. CUTSET=.FALSE. NCYCLE=0 NSETOLD=-1 IF (HASMAGS .AND. NSTDOBS.GE.NKS) THEN C assume we can determine zero pts. CUTOFF=PHOMAG(KMID)+2.8 ELSE C assume we must work only in instrumental system. CUTOFF=25. CUTSET=.TRUE. END IF C C IF (HASMAGS .AND. NSTDOBS.GT.15*NIGHTS*NKS) THEN C C we have enough std. star observations to determine ext. C Initially assume null transformation, and proceed: DO 525 J=1,NDATA C Set only those stars for which we have data: I=NSTR(J) IF (STYPE(I).NE.'S') GO TO 525 K=KBND(J) XMAG(K,I)=COLORS(K,I) 525 CONTINUE CALL TV('Starting solution with standard-star values...') C (this assumes stds. are bright enough to neglect photon noise...) GO TO 560 C to determine ext. coeffs. C ELSE IF (HASMAGS .AND. NSTDOBS.GT.0) THEN C C we have enough std. star observations for zero-pts. DO 538 K=KMIN,KMAX AEXT(K,NBESTS)=EXTIN(K) NPT=0 DO 535 J=1,NDATA N=NITE(J) IF (N.NE.NBESTS .OR. KBND(J).NE.K) GO TO 535 I=NSTR(J) IF (STYPE(I).NE.'S') GO TO 535 NPT=NPT+1 YS(NPT)=SIGNAL(J)-AIRM(J)*AEXT(K,N)-COLORS(K,I) 535 CONTINUE C adopt median. CALL SORT1(YS,NPT) ZPT(K,NBESTS)=0.5*(YS(NPT/2+1)+YS((NPT+1)/2)) IF (K.EQ.KMID .AND. .NOT.CUTSET) THEN CUTOFF=CUTOFF+ZPT(K,NBESTS) CUTSET=.TRUE. WRITE(CARD,'(A,F8.3)')'Cutoff set to',CUTOFF CALL TV(CARD) END IF 538 CONTINUE CALL TV('Starting solution with nominal extinction...') GO TO 570 C to find mags. C ELSE C C assume reasonable ext.coeffs., and proceed in instrumental system. C DO 542 K=KMIN,KMAX C start with best night only... AEXT(K,NBESTI)=EXTIN(K) TRCOEF(K)=0. 542 CONTINUE C zpt was already zeroed out. IF (HASMAGS) CALL TV('NO standard-star observations.') CALL TV('Starting solution with nominal extinction...') GO TO 570 C to find mags. C END IF C C C ** BEGIN CYCLE ** C C 560 CONTINUE C C Use mags. to determine extinction: C CALL SPACE CALL TV('estimating extinction...') DO 566 N=1,NIGHTS CALL NEED(NKS+3) CALL JD2DAT(REAL(2400000.5D0+DTZERO(N)),DAT) WRITE(CARD,'(''Approximate extinction coeffs. for '',A30)') DAT CALL TV(CARD) CALL SPACE C ** DO 564 K=KMIN,KMAX C This is inefficient; but it does not seem too slow. NPT=0 DO 562 J=1,NDATA IF (NITE(J).NE.N .OR. KBND(J).NE.K .OR. 1 (KESTERR.GT.0 .AND. ESTER(J).GT.0.02) .OR. C skip noisy data. 2 (KESTERR.LT.0 .AND. SIGNAL(J).GT.CUTOFF) ) GO TO 562 I=NSTR(J) C skip unset stars and missing std.values: IF (XMAG(K,I).EQ.0. .OR. .NOT.(XMAG(K,I).LT.50.)) GOTO 562 NPT=NPT+1 XS(NPT)=AIRM(J) YS(NPT)=SIGNAL(J) - XMAG(K,I) 562 CONTINUE C IF (NPT.NE.0) THEN C extinction plots for debugging: C CALL PLOT(0,0.,1.,'I') C CALL PLOT(NPT,XS,YS,BANDS(K)(:LWORD(BANDS(K)))) C CALL RTNCON(' ',1) C CALL PLOT(0,0.,0.,'I') CALL ROBLIN(XS,YS,NPT, XBAR,YBAR,SLOPE) C C (remember that ONEZPT can only be true if NIGHTS.gt.1): IF (ONEZPT) THEN IF (XBAR.GT.1. .AND. XBAR.LT.2.5) THEN AEXT(K,N)=YBAR/XBAR ELSE AEXT(K,N)=EXTIN(K) END IF ELSE IF (NPT.GT.9 .AND. SLOPE.GT.EXTIN(K)/2. .AND. C CAUTION: we rely on a side effect here! (ROBLIN sorts XS in XDUM). 1 SLOPE.LT.5. .AND. XDUM(NPT)-XDUM(1).GT.0.3) THEN C accept results. ZPT(K,N)=YBAR-XBAR*SLOPE AEXT(K,N)=SLOPE WRITE(CARD,'(4X,A,'' ='',F6.2)') BANDS(K)(:LENB),SLOPE C reality check: IF (AEXT(K,N).LT.0.8*EXTIN(K) .OR. 1 AEXT(K,N).GT.2.*EXTIN(K))THEN CALL TV(CARD) C Looks fishy. Ask for help: WRITE(CARD,'(A,F5.2,A)') 1 'Value seems unreasonable. Expected about',EXTIN(K) CALL TV(CARD) WRITE(CARD,'(A,F5.2,A)') 1 'Do you want to use',EXTIN(K),' instead?' CALL ASKN(CARD,A1) IF (A1.EQ.'Y') THEN AEXT(K,N)=EXTIN(K) ZPT(K,N)=YBAR-XBAR*AEXT(K,N) WRITE(CARD,'(A,F5.2,A)') 1 ' ',EXTIN(K),' adopted.' CALL TV(CARD) ELSE END IF CARD=' ' CALL SPACE ELSE C Looks OK. END IF ELSE C use zero-pt.only. AEXT(K,N)=EXTIN(K) ZPT(K,N)=YBAR-XBAR*EXTIN(K) WRITE(CARD,'(''can''''t determine extinction for '', + A,'' -- USING DEFAULT ('',F4.2,'')'')') + BANDS(K)(:LENB),EXTIN(K) END IF C Fix cutoff if zero set for first time. IF (.NOT.CUTSET .AND. K.EQ.KMID .AND. 1 N.EQ.NBESTS) THEN CUTOFF=CUTOFF+ZPT(K,NBESTS) CUTSET=.TRUE. END IF C CALL TVN(CARD) ELSE CARD='No data above noise cutoff for '//BANDS(K) CALL TV(CARD) IF (NCYCLE.LT.NIGHTS+1) GO TO 570 C Give up -- not enough data. CALL TV('GIVING UP -- not enough data to connect nights.') CALL SPACE CALL STSEPI END IF C 564 CONTINUE C ** (end loop over bands) C 566 CONTINUE C (end loop over nights) C C *** C C Use extinction to re-determine mags.: C C 570 CONTINUE CALL SPACE CALL TV('estimating magnitudes...') NSET=0 NPT=0 DO 574 J=1,NDATA K=KBND(J) N=NITE(J) IF (AEXT(K,N).EQ.0.) GO TO 574 C OK, we have extinction available. I=NSTR(J) IF (STYPE(I).EQ.'V') GO TO 574 NPT=NPT+1 C be very sneaky... XS(NPT)=I+REAL(K)/(MBANDS+1) YS(NPT)=SIGNAL(J)-AEXT(K,N)*AIRM(J)-ZPT(K,N) 574 CONTINUE C CALL SORT2(XS,YS,NPT) C This has put all observations of the same (K,I) together. OLDX=XS(1) N=0 DO 578 J=1,NPT IF (XS(J).EQ.OLDX) THEN C collect YS for given (K,I): N=N+1 ZDUM(N)=YS(J) ELSE C J refers to next (K,I). Process old one: CALL SORT1(ZDUM,N) C now extract K,I from previous XS, you clever devil: I=INT(XS(J-1)) K=(XS(J-1)-I)*(MBANDS+1) +0.5 C Adopt median. XMAG(K,I)=(ZDUM((N+1)/2) + ZDUM(N/2+1))*0.5 NSET=NSET+1 C start next batch: N=1 OLDX=XS(J) ZDUM(1)=YS(J) END IF 578 CONTINUE C don't forget the last batch: IF (N.GT.0) THEN CALL SORT1(ZDUM,N) I=INT(XS(NPT)) K=(XS(NPT)-I)*(MBANDS+1) +0.5 XMAG(K,I)=(ZDUM((N+1)/2) + ZDUM(N/2+1))*0.5 NSET=NSET+1 END IF C C NSET counted total number of stars with values set here. C It is used at 590 to determine convergence. C C *** C C IF (NSTDOBS.EQ.0) GOTO 590 C C Redetermine transformation, and set XMAGs to transformed std. values: C CALL SPACE CALL TV('Approximate transformations:') C C (begin loop over bands.) DO 588 K=KMIN,KMAX C Set K1 and K2 here: K1=MAX(KMIN,K-1) K2=MIN(KMAX,K+1) IF (USE3PT(K)) THEN IF (K.EQ.KMIN) THEN K2=K+2 ELSE IF (K.EQ.KMAX) THEN K1=K-2 END IF END IF C Special for H-beta problems: IF (SYSTEM.EQ.'uvbyHB') THEN IF (BANDS(K).EQ.'y') THEN K2=K IF (USE3PT(K)) K1=K-2 ELSE IF (BANDS(K).EQ.'betaW') THEN K1=0 K2=0 ELSE IF (BANDS(K).EQ.'betaN') THEN K1=0 K2=0 ELSE C normal. END IF ELSE IF (SYSTEM.EQ.'H-BETA') THEN K1=0 K2=0 END IF C Save K1, K2 for use elsewhere: K1S(K)=K1 K2S(K)=K2 N=0 C DO 584 I=1,LASTD IF (STYPE(I).NE.'S' .OR. COLORS(K,I).EQ.3.E33 .OR. 1 XMAG(K,I).EQ.3.E33 .OR. XMAG(K,I).EQ.0. .OR. 2 (K1.NE.0 .AND. COLORS(K1,I).EQ.3.E33) .OR. 3 (K2.NE.0 .AND. COLORS(K2,I).EQ.3.E33)) GO TO 584 N=N+1 IF (K1.EQ.0) THEN C H-beta. IF (COLORS(K,I).EQ.3.E33 .OR. 1 BANDS(K).EQ.'betaW') THEN C skip it. N=N-1 ELSE C We have betaN; set up for beta-transformation. C (K,I) contains betaN mag; (K-1,I) contains betaW mag, IF (XMAG(K-1,I).EQ.0.)THEN C skip it. N=N-1 ELSE XS(N)=COLORS(K,I) YS(N)=XMAG(K,I)-XMAG(K-1,I) C assuming that betaW precedes betaN. END IF END IF ELSE C normal case. XS(N)=COLORS(K1,I)-COLORS(K2,I) YS(N)=XMAG(K,I)-COLORS(K,I) END IF 584 CONTINUE C IF (N.EQ.0) THEN CARD='No stds. found at 584 for' CARD(28:)=BANDS(K) IF (K1.NE.0) CALL TV(CARD) C make a reasonable guess... VARK(K)=4.E-4 GO TO 588 ELSE C DEBUGGING only: C CALL NEED(24) C CARD=' '//BANDS(K)//' transformation plot' C CALL TV(CARD) C CALL PLOT(N,XS,YS,'*') C WRITE(CARD,*) N,' stars' C CALL RTNCON(CARD,20) END IF C CALL ROBLIN(XS,YS,N, XBAR,YBAR,SLOPE) C now: m_obs = m_std + slope*color + ybar. C ... IF (K1.EQ.0) THEN C ... C H-beta problem. IF (BANDS(K).EQ.'betaW') THEN C do nothing. ELSE C Output beta-transformation: BETAZ=YBAR+SLOPE*XBAR WRITE(CARD,'(3X,A,F5.2,A,SP,F5.2)') 1 'beta =',SLOPE,' beta ',BETAZ CALL NEED(3) CALL TV(CARD) CALL TVN(' obs std') VARK(K)=4.E-4 END IF C (Needs a reality check for H-beta here.) C ... ELSE C ... C Normal magnitude. L=LWORD(BANDS(K)) L1=LWORD(BANDS(K1)) L2=LWORD(BANDS(K2)) C C display new transformation: IF (SLOPE.GE.0.) THEN WRITE(CARD,'(3X,4A,F5.2,5A)') 1 BANDS(K)(:L),' = ',BANDS(K)(:L),' + ', 2 SLOPE,' *(',BANDS(K1)(:L1),' - ',BANDS(K2)(:L2),')' ELSE WRITE(CARD,'(3X,4A,F5.2,5A)') 1 BANDS(K)(:L),' = ',BANDS(K)(:L),' - ', 2 -SLOPE,' *(',BANDS(K1)(:L1),' - ',BANDS(K2)(:L2),')' END IF CALL NEED(3) CALL TV(CARD) DAT=' ' WRITE(CARD,'(3X,2A,2X,2A)')DAT(:L),'obs',DAT(:L),'std' CALL TVN(CARD) C C Reality check: C IF (ABS(SLOPE).GT.0.2) THEN CALL TV('That''s an implausibly large color term.') CALLASK('Do you want to try a more reasonable value?',DAT) A1=DAT(:1) IF (A1.EQ.'Y' .OR. A1.EQ.'O') THEN CALL QF('Enter new trial color coefficient:',SLOPE) ELSE IF (A1.EQ.'N') THEN C do nothing. ELSE READ (DAT,'(F9.3)') SLOPE END IF END IF C C ... END IF C ... TRCOEF(K)=SLOPE C special for H-beta: IF (K1.EQ.0) GO TO 588 C N=0 DO 586 I=1,LASTD IF (STYPE(I).NE.'S' .OR. COLORS(K,I).EQ.3.E33 .OR. 1 XMAG(K,I).EQ.3.E33 .OR. XMAG(K,I).EQ.0. .OR. 2 COLORS(K1,I).EQ.3.E33 .OR. 3 COLORS(K2,I).EQ.3.E33) GO TO 586 C note that we intentionally omit ybar, to stabilize zero points. XMAG(K,I)=COLORS(K,I) + SLOPE*(COLORS(K1,I)-COLORS(K2,I)) N=N+1 C save absolute residual: XDUM(N)=ABS(YS(N)-YBAR-(XS(N)-XBAR)*SLOPE) 586 CONTINUE C CALL SORT1(XDUM,N) C use (square of MAD)* 2.2 for later weight. (.25*2.2=.55) VARK(K)=0.55*(XDUM((N+1)/2)+XDUM(N/2+1))**2 C prevent excessive weights. IF (N.LT.3 .OR. VARK(K).LT.1.E-5) VARK(K)=4.E-4 C C (remember that ONEZPT can only be true if NIGHTS.gt.1): IF (ONEZPT) THEN C force all nights to fit new zero point. DO 587 N=1,NIGHTS ZPT(K,N)=YBAR 587 CONTINUE END IF C 588 CONTINUE C (end loop over bands.) C IF (NSET.EQ.NSETOLD) THEN IF (N.LT.9) THEN WRITE(CARD,'(A,I2,A)')'Only',N,' standard stars! NOT ENOUGH' CALL TV(CARD) CALL TVN('to determine reliable transformation !!') CALL SPACE CALL RTNCON(' ',1) END IF END IF C C C Finish cycle & prepare for next one, if necessary. C 590 CONTINUE C IF (NSET.NE.NSETOLD) THEN C repeat cycle if still picking up stars and/or nights. NSETOLD=NSET C C reset CUTOFF for photon noise: XLIM(2)=0. NPT=0 DO 595 J=1,NDATA N=NITE(J) K=KBND(J) IF (AEXT(K,N).EQ.0. .OR. SIGNAL(J).GT.50.) GO TO 595 I=NSTR(J) IF(XMAG(K,I).EQ.0. .OR. XMAG(K,I).GT.50. .OR. 1 STYPE(I).EQ.'V') GOTO 595 NPT=NPT+1 C (we really should include exptim; but neglect it.) C XS is reciprocal of expected intensity; YS is variance. XS(NPT)=1./10.**(-.4*(XMAG(K,I)+AEXT(K,N)+ZPT(K,N))) YS(NPT)=(SIGNAL(J)-XMAG(K,I)-AEXT(K,N)*AIRM(J)-ZPT(K,N))**2 C skip stars with only one datum. IF (YS(NPT).LT.1.E-5) THEN NPT=NPT-1 C GO TO 595 ELSE XLIM(2)=MAX(XLIM(2),XS(NPT)) END IF 595 CONTINUE C IF (NPT.EQ.0) CALL TV('NPT = 0 at 595') CALL SPACE IF (NPT.GT.2.E3)CALLTV('analyzing variances; may take time...') CALL ROBLIN(XS,YS,NPT, XBAR,YBAR,SLOPE) CALL NEED(24) CALL CENTER('PHOTON-NOISE variance vs. (1/I):') CALL TVN('Variance') XLIM(1)=0. YLIM(1)=0. YLIM(2)=YBAR+ABS(SLOPE*XLIM(2)) + 2.E-4 CALL PLOT(0,XLIM,YLIM,'L') C Indicate points outside plot. CALL PLOT(0,1.,1.,'O') CALL PLOT(-NPT,XS,YS,'*') C Restore normal plotting. CALL PLOT(0,0.,0.,'O') DO 596 J=1,20 XS(J)=XLIM(2)*J/20. YS(J)=YBAR + SLOPE*(XS(J)-XBAR) 596 CONTINUE CALL PLOT(20,XS,YS,'-') CALL RTNCON(' reciprocal of signal',27) C IF (SLOPE.GT.0. .AND. (YBAR-SLOPE*XBAR).GT.0.) THEN C add 2% more noise: YBAR=YBAR+4.E-4 C Xcut is RECIPROCAL of cutoff count, so no minus sign: CUTOFF = 2.5*LOG10((YBAR/SLOPE)-XBAR) WRITE(CARD,597)'New photon-noise cutoff at',CUTOFF 597 FORMAT (A,F6.2) CALL TV(CARD) WRITE(CARD,597)'where photon noise =',SQRT(YBAR-SLOPE*XBAR) CALL TVN(CARD) END IF C NCYCLE=NCYCLE+1 CALL SPACE2 WRITE(CARD,'(A,I3)')'BEGIN CYCLE',NCYCLE CALL TV(CARD) GO TO 560 END IF C C ** END CYCLE ** C C C ***** END starting values ***** C C C 600 continue C C C ***** BEGIN solutions ***** C C Storage Maps: C ============ C C INPUT DATA: C ---------- C C Y(J) is observed signal C C X(1,J) is airmass C X(2,J) is time C X(3,J) is filter temperature C X(4,J) is relative humidity C X(5,J) is detector temperature C C KX(1,J) is data type (1 = observation, 2 = std.mag., 3 = H-Beta) C KX(2,J) is star number in modified index L C KX(3,J) is band number K C KX(4,J) is night number N C KX(5,J) is detector number C KX(6,J) is ND number C C C OUTPUT PARAMETERS: C ----------------- C C *** STARS: C C P ((L-1)*NKS + (K-KMINM1)) is star L magnitude for band K C C C *** NIGHTS: C C nightly zero slot: (This is last P that refers to stars.) C NITEZ = LEXT2S*NKS C C MPPKN is number of parameters per (K,N) (Zpt + Aext = 2); C MPPN = MPPKN*NKS is total number of P's per night. C C P (NITEZ + (N-1)*MPPN + (K-KMIN)*MPPKN +1) = ZPT(K,N) C P (NITEZ + (N-1)*MPPN + (K-KMIN)*MPPKN +2) = AEXT(K,N) C P (NITEZ + (N-1)*MPPN + (K-KMIN)*MPPKN +3) = linear time term; etc. C C C *** SYSTEM PARAMETERS: C C MSYSTZ = NITEZ+MPPN*NIGHTS is the last P that refers to nights. C C Bandwidth(K) is stored in MSYSTZ + (K-KMINM1) C Transf.coef(K) is stored in MSYSTZ + NKS + (K-KMINM1) C = MTRANZ + (K-KMINM1) C 2nd tr.coef(K) is stored in MTR2Z + (K-KMINM1) C Global zero(K) is stored in MTRZ + (K-KMINM1) C Temp. coef.(K) is stored in MT1Z + (K-KMINM1) C Temp. coef2(K) is stored in MT2Z + (K-KMINM1) C Rel.hum.coef(K) is stored in MRHZ + (K-KMINM1) C C NSYSTP is the number of system parameters. C = 3*NKS if NKS bandwidths + NKS color terms C + NKS transf.zero points are used. C Add another NKS for temp. or RH terms. C C NREST is the number of remaining parameters. C C ND correction (mags) to XND(ND,K) is in C MSYSTZ + NSYSTP + KND = NDZ + KND C = NDZ + ND2NP(ND,K) C C Deadtime correction (sec) to DEDTS(ndet) is in C NDT2NP(NDET) C C C NPARMS = MSYSTZ + NSYSTP + NREST is total number of P's in solution. C C C C C SET UP input data: C DO 601 I=1,NSTARS C Clear cross-reference lists. L2N(I)=0 N2L(I)=0 C Clear XS to length of star catalog. XS(I)=0. YS(I)=I 601 CONTINUE C C count observations/star in XS; catalog number is in YS. C DO 602 J=1,NDATA C NSTAR is index in star catalog. NSTAR=NSTR(J) XS(NSTAR)=XS(NSTAR)+1. 602 CONTINUE CALL SORT2(XS,YS,NSTARS) C XS contains total number of data for star in YS (each filter counts). C Stars with most data are at the END of the list. C L=0 C start with most-observed stars, and back up. C DO 603 J=NSTARS,1,-1 C skip unobserved stars. IF (XS(J).EQ.0.) GO TO 603 NSTAR=YS(J) IF (STYPE(NSTAR).EQ.'S') THEN C put std. star in list. L=L+1 L2N(L)=NSTAR ELSE IF (XS(J).LE.NKS .AND. STYPE(NSTAR).EQ.'X') THEN C remove from list of extinction stars; flag as "p". STYPE(NSTAR)='p' NEXTS=NEXTS-1 END IF 603 CONTINUE LSTDS=L C C LSTDS Std. stars are now in L-list. C C Next find best-observed eXt. stars: DO 604 J=NSTARS,1,-1 IF (XS(J).LE.1.) GO TO 604 NSTAR=YS(J) IF (XS(J).GT.NKS .AND. STYPE(NSTAR).EQ.'X') THEN L=L+1 L2N(L)=NSTAR END IF 604 CONTINUE LEXT2S=L C C EXTinction stars have been observed more than once, down to C LEXT2S in the L-list. This includes stds. C C C Next find best-observed Pgm. stars: DO 605 J=NSTARS,1,-1 IF (XS(J).LE.1.) GO TO 605 NSTAR=YS(J) IF (XS(J).GT.NKS .AND. STYPE(NSTAR).EQ.'P') THEN L=L+1 L2N(L)=NSTAR END IF 605 CONTINUE LPGM2S=L C C PROGRAM stars have been observed more than once, down to C LPGM2S in the L-list. These are POTENTIAL extinction stars. C C C Next find Pgm. stars UNsuitable for extinction: DO 606 J=NSTARS,1,-1 IF (XS(J).EQ.0.) GO TO 606 NSTAR=YS(J) IF (XS(J).LE.NKS .AND. STYPE(NSTAR).EQ.'P' .OR. 1 STYPE(NSTAR).EQ.'p') THEN L=L+1 L2N(L)=NSTAR END IF 606 CONTINUE C LPGM1S=L C C C Last, find Var. stars: DO 607 J=NSTARS,1,-1 IF (XS(J).EQ.0.) GO TO 607 NSTAR=YS(J) IF (STYPE(NSTAR).EQ.'V') THEN L=L+1 L2N(L)=NSTAR END IF 607 CONTINUE LVARS=L C That should account for all stars observed. C IF (L.EQ.ISTARS) THEN C Every star position observed has a magnitude. ELSE IF (L.LT.ISTARS) THEN C reality check (this block executed when there are sky positions): FLAGGED=.FALSE. DO 6085 J=1,ISTARS JJ=JSTAR(J) DO 6081 L=1,LVARS IF (JJ.EQ.L2N(L)) GO TO 6085 6081 CONTINUE C Here when we find an item in ISTARS that is NOT in L-list. IF (INDEX(STARS(JJ),'SKY').GT.0 .OR. STYPE(JJ).EQ.'p' .OR. 1 INDEX(STARS(JJ),'sky').GT.0) GO TO 6085 C Ask for help: CALL SPACE CARD='Is '//STARS(JJ)(:LWORD(STARS(JJ)))//' a SKY position?' CALL ASK(CARD,A1) IF (A1.EQ.'Y') THEN C OK. ELSE C We have problems! IF (NBREJ.GT.0) THEN C Maybe it was observed only in rejected bands? CALL TV('It may have been observed only in bands that') CALL TVN('you chose to ignore. Are you willing to') CALL ASKN('ignore this object?',A1) IF (A1.EQ.'Y') THEN DO 6082 L=1,NSTDNM IF (KSTARS(L).EQ.JJ) KSTARS(L)=0 6082 CONTINUE DO 6083 L=1,LDICT IF (NDICT(L).EQ.JJ) NDICT(L)=0 6083 CONTINUE STYPE(JJ)='p' FLAGGED=.TRUE. ELSE CALL TV('You have data for some star, but no mag.') WRITE(CARD,609) 'L, ISTARS =',LVARS,ISTARS CALL TV(CARD) CALL TV('Impossible bug found at 6083 -- QUITTING.') CALL STSEPI END IF ELSE CALL TV('You have data for some star, but no mag.') WRITE(CARD,609) 'L, ISTARS =',LVARS,ISTARS CALL TV(CARD) CALL TV('Impossible bug found at 6085 -- QUITTING.') CALL STSEPI END IF END IF 6085 CONTINUE IF(FLAGGED)GO TO 512 ELSE C We have problems! WRITE(CARD,609) 'L, ISTARS =',L,ISTARS 609 FORMAT(A,2I5) CALL TV(CARD) CALL TV('Impossible bug found at 609 -- QUITTING.') CALL STSEPI END IF C C make reverse index: ISTARS=LVARS DO 610 L=1,ISTARS NSTAR=L2N(L) N2L(NSTAR)=L 610 CONTINUE C C C Star cross-indexing: C C NSTARS total number of stars in catalog (names in STARS(NSTAR)) C ISTARS total number of stars observed C C NSTR(J) converts index J <= NDATA in data like AIRM(J) to cat.no. C N2L(NSTAR) converts index NSTAR in catalog to index L <= ISTARS C L2N(L) converts index L in observed list back to NSTAR in C star catalog. C LSTDS of the ISTARS are stds. C LEXT2S of the ISTARS are stds. or ext. stars. C LPGM2S of the ISTARS are potential ext. stars (pgm.* w. 2+ data) C C NSTDS is total number of Std. stars observed. C NEXTS is total number of eXt. stars observed. C NPGMS is total number of Pgm. stars observed. C C NSTDOBS is number of OBServations of STD. stars C NEXTOBS is number of OBServations of EXT. stars C C USES4X=.FALSE. C C *** Now set up data for DLSQ: *** C CALL SPACE2 CALL CENTER('Good STARTING VALUES are now ready.') CALL CENTER('Setting up full solution.') CALL SPACE C C IF (LEXT2S.GT.0) THEN C Std. and/or ext.stars are available. LMAX=MIN(LEXT2S, (MXP-40)/NKS - NIGHTS*MPPN) C IF (HASMAGS .AND. NSTDS.GT.1) THEN C Stds.can be used. CALL SPACE CALL TV('You can use standard VALUES of std.stars to') CALL TVN('influence the extinction solution.') C IF (NSTDOBS+NEXTOBS .GE. NKS*(NSTDS+NEXTS+20*NIGHTS)) THEN C Plenty of extinction data; don't need stds. CALLTV('You should be able to determine extinction well') CALL TVN('without using standard values.') ELSE IF(((NSTDS+NIGHTS)*2+NEXTS)*NKS.GT.NSTDOBS+NEXTOBS)THEN C Std.values add (NSTDS*NKS) degrees of freedom; C Obs.data add only (NSTDS+NEXTOBS-NKS*(NIGHTS*2+NSTDS+NEXTS)) C degrees of freedom; so: CALL TV('Using std.values may strengthen the solution.') ELSE C Hard to say; so say nothing. END IF CALL SPACE C 611 CALL ASK( 1 'Do you want to use standard VALUES for extinction?',A1) IF (A1.EQ.'Y') THEN USES4X=.TRUE. CALL TV(' Including Std.values in extinction solution.') ELSE IF (HELP(A1)) THEN CALL SPACE CALL TV('Using standard values of standard stars may') CALL TVN('increase precision but decrease accuracy.') CALLTV('Don''t use stds. for extinction if you solve for') CALL TVN('nonlinearity as well; brightest star will then') CALL TVN('dominate the solution.') CALL SPACE GO TO 611 ELSE CALL TV(' Std.values will NOT be used.') END IF ELSE END IF C IF(NEXTS.EQ.0) THEN C only std. stars are available. CALL SPACE2 CALL TV('No pure extinction stars designated.') CALL ASK('Do you want to use PROGRAM stars for extinction?', 1 A1) IF (A1.EQ.'Y' .OR. A1.EQ.'O') THEN C Do. LMAX=MIN(LPGM2S, (MXP-40)/NKS - NIGHTS*2) CALL P2X(STYPE,LMAX,L2N,NEXTS) EXTEND=.TRUE. GO TO 512 ELSE C Don't. END IF ELSE C We have some ext.stars already. END IF C ELSE C No std. or ext.stars are available. CALL TV( 1 'No extinction stars available; we must use program stars.') LMAX=MIN(LPGM2S, (MXP-40)/NKS - NIGHTS*2) CALL P2X(STYPE,LMAX,L2N,NEXTS) EXTEND=.TRUE. GO TO 512 END IF C C Come back to here (from about 647) to re-start solution. C 612 CONTINUE C NPTS=0 NIX=0 AIRMAX=0. DO 615 J=1,NDATA NSTAR=NSTR(J) IF (STYPE(NSTAR).EQ.'V' .OR. STYPE(NSTAR).EQ.'P' .OR. 1 STYPE(NSTAR).EQ.'p') GO TO 615 C we are left with std. + ext. stars. NPTS=NPTS+1 IF (NPTS.GT.MXPT)THEN CALL EXCEED(NPTS,'MXPT ',MXPT) CALL STSEPI END IF LSTAR=N2L(NSTAR) KX(1,NPTS)=1 KX(2,NPTS)=LSTAR KX(3,NPTS)=KBND(J) KX(4,NPTS)=NITE(J) C index of detector to KX(5,*): KX(5,NPTS)=NDTUSD(KBND(J)) C index of ND filter to KX(6,*): DO 613 ND=1,NDS IF (NDFILT(J).EQ.NDNAME(ND)) GO TO 614 613 CONTINUE 614 KX(6,NPTS)=ND C AIRMAX=MAX(AIRMAX,AIRM(J)) X(1,NPTS)=AIRM(J) X(2,NPTS)=DJOBS(J) X(3,NPTS)=FTMP(J) X(4,NPTS)=RELH(J) Y(NPTS)=SIGNAL(J) C SCINTSQ=ZSCSQ*(AIRM(J)**(3.5))/EXPTIM(J) C Set weights so that unit wt. corresponds to 0.01 mag. error. IF (KESTERR.GT.0) THEN C Use estimated error, if available. W(NPTS)=1.E-4/(ESTER(J)**2 + UNMOD) ELSE C Make a reasonable guess: scint + photon noise. W(NPTS)=1.E-4/(SCINTSQ+PHVAR(J) + UNMOD) END IF 615 CONTINUE C NONSTD=NPTS C C C add std. values as pseudo-observations: C DO 618 L=1,LSTDS NSTAR=L2N(L) DO 617 K=KMIN,KMAX IF (COLORS(K,NSTAR).EQ.3.E33) GO TO 617 K1=K1S(K) K2=K2S(K) C C Skip if no std. value: IF (K1.EQ.0) THEN C H-Beta. IF (BANDS(K).EQ.'betaW') THEN IF (COLORS(K+1,NSTAR).EQ.3.E33) GO TO 617 ELSE IF (COLORS(K,NSTAR).EQ.3.E33) GO TO 617 END IF ELSE C Normal band. IF (COLORS(K1,NSTAR).EQ.3.E33) GO TO 617 IF (COLORS(K2,NSTAR).EQ.3.E33) GO TO 617 END IF C NPTS=NPTS+1 IF (NPTS.GT.MXPT)THEN CALL EXCEED(NPTS,'MXPT ',MXPT) CALL STSEPI END IF C flag as std.datum. KX(1,NPTS)=2 KX(2,NPTS)=L KX(3,NPTS)=K C Assume transformation error = sqrt(VARK) mag per star. W(NPTS)=1.E-4/VARK(K) C C Load std. value: IF (K1.EQ.0) THEN C H-Beta. IF (BANDS(K).EQ.'betaW') THEN C skip it. NPTS=NPTS-1 ELSE C flag as color datum. KX(1,NPTS)=3 Y(NPTS)=COLORS(K,NSTAR) END IF ELSE C Normal band. KX(4,NPTS)=K1 KX(5,NPTS)=K2 C X(1,NPTS)=COLORS(K1,NSTAR)-COLORS(K2,NSTAR) Y(NPTS)=COLORS(K,NSTAR) END IF C 617 CONTINUE 618 CONTINUE CALL SPACE WRITE(CARD,'(I5,'' data,'',I5,'' total space'')')npts,MXPT CALL TV(CARD) WRITE(CARD,'(F5.1,''% used.'')')NPTS*100/FLOAT(MXPT) CALL TV(CARD) C NPTOT=NPTS IF (.NOT.USES4X) NPTS=NONSTD C C C *** set PG's and indexing of P's: *** C C Set up PG's for stars: C FLAGGED=.FALSE. DO 620 L=1,LMAX NSTAR=L2N(L) DO 620 K=KMIN,KMAX IF (STYPE(NSTAR).NE.'p' .AND. XMAG(K,NSTAR).EQ.0.)THEN CARD='Removing unsuitable extinction star '//STARS(NSTAR) CALL TV(CARD) CALL TVN('from extinction solution.') CARD='(no data in band '//BANDS(K)(:LWORD(BANDS(K)))//')' CALL TVN(CARD) STYPE(NSTAR)='p' FLAGGED=.TRUE. END IF PG((L-1)*NKS + (K-KMINM1)) = XMAG(K,NSTAR) 620 CONTINUE IF (FLAGGED) THEN CALL SPACE CALL RTNCON('Re-starting...',14) GO TO 512 END IF C C and nights: C C zero slot for nights: (This is last P that refers to stars.) NITEZ=LMAX*NKS C IF (TIMFLGA.AND.TIMFLGZ) THEN C make room for both time terms: MPPKN=4 ELSE IF(TIMFLGA) THEN C make room for only extinction time terms: MPPKN=3 ELSE IF(TIMFLGZ) THEN C make room for only zero-point time terms: MPPKN=3 ELSE C make room for only AEXT + ZPT (no time terms): MPPKN=2 END IF C MPPKN is Max. Parameters Per (K,N) slot. MPPN=MPPKN*NKS C MPPN is Max. Parameters Per Night. DO 621 N=1,NIGHTS DO 621 K=KMIN,KMAX I= NITEZ + (N-1)*MPPN + (K-KMIN)*MPPKN C I is zero slot for (K,N). PG(I+1) = ZPT(K,N) PG(I+2) = AEXT(K,N) IF (ONEZPT) THEN C hold all these Z's fixed, and vary the common zero only. J=I+1 CALL FIXP(J,PG(J),NIX) END IF C set up time terms: C P (NITEZ + (N-1)*MPPN + (K-KMIN)*MPPKN +3) = linear time term; etc. I=I+2 IF (TIMFLGA.AND.TIMFLGZ) THEN C set up both time terms: PG(I)=0. PG(I+1)=0. ELSE IF(TIMFLGA) THEN C set up only extinction time terms: PG(I)=0. ELSE IF(TIMFLGZ) THEN C set up only zero-point time terms: PG(I)=0. ELSE C no time terms; already done. END IF 621 CONTINUE C C and system parameters: C C Zero-slot for system parameters: MSYSTZ=NITEZ+MPPN*NIGHTS C set up bandwidth parameters: DO 622 K=KMIN,KMAX KOFF=K-KMINM1 C NOTE: Can't start from zero, or shortcut in YPSTD will kill it. PG(MSYSTZ+KOFF)=1.E-5 C EXCEPTION: pure H-Beta MUST use zero (no colors!). IF (SYSTEM.EQ.'H-BETA') THEN J=MSYSTZ+KOFF PG(J)=0. CALL FIXP(J,PG(J),NIX) END IF 622 CONTINUE C Bandwidths use first NKS slots: NSYSTP=NKS C C Now see if transformation is needed: C IF (LSTDS.GT.1) THEN C we have transformation data. C C Zero-slot for transformation parameters: MTRANZ=MSYSTZ+NKS IF (USES3PTS) THEN C Storage: (trans(1),k=kmin,kmax), in MTRANZ + K-KMINM1 C (trans(2),k=kmin,kmax), in MTR2Z + K-KMINM1 C (zpt,k=kmin,kmax) in MTRZ + K-KMINM1 NTRANS=3 MTR2Z=MTRANZ+NKS MTRZ=MTR2Z+NKS ELSE C Storage: (trans(1),k=kmin,kmax), in MTRANZ + K-KMINM1 C (zpt,k=kmin,kmax) in MTRZ + K-KMINM1 NTRANS=2 MTR2Z=0 MTRZ=MTRANZ+NKS END IF C Total space: NSYSTP=NSYSTP+NKS*NTRANS C DO 623 K=KMIN,KMAX KOFF=K-KMINM1 C space for first transformation coefficient: I= MTRANZ+ KOFF IF (K1S(K).EQ.0) THEN C H-beta. IF (TRCOEF(K).NE.0.) THEN PG(I)=1./TRCOEF(K) ELSE PG(I)=1. END IF ELSE C Normal passband; C note sign change. PG(I)= -TRCOEF(K) END IF IF (.NOT.USES4X) CALL FIXP(I,PG(I),NIX) C IF (USES3PTS) THEN C make space for second transformation coefficient. I=I+NKS PG(I)=0. IF (.NOT.(USES4X .AND. USE3PT(K))) CALL FIXP(I,PG(I),NIX) END IF C C space for transformation (common) zero point: I=MTRZ + KOFF IF (K1S(K).EQ.0) THEN C H-beta. IF (K.GT.3)THEN C betaW. PG(I)=0. CALL FIXP(I,PG(I),NIX) ELSE C betaN. PG(I)=-BETAZ END IF ELSE C Normal passband. PG(I)=0. END IF C C (remember that ONEZPT can only be true if NIGHTS.gt.1): IF (.NOT.USES4X .OR. .NOT.ONEZPT) THEN C We are either using separate nightly zeroes, or C a separate transformation solution. C Don't solve for the transformation zero at this time. CALL FIXP(I,PG(I),NIX) END IF 623 CONTINUE ELSE C No transformation data. NTRANS=0 MTRANZ=0 MTR2Z=0 END IF C C Now see if Filter Temperature term is needed: C IF (HASFILTT) THEN MT1Z=MSYSTZ+NSYSTP NSYSTP=NSYSTP+NKS DO 625 K=KMIN,KMAX KOFF=K-KMINM1 C space for Filt. Temp. coefficient: I= MT1Z+KOFF PG(I)=0. 625 CONTINUE END IF C C Now see if Rel.Hum. term is needed: C IF (HASRH) THEN MRHZ=MSYSTZ+NSYSTP NSYSTP=NSYSTP+NKS DO 626 K=KMIN,KMAX KOFF=K-KMINM1 C space for RH coefficient: I= MRHZ+KOFF PG(I)=0. 626 CONTINUE NSYSTP=NSYSTP+NKS END IF C C NSYSTP is now the number of system parameters (bandwidths + C transf.params. + C temp. & RH params.) NPARMS=MSYSTZ+NSYSTP C C C *** Add any other parameters needed: *** C (need NOT be multiples of NKS) C C Check for ND filters: C IF (NUMNDS.GT.1) THEN NDZ=NPARMS C NDZ is zero-slot for ND parameters. DO 628 NUM=1,NUMNDS DO 628 K=KMIN,KMAX ND=NUM2ND(NUM) IF (ND2NP(ND,K).GT.0) THEN NPARMS=NPARMS+1 PG(NPARMS)=0. END IF 628 CONTINUE END IF C C Index the nonlinearity parameters: C NDEDTZ=NPARMS C NDEDTZ is zero-slot for dead-time parameters. DO 630 NDET=MINDET,MAXDET NDT2NP(NDET)=0 DO 629 K=KMIN,KMAX IF (NDTUSD(K).EQ.NDET) THEN NPARMS=NPARMS+1 PG(NPARMS)=0. NDT2NP(NDET)=NPARMS GO TO 630 END IF 629 CONTINUE 630 CONTINUE C C *** PG's and indexing of P's now set. *** C C Compile mean airmasses. First clear arrays: DO 634 K=KMIN,KMAX DO 631 N=1,NIGHTS AIRKN(K,N)=0. AIRKNS(K,N)=0. AIRKN2(K,N)=0. 631 CONTINUE DO 633 I=1,LEXT2S AIRKI(K,I)=0. AIRKIS(K,I)=0. 633 CONTINUE 634 CONTINUE C C scan dlsq data, get sums: DO 636 J=1,NONSTD I=KX(2,J) K=KX(3,J) N=KX(4,J) AIR=X(1,J) AIRKI(K,I)=AIRKI(K,I)+AIR*W(J) AIRKIS(K,I)=AIRKIS(K,I)+W(J) IF (I.GT.LSTDS) GO TO 636 C count std. stars only, in N-sums. AIRKN(K,N)=AIRKN(K,N)+AIR*W(J) AIRKNS(K,N)=AIRKNS(K,N)+W(J) AIRKN2(K,N)=AIRKN2(K,N)+AIR*AIR*W(J) 636 CONTINUE C C compute means: DO 639 K=KMIN,KMAX DO 637 N=1,NIGHTS IF (AIRKNS(K,N).GT.0.) THEN C sum-of-squares of deviations of airmasses of stds. AIRKN2(K,N)=AIRKN2(K,N)-(AIRKN(K,N)**2)/AIRKNS(K,N) C mean airmass of stds. AIRKN(K,N)=AIRKN(K,N)/AIRKNS(K,N) END IF 637 CONTINUE DO 638 I=LSTDS+1,LEXT2S C mean airmass of non-stds. IF (AIRKIS(K,I).GT.0.) AIRKI(K,I)=AIRKI(K,I)/AIRKIS(K,I) 638 CONTINUE 639 CONTINUE C C Now add extinction-star sums to those for stds.: DO 640 J=1,NONSTD I=KX(2,J) IF (I.LE.LSTDS) GO TO 640 K=KX(3,J) N=KX(4,J) AIR=X(1,J) AIRKN2(K,N)=AIRKN2(K,N)+((AIR-AIRKI(K,I))**2)*W(J) 640 CONTINUE C AIRKN2 now has approximate weight (airmasses-squared) for ext. C C See if we should hold anything fixed: C DO 650 N=1,NIGHTS DO 650 K=KMIN,KMAX IF (AIRKN2(K,N).EQ.0.) GO TO 650 IF (AIRKN2(K,N).LT.0.2) THEN C Not likely to determine extinction. Complain: CARD='Not enough data to determine '//BANDS(K) CARD(LWORD(CARD)+2:)='extinction on' CALL JD2DAT(REAL(2400000.5D0+DTZERO(N)),CARD(LWORD(CARD)+2:)) CALL SPACE CALL TV(CARD) IF (EXTEND) THEN C Program stars already added. CALL TVN('Still not enough!') ELSE C Program stars not yet added. CALLTV('Not enough data to solve for stars and extinction!') CALL SPACE CALL ASK('Do you want to use PROGRAM stars for extinction?', 1 A1) IF (A1.EQ.'Y' .OR. A1.EQ.'O') THEN EXTEND=.TRUE. LMAX=MIN(LPGM2S, (MXP-40)/NKS - NIGHTS*2) CALL P2X(STYPE,LMAX,L2N,NEXTS) GO TO 612 ELSE IF (A1.EQ.'N') THEN C (should offer to use std. stars here, if available.) CALL TV('OK, we can try to solve just for stars.') END IF END IF C C nix the extinction coeff. NIX=NIX+1 IX(NIX)=NITEZ + (N-1)*MPPN + (K-KMIN)*MPPKN +2 ELSE C We are OK. END IF 650 CONTINUE C IF (NSTDOBS.EQ.0 .OR. .NOT.USES4X) THEN C hold best night's zero-points fixed to avoid singular matrix. DO 651 K=KMIN,KMAX NIX=NIX+1 IX(NIX)=NITEZ+(NBESTI-1)*MPPN+(K-KMIN)*MPPKN+1 C PG(IX(NIX))=0. 651 CONTINUE END IF C C (start ND filter section) IF (NUMNDS.GT.1) THEN C CALL SPACE2 WRITE (CARD,'(I2,A)') NUMNDS,' (ND,band) combinations used.' CALL TV(CARD) C See if some ND filter is used in every position: DO 654 ND=1,NDS FLAGGED=.FALSE. DO 652 K=KMIN,KMAX C Flag if a color is NOT used. IF(ND2NP(ND,K).EQ.0) FLAGGED=.TRUE. 652 CONTINUE C we now know whether all colors are used... IF (.NOT.FLAGGED) THEN C OK, fix this ND. CARD='Holding '//NDNAME(ND)//' fixed.' IF (NDNAME(ND).NE.' ') CALL TV(CARD) DO 653 K=KMIN,KMAX NIX=NIX+1 IX(NIX)=NDZ+ND2NP(ND,K) IF(IX(NIX).GT.NPARMS)CALL TV('IX > NPARMS') 653 CONTINUE GO TO 658 ELSE C at least 1 band not used for this ND; go on. END IF 654 CONTINUE C C Failed to find a filter used in all bands; so fix first one for each. DO 656 K=KMIN,KMAX DO 655 NUM=1,NUMNDS IF (NP2K(NUM).EQ.K) THEN C hold the first slot in this color fixed. NIX=NIX+1 IX(NIX)=NDZ+NUM ND=NP2ND(NUM) CARD='Holding '//NDNAME(ND)//' fixed.' CALL TV(CARD) GO TO 656 END IF 655 CONTINUE 656 CONTINUE C 658 CONTINUE C END IF C (end of ND filter section) C IF (NPARMS.GT.100) THEN WRITE(CARD,'(I5,'' parameters to adjust --'')') NPARMS CALL TV(CARD) CALLTVN('you may want to select item 2 below to see progress.') END IF C Ask user for detail level... CALL IPRSET(IPR) C C List starting values: IF (IPR.GT.2) THEN CALL CENTER(' ... STARTING VALUES ...') CALL SPACE2 C Report indexing: CARD='Last measurement point is' WRITE(CARD(26:),'(I5)') NONSTD CALL TV(CARD) IF (LSTDS.GT.1) THEN CARD='Last Std.-value point is' WRITE(CARD(26:),'(I5)') NPTOT CALL TV(CARD) END IF CALL SPACE CALL TV(' Parameters:') CARD='Stars end at' WRITE(CARD(13:),'(I4)') NITEZ CALL TV(CARD) CARD='Nights end at' WRITE(CARD(14:),'(I4)') MSYSTZ CALL TV(CARD) CARD='Widths end at' WRITE(CARD(14:),'(I4)') MSYSTZ+NKS CALL TV(CARD) CARD='Trans.coeffs. end at' WRITE(CARD(21:),'(I4)') MTRZ CALL TV(CARD) CARD='Trans. zeroes end at' WRITE(CARD(21:),'(I4)') MTRZ+NKS CALL TV(CARD) IF (NUMNDS.GT.1) THEN CARD='ND params. begin at' WRITE(CARD(20:),'(I4)') NDZ+1 CALL TV(CARD) END IF CARD='Dead-times begin at' WRITE(CARD(20:),'(I4)') NDEDTZ+1 CALL TV(CARD) CALL SPACE2 C transfer PG's to P's for report: DO 660 I=1,NPARMS P(I)=PG(I) 660 CONTINUE CALL REPORT(LMAX,BANDS,L2N,USES4X,IPR) END IF C C To DEBUG: Temporarily fix all bandwidths: C DO 665 K=1,NKS C IX(NIX+K)=MSYSTZ+K C 665 CONTINUE C NIX=NIX+NKS C C 670 CONTINUE IF (IPR.EQ.4) THEN CALL SPACE2 DO 671 I=NITEZ+2,NITEZ+MPPKN*NKS*NIGHTS,MPPKN C fix all ext.coeffs. CALL FIXP(I,PG(I),NIX) 671 CONTINUE CALL RTNCON(' ',1) C Calculate residuals for starting values. C Subroutine DLSQ(YP,NPTS,NPARMS,NBLOX,MBLOK,NIX,NARGS,NKARGS,TEST) CALL DLSQ(YPSTD,NPTS,NPARMS,LMAX, NKS, NIX, 4, 6, 1.) C ^ change to 4. CALL SPACE2 CALL TV(' INITIAL RESIDUALS') GO TO 800 END IF C 672 CALL SPACE WRITE(CARD,'(A,I4,A,I4,A)') 1 'Adjusting',NPARMS-NIX,' of',NPARMS,' parameters.' CALL TV(CARD) IF (IPR.EQ.0) CALL TV('Iterating...') C C C Should be all set now. Call DLSQ: C C Subroutine DLSQ(YP,NPTS,NPARMS,NBLOX,MBLOK,NIX,NARGS,NKARGS,TEST) CALL DLSQ(YPSTD, NPTS,NPARMS, LMAX, NKS, NIX, 4 , 6 ,1.E-5) C ^ change to 4. C C C ***** Check results: ***** C CALL SPACE IF(WVAR.GT.0.) THEN IF (WVAR.LT.3.E-3 .AND. WVAR.GT.1.E-5) THEN C Reasonable errors. WRITE(CARD,'(A,F7.3)')'Typical error is',SQRT(WVAR) ELSE C Unreasonable errors. WRITE(CARD,'(A,G9.2)')'Typical error is',SQRT(WVAR) END IF CALL TV(CARD) END IF CALL SPACE C C Did DLSQ converge? (It sets WVAR and SCALE.) C IF (WVAR.EQ.0. .OR. SCALE.EQ.0.)THEN C C did not converge. CALL TV('Solution did NOT converge!') C try holding ext.coeffs. fixed at reasonable values. C NIXOLD=NIX C DO 675 N=1,NIGHTS C DO 675 K=KMIN,KMAX C L=NITEZ+(N-1)*MPPN+(K-KMIN)*MPPKN+2 C CALL FIXP(L,EXTIN(K),NIX) C 675 CONTINUE C IF (NIX.EQ.NIXOLD) THEN C give up. C CALL TV('You need more data. PEPSYS throws in the towel.') C CALL TV('Here is where you got to:') C DONE=.TRUE. C GO TO 900 C ELSE C OK, made a difference. C CALL SPACE C CARD= C 1 'Let''s try fixing extinction coefficients at reasonable' C CARD(56:)='values:' C CALL TV(CARD) C CALL SPACE2 C CARD=' ' C CALL RTNCON(CARD,34) C END IF C GO TO 670 C ELSE IF (WVAR.LT.1.E-6 .OR. WVAR.GT.0.01) THEN CALL ASKN('Does that seem reasonable?',A1) IF (A1.EQ.'Y') THEN C go on. ELSE C should ask user for advice. CALL TV('You may have to hold more parameters fixed.') CALL TVN('Please consider the following suggestions:') END IF C ELSE C OK so far. C END IF C C C See if converged to reasonable parameters: C C C Check transformation coeffs. & bandwidths: C NIXOLD=NIX DO 680 K=KMIN,KMAX C Check main transformation coeffs.: L=MSYSTZ+NKS+K-KMINM1 C IF (K1S(K).EQ.0) THEN C H-Beta. IF (BANDS(K).EQ.'betaW') THEN C Do nothing. ELSE IF (P(L).LT.0.8 .OR. P(L).GT.1.2) THEN CALL SPACE CALL TV( 1 'Unlikely transformation coefficient for Beta index') WRITE(CARD,'(G12.3)') P(L) CALL TVN(CARD) CALL QFIX(L,PG(L),NIX) END IF ELSE IF (ABS(P(L)).GT.0.15) THEN C Normal bands. CARD='Excessive transformation coefficient for '//BANDS(K) CALL TV(CARD) WRITE(CARD,'(G12.3)') P(L) CALL TVN(CARD) CALL QFIX(L,PG(L),NIX) END IF C C Check bandwidths: IF (K1S(K).EQ.0) THEN C H-Beta. IF (SYSTEM.EQ.'uvbyHB') THEN C colors available. SEPN=WLS(4)-WLS(3) REASON=(WIDTHS(K)/(2.6*SEPN))**2 ELSE C no colors available. REASON=0. END IF ELSE C Normal bands. SEPN=WLS(K2S(K))-WLS(K1S(K)) REASON=(WIDTHS(K)/(2.6*SEPN))**2 END IF L=L-NKS IF (P(L).LT.0.) THEN CALL SPACE CARD='Negative second moment (bandwidth) factor for '// 1 BANDS(K)(:LENB)//' !' CALL TV(CARD) WRITE (CARD,'(5X,A,F6.4)') 'It will be held at ',REASON CALL TVN(CARD) PG(L)=REASON CALL FIXP(L,REASON,NIX) ELSE IF (P(L).LT.REASON/2. .OR. P(L).GT.REASON*2.) THEN CALL SPACE CARD='Unlikely second moment for '//BANDS(K)(:LENB)//';' CALL TV(CARD) WRITE (CARD,'(A,F6.3,A,F6.3)') ' -- found',P(L), 1 ' but expected about',REASON CALL TVN(CARD) CALL QFIX(L,REASON,NIX) ELSE C accept result. END IF 680 CONTINUE C C Check nonlinearity coeffs.: C CALL SPACE DO 682 NDET=MINDET,MAXDET NP=NDT2NP(NDET) C Skip unused detectors. IF (NP.EQ.0) GO TO 682 CALL SPACE CALL NEED(5) C *** IF (PC(NDET)) THEN C *** C PC: do dead-time. XS(1)=PG(NP) IF (DEDTS(NDET)+REAL(P(NP)).LT.0.) THEN C Negative dead-time -- probably impossible. CARD='Negative dead-time parameter for '//DETNAME(NDET) CALL TV(CARD) WRITE(CARD,'(3X,A,1PE9.2,A)') 1 '(Nominal value was',DEDTS(NDET),' sec)' CALL TV(CARD) C necessary fudge: P(NP)=P(NP)+DEDTS(NDET) REASON=DEDTS(NDET) CALL QFIX(NP,REASON,NIX) C undo fudge: P(NP)=P(NP)-DEDTS(NDET) ELSE IF (ABS(P(NP)).GT.0.1*DEDTS(NDET) .AND. 1 ABS(P(NP)).LT.3.*SP(NP) ) THEN C Large, non-significant change. CARD='Program wants to change '//DETNAME(NDET) CALL TV(CARD) WRITE(CARD,'(A13,1PE9.2,A4,E9.2,'' sec.'')') 1 'deadtime from',DEDTS(NDET),' to',DEDTS(NDET)+P(NP) CALL TVN(CARD) WRITE(CARD,'(23X,''+/-'',1PE9.2)') SP(NP) CALL TVN(CARD) C necessary fudge: P(NP)=P(NP)+DEDTS(NDET) REASON=DEDTS(NDET) CALL QFIX(NP,REASON,NIX) C undo fudge: P(NP)=P(NP)-DEDTS(NDET) ELSE C Change is small and/or significant; accept it. END IF C C See if QFIX changed PG: IF (PG(NP).NE.XS(1)) THEN C it got changed. Apply necessary fix: PG(NP)=PG(NP)-DEDTS(NDET) END IF C *** ELSE C *** C DC: check for significance. IF (ABS(P(NP)).LT.3.*SP(NP)) THEN C Not significant. CARD='Program wants to change '//DETNAME(NDET) CALL TV(CARD) WRITE(CARD,'(A,1PE9.2,A5,E9.2)') 1 'non-linearity to',P(NP),' +/- ',SP(NP) CALL TVN(CARD) CALL TV('This change is NOT significant.') CALL QFIX(NP,0.,NIX) ELSE C Significant. END IF C *** END IF C *** 682 CONTINUE C IF (NIX.GT.NIXOLD) THEN CALL SPACE2 CALL RTNCON('RE-solve with fixed parameters...',33) GOTO 670 END IF C C Check night constants: C NIXOLD=NIX DO 685 N=1,NIGHTS C find limits of night: JBGN=0 DO 683 J=1,NPTS IF (KX(1,J).NE.1) GO TO 683 IF (KX(4,J).EQ.N) THEN IF (JBGN.EQ.0) JBGN=J JEND=J END IF 683 CONTINUE C format date if needed. CALL JD2DAT(REAL(2400000.5D0+DTZERO(N)),DMS) C Begin loop over bands: DO 685 K=KMIN,KMAX L=NITEZ+(N-1)*MPPN+(K-KMIN)*MPPKN+2 C Check extinction coeffs.: WRITE(CARD(:32),'(A,F6.3)')'Extinction coefficient of',P(L) CARD(33:)='in '//BANDS(K) IF (P(L).LT.0.5*EXTIN(K))THEN CALL TV(CARD) CARD(:3)='on' CARD(4:36)=DMS CARD(16:)='is too small, and will be reset to' WRITE(CARD(50:),'(F6.3)')EXTIN(K) CALL TVN(CARD) CALL FIXP(L,EXTIN(K),NIX) ELSE IF (P(L).LT.0.8*EXTIN(K) .OR. P(L).GT.2.*EXTIN(K))THEN C Looks fishy. CALL TV(CARD) CARD(:3)='on' CARD(4:36)=DMS CARD(16:)='looks unreasonable.' CALL TVN(CARD) CALL QFIX(L,EXTIN(K),NIX) ELSE C Looks OK. END IF C Time-dependent terms (indexing): IF (TIMFLGZ) THEN C Time-dependent zero in L1: L1=L+1 IF (TIMFLGA) THEN C ALSO time-dependent extinction in L2: L2=L1+1 END IF ELSE IF (TIMFLGA) THEN C ONLY time-dependent extinction in L2: L2=L+1 END IF C Time-dependent terms (checking): IF (TIMFLGZ) THEN C Check time-dependent zero: TERM=ABS(P(L1)*(X(2,JBGN)-X(2,JEND))) CALL BIGDRIFT('Zero-point',TERM,BANDS(K),CARD,DMS,L1,NIX) END IF IF (TIMFLGA) THEN C Check time-dependent extinction: TERM=ABS(P(L2)*(X(2,JBGN)-X(2,JEND))) CALL BIGDRIFT('Extinction',TERM,BANDS(K),CARD,DMS,L2,NIX) END IF 685 CONTINUE IF (NIX.GT.NIXOLD) GOTO 670 C C Report results, & reset PG's: IF (WVAR.NE.0.) CALL REPORT(LMAX,BANDS,L2N,USES4X,IPR/2) C C C Check weights: C C Variance model is: C C for observations: VAR = photon + scint + UNMOD C for std. stars: VAR = VARK(K) + UNMOD C FLAGGED=.FALSE. SUMNI=0. SUMNS=0. IF (SCALE.EQ.0.) SCALE=0.01 DO 690 J=1,NONSTD TERM=W(J)*(Y(J)-REAL(YC(J)))**2 C Term is Studentized residual squared. USQ=TERM/(36.*SCALE**2) C C=6 for biweight A-estimator. IF (USQ.LT.1.) THEN C Use it. SUMNI=SUMNI+TERM*((1.-USQ)**4) SUMNS=SUMNS+(1.-USQ)*(1.-5.*USQ) ELSE C Ignore it. END IF 690 CONTINUE BIWVAR=NONSTD*SUMNI/(SUMNS*(SUMNS-1.)) C Biweight variance per observation of unit wt. (should be 1.e-4). UNMOD2=BIWVAR-1.E-4 WRITE(CARD,'(A,1PE9.1)') 1 'New estimate of unmodelled variance =',UNMOD2 CALL TV(CARD) C IF (UNMOD2.GE.0.) THEN C Re-estimate weights by correcting unmodelled variance. WRITE(CARD,'(19X,A,F6.3)') 1 'unmodelled error =',SQRT(UNMOD2) CALL TVN(CARD) C Smoothing... UNMOD2=0.5*(UNMOD+UNMOD2) DO 692 J=1,NONSTD W(J)=1./ABS(1./W(J) + UNMOD2 -UNMOD) 692 CONTINUE IF (ABS(UNMOD-UNMOD2)/UNMOD2.GT.0.2) FLAGGED=.TRUE. UNMOD=UNMOD2 ELSE C Re-estimate scintillation and photon noise, which seem too big. END IF C C $$$ NEEDS SCINT & PHOTON REVISION HERE. C IF(NSTDOBS.EQ.0 .OR. .NOT.USES4X) GO TO 730 CALL SPACE CALL TV('New estimates of transformation errors:') DO 720 K=KMIN,KMAX SUMNI=0. SUMNS=0. N=0 I1=0 DO 715 J=NONSTD+1,NPTS IF (K.NE.KX(3,J)) GO TO 715 N=N+1 TERM=(Y(J)-REAL(YC(J)))**2 C don't let scale drop below 1% here. USQ=TERM/(36.*(VARK(K)+1.E-4)) IF (USQ.LT.1.) THEN SUMNI=SUMNI+TERM*((1.-USQ)**4) SUMNS=SUMNS+(1.-USQ)*(1.-5.*USQ) ELSE C Count rejects to see if excessive. I1=I1+1 END IF 715 CONTINUE TERM=N*SUMNI/(SUMNS*(SUMNS-1.)) C Term is variance per star. IF (TERM.LE.0. .OR. I1*5.GT.N) THEN C fudge to handle excessive rejects: IF (VARK(K).LT.4.E-4) TERM=2.*VARK(K)+1.E-4 END IF C Include UNMOD, to prevent std.values from dominating soln. TERM=TERM+UNMOD C IF (ABS(VARK(K)-TERM)/TERM.GT.0.2) FLAGGED=.TRUE. C NO Smoothing... VARK(K)=TERM C Smoothing... C VARK(K)=0.5*(TERM+VARK(K)) WRITE(CARD,'(5X,A8,F6.3)')BANDS(K),SQRT(TERM) CALL TV(CARD) DO 718 J=NONSTD+1,NPTS IF (K.NE.KX(3,J)) GO TO 718 W(J)=1.E-4/ABS(TERM) 718 CONTINUE 720 CONTINUE C IF (FLAGGED) THEN CALL SPACE2 IF (IPR.EQ.0) THEN CALL TVN('Repeat solution with new weights...') ELSE CALL RTNCON('Repeat solution with new weights...',35) END IF GO TO 670 END IF C C C Check stars to change categories: C 730 CONTINUE CALL SPACE2 K=0 DO 731 L=LMAX,LPGM2S I=L2N(L) IF (STYPE(I).EQ.'P') K=K+1 731 CONTINUE IF (K.GT.0) THEN CALL SPACE2 WRITE(CARD,'(A,I4,A)')'You have',K, 1 ' program stars. Some might be useful for extinction.' CALL SPACE CALL TV(CARD) CALL SPACE CALL TV(' Do you want to use:') CALL TV(' ALL') CALL TV(' SOME') CALL TV(' or NONE') CALL SPACE CALL ASK('of them for extinction?',A1) IF (A1.EQ.'A') THEN IF (LPGM2S .GT. (MXP-40)/NKS - NIGHTS*2) THEN CALL TV('Too many stars to use all; pick only the best.') OFFER=.TRUE. ELSE CALL P2X(STYPE,LPGM2S,L2N,NEXTS) GO TO 512 END IF ELSE IF (A1.EQ.'N') THEN OFFER=.FALSE. ELSE IF (HELP(A1)) THEN CALL TV('If you reply SOME, the program will ask you about') CALL TVN('the individual stars.') CALL TV('If you reply ALL, the program will give you') CALL TVN('a chance to reject non-constant stars later.') GO TO 730 ELSE OFFER=.TRUE. END IF ELSE END IF C C See if individual stars need changes: C C Set up for plots: CALL PLOT(0,78.,18.,'P') C Invert Y: CALL PLOT(0,0.,1.,'I') C Plot individual symbols: CALL PLOT(0,0.,0.,'D') C get plot offset: I=DLOG10(TIMAX-TIMIN) J=MAX(0,I)+1 C J is next power of 10 larger than span of data (days). DJZPLT=TIMIN-MOD(TIMIN,10.D0**J) C C Clear re-run flag: FLAGGED=.FALSE. C Skip variable stars, so only do first LPGM2S. DO 755 L=1,LPGM2S I=L2N(L) N=0 SUMNI=0. IF (OFFER .AND. STYPE(I).EQ.'P') THEN C see if program star is suitable for extinction: DO 734 J=1,NDATA IF(NSTR(J).NE.I) GO TO 734 C Here for observed data on star I. N=N+1 XS(N)=DJOBS(J) YS(N)=AIRM(J) 734 CONTINUE CALL SORT1(XS,N) CALL SORT1(YS,N) IF ( (XS(N)-XS(1).GT.0.04 .OR. YS(N)-YS(1).GT.0.1) .AND. C Time spread > 1 hour or airmass range > 0.1 1 (NKS*(NEXTS+NSTDS)+NIGHTS*MPPN.LT.MXP-30) ) THEN C some room remains for parameters CALL SPACE CARD='Program star '//STARS(I)(:LWORD(STARS(I)))// 1 ' may be useful for extinction.' CALL TV(CARD) WRITE(PAGE,'(4(5X,A,'' ='',F7.2))') 1 (BANDS(K)(:LENB),XMAG(K,I),K=KMIN,KMAX) DO 738 J=1,(NKS+3)/4 738 CALL TVN(PAGE(J)) WRITE(CARD,'(I6,A)') N/NKS,' sets of data' CALL TVN(CARD) CALL ASK('Do you want to use it for extinction?',A1) IF (A1.EQ.'Y' .OR. A1.EQ.'O')THEN STYPE(I)='X' NEXTS=NEXTS+1 FLAGGED=.TRUE. ELSE END IF ELSE C Skip stars with only a neighboring pair or so of data. END IF ELSE IF (STYPE(I).EQ.'X' .OR. STYPE(I).EQ.'S') THEN C see if ext. or std. star is UNsuitable for extinction: C Find pseudovariances: DO 745 J=1,NPTS IF(L2N(KX(2,J)).NE.I .OR. KX(1,J).GE.2) GO TO 745 C Here for observed data on star I. N=N+1 YS(N)=Y(J)-YC(J) XS(N)=W(J)*(YS(N)**2) C Variance ratio is in XS; actual resid., in YS. SUMNI=SUMNI+XS(N) C SUMNI is weighted sum of variances; should be (scale**2 * n). C Save stuff for plotting: C time. NIGHT=KX(4,J) ZDUM(N)=DTZERO(NIGHT)+X(2,J)-DJZPLT C band. IF (K1S(KX(3,J)).EQ.0) THEN C special for H-Beta: use N or W. DTYPE(N)=BANDS(KX(3,J))(5:5) ELSE C Normal. DTYPE(N)=BANDS(KX(3,J))(:1) END IF 745 CONTINUE IF (N.LE.NKS) GO TO 755 C Subtract NKS degrees of freedom... REALF=SUMNI/((N-NKS)*SCALE*SCALE) CALL SORT1(XS,N) PSEUDOF=(XS((N+1)/2)+XS(N/2+1))*0.5*N/((N-NKS)*SCALE*SCALE) C Crude approx. to F-test for Q=0.1: FCUT=1.+14./N C debugging: C CALL TV(STARS(I)) C WRITE(CARD,*)'REALF=',REALF,' PSEUDOF=',PSEUDOF C CALL TVN(CARD) IF (PSEUDOF.GT.5.) THEN IF (STYPE(I).EQ.'S') NSTDS=NSTDS-1 IF (STYPE(I).EQ.'X') NEXTS=NEXTS-1 STYPE(I)='V' FLAGGED=.TRUE. CARD=STARS(I)(:LWORD(STARS(I)))// 1 ' appears to be variable.' CALL TV(CARD) IF (REALF.GT.999.) THEN WRITE(CARD,'(A,1P,G8.1,A)')'observed variance =',REALF, 1 ' times expected variance' ELSE WRITE(CARD,'(A,F7.2,A)')'observed variance =',REALF, 1 ' times expected variance' END IF CALL TVN(CARD) CALL TV('It will be treated as variable from now on.') ELSE IF (REALF.GT.FCUT .OR. 1 REALF.GT.3.*PSEUDOF .AND. REALF.GT.1.) THEN 750 CALL SPACE IF (N.GT.3*NKS) THEN CALL NEED(22) END IF CALL SPACE CARD=STARS(I)(:LWORD(STARS(I)))//' may be variable.' CALL TV(CARD) IF (REALF.GT.999.) THEN WRITE(CARD,'(A,1P,G9.2,A)')'observed variance =',REALF, 1 ' times expected variance' ELSE WRITE(CARD,'(A,F7.2,A)')'observed variance =',REALF, 1 ' times expected variance' END IF CALL TVN(CARD) IF (N.GT.3*NKS) THEN C make room for extra points to scale time axis: N=N+1 ZDUM(N)=TIMIN-DJZPLT YS(N)=0. DTYPE(N)='+' N=N+1 ZDUM(N)=TIMAX-DJZPLT YS(N)=0. DTYPE(N)=' ' CALL TV('Here is a "light curve" of residuals:') CALL PLOT(N,ZDUM,YS,DTYPE) CALL TVN(' days -->') ELSE CALL SPACE WRITE(CARD,'(A,1P,G9.2,A)')'Weighted RMS residual = ', 1 SCALE*SQRT(REALF/N),',' WRITE(CARD(37:),'(2(I3,A))') N,' data in',NKS,' bands' CALL TV(CARD) END IF CALL ASK('Do you want to treat it as a variable star?', 1 A1) IF (A1.EQ.'Y' .OR. A1.EQ.'O')THEN IF (STYPE(I).EQ.'X') THEN NEXTS=NEXTS-1 ELSE IF (STYPE(I).EQ.'S') THEN NSTDS=NSTDS-1 END IF STYPE(I)='V' FLAGGED=.TRUE. ELSE IF (HELP(A1)) THEN CALL SPACE CARD='Consider the number of observations and' CARD(40:)='the observed variance.' CALL TV(CARD) IF (STYPE(I).EQ.'S') THEN CARD='This is a standard star, so you need' CARD(38:)='good evidence to condemn it.' CALL TV(CARD) END IF IF (N.GT.3*NKS) THEN CARD='Does the light curve indicate smooth changes' CARD(46:)='that are different from other stars' CALL TV(CARD) CARD= 1 '(i.e., not likely to be due to varying extinction)?' CALL TVN(CARD) END IF CALL SPACE CALL RTNCON('Try again when you are ready.',29) GO TO 750 ELSE C Leave it as is. END IF ELSE C star passes test for stability. END IF ELSE C Ignore intermediate stars that have been marked variable. END IF 755 CONTINUE C C Restore normal plotting. CALL PLOT(0,0.,0.,'I') CALL PLOT(0,0.,0.,'S') CALL PLOT(0,78.,22.,'P') C C Re-do solution if anything was flagged. IF (FLAGGED) GO TO 512 C CALL SPACE2 IF (WVAR.EQ.0.D0) THEN CALL TV('N O T E : SOLUTION FAILED!') 790 CALL ASK('Do you want to try more iterations?',A1) IF (A1.EQ.'Y') THEN DO 792 I=1,NPARMS 792 PG(I)=P(I) GO TO 512 ELSE IF (A1.EQ.'N') THEN CALL TV('Here are the residual plots. Ignore error values.') ELSE IF (A1.EQ.'H') THEN CALL TV('If the iterations were converging well, a few more') CALL TVN('might finish the job.') CALL TV('If the iterations were not converging, you need') CALL TVN('more and/or better data.') GO TO 790 ELSE GO TO 790 END IF ELSE C normal. CALL CENTER('Solution has done all it can do.') CALL CENTER('Final results follow.') END IF DONE=.TRUE. C C C Plot residuals: C C First, assign labels to DTYPE for each datum in solution: C (may jump here from 671-672 before iterating) 800 DO 801 J=1,NPTOT L=MOD(KX(2,J),MCODES) C labels correspond to star numbers in soln. DTYPE(J)=PLTSYM(L:L) 801 CONTINUE C CALL SPACE2 CALL TV('Here are the RESIDUAL plots:') C C Make inverted plots. CALL PLOT(0,0.,1.,'I') C Put 2 plots per screen. CALL PLOT(0,78.,12.,'P') C Indicate points outside plot. CALL PLOT(0,0.,1.,'O') C CALL TV('You will see the residuals plotted vs. AIRMASS') CALL TVN('for each night, in order of colors.') CALL TV('A different symbol represents each star.') CALL TV('The residuals are in the O-C sense, with bright data') CALL TVN('at the top of each plot.') CALL SPACE CALL RTNCON(' ',1) CALL NEED(24) C DO 810 N=1,NIGHTS CALL JD2DAT(REAL(2400000.5D0+DTZERO(N)),CARD(19:)) WRITE(CARD(LWORD(CARD)+3:),'(''= MJD'',F7.0)') DTZERO(N) CALL SPACE DO 808 K=KMIN,KMAX CALL NEED(12) CARD(:18)=' '//BANDS(K)(:LENB)//' resids. on' CALL TVN(CARD) XLIM(1)=1. XLIM(2)=AIRMAX YLIM(1)=SCALE*3. YLIM(2)=-YLIM(1) CALL PLOT(0,XLIM,YLIM,'L') C draw dashed-line axis: CALL XAXIS(XLIM) C add points: DO 805 J=1,NPTS IF (KX(3,J).NE.K .OR. KX(4,J).NE.N) GO TO 805 IF (KX(1,J).NE.1) GO TO 806 A1=DTYPE(J) CALL PLOT(-1,X(1,J),Y(J)-REAL(YC(J)),A1) 805 CONTINUE C force out plot. 806 CALL PLOT(1,3.,3.,' ') CALL RTNCON(' Airmass --> ',22) 808 CONTINUE C end of night. CALL TV(' * * * * * * * * * * * * * * * * * * * * * *') CALL SPACE2 810 CONTINUE C CALL SPACE2 CALL NEED(5) CALL TV('Next, you will see residuals as functions of TIME.') CALL TV('Please inspect these plots carefully for evidence of') CALL RTNCON('variations with time.',21) CALL SPACE CALL NEED(24) C DO 820 N=1,NIGHTS CALL JD2DAT(REAL(2400000.5D0+DTZERO(N)),CARD(19:)) WRITE(CARD(LWORD(CARD)+3:),'(''= MJD'',F7.0)') DTZERO(N) CALL SPACE JBGN=0 DO 812 J=1,NPTS IF (KX(1,J).NE.1) GO TO 812 IF (KX(4,J).EQ.N) THEN IF (JBGN.EQ.0) JBGN=J JEND=J END IF 812 CONTINUE C Night begins at JBGN and ends at JEND. C C Separate plots for different colors: DO 815 K=KMIN,KMAX CALL NEED(12) CARD(:18)=' '//BANDS(K)(:LENB)//' resids. on' CALL TVN(CARD) XLIM(1)=X(2,JBGN) XLIM(2)=X(2,JEND) YLIM(1)=SCALE*3. YLIM(2)=-YLIM(1) CALL PLOT(0,XLIM,YLIM,'L') CALL XAXIS(XLIM) DO 814 J=JBGN,JEND IF (KX(3,J).NE.K) GO TO 814 A1=DTYPE(J) CALL PLOT(-1,X(2,J),Y(J)-REAL(YC(J)),A1) 814 CONTINUE CALL PLOT(1,3.,3.,' ') CALL RTNCON(' decimal day (UT) -->',21) 815 CONTINUE C C ***** THIS BLOCK COMMENTED OUT ***** C C Combined plot for structure fcn.: C plot right-side up. C CALL PLOT(0,0.,0.,'I') C CALL PLOT(0,60.,23.,'P') C XLIM(1)=LOG(100./86400.) C XLIM(2)=LOG(ABS(X(2,JBGN)-X(2,JEND)))-0.5 C YLIM(1)=-25. C YLIM(2)=-4.5 C CALL PLOT(0,XLIM,YLIM,'L') C CALL NEED(24) C CALL CENTER('Temporal structure function of residuals:') C CALL TVN(' ln(D)') C L=0 C DO 818 J=JBGN,JEND C K=KX(3,J) C IF (W(J).LT.0.2E-4/VARK(K)) GO TO 818 C IF(ABS(Y(J)-REAL(YC(J))).GT.0.5) GO TO 818 C DO 817 JJ=J+1,JEND C K=KX(3,JJ) C IF (W(JJ).LT.0.2E-4/VARK(K)) GO TO 817 C TERM=ABS(X(2,J) - X(2,JJ)) C IF (TERM.EQ.0.) GO TO 817 C IF (ABS(Y(JJ)-REAL(YC(JJ))).GT.0.5 ) GO TO 817 C L=L+1 C XS(L)=LOG(TERM) C YS(L)=((Y(J)-REAL(YC(J))) - (Y(JJ)-REAL(YC(JJ))) )**2 C IF (YS(L).EQ.0.) YS(L)=1.E-6 C IF (YS(L).GT.1.2) THEN C skip wild resids. C L=L-1 C ELSE C YS(L)=LOG(YS(L)) C END IF C IF (L.EQ.MXOBS) GO TO 819 C 817 CONTINUE C 818 CONTINUE C 819 CALL PLOT(L,XS,YS,'*') C CALL RTNCON(' log(Lag, days) -->',19) C Make inverted plots again. C CALL PLOT(0,0.,1.,'I') C Put 2 plots per screen. C CALL PLOT(0,78.,12.,'P') C C end of night: CALL CENTER(' * * * * * * * * * * * * * * * * * * * * * *') CALL SPACE2 820 CONTINUE C IF (.NOT.(TIMFLGA .OR. TIMFLGZ) ) THEN CALL ASK('Do you want to solve for TIME-dependent parameters?',A1) ELSE CALL TV('Do you want to solve for a DIFFERENT set of') CALL ASKN('time-dependent parameters?',A1) END IF C IF (A1.EQ.'Y') THEN C drop through. ELSE IF (A1.EQ.'N') THEN C eat spaghetti. GO TO 860 ELSE END IF C C C Plot drift-detection graphs: C CALL SPACE2 CALL TV('Now, you will see the drift-detection plots.') CALL SPACE CALL PLOT(0,60.,23.,'P') C DO 840 N=1,NIGHTS CALL JD2DAT(REAL(2400000.5D0+DTZERO(N)),CARD(19:)) WRITE(CARD(LWORD(CARD)+3:),'(''= MJD'',F7.0)') DTZERO(N) CALL SPACE JBGN=0 DO 822 J=1,NPTS IF (KX(1,J).NE.1) GO TO 822 IF (KX(4,J).EQ.N) THEN IF (JBGN.EQ.0) JBGN=J JEND=J END IF 822 CONTINUE C Night begins at JBGN and ends at JEND. DO 828 K=KMIN,KMAX TIME=3.E33 SUMNI=0. SUMNS=0. JOLD=0 L=0 DO 823 J=JBGN,JEND IF (KX(3,J).NE.K .OR. W(J).LT.0.2E-4/VARK(K)) GO TO 823 C Here for another good point in right color. IF (ABS(TIME-X(2,J)).LT.0.05) THEN C Close enough to ignore drift; add to list. XSTAR=X(1,J) C XSTAR is current airmass; YBAR is old one. C skip useless pairs: IF (ABS(XSTAR-XBAR).LT.0.05) GO TO 823 YSTAR=Y(J)-REAL(YC(J)) C YSTAR is current resid.; YBAR is old one. L=L+1 YS(L)=YSTAR-YBAR TERM=(XSTAR-XBAR)/(XSTAR+XBAR) XS(L)=TERM*(YSTAR+YBAR) C YS is diff. between adjacent pair of resids.; C XS is that expected from slope from origin to their mean. C These should be equal IF extinction drift is main error. SUMNI=SUMNI+1. SUMNS=SUMNS+ABS(TERM) END IF C Advance time. TIME=X(2,J) YBAR=Y(J)-REAL(YC(J)) XBAR=X(1,J) JOLD=J 823 CONTINUE IF (L.LT.10) THEN CARD='Too few data to diagnose '//BANDS(K) CALL TV(CARD) GO TO 828 ELSE CALL SORT2(XS,YS,L) XBAR=(XS(L/2+1)+XS((L+1)/2))*0.5 XSTAR=(XS(L/4+1)-XS(L-L/4))*1.5 XLIM(1)=XBAR-XSTAR XLIM(2)=XBAR+XSTAR CALL SORT2(YS,XS,L) YBAR=(YS(L/2+1)+YS((L+1)/2))*0.5 YSTAR=(YS(L/4+1)-YS(L-L/4))*1.5 YLIM(1)=YBAR-YSTAR YLIM(2)=YBAR+YSTAR CALL PLOT(0,XLIM,YLIM,'L') CALL XAXIS(XLIM) CALL ROBLIN(XS,YS,L, XBAR,YBAR,SLOPE) DO 825 I=1,80 OLDX=XLIM(1)+(XLIM(2)-XLIM(1))*I/60. CALL PLOT(-1,OLDX,SLOPE*OLDX,'+') 825 CONTINUE CALL NEED(24) CARD=BANDS(K)(:LENB)//' drift plot slope =' WRITE(CARD(LWORD(CARD)+1:),'(F5.2,I5,A)')SLOPE,L,' data' CALL CENTER(CARD) CALL TVN('differential offset') CALL PLOT(L,XS,YS,'*') CARD=' mean offset -->' WRITE(CARD(27:),'(A,2F7.3)') 1 'ratios:',SUMNS/SUMNI,XSTAR/YSTAR CALL RTNCON(CARD,50) C use mean values: IF (SLOPE.GT.0.5) THEN NAT(K,N)=NAT(K,N)+1 ELSE NZT(K,N)=NZT(K,N)+1 END IF C use spreads: IF (SUMNS/SUMNI.LT.XSTAR/YSTAR) THEN NAT(K,N)=NAT(K,N)+1 ELSE NZT(K,N)=NZT(K,N)+1 END IF END IF 828 CONTINUE C end of night. CALL CENTER(' * * * * * * * * * * * * * * * * * * * * * *') CALL SPACE2 840 CONTINUE C end of loop over nights. C CALL NEED(MIN(24,2*NIGHTS+4)) CALL TV('Summary of residual analysis:') WRITE(CARD,'(A9,10(A6,1X))')'Night', 1 (BANDS(K)(:LENB),K=KMIN,MIN(10+KMINM1,KMAX)) CALL TV(CARD) WRITE(CARD,'(4X,''----- '',10(A7))') 1 ('------ ',K=KMIN,MIN(10+KMINM1,KMAX)) CALL TVN(CARD) SUMNI=0. SUMNS=0. DO 850 N=1,NIGHTS WRITE(CARD,'(I7)') N DO 848 K=KMIN,KMAX J=8+7*K+LENB/2 IF (NAT(K,N).EQ.1) THEN CARD(J:J)='e' SUMNI=SUMNI+1. ELSE IF (NAT(K,N).EQ.2) THEN CARD(J:J)='E' SUMNI=SUMNI+2. ELSE IF (NZT(K,N).EQ.1) THEN CARD(J:J)='z' SUMNS=SUMNS+1. ELSE IF (NZT(K,N).EQ.2) THEN CARD(J:J)='Z' SUMNS=SUMNS+2. ELSE CARD(J:J)='-' END IF 848 CONTINUE CALL TV(CARD) 850 CONTINUE C 851 CALL SPACE IF (NIGHTS.GT.6) CALL RTNCON(' ',1) CALL TV('Do you want to have time-dependent') CALL TV(' Extinction') CALL TV(' Zero-points') CALL TV(' Neither') CALL TV(' or Both ?') CALL ASK(' ?',A1) C IF (A1.EQ.'E') THEN IF (TIMFLGA.AND. .NOT.TIMFLGZ) THEN C drop through. ELSE TIMFLGA=.TRUE. GO TO 512 END IF ELSE IF (A1.EQ.'Z') THEN IF (TIMFLGZ.AND. .NOT.TIMFLGA) THEN C drop through. ELSE TIMFLGZ=.TRUE. GO TO 512 END IF ELSE IF (A1.EQ.'N') THEN C drop through. ELSE IF (A1.EQ.'B') THEN IF (TIMFLGZ.AND.TIMFLGA) THEN C drop through. ELSE TIMFLGA=.TRUE. TIMFLGZ=.TRUE. GO TO 512 END IF ELSE IF (HELP(A1)) THEN IF (SUMNI.GT.FLOAT(NIGHTS*NKS)) THEN CALL TV('More than half of data show variable extinction.') ELSE IF (SUMNS.GT.FLOAT(NIGHTS*NKS)) THEN CALL TV('More than half of data show variable zero-pts.') ELSE CALL TV('Not much evidence.') END IF IF (STABLE) THEN CALL TV('The instrument should be stable, so variation is') CALL TVN('more likely in the extinction.') END IF CALL SPACE CALL RTNCON(' ',1) GO TO 851 ELSE GO TO 851 END IF C C C Plot transformation residuals if we solved for transformation above: 860 IF (USES4X) CALL PLTRAN(BANDS,CARD,NONSTD,NPTS,DTYPE) C C Plot linearity: C CALL SPACE2 IF (NDETS.EQ.1) THEN CALL CENTER('Linearity check:') ELSE CALL CENTER('Linearity checks:') END IF C DO 880 NDET=MINDET,MAXDET IF (NDT2NP(NDET).EQ.0) GO TO 880 CALL NEED(24) CARD=DETNAME(NDET)(:LWORD(DETNAME(NDET)))// 1 ' Residual vs. Intensity' CALL TV(CARD) CALL PLOT(0,79.,22.,'P') CALL PLOT(0,0.,1.,'O') N=0 DO 870 I=1,NONSTD IF (KX(5,I).NE.NDET) GO TO 870 K=KX(3,I) ND=KX(6,I) N=N+1 C use actually measured intensity. XS(N)=(10.**(-0.4*Y(I))) YS(N)=Y(I)-REAL(YC(I)) ZDUM(N)=ICHAR(DTYPE(I)) 870 CONTINUE C sort intensities to determine scaling: CALL SORT2(XS,YS,N) XLIM(1)=0. XLIM(2)=XS(N) YLIM(1)=SCALE*3. YLIM(2)=-YLIM(1) CALL PLOT(0,XLIM,YLIM,'L') C Draw x-axis: CALL XAXIS(XLIM) C plot data. DO 875 I=1,N CALL PLOT(-1,XS(I),YS(I),CHAR(INT(ZDUM(I)))) 875 CONTINUE C Restore normal plotting. CALL PLOT(0,0.,0.,'O') CALL PLOT(1,-1.,3.,' ') CALL RTNCON(' Intensity -->',19) CALL SPACE 880 CONTINUE C C C ***** Report final results: ***** C 900 CONTINUE CALL REPORT(LMAX,BANDS,L2N,USES4X,1) C C List final values: C IF (IPR.GT.4) THEN C List individual parameters to debug REPORT. CALL SPACE CALL TV('Parameter values:') DO 910 NP=1,NPARMS WRITE(CARD,'(I4,F10.5,'' +/-'',F10.5)') NP,P(NP),SP(NP) CALL TVN(CARD) 910 CONTINUE END IF C C C tabulate individual residuals in logfile: C CALL SPACE2 CALL NEED(8) CARD='Residuals for individual observations:' CARD(54:)='(rejects flagged by *)' CALL TV(CARD) CARD=' SYM STAR BAND AIRMASS OBS' CARD(60:)='WT RESID' CALL TV(CARD) C save for page head: PAGE(1)=CARD CALL STKRDI('LOG',7,1, N,NLPP,IUNIT,NULLS,ISTAT) IF (ISTAT.NE.0) CALL STETER(948,'Could not read Keyword LOG') C NLPP is no.of lines per page. NREJ1=0 NREJ2=0 DO 950 J=1,NPTS IF (KX(1,J).NE.1) GO TO 960 I=L2N(KX(2,J)) K=KX(3,J) C N=KX(4,J) C1=DTYPE(J) IF (W(J)*(Y(J)-REAL(YC(J)))**2 .GT. 36.E-4) THEN C Flag and count rejects. A1='*' NREJ1=NREJ1+1 ELSE A1=' ' END IF 949 FORMAT(A3,3X,A20,A6,4(3X,F7.3),A2) WRITE(CARD,949) 1 C1,STARS(I),BANDS(K),X(1,J),Y(J),W(J),Y(J)-REAL(YC(J)),A1 CALL TVN(CARD) C Where are we on page? CALL STKRDI('LOG',6,1, N,L,IUNIT,NULLS,ISTAT) IF (ISTAT.NE.0) CALL STETER(950,'Could not read Keyword LOG') C Line L. Produce new page heading if needed: IF (L.EQ.NLPP) CALL TV(PAGE(1)) 950 CONTINUE CALL SPACE WRITE(CARD,981) NREJ1,' rejected observations' CALL TV(CARD) C C P's are still OK here. C C Transformation: C 960 IF (NSTDOBS.EQ.0) GOTO 980 C Just report results if we already solved for transformations. IF (USES4X) GO TO 973 CALL SPACE2 WRITE(CARD,'(38('' *''))') CALL TV(CARD) CALL SPACE CALL CENTER('Solving for transformations ...') CALL IPRSET(IPR) IF (IPR.EQ.0) CALL TV('Iterating...') C C Now solve for transformation, if not done in combined solution: C C First, free up the transformation parameters. DO 962 I=MSYSTZ+NKS+1,MSYSTZ+NSYSTP K=MOD(I-MSYSTZ+NKS,NKS) IF (K.EQ.0.) K=NKS K=K+KMINM1 IF (K1S(K).EQ.0) THEN C H-Beta. IF (TRCOEF(K).NE.0.) THEN PG(I)=1./TRCOEF(K) ELSE PG(I)=1. END IF C IF (K.EQ.1 .OR. K.EQ.5) THEN C betaW: keep fixed. CALL FIXP(I,PG(I),NIX) ELSE C betaN: vary. CALL UNFIXP(I,NIX) END IF ELSE C Normal. PG(I)=0. CALL UNFIXP(I,NIX) END IF 962 CONTINUE C Skip all observational data... DO 963 I=1,NONSTD 963 W(I)=0. C ... and fix star, night, and bandwidth parameters. DO 964 I=1,MSYSTZ+NKS 964 CALL FIXP(I,PG(I),NIX) C Finally, fix ND-filter and nonlinearity parameters. DO 965 I=MSYSTZ+NSYSTP+1,NPARMS 965 CALL FIXP(I,PG(I),NIX) C C Now include the std.values in the solution... C Subroutine DLSQ(YP,NPTS,NPARMS,NBLOX,MBLOK,NIX,NARGS,NKARGS,TEST) 966 CALL DLSQ(YPSTD,NPTOT,NPARMS, LMAX, NKS, NIX, 4 , 6 ,1.E-5) C ^ change to 4. C C Re-check weights: C DO 967 K=KMIN,KMAX XS(K)=0. YS(K)=0. 967 CONTINUE C scan data & accumulate biweight stuff. DO 968 J=NONSTD+1,NPTOT K=KX(3,J) IF (K1S(K).EQ.0 .AND. (K.EQ.1 .OR. K.EQ.5)) THEN C betaW: keep fixed. ELSE C Normal band. TERM=W(J)*(Y(J)-REAL(YC(J)))**2 C Term is Studentized residual squared. USQ=TERM/(36.*SCALE**2) C C=6 for biweight A-estimator. IF (USQ.LT.1.) THEN C Use it. XS(K)=XS(K)+TERM*((1.-USQ)**4) YS(K)=YS(K)+(1.-USQ)*(1.-5.*USQ) ELSE C Ignore it. END IF END IF 968 CONTINUE IF (IPR.GT.0) THEN CALL SPACE CALL TV('Revising conformity errors:') ELSE CALL TVN('revising conformity errors...') END IF FLAGGED=.FALSE. C update variances: CARD(:5)=' ' DO 969 K=KMIN,KMAX IF (K1S(K).EQ.0 .AND. (K.EQ.1 .OR. K.EQ.5)) THEN C betaW: keep fixed. ELSE C Normal band. IF (YS(K).GT.1.) THEN BIWVAR=(NPTOT-NONSTD)*XS(K)/(YS(K)*(YS(K)-1.)) ELSE BIWVAR=VARK(K)*2. END IF C prevent unreal weights. IF (BIWVAR.LT.1.E-6) BIWVAR=1.E-4 C flag if significant change. IF (ABS(BIWVAR-VARK(K))/VARK(K).GT.0.1) FLAGGED=.TRUE. C smoothing required for stability: VARK(K)=(BIWVAR+VARK(K))*0.5 CARD(6:)='typical conformity error in '//BANDS(K)(:LENB)//' =' WRITE(CARD(LENB+36:),'(F6.3)') SQRT(VARK(K)) IF (IPR.GT.0) CALL TV(CARD) END IF 969 CONTINUE IF (IPR.GT.0) CALL SPACE C update weights: DO 970 J=NONSTD+1,NPTOT K=KX(3,J) W(J)=1.E-4/VARK(K) 970 CONTINUE C Loop back & re-do soln. if needed. IF (FLAGGED)THEN C reset P's: DO 971 J=1,NPARMS PG(J)=P(J) 971 CONTINUE GO TO 966 ELSE IF (IPR.EQ.0) THEN C Show final conformity errors: CALL SPACE CALL TV('Adopted conformity errors:') DO 972 K=KMIN,KMAX CARD(6:)='typical conformity error in '//BANDS(K)(:LENB)//' =' WRITE(CARD(LENB+36:),'(F6.3)') SQRT(VARK(K)) CALL TV(CARD) 972 CONTINUE END IF C CALL SPACE CALL TV('VALUES after transformation solution:') CALL REPORT(LMAX,BANDS,L2N,.TRUE.,2) C C Show transformation results: C C First, plot... CALL PLTRAN(BANDS,CARD,NONSTD,NPTOT,DTYPE) C ...then, tabulate: 973 CALL TV('Standard-star residuals:') CARD=' SYM STAR BAND COLOR VALUE' C Special for H-Beta system: IF (K1S(1).EQ.0) CARD(26:42)=' ' CARD(60:)='WT RESID' CALL TV(CARD) C save for page head: PAGE(1)=CARD DO 975 J=NONSTD+1,NPTOT L=KX(2,J) I=L2N(L) K=KX(3,J) C1=DTYPE(J) IF (W(J)*(Y(J)-REAL(YC(J)))**2 .GT. 36.E-4) THEN C Flag rejects. A1='*' NREJ2=NREJ2+1 ELSE A1=' ' END IF IF (K1S(K).EQ.0) THEN C H-Beta. IF (K.GT.3) THEN C system = uvbyHB. WRITE(CARD,949) 1 C1,STARS(I),' beta ',3.E33, Y(J),W(J),Y(J)-REAL(YC(J)),A1 ELSE C system = H-Beta. WRITE (CARD,974) 1 C1,STARS(I), Y(J),W(J),Y(J)-REAL(YC(J)),A1 974 FORMAT(A3,3X,A32,4X,3(3X,F7.3),A2) END IF ELSE C Normal. K1I=(L-1)*NKS+K1S(K)-KMINM1 K2I=(L-1)*NKS+K2S(K)-KMINM1 WRITE(CARD,949) C1,STARS(I),BANDS(K), 1 (P(K1I)-P(K2I)),Y(J),W(J),Y(J)-REAL(YC(J)),A1 END IF CALL TVN(CARD) C Where are we on page? CALL STKRDI('LOG',6,1, N,L,IUNIT,NULLS,ISTAT) IF (ISTAT.NE.0) CALL STETER(975,'Could not read Keyword LOG') C Line L. IF (L.EQ.NLPP) CALL TV(PAGE(1)) 975 CONTINUE C 980 CONTINUE CALL SPACE2 WRITE(CARD,981) NREJ1,' rejected observations' IF (NREJ1.EQ.1) CARD(27:27)=' ' CALL TV(CARD) IF (NSTDOBS.NE.0) THEN WRITE(CARD,981) NREJ2,' rejected transformation data' IF (NREJ2.EQ.1) CARD(34:35)='um' CALL TV(CARD) END IF C WRITE(CARD,981)NREJ1+NREJ2,' total rejects out of',NPTOT 981 FORMAT(I5,A,I5) CARD(33:)='total data.' CALL TV(CARD) C IF (NREJ1+NREJ2 .GT. NPTS/10) THEN CALL TV('Excessive rejection of data. You may be trying to') CALL TVN('solve for more parameters than the data will allow.') IF (NIX.NE.NPARMS .AND. NONSTD/(NPARMS-NIX).LT.5) THEN WRITE (CARD,'(''Only'',F4.1,A)') REAL(NONSTD)/(NPARMS-NIX), 1 ' observations per parameter.' CALL TV(CARD) ELSE CALL TV(' Or you may have misidentified some stars.') END IF CALL SPACE CALL RTNCON(' ',1) END IF C IF (.NOT.DONE) THEN IF (IPR.EQ.4) IPR=3 GO TO 672 END IF C C C ***** END solutions ***** C C C C Tabulate results in results.tbl: C CALL TBTINI ('results.tbl', 0, 0, 1, 1, IDAT, ISTAT) IF (ISTAT.NE.0) THEN CALL TV('Unable to create results table...') CALL STECNT('PUT', JCONT,JLOG,JDISP) CALL STETER(980,' ') ELSE C CALL TV(' New results.tbl file created.') ENDIF C C Create columns for output table: C C CALL TBCINI (IDAT, D_I1_FORMAT, 1, 'I5', ' ', 'NBAND', C 1 KNBAND, ISTAT) C IF (ISTAT.NE.0) THEN C CALL TERROR(IDAT,980,'Could not create NBAND Column') C ENDIF C CALL TBCINI (IDAT, D_R8_FORMAT, 1,'F12.5',' ','MJDOBS', 1 KMJDOBS, ISTAT) IF (ISTAT.NE.0) THEN CALLTERROR(IDAT,981,'Could not create MJDOBS column') ENDIF C CALL TBCINI (IDAT, D_R8_FORMAT, 1,'F14.5',' ','HJD', 1 KHJD, ISTAT) IF (ISTAT.NE.0) THEN CALLTERROR(IDAT,982,'Could not create HJD column') ENDIF C CALL TBCINI (IDAT, D_C_FORMAT, 32, 'A32', ' ', 'OBJECT', 1 KOBJECT, ISTAT) IF (ISTAT.NE.0) THEN CALL TERROR(IDAT,983,'Could not create OBJECT Column') ENDIF C CALL TBCINI (IDAT, D_C_FORMAT, 8, 'A8', ' ', 'BAND', 1 KBAND, ISTAT) IF (ISTAT.NE.0) THEN CALL TERROR(IDAT,984,'Could not create BAND Column') ENDIF C CALL TBCINI (IDAT, D_R4_FORMAT, 1,'F7.3',' ','STDMAG', 1 KMAG, ISTAT) IF (ISTAT.NE.0) THEN CALLTERROR(IDAT,985,'Could not create STDMAG column') ENDIF C C CALL SPACE2 CALL SPACE2 CALL NEED(12) CALL TV('Individual observations, star by star:') C C Summarize individual observations: C NONEQ=1 KZ(1)=1 LOOPMX=2 IF (NSTDOBS.EQ.0) LOOPMX=1 C C NOTE: the many nested DO and IF blocks here are too numerous and C too long to indent fully. They are delimited by the kinds C of special comment delimiters you see below; the elements C of a given block or level have the same delimiters. C C ***** DO 1100 LOOP=1,LOOPMX C ***** CALL NEED(MIN(24,13+NKS)) WRITE(CARD,'(38('' *''))') CALL TV(CARD) CALL SPACE IF (LOOP.EQ.1) THEN CALL CENTER('INSTRUMENTAL SYSTEM') ELSE CALL CENTER('STANDARD SYSTEM') END IF NSLOT=0 C ==== DO 1060 I=1,NSTARS C ==== C == IF (N2L(I).NE.0) THEN C == C collect info for this star: CALL NEED(MIN(12,NKS+6)) CALL SPACE C CARD(:40)=STARS(I) IF (STYPE(I).EQ.'S') THEN CARD(41:51)=' Standard' ELSE IF (STYPE(I).EQ.'X') THEN CARD(41:51)='Extinction' ELSE IF (STYPE(I).EQ.'P' .OR. STYPE(I).EQ.'p') THEN CARD(41:51)=' Program' ELSE IF (STYPE(I).EQ.'V') THEN CARD(41:51)=' Variable' ELSE CARD(41:51)=STYPE(I) END IF CARD(52:60)='star, in' C IF (LOOP.EQ.1)THEN CARD(61:)='instrumental system' ELSE CARD(61:)='standard system' END IF C CALL TV(CARD) C CARD=' UT days HJD-2400000 observation' CALL TV(CARD) CARD=' ------- ----------- -----------' CALL TVN(CARD) CONTIG=.FALSE. C --- loop over data (J): DO 1050 J=1,NDATA C --- C -- IF (NSTR(J).NE.I) THEN C -- CONTIG=.FALSE. C -- ELSE C -- C Got an observation of this star. N=NITE(J) COMPLETE=.TRUE. C C (begin loop over passbands). DO 1010 K=KMIN,KMAX C Search for complete set of data: C search for neighboring data in band K: JPRE(K)=0 JPOST(K)=0 C C Note: J is index of datum in observation list C JPRE is index of preceding datum in band K C JPOST is index of following datum in band K C C search backward for previous datum (JJ) in band K: DO 1004 JJ=J-1,1,-1 C Break out at end of night: IF (NITE(JJ).NE.N) GO TO 1005 IF (KBND(JJ).EQ.K .AND. NSTR(JJ).EQ.I) THEN C Found a preceding datum. JPRE(K)=JJ XS(K)=DJOBS(JJ) KN=NITEZ + (N-1)*MPPN + (K-KMIN)*MPPKN C initial guess ignores color terms, but includes ND. C Convert ND filter name to number: DO 1002 ND=1,NDS IF (NDFILT(JJ).EQ.NDNAME(ND)) GO TO 1003 1002 CONTINUE ND=1 1003 NDK=ND2NP(ND,K) C save starting value, corrected for "first-order" ext.: YS(K)=SIGNAL(JJ)-P(KN+1) - AIRM(JJ)*P(KN+2) 1 - P(NDZ+NDK) GO TO 1005 END IF 1004 CONTINUE C 1005 CONTINUE C search forward for next datum in band K: DO 1008 JJ=J+1,NDATA IF (NITE(JJ).NE.N) GO TO 1009 IF (KBND(JJ).EQ.K .AND. NSTR(JJ).EQ.I) THEN C Found a following datum. JPOST(K)=JJ XS(K+KMAX)=DJOBS(JJ) KN=NITEZ + (N-1)*MPPN + (K-KMIN)*MPPKN DO 1006 ND=1,NDS IF (NDFILT(JJ).EQ.NDNAME(ND)) GO TO 1007 1006 CONTINUE ND=1 1007 NDK=ND2NP(ND,K) YS(K+KMAX)=SIGNAL(JJ)-P(KN+1) - AIRM(JJ)*P(KN+2) 1 - P(NDZ+NDK) GO TO 1009 END IF 1008 CONTINUE C 1009 CONTINUE C C XS(K) now holds time of preceding observation in band K C YS(K) now holds (approx.) preceding observation in band K C XS(K+KMAX) holds time of following observation in band K C YS(K+KMAX) holds (approx.) following observation in band K C C See if we have a complete set: IF (JPRE(K).EQ.0.AND.JPOST(K).EQ.0.AND.K.NE.KBND(J)) THEN C No data this night for star I in band K. COMPLETE=.FALSE. ELSE IF (JPRE(K).EQ.0 .AND. JPOST(K).NE.0) THEN C No previous datum; use post instead. JPRE(K)=JPOST(K) XS(K)=XS(K+KMAX) YS(K)=YS(K+KMAX) ELSE IF (JPOST(K).EQ.0 .AND. JPRE(K).NE.0) THEN C No following datum; use pre instead. JPOST(K)=JPRE(K) XS(K+KMAX)=XS(K) YS(K+KMAX)=YS(K) ELSE C found both. END IF C 1010 CONTINUE C (ends loop over passbands). C C Now make sure EACH datum is nearest the rest in each set: JJ=0 DO 1011 K=KMIN,KMAX C Skip K of current obs: IF (K.EQ.KBND(J)) GO TO 1011 JJ=JJ+1 ZDUM(JJ)=XS(K) ZDUM(JJ+KMAX)=XS(K+KMAX) 1011 CONTINUE C We now have the *other* bands' times in ZDUM. C Sort the first (JJ = NKS-1) entries & take median: CALL SORT1(ZDUM,JJ) TIME=(ZDUM(JJ/2+1) + ZDUM((JJ+1)/2))*0.5 K=KBND(J) C IF (ABS(TIME-XS(K)).GT.ABS(TIME-DJOBS(J)) .OR. 1 JPRE(K).EQ.0)THEN C Switch to sample at J: JPRE(K)=J XS(K)=DJOBS(J) KN=NITEZ + (N-1)*MPPN + (K-KMIN)*MPPKN C initial guess ignores color terms, but includes ND filter. DO 1012 ND=1,NDS IF (NDFILT(J).EQ.NDNAME(ND)) GO TO 1013 1012 CONTINUE ND=1 1013 NDK=ND2NP(ND,K) YS(K)=SIGNAL(J)-P(KN+1) - AIRM(J)*P(KN+2) 1 - P(NDZ+NDK) ELSE C Don't switch. END IF C C Now do the same for the "Post-" sample: DO 1014 K=1,NKS-1 C Move them down to start of array... ZDUM(K)=ZDUM(K+KMAX) 1014 CONTINUE C Sort the first JJ entries & take median: CALL SORT1(ZDUM,JJ) TIME=(ZDUM(JJ/2+1) + ZDUM((JJ+1)/2))*0.5 K=KBND(J) C IF (ABS(TIME-XS(K+KMAX)).GT.ABS(TIME-DJOBS(J)) .OR. 1 JPOST(K).EQ.0) THEN C Switch. JPOST(K)=J XS(K+KMAX)=DJOBS(J) KN=NITEZ + (N-1)*MPPN + (K-KMIN)*MPPKN C initial guess ignores color terms, but includes ND filter. DO 1015 ND=1,NDS IF (NDFILT(J).EQ.NDNAME(ND)) GO TO 1016 1015 CONTINUE ND=1 1016 NDK=ND2NP(ND,K) YS(K+KMAX)=SIGNAL(J)-P(KN+1) - AIRM(J)*P(KN+2) 1 - P(NDZ+NDK) ELSE C Don't switch. END IF C C We now have starting values in YS(K) (at time XS(K)) and C ... YS(K+KMAX) (at XS(K+KMAX)). IF (COMPLETE) THEN C ... C do FULL reduction for preceding and following sets... C (save results in star slots 1 and 2 of P arrays) KZ(4)=N C load starting values: DO 1020 K=KMIN,KMAX P(K-KMIN+1)=YS(K) P(K-KMIN+1+NKS)=YS(K+KMAX) 1020 CONTINUE C C Now ready to make differential corrections for color terms: C debugging: C CALL TV('iteration:') DO 1034 L=1,4 DO 1033 K=KMIN,KMAX KZ(3)=K C C Pretend preceding observation is star #1: KZ(2)=1 JJ=JPRE(K) KZ(5)=NDTUSD(KBND(JJ)) C Convert ND filter name to number: DO 1026 ND=1,NDS IF (NDFILT(JJ).EQ.NDNAME(ND)) GO TO 1027 1026 CONTINUE ND=1 1027 KZ(6)=ND Z(1)=AIRM(JJ) Z(2)=DJOBS(JJ) Z(3)=FTMP(JJ) Z(4)=RELH(JJ) C Set YT: CALL YPSTD P(K-KMIN+1)=P(K-KMIN+1)+(SIGNAL(JJ)-YT) C debugging: C WRITE(CARD,*)K,P(K-KMINM1) C CALL TVN(CARD) C C Pretend following observation is star #2: KZ(2)=2 JJ=JPOST(K) KZ(5)=NDTUSD(KBND(JJ)) DO 1028 ND=1,NDS IF (NDFILT(JJ).EQ.NDNAME(ND)) GO TO 1029 1028 CONTINUE ND=1 1029 KZ(6)=ND Z(1)=AIRM(JJ) Z(2)=DJOBS(JJ) Z(3)=FTMP(JJ) Z(4)=RELH(JJ) C Set YT: CALL YPSTD P(K-KMIN+1+NKS)=P(K-KMIN+1+NKS)+(SIGNAL(JJ)-YT) 1033 CONTINUE 1034 CONTINUE C C Now interpolate each color to time of main band: DO 1035 K=KMIN,KMAX IF (XS(K).NE.XS(K+KMAX)) THEN C Note: we use K1 and K2 in a NON-standard way here! K1=K-KMINM1 K2=K1+NKS C interpolate to DJOBS(J): P(K1)=P(K1)+ 1 (P(K2)-P(K1))*(DJOBS(J)-XS(K))/(XS(K+KMAX)-XS(K)) ELSE C No interpolation needed. END IF 1035 CONTINUE C C We now have interpolated colors in star 1. Reduce main band: K=KBND(J) KOFF=K-KMINM1 KZ(2)=1 KZ(3)=K KZ(5)=NDTUSD(K) DO 1036 ND=1,NDS IF (NDFILT(J).EQ.NDNAME(ND)) GO TO 1037 1036 CONTINUE ND=1 1037 KZ(6)=ND Z(1)=AIRM(J) Z(2)=DJOBS(J) Z(3)=FTMP(J) Z(4)=RELH(J) C Iterate... DO 1038 L=1,4 CALL YPSTD P(KOFF)=P(KOFF)+(SIGNAL(J)-YT) 1038 CONTINUE C Whew. Now output result: C IF(CONTIG)THEN C no space. ELSE CALL SPACE CONTIG=.TRUE. END IF C C HELCOR Requires full JD as 3rd arg. HJD=(DTZERO(N)+DJOBS(J)) + 0.5D0 + 1 HELCOR(RAS(I), DECS(I), 2 (DTZERO(N)+DJOBS(J))+2400000.5D0) C HJD is now true HJD -2400000. K1=K1S(K) K2=K2S(K) C save integer part of day for output. TERM=MOD(DTZERO(N),10.D0) C .. IF (LOOP.EQ.1) THEN C .. C Output INSTRUMENTAL values on 1st pass: C IF (K1.EQ.0) THEN C H-Beta. WRITE(CARD,1041) 1 TERM+DJOBS(J),HJD,BANDS(K)(:LENB),P(KOFF) 1041 FORMAT(F10.5,F13.5,2X,A,' =',F8.3) ELSE C Normal. WRITE(CARD,1042) 1 TERM+DJOBS(J),HJD,BANDS(K)(:LENB),P(KOFF), 2 BANDS(K1)(:LENB),BANDS(K2)(:LENB), 3 P(K1-KMINM1)-P(K2-KMINM1) 1042 FORMAT(F10.5,F13.5,2X,A,' =',F8.3,' if (',A,' - ',A,') =' 1,F7.3) END IF C .. ELSE C .. C Output STANDARD values on 2nd pass: C KTRANS=MTRANZ+KOFF C IF (K1.EQ.0) THEN C H-Beta. IF (K.EQ.1 .OR. K.EQ.5) THEN C betaW; do nothing. GO TO 1050 ELSE C betaN; output results. XMAG(K,1)=P(KTRANS)*(P(KOFF)-P(KOFF-1)) + 1 P(KTRANS+NKS) WRITE (CARD,1046) 1 TERM+DJOBS(J),HJD, XMAG(K,1) 1046 FORMAT(F10.5,F13.5,' Beta =',F6.3) END IF ELSE C Normal. XMAG(K,1)=P(KOFF) + C color term: 1 P(KTRANS)*(P(K1-KMINM1)-P(K2-KMINM1)) + C zero-point term: 2 P(MTRZ+KOFF) IF (USE3PT(K)) THEN C add curve term: XMAG(K,1)=XMAG(K,1) + P(KTRANS+NKS)* C curve: 1 ( (P(K1-KMINM1) - P(K1+1-KMINM1)) - 2 (P(K1+1-KMINM1) - P(K2-KMINM1)) ) END IF WRITE (CARD,1047) 1 TERM+DJOBS(J),HJD,BANDS(K)(:LENB), XMAG(K,1) 1047 FORMAT(F10.5,F13.5,2X,A,' =',F8.3) END IF C C ... and write to results.tbl: C (reduce indent 2 cols.) NSLOT=NSLOT+1 C CALL TBEWRD(IDAT,NSLOT,KMJDOBS,DJOBS(J)+DTZERO(N), ISTAT) IF (ISTAT.NE.0) THEN CALLTERROR(IDAT,1047,'Could not write to MJDOBS Column') ENDIF C CALL TBEWRD(IDAT, NSLOT, KHJD, HJD, ISTAT) IF (ISTAT.NE.0) THEN CALL TERROR(IDAT,1047,'Could not write to HJD Column') ENDIF C CALL TBEWRC(IDAT, NSLOT, KOBJECT, STARS(I), ISTAT) IF (ISTAT.NE.0) THEN CALLTERROR(IDAT,1047,'Could not write to OBJECT Column') ENDIF C CALL TBEWRC(IDAT, NSLOT, KBAND, BANDS(K), ISTAT) IF (ISTAT.NE.0) THEN CALL TERROR(IDAT,1047,'Could not write to BAND Column') ENDIF C CALL TBEWRR(IDAT, NSLOT, KMAG, XMAG(K,1), ISTAT) IF (ISTAT.NE.0) THEN CALLTERROR(IDAT,1047,'Could not write to STDMAG Column') ENDIF C (sorry about missing indents; lines are too long.) C .. END IF C .. C CALL TVN(CARD) C ... ELSE C ... C ARRGHHH! NOT a complete set. Give up for now: CARD=' Incomplete data set for '//STARS(I) CALL TV(CARD) CALL TVN('... cannot be reduced accurately.') C ... END IF C ... (ends block testing for complete set). C -- END IF C -- (ends block matching current star). C --- 1050 CONTINUE C --- (ends loop on J over observations). C == ELSE C == C skip unobserved star. C == END IF C == C C ==== 1060 CONTINUE C ==== C C ***** 1100 CONTINUE C ***** C C C C ************ We are done; end MIDAS: **************************** C C Close output table file. CALL TBTCLO(IDAT, ISTAT) C Restore flags... CALL STECNT('PUT', JCONT,JLOG,JDISP) C ...and quit. CALL STSEPI C END SUBROUTINE YPSTD C C C evaluates the equation of condition: C C C m = m (K,I) + A(K,N)*AIRMASS + Z(K,N) C obs 0 C -W*(AM)*(STGRAD + AM/2) C C where AM is atmospheric reddening, and STGRAD is stellar gradient. C C IMPLICIT NONE C DOUBLE PRECISION WIDTH, STGRAD, ATGRAD, RED, WRTERM, WCTERM, COLOR DOUBLE PRECISION CURVE, PCURVE, PTRANS EQUIVALENCE (STGRAD, COLOR) C INTEGER I, K, N, NDET, ND, KK, KI, KNZ, KNA, NPND, KW, K1, 1 K2, KIK1, KIK2, KNK1, KNK2, KTRANS C INCLUDE 'MID_REL_INCL:kingfit.inc' INCLUDE 'MID_REL_INCL:dlsq.inc' C INTEGER KMIN, KMAX, NKS, KMINM1, MPPN, MPPKN, NITEZ, MSYSTZ INTEGER NSYSTP, NDZ, NDEDTZ, NTRANS INTEGER MTRANZ, MTR2Z, MTRZ, MT1Z, MT2Z, MRHZ C EQUIVALENCE (KMIN,KDUM(1)), (KMAX,KDUM(2)), (NKS,KDUM(3)) EQUIVALENCE (KMINM1,KDUM(4)), (MPPN,KDUM(5)), (MPPKN,KDUM(6)) EQUIVALENCE (NITEZ,KDUM(7)), (MSYSTZ,KDUM(8)), (NSYSTP,KDUM(9)) EQUIVALENCE (NUMNDS,KDUM(10)), (NDZ,KDUM(11)), (NDEDTZ,KDUM(12)) EQUIVALENCE (NTRANS,KDUM(13)) EQUIVALENCE (MTRANZ,KDUM(14)), (MTR2Z,KDUM(15)), (MTRZ,KDUM(16)) EQUIVALENCE (MT1Z,KDUM(17)), (MT2Z,KDUM(18)), (MRHZ,KDUM(19)) C EQUIVALENCE (I,KZ(2)), (K,KZ(3)), (N,KZ(4)), (NDET,KZ(5)), 1 (ND,KZ(6)) REAL AIRMASS, TIME EQUIVALENCE (AIRMASS,Z(1)), (TIME, Z(2)) C INCLUDE 'MID_REL_INCL:mbands.inc' C PARAMETER (MBANDS=9) C C Common for solution flags (appears in REDUCE, YPSTD & REPORT): C LOGICAL USE3PT, USES3PTS COMMON /SOLFLG/ USE3PT(MBANDS), USES3PTS C C INCLUDE 'MID_REL_INCL:obs.inc' C C Common for time dependences: C REAL TIMID(MXNITE) INTEGER NAT(MBANDS,MXNITE),NZT(MBANDS,MXNITE) LOGICAL TIMFLGA, TIMFLGZ COMMON /TIMDEP/ TIMID, NAT,NZT, TIMFLGA,TIMFLGZ C C C Common for ND filters: C INTEGER MXCOLR PARAMETER (MXCOLR=3*MBANDS) INTEGER NUM2ND(MBANDS),NP2ND(MBANDS*MBANDS),NP2K(MBANDS*MBANDS) INTEGER ND2NP(MBANDS,MBANDS), NUMNDS,NDK,NDS C indices: ND,K REAL XND(MBANDS,MBANDS) COMMON /NDJUNK/XND,NUM2ND,NP2ND,NP2K,ND2NP,NDS C C Common for dead-time corrections: C REAL DEDTS(MXCOLR),SDEDTS(MXCOLR) INTEGER NDT2NP(MXCOLR) LOGICAL PC(MXCOLR),DC(MXCOLR),CI(MXCOLR) COMMON /NDTX/NDT2NP,DEDTS,SDEDTS,PC,DC,CI C C Common for long comments: C CHARACTER*79 PAGE(21) COMMON /SCREEN/PAGE C C Common for color baselines: C INTEGER K1S(MBANDS),K2S(MBANDS) COMMON /K12S/ K1S, K2S C C C Local stuff: C DOUBLE PRECISION RATE, FACTOR, TOFF INTEGER IPK, JJ, KIKM, KDRIFTA, KDRIFTZ C C ******************************************** C C Don't forget: KIP = no. of terms evaluated! C C C ************* BEGIN execution ************ C KK=K-KMINM1 C KK=1 for K=KMIN; KK=NKS for K=KMAX. KI=(I-1)*NKS + KK C IF (KZ(1).NE.1) GO TO 100 C C C Here for ordinary star observation. C C Basic terms: C KNZ=NITEZ + (N-1)*MPPN + (K-KMIN)*MPPKN + 1 KNA=KNZ+1 C IP(1)=KI IP(2)=KNZ IP(3)=KNA KIP=3 C PART(KI)=1. PART(KNZ)=1. PART(KNA)=AIRMASS C YT=P(KI) + P(KNA)*AIRMASS + P(KNZ) C C Time-dependent terms: C IF (TIMFLGA) THEN C add extinction-drift term... TOFF=TIME-TIMID(N) IF (TIMFLGZ) THEN C ...and zero-drift term. KDRIFTZ=KNA+1 KDRIFTA=KDRIFTZ+1 KIP=KIP+1 IP(KIP)=KDRIFTZ PART(KDRIFTZ)=TOFF C extinction-drift term here. KIP=KIP+1 IP(KIP)=KDRIFTA PART(KDRIFTA)=AIRMASS*TOFF YT=YT + TOFF*(P(KDRIFTZ) +P(KDRIFTA)*AIRMASS) ELSE C ...only extinction-drift term. KDRIFTA=KNA+1 KIP=KIP+1 IP(KIP)=KDRIFTA PART(KDRIFTA)=AIRMASS*TOFF YT=YT + TOFF*P(KDRIFTA)*AIRMASS END IF ELSE IF (TIMFLGZ) THEN C add zero-drift term. TOFF=TIME-TIMID(N) KDRIFTZ=KNA+1 KIP=KIP+1 IP(KIP)=KDRIFTZ PART(KDRIFTZ)=TOFF YT=YT + TOFF*P(KDRIFTZ) ELSE C OK as is. END IF C C C Do we need ND filter adjustment? C IF (NUMNDS.GT.1) THEN NDK=ND2NP(ND,K) NPND=NDZ+NDK KIP=KIP+1 IP(KIP)=NPND PART(NPND)=1. YT=YT+P(NPND) END IF C C C Now to add bandwidth effects: C KW=MSYSTZ+KK C KW=MSYSTZ+1 for K=KMIN C KW=MSYSTZ+NKS for K=KMAX WIDTH=P(KW) IF (WIDTH.NE.0.) THEN C CAUTION: This time-saver prevents evaluation if P(KW)=0. C IF (K1S(K).EQ.0) THEN C special for H-Beta: IF (K.GT.4) THEN C uvbyHB. Use (b-y) color to reduce both wide & narrow. K1=3 -K K2=4 -K ELSE C pure H-Beta. NO color available! C CALL TV('Program error: no colors available!') C CALL STSEPI END IF ELSE C normal band. K1=K1S(K) -K K2=K2S(K) -K END IF C C K1, K2 are k-OFFSETS for color baseline. C (note that this is DIFFERENT from usage elsewhere!) C KIK1=KI+K1 KIK2=KI+K2 C Stellar gradient: STGRAD=P(KIK1) - P(KIK2) C KNK1=KNA+K1*MPPKN KNK2=KNA+K2*MPPKN C Atmospheric gradient: ATGRAD=P(KNK1) - P(KNK2) C C Strictly speaking, we should include the instantaneous reddening C here, if it is time-dependent. As that is a higher-order effect, C we neglect it.... C C Atmospheric reddening: RED=AIRMASS*ATGRAD PART(KW)=-RED*(STGRAD + 0.5*RED) YT=YT+WIDTH*PART(KW) C C Update indexing: KIP=KIP+1 IP(KIP)=KW C WRTERM=WIDTH*RED WCTERM= WIDTH*AIRMASS*(STGRAD+RED) C IF (K1.NE.0) THEN C new term. IP(KIP+1)=KIK1 IP(KIP+2)=KNK1 KIP=KIP+2 PART(KIK1)= -WRTERM PART(KNK1)= - WCTERM ELSE C term already exists. PART(KIK1)=PART(KIK1) - WRTERM PART(KNK1)=PART(KNK1) - WCTERM END IF C IF (K2.NE.0) THEN IP(KIP+1)=KIK2 IP(KIP+2)=KNK2 KIP=KIP+2 PART(KIK2)= WRTERM PART(KNK2)= WCTERM ELSE PART(KIK2)=PART(KIK2) + WRTERM PART(KNK2)=PART(KNK2) + WCTERM END IF END IF C C Nonlinearity: C KIP=KIP+1 IPK=NDT2NP(NDET) IP(KIP)=IPK C Find expected linear intensity: RATE=10.D0**(-0.4D0*YT) C IF (PC(NDET)) THEN C Use dead-time stuff: FACTOR=1.D0/(1.D0+RATE*P(IPK)) YT=-2.5D0*DLOG10(RATE*FACTOR) C P(IPK) is correction to dead-time (sec). PART(IPK)=1.0857362*RATE*FACTOR ELSE C set up for DC effects. FACTOR=1.D0+P(IPK)*RATE YT=-2.5D0*DLOG10(RATE*FACTOR) PART(IPK)=-1.0857362*RATE/FACTOR END IF C C Correct earlier partials for nonlinearity: IF (P(IPK).NE.0.D0) THEN DO 25 JJ=1,KIP-1 PART(IP(JJ))=PART(IP(JJ))*FACTOR 25 CONTINUE END IF C RETURN C C --------------------------------------- C C Here for standard-star value. C 100 CONTINUE C index of TRCOEF: KTRANS=MTRANZ+KK PTRANS=P(KTRANS) C IF (K1S(K).EQ.0) GO TO 200 C C C Transformation eqn. of cond.: C C C a) 2-band case: C C m(std) = m(instr) + TRCOEF*(obs.color) + ZT(band) C C b) 3-band case: C C m(std) = m(instr) + TRCOEF*(obs.color) + PCURVE*(obs.curve) + ZT(band) C C C C Set up color-term indexing: K1=K1S(K) -K K2=K2S(K) -K C K1, K2 are k-OFFSETS for color baseline. KIK1=KI+K1 KIK2=KI+K2 COLOR=P(KIK1) - P(KIK2) C C on-band term: IP(1)=KI PART(KI)=1. C main transformation: IP(2)=KTRANS PART(KTRANS)=COLOR C C 2nd term: IF (USE3PT(K)) THEN KIKM=KIK1+1 CURVE=(P(KIK1)-P(KIKM)) - (P(KIKM)-P(KIK2)) IP(6)=KTRANS+NKS PART(IP(6))=CURVE PCURVE=P(IP(6)) KIP=6 ELSE KIP=5 END IF C C zero-point: IP(3)=MTRZ+KK PART(IP(3))=1. C C IF (K1.EQ.0) THEN C K1 term already exists. IP(4)=KIK2 IF (USE3PT(K)) THEN PART(KI)=PART(KI)+PCURVE + PTRANS IP(5)=KIKM PART(KIKM)=-2.D0*PCURVE PART(KIK2)=PCURVE-PTRANS ELSE PART(KI)=PART(KI) + PTRANS PART(KIK2)=-PTRANS KIP=4 END IF ELSE IF (K2.EQ.0) THEN C K2 term already exists. IP(4)=KIK1 IF (USE3PT(K)) THEN PART(KIK1)=PCURVE+PTRANS IP(5)=KIKM PART(KIKM)=-2.D0*PCURVE PART(KI)=PART(KI)+PCURVE-PTRANS ELSE PART(KIK1)=PTRANS PART(KI)=PART(KI) - PTRANS KIP=4 END IF ELSE C new terms. IP(4)=KIK1 IP(5)=KIK2 IF (USE3PT(K)) THEN PART(KIK1)=PCURVE+PTRANS PART(KI)=PART(KI)-PCURVE*2.D0 PART(KIK2)=PCURVE-PTRANS ELSE PART(KIK1)=PTRANS PART(KIK2)=-PTRANS KIP=5 END IF END IF C IF (USE3PT(K)) THEN YT = P(KI) + PTRANS*COLOR + PCURVE*CURVE + P(IP(3)) ELSE YT = P(KI) + PTRANS*COLOR + P(IP(3)) END IF C RETURN C C --------------------------------------- C C Here for index-only value. (H-Beta) C 200 CONTINUE C C Transformation eqn. of cond.: C C beta(std) = TRCOEF*(instr.beta) + ZT(band) C C COLOR = P(KI) - P(KI-1) C We set KTRANS above at 100. IP(1)=KTRANS IP(2)=KTRANS+NKS IP(3)=KI IP(4)=KI-1 KIP=4 C PART(IP(1))=COLOR PART(IP(2))=1.D0 PART(IP(3))=PTRANS PART(IP(4))=-PTRANS C YT = PTRANS*COLOR + P(IP(2)) C RETURN C C --------------------------------------- C END SUBROUTINE REPORT(LMAX,BANDS,L2N,USESTD,JPR) C C Reports the results, and prepares for next round. C C WARNING: Side effect: REPORT may reset XMAG to std. values! C ------- C IMPLICIT NONE C INTEGER LMAX,JPR LOGICAL USESTD C INCLUDE 'MID_REL_INCL:mbands.inc' C PARAMETER (MBANDS=9) C C Common for solution flags (appears in REDUCE, YPSTD & REPORT): C LOGICAL USE3PT, USES3PTS COMMON /SOLFLG/ USE3PT(MBANDS), USES3PTS C C Common for detector limits (used in REPORT): C INTEGER MINDET,MAXDET COMMON /MDETS/ MINDET,MAXDET C C INTEGER MXCOLR PARAMETER (MXCOLR=3*MBANDS) CHARACTER*8 CARD*80 REAL SMAG(MBANDS), SK(MBANDS) 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 block /NAMES/ is used in GETJD; used by PLAN also. C C COMMON /NAMES/NAMES,TITLE, AVAR CHARACTER *8 BANDS(MXCOLR), CNAMES(2,MBANDS) 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 (CARD,TITLE) EQUIVALENCE (CNAMES,NAMES(13)) C 13 BECAUSE CVARS IS VAR(13). C REAL COLORM, COLRIN, XINV,YINV INTEGER NBANDS,LENB,LENC,KX1,KY1 COMMON /CMAGS1/ COLORM(MBANDS,MBANDS),COLRIN(MBANDS,MBANDS), 1 XINV,YINV,NBANDS,LENB,LENC,KX1,KY1 C INCLUDE 'MID_REL_INCL:mstars.inc' C PARAMETER (MSTARS=1650) CHARACTER *32 STARS COMMON /SCATA/ STARS(MSTARS) INTEGER L2N(MSTARS) C INCLUDE 'MID_REL_INCL:kingfit.inc' INCLUDE 'MID_REL_INCL:dlsq.inc' C INTEGER KMIN, KMAX, NKS, KMINM1, MPPN, MPPKN, NITEZ, MSYSTZ INTEGER NSYSTP, NDZ, NDEDTZ, NTRANS INTEGER MTRANZ, MTR2Z, MTRZ, MT1Z, MT2Z, MRHZ C EQUIVALENCE (KMIN,KDUM(1)), (KMAX,KDUM(2)), (NKS,KDUM(3)) EQUIVALENCE (KMINM1,KDUM(4)), (MPPN,KDUM(5)), (MPPKN,KDUM(6)) EQUIVALENCE (NITEZ,KDUM(7)), (MSYSTZ,KDUM(8)), (NSYSTP,KDUM(9)) EQUIVALENCE (NUMNDS,KDUM(10)), (NDZ,KDUM(11)), (NDEDTZ,KDUM(12)) EQUIVALENCE (NTRANS,KDUM(13)) EQUIVALENCE (MTRANZ,KDUM(14)), (MTR2Z,KDUM(15)), (MTRZ,KDUM(16)) EQUIVALENCE (MT1Z,KDUM(17)), (MT2Z,KDUM(18)), (MRHZ,KDUM(19)) C EQUIVALENCE (I,KZ(2)), (K,KZ(3)), (N,KZ(4)), (NDET,KZ(5)) C INCLUDE 'MID_REL_INCL:obs.inc' C C Common for estimated parameters: C COMMON /PARMS/ ZPT(MBANDS,MXNITE),AEXT(MBANDS,MXNITE), 1 XMAG(MBANDS,MSTARS),TRCOEF(MBANDS) C C C Commons for ND filters: C INTEGER NUM2ND(MBANDS),NP2ND(MBANDS*MBANDS),NP2K(MBANDS*MBANDS) INTEGER ND2NP(MBANDS,MBANDS), NUMNDS,NDK,NDS C indices: ND,K REAL XND(MBANDS,MBANDS) COMMON /NDJUNK/XND,NUM2ND,NP2ND,NP2K,ND2NP,NDS C CHARACTER NDNAME(MBANDS)*4 COMMON /NDC/NDNAME C C Common for dead-time corrections: C REAL DEDTS(MXCOLR),SDEDTS(MXCOLR) INTEGER NDT2NP(MXCOLR) LOGICAL PC(MXCOLR),DC(MXCOLR),CI(MXCOLR) COMMON /NDTX/NDT2NP,DEDTS,SDEDTS,PC,DC,CI C CHARACTER DETNAME(MXCOLR)*16 COMMON /NDTNAM/ DETNAME C C Common for color baselines: C INTEGER K1S(MBANDS),K2S(MBANDS) COMMON /K12S/ K1S, K2S C C Common for time dependences: C REAL TIMID(MXNITE) INTEGER NAT(MBANDS,MXNITE),NZT(MBANDS,MXNITE) LOGICAL TIMFLGA, TIMFLGZ COMMON /TIMDEP/ TIMID, NAT,NZT, TIMFLGA,TIMFLGZ C C INTEGER KK,KKI, KKK, LARGER, LOOPMX C INTEGER I, K, N, N1, 1 NDET, K1, K2, LW, LWORD, KW, ND, KN, LENAME, KOLS, KM1, KI, 2 LOOP, J, KTRANS, KTR2, KTRZ, L, L1, L2 C REAL ZPT, AEXT, XMAG, TRCOEF, FMAG, COLR(MBANDS) C CHARACTER*28 FMT*32, F26,F27, FMTK, F35 C LOGICAL HBETA, ERRORS, TDIFLG C C C C ***** BEGIN ***** C C IF(.NOT.USESTD) GO TO 20 C C Report the transformation: C IF (JPR.GT.0) THEN CALL SPACE2 CALL NEED(MIN(20,4+3*NKS)) CALL TV('TRANSFORMATIONS:') CALL TVN('================') CALL SPACE END IF C DO 10 K=KMIN,KMAX C K offset: KK=K-KMINM1 C point to trans.coeff. & zero pt.: KTRANS=MTRANZ+KK C transfer P to PG: PG(KTRANS)=P(KTRANS) IF (USE3PT(K)) PG(KTRANS+1)=P(KTRANS+1) C Find where zero-point is stored: KTRZ=MTRZ+KK C Initial column for output: IF (USES3PTS) THEN N1=MAX(1,13-5*LENB) KTR2=KTRANS+NKS ELSE N1=10 END IF IF (JPR.GT.0) THEN K1=K1S(K) K2=K2S(K) L1=MIN(5,LWORD(BANDS(K1))) L2=MIN(5,LWORD(BANDS(K2))) IF (USE3PT(K)) THEN CALL NEED(5) ELSE CALL NEED(3) END IF CARD(:N1)=' ' IF (K1.EQ.0) THEN C H-Beta. HBETA=.TRUE. IF (K.EQ.1 .OR. K.EQ.5)THEN C betaW; do nothing. GO TO 10 ELSE C betaN; display transformation. CARD(N1+1:N1+26)='Beta = (betaN - betaW) *' WRITE(CARD(N1+27:),'(F6.3,F9.3)') P(KTRANS),P(KTRZ) IF (P(KTRZ).GT.0.) CARD(N1+35:N1+35)='+' IF (SP(KTRANS).EQ.0.D0 .AND. SP(KTRZ).EQ.0.D0) THEN CARD(N1+50:N1+56)='(fixed)' END IF LW=4 END IF ELSE C Normal. HBETA=.FALSE. LW=MIN(5,LWORD(BANDS(K))) CARD(N1+1:N1+10)=BANDS(K) CARD(N1+5+LW:N1+6+LW)='-' CARD(N1+7+LW:N1+11+2*LW)=BANDS(K) CARD(N1+12+2*LW:N1+13+2*LW)='=' WRITE (CARD(N1+14+2*LW:N1+21+2*LW),'(F7.3)') P(KTRANS) IF (L1+L2+LW.GT.12) THEN C have to squeeze out 3 blanks. CARD(N1+22+2*LW:)='*('//BANDS(K1)(:L1)//'-'// 1 BANDS(K2)(:L2)//')' N=N1+31+2*LW+L1+L2 ELSE C can leave it easy to read. CARD(N1+22+2*LW:)='* ('//BANDS(K1)(:L1)//' - '// 1 BANDS(K2)(:L2)//')' C save column for next field in N: N=N1+34+2*LW+L1+L2 END IF IF (USE3PT(K)) THEN C add second term to transformation: IF (P(KTR2).GT.0.D0) THEN CARD(N-3:)='+' ELSE CARD(N-3:)='-' END IF WRITE(CARD(N-2:N+5),'(F7.3)') ABS(P(KTR2)) CARD(N+6:)='* curve('//BANDS(K)(:LW)//')' N=N+17+LW END IF IF (SP(KTRANS).EQ.0.D0) THEN CARD(N:)='(fixed)' ELSEIF (P(KTRZ).NE.0.D0 .OR. SP(KTRZ).NE.0.)THEN C add zero-point term: WRITE(CARD(N:),'(SP,F6.3)') P(KTRZ) END IF END IF C print transformation eqn. CALL TV(CARD) C C set up errors: CARD(N1+1:N1+7)=' ' CARD(N1+1+LW:N1+7+LW)='std' IF (K1.EQ.0) THEN C H-Beta. CARD(N1+7+LW+1:N1+23)=' ' WRITE(CARD(N1+27:),'(F6.3,F9.3)') SP(KTRANS),SP(KTRZ) CARD(N1+24:N1+26)='+/-' CARD(N1+34:N1+36)='+/-' ELSE C Normal. CARD(N1+7+2*LW:N1+15+2*LW)='inst +/-' WRITE (CARD(N1+16+2*LW:),'(F5.3,6X,''inst'')') SP(KTRANS) IF (USE3PT(K)) THEN WRITE(CARD(N-LW-20:N-LW-13),'(A3,F5.3)')'+/-',SP(KTR2) END IF C column for zero-point saved in N: IF (P(KTRZ).NE.0.D0) THEN CARD(N-3:N-1)='+/-' WRITE(CARD(N:),'(F6.3)') SP(KTRZ) END IF END IF C print errors. CALL TVN(CARD) C IF (USE3PT(K)) THEN C add explanation: LW=LWORD(BANDS(K1+1)) N=N-36-L1-L2-(LW+LW) CARD(N1+1:N)=' ' CARD(N:)='where curve('//BANDS(K)(:LW)//') = ('// 1 BANDS(K1)(:L1)//' - '//BANDS(K1+1)(:LW)//') - ('// 2 BANDS(K1+1)(:LW)//' - '//BANDS(K2)(:L2)//')' CALL TV(CARD) CALL SPACE END IF END IF 10 CONTINUE C C C Report the bandwidths: C 20 IF (JPR.GT.0) THEN CALL SPACE2 CALL NEED(4+3*NKS) CALL TV('BANDWIDTHS:') CALL TVN('===========') CALL SPACE END IF C DO 25 K=KMIN,KMAX KW=MSYSTZ+K-KMINM1 IF (JPR.GT.0) THEN WRITE(CARD,'(10X,A8,F6.3)') 1 BANDS(K),P(KW) IF (SP(KW).EQ.0.D0) THEN CARD(30:)='(fixed)' CALL TV(CARD) ELSE CALL TV(CARD) WRITE(CARD,'(15X,''+/-'',F6.3)') SP(KW) CALL TVN(CARD) END IF END IF C transfer P to PG: PG(KW)=P(KW) 25 CONTINUE C C C Report the ND filter values: C IF (NUMNDS.GT.1) THEN IF (JPR.GT.0) THEN CALL SPACE2 CALL NEED(4+3*NKS) CALL TV('ND FILTERS:') CALL TVN('===========') END IF C C Scan all possible ND filters: DO 60 ND=1,NDS C Scan the list of combinations in use... DO 47 K=KMIN,KMAX IF (ND2NP(ND,K).GT.0) GO TO 48 47 CONTINUE C Here if this ND filter not used at all. Go to next one. GO TO 60 C 48 CONTINUE C Here if this ND is used. IF (JPR.GT.0) THEN C Print heading. IF (NDNAME(ND).EQ.' ') THEN CALL TV(' (no filter)') ELSE WRITE(CARD,'(5X,A)') NDNAME(ND) CALL TV(CARD) END IF END IF C DO 50 K=KMIN,KMAX IF (ND2NP(ND,K).EQ.0) GO TO 50 C (skip unused combinations.) NDK=NDZ+ND2NP(ND,K) IF (JPR.GT.0) THEN FMAG=P(NDK)+2.5*ALOG10(XND(ND,K)) WRITE(CARD,'(16X,A8,F7.4,'' mag'')') BANDS(K),FMAG WRITE(CARD(37:),'(''='',F7.3,'' x'')') 10.**(0.4*FMAG) IF (SP(NDK).EQ.0.D0) THEN CARD(50:)='(fixed)' ELSE CALL TVN(CARD) WRITE(CARD,'(21X,''+/-'',F7.4)') SP(NDK) END IF CALL TVN(CARD) CALL SPACE END IF PG(NDK)=P(NDK) 50 CONTINUE 60 CONTINUE END IF C C C Report the nonlinearity values: C IF (JPR.GT.0) THEN CALL SPACE CALL NEED(4+4*(MAXDET-MINDET+1)) CALL TV('NONLINEARITY:') CALL TVN('=============') END IF C DO 150 NDET=MINDET,MAXDET ND=NDT2NP(NDET) IF (ND.EQ.0) GO TO 150 PG(ND)=P(ND) C IF (JPR.GT.0) THEN WRITE(CARD,'(10X,A,'':'')') 1 DETNAME(NDET)(:LWORD(DETNAME(NDET))) CALL TV(CARD) C IF (PC(NDET)) THEN C Pulse-counting, so show revised deadtime: FMT='(10X,''deadtime ='',F6.2,'' nsec'')' FMTK='(17X,''+/-'',F6.2)' IF (P(ND)+DEDTS(NDET).LT.1.E-7) THEN C F6.2 is enough. ELSE IF (P(ND)+DEDTS(NDET).LT.1.E-6) THEN C try F6.1 instead. FMT(22:22)='1' FMTK(15:15)='1' ELSE C try F6.0 instead. FMT(22:22)='0' FMTK(15:15)='0' END IF WRITE(CARD,FMT) (P(ND)+DEDTS(NDET))*1.E9 IF (SP(ND).EQ.0.D0) THEN CARD(46:52)='(fixed)' CALL TVN(CARD) ELSE IF (ABS(P(ND)).GT.3.*SP(ND)) CARD(46:)='CHANGED -- rerun' CALL TVN(CARD) WRITE(CARD,FMTK)SP(ND)*1.E9 CALL TVN(CARD) END IF C ELSE C DC, so show parabolic coefficient: WRITE(CARD,'(10X,''nonlinearity coeff. ='',1PE9.2)') P(ND) IF (SP(ND).EQ.0.D0) THEN CARD(46:52)='(fixed)' CALL TVN(CARD) ELSE IF (ABS(P(ND)).GT.3.*SP(ND)) CARD(46:)='CHANGED -- rerun' CALL TV(CARD) WRITE(CARD,'(28X,''+/-'',1PE9.2)')SP(ND) CALL TVN(CARD) END IF END IF C END IF 150 CONTINUE C C C C C Report the extinction values: C IF (JPR.GT.0) THEN CALL SPACE2 IF (TIMFLGZ .OR. TIMFLGZ) THEN N1=6 ELSE N1=3 END IF CALL NEED(7+MIN(45,N1*NKS)) CALL TV('EXTINCTION VALUES:') CALL TVN('==================') END IF C DO 200 N=1,NIGHTS IF (JPR.GT.0) THEN CALL SPACE CALL JD2DAT(REAL(2400000.5D0+DTZERO(N)),CARD) CARD(26:)='EXT. COEFF. ZERO POINT' CALL NEED(3+MIN(40,N1*NKS)) CALL TV(CARD) CARD(:25)=' ' CARD(26:)='---------- ----------' CALL TVN(CARD) END IF TDIFLG=.FALSE. DO 180 K=KMIN,KMAX KN=NITEZ + (N-1)*MPPN + (K-KMIN)*MPPKN C KN is base address for night parameters. ZPT(K,N)=P(KN+1) AEXT(K,N)=P(KN+2) C Transfer all night parameters: DO 160 L=1,MPPKN 160 PG(KN+L)=P(KN+L) IF (JPR.GT.0) THEN CALL NEED(N1) C Print basic parameters: WRITE(CARD,'(21X,A8,F6.3,11X,F7.3)') 1 BANDS(K),AEXT(K,N),ZPT(K,N) IF (SP(KN+1).EQ.0.D0 .AND. SP(KN+2).EQ.0.D0) THEN CARD(60:)='(fixed)' CALL TV(CARD) ELSE CALL TV(CARD) WRITE(CARD,'(26X,A3,F6.3,9X,A3,F6.3)') 1 '+/-',SP(KN+2),'+/-',SP(KN+1) IF (SP(KN+1).EQ.0.D0) THEN IF (SP(KN+2).EQ.0.D0) THEN CARD(60:)='(both fixed)' ELSE CARD(60:)='(zero fixed)' END IF END IF CALL TVN(CARD) END IF C C Print drift parameters: C C set up indexing: IF (TIMFLGZ) THEN J=56 L1=KN+3 C see if we need A as well: IF (TIMFLGA) THEN L2=L1+1 END IF ELSE IF (TIMFLGA) THEN C ONLY A. J=38 L2=KN+3 ELSE C skip it. GO TO 180 END IF C C Print values: CARD=' ' C may have either or both, so test separately: IF (TIMFLGA) THEN WRITE(CARD(30:35),'(SP,F6.3)') P(L2) END IF IF (TIMFLGZ) THEN WRITE(CARD(48:),'(SP,F6.3)') P(L1) END IF CARD(J:75)='x (time difference)' IF (TIMFLGA.OR.TIMFLGZ) THEN CALL NEED(3) CALL TV(CARD) TDIFLG=.TRUE. END IF C C Print errors: IF ( (TIMFLGA.AND.(SP(L2).NE.0.)) .OR. 1 (TIMFLGZ.AND.(SP(L1).NE.0.)) ) THEN CARD=' ' IF (TIMFLGA) THEN WRITE(CARD(27:35),'(''+/-'',F6.3)') SP(L2) END IF IF (TIMFLGZ) THEN WRITE(CARD(45:),'(''+/-'',F6.3)') SP(L1) END IF IF (TIMFLGA.OR.TIMFLGZ) THEN CALL TVN(CARD) CALL SPACE END IF ELSE IF (TIMFLGA.OR.TIMFLGZ) THEN CALL SPACE ELSE C Don't space. END IF END IF 180 CONTINUE C (end loop over colors) IF (JPR.GT.0 .AND. TDIFLG) THEN CARD(27:)='where (time difference) = (MJD -' WRITE(CARD(60:),'(F12.5)') DTZERO(N)+TIMID(N) CARD(72:72)=')' CALL TV(CARD) CALL SPACE END IF 200 CONTINUE C C Report the LMAX extinction stars: C IF (JPR.GT.0) THEN CALL SPACE2 CALL NEED(16) CALL TV('S T A R S :') CALL TVN('===========') LENAME=1 DO 220 I=1,LMAX LENAME=MAX(LENAME,LWORD(STARS(L2N(I)))) 220 CONTINUE C see how many columns of magnitudes we have room for: LARGER=MAX(LENB,LENC) C 79=page width, 12=min.spaces per column. KOLS=MIN(NKS,(79-LENAME)/(14+LARGER)) KM1=KOLS-1 C KOLS is number of bands or color columns across the page. C Each row of data needs 6 rows of print. CALL NEED(6*((NKS+KM1)/KOLS)) FMT='(A32,5( 4X,A4,'' ='',F7.3))' WRITE (FMT(3:4),'(I2)') LENAME WRITE (FMT(8:9),'(I2)') LARGER-LENB+4 WRITE (FMT(13:13),'(I1)') LENB+1 C FMT is now the format for first line . F26='(32X,5( 8X,''+/-'',F6.3:))' WRITE (F26(2:3),'(I2)') LENAME WRITE (F26(8:9),'(I2)') LARGER+5 C F26 is the format for errors. C F27 is the format for magnitude overflow lines. F27='(32X,5( 4X,A4,'' ='',F7.3))' WRITE (F27(2:3),'(I2)') LENAME WRITE (F27(8:9),'(I2)') LARGER-LENB+4 WRITE (F27(13:13),'(I1)') LENB+1 C Now do the same for colors: FMTK='(32X,5( 4X,A4,'' ='',F7.3))' WRITE (FMTK(2:3),'(I2)') LENAME WRITE (FMTK(8:9),'(I2)') LARGER-LENC+4 WRITE (FMTK(13:13),'(I1)') LENC+1 C FMTK is the format for first line of colors. C F35 is the format for color overflow lines. F35='(32X,5( 4X,A4,'' ='',F7.3))' WRITE (F35(2:3),'(I2)') LENAME WRITE (F35(8:9),'(I2)') LARGER-LENC+4 WRITE (F35(13:13),'(I1)') LENC+1 END IF C LOOPMX=2 IF (.NOT.USESTD) LOOPMX=1 C C Begin loop over systems: C C --- DO 500 LOOP=1,LOOPMX C --- C IF (JPR.GT.0) THEN IF (LOOP.EQ.1) THEN CALL CENTER('(natural system)') ELSE CALL NEED(10) CALL SPACE CALL CENTER('(standard system)') END IF WRITE(CARD,'(38('' *''))') CALL TV(CARD) END IF C C Begin loop over stars in solution: C DO 400 L=1,LMAX C I=L2N(L) DO 240 K=KMIN,KMAX KI=(L-1)*NKS + K-KMINM1 XMAG(K,I)=P(KI) SMAG(K)=SP(KI) PG(KI)=P(KI) 240 CONTINUE C IF (JPR.GT.0) THEN CALL SPACE C C First print the magnitudes: C IF (KMIN+KM1.LE.KMAX) THEN CALL NEED(3) ELSE CALL NEED(6) END IF C IF (LOOP.EQ.1) THEN C instrumental mags; do nothing. ELSE C compute std. mags. in XMAGS: DO 250 K=KMIN,KMAX KK=K-KMINM1 C index of main trans.coef.: J=MTRANZ+KK C index of zero-point: KTRZ=MTRZ+KK IF (K1S(K).EQ.0) THEN C H-Beta. C IF (K.EQ.1 .OR. K.EQ.5) THEN C betaW; do nothing. C ELSE C betaN; compute std. beta index. C XMAG(K,I)=(XMAG(K,I)-XMAG(K-1,I))*P(J) + P(J+NKS) C END IF ELSE C Normal system. K1=K1S(K)-KMINM1 K2=K2S(K)-KMINM1 XMAG(K,I)=XMAG(K,I)+ C transformation coeff. times 1 P(J)* C color in instrumental system... 2 (P((L-1)*NKS+K1) - P((L-1)*NKS+K2)) C ... plus transformation zero-point. 3 + P(KTRZ) IF (USE3PT(K)) THEN C 3-color transformation; add curve term: XMAG(K,I)=XMAG(K,I) + P(MTR2Z+KK)* C curve: 1 ( (P((L-1)*NKS+K1) - P((L-1)*NKS+K1+1)) - 2 (P((L-1)*NKS+K1+1) - P((L-1)*NKS+K2)) ) ELSE C 2-color transformation; all set. END IF END IF 250 CONTINUE END IF C WRITE (CARD,FMT) STARS(I)(:LENAME), 1 (BANDS(K),XMAG(K,I),K=KMIN,MIN(KMIN+KM1,KMAX)) CALL TV(CARD) C C ... and errors: IF (SMAG(KMIN).GT.0. .OR. SMAG(KMAX).GT.0.) THEN ERRORS=.TRUE. ELSE ERRORS=.FALSE. END IF C IF (ERRORS) THEN IF (LOOP.EQ.1) THEN C natural error calc. WRITE (CARD,F26)(SMAG(K),K=KMIN,MIN(KMIN+KM1,KMAX)) ELSE C std. error calc. WRITE (CARD,F26)(SMAG(K),K=KMIN,MIN(KMIN+KM1,KMAX)) END IF CALL TVN(CARD) END IF C ... and overflow, if needed: IF (ERRORS) CALL SPACE DO 280 J=KMIN+KOLS,KMAX,KOLS C instrumental mags. WRITE(CARD,F27)(BANDS(K),XMAG(K,I),K=J,MIN(J+KM1,KMAX)) CALL TVN(CARD) IF (ERRORS) THEN WRITE(CARD,F26)(SMAG(K),K=J,MIN(J+KM1,KMAX)) CALL TVN(CARD) END IF 280 CONTINUE C C ... then compute the colors: C DO 340 K=KMIN,KMAX C Compute the K-th color index: COLR(K)=0. SK(K)=0. DO 332 KK=KMIN,KMAX C Compute the KK-th term in the K-th color index: IF (COLORM(KK,K).EQ.0.) GO TO 332 C use color matrix to compute indices: COLR(K)=COLR(K)+XMAG(KK,I)*COLORM(KK,K) C ...and variances: SK(K)=SK(K)+(COLORM(KK,K)*SMAG(KK))**2 DO 330 J=1,KK-1 C do cross-terms: IF (COLORM(J,K).NE.0.) THEN KI=(L-1)*NKS + KK-KMINM1 KKI=KI-KK+J C Locate (J,KK) covariance in A-matrix: KKK=(MAX(KI,KKI)-1)*(MAX(KI,KKI))/2 +MIN(KI,KKI) SK(K)=SK(K)+ 1 2.*COLORM(J,K)*COLORM(KK,K)*A(KKK)*WVAR END IF 330 CONTINUE 332 CONTINUE IF (SK(K).GE.0.) THEN SK(K)=SQRT(SK(K)) ELSE SK(K)=3.E33 END IF 340 CONTINUE C C Colors are now ready for printing. Do first row... C IF (KMIN+KM1.LE.KMAX) THEN CALL NEED(3) ELSE CALL NEED(6) END IF C IF (HBETA) THEN C H-Beta. IF (KMAX.GT.3)THEN C System is uvbyHB. WRITE (CARD,FMTK) 1 (CNAMES(1,K),COLR(K),K=KMIN,MIN(KMIN+KM1,4)) ELSE C System is H-Beta. IF (LOOP.EQ.1) THEN C compute instrumental beta index. XMAG(2,I)=XMAG(2,I)-XMAG(1,I) ELSE C compute std. beta index. XMAG(2,I)=(XMAG(2,I)-XMAG(1,I))*P(KTRANS) +P(KTRZ) END IF WRITE (CARD,FMTK) 'BETA',XMAG(2,I) CARD(60:)=' ' END IF ELSE C Normal. WRITE (CARD,FMTK) 1 (CNAMES(1,K),COLR(K),K=KMIN,MIN(KMIN+KM1,KMAX)) END IF C CALL TV(CARD) C C ... and errors... C IF (ERRORS) THEN IF (HBETA) THEN C special for H-Beta: IF (KMAX.GT.3) THEN C System is uvbyHB. WRITE (CARD,F26)(SK(K),K=KMIN,MIN(KMIN+KM1,4)) ELSE C System is H-Beta. WRITE (CARD,F26) SMAG(2) CARD(60:)=' ' END IF ELSE C Normal. WRITE (CARD,F26)(SK(K),K=KMIN,MIN(KMIN+KM1,KMAX)) END IF CALL TVN(CARD) END IF C C ... and overflow, if needed. IF (ERRORS) CALL SPACE DO 360 J=KMIN+KOLS,KMAX,KOLS WRITE(CARD,F35)(CNAMES(1,K),COLR(K),K=J,MIN(J+KM1,KMAX)) CALL TVN(CARD) IF (ERRORS) THEN WRITE(CARD,F26)(SK(K),K=J,MIN(J+KM1,KMAX)) CALL TVN(CARD) END IF 360 CONTINUE END IF C 400 CONTINUE C C End loop over systems (natural/std.): C C --- 500 CONTINUE C --- C RETURN C END SUBROUTINE BIGDRIFT(TYPE,TERM,BAND,CARD,DMS,L,NIX) C C Prints complaint about big drift terms. C IMPLICIT NONE C C CHARACTER TYPE*10, CARD*80, DMS*32, BAND*8 REAL TERM INTEGER L, NIX C INTEGER LWORD EXTERNAL LWORD C C INCLUDE 'MID_REL_INCL:kingfit.inc' INCLUDE 'MID_REL_INCL:dlsq.inc' C C IF (TERM.LT.0.1 .AND. ABS(P(L)).LT.1.D0) THEN RETURN ELSE CALL SPACE2 CALL NEED(7) CARD(:19)=TYPE//' drift of' WRITE(CARD(20:),'(F5.2)') TERM CARD(26:41)='mag. in '//BAND CARD(LWORD(CARD)+1:)=' during' CARD(LWORD(CARD)+2:)=DMS CALL TV(CARD) IF (TERM.GT.0.1) THEN CALL TVN('seems large. The drift coefficient is') ELSE CALL TV('The drift coefficient seems large:') END IF WRITE(CARD,'(F11.3,'' mag/day'')') P(L) CALL TV(CARD) WRITE(CARD,'('' +/- '',F5.3)') SP(L) CALL TVN(CARD) CALL QFIX(L,0.,NIX) END IF C RETURN END SUBROUTINE P2X(STYPE,NSTARS,L2N,NEXTS) C C Converts ALL Program stars to eXtinction type. C IMPLICIT NONE C INTEGER NSTARS, L2N(NSTARS),NEXTS CHARACTER STYPE(*) C INTEGER I,J C C DO 10 J=1,NSTARS I=L2N(J) IF (STYPE(I).EQ.'P') THEN STYPE(I)='X' NEXTS=NEXTS+1 END IF 10 CONTINUE C C RETURN C END FUNCTION HELCOR(RA,DEC,DJ) C C Calculates heliocentric correction (days) for star at (RA,DEC) C for actual Julian Date DJ (double precision), using "low-precision" C formulae on p. C24 of the 1992 AA. C C As these formulae are good to about 0.01 degree or 1/6000 radian, C we expect this routine to be good to about 1.E-6 day. However, C the Sun is not the barycenter; so we can in fact be off by C somewhat more than this -- a couple of parts in 10**5 at worst. C IMPLICIT NONE C REAL HELCOR,RA,DEC DOUBLE PRECISION DJ C REAL DAYS,BIGL, EPS,COSE,SINE REAL COSD,SIND,R,G,COSG,COS2G,SING,SIN2G REAL CDSA,COSB,ECL,STARL C C C Compute days from J2000. DAYS=DJ-2451545.D0 C C Obliquity: EPS=.409088 + .00000000698*DAYS COSE=COS(EPS) SINE=SIN(EPS) C C Mean longitude of Sun: BIGL=4.89495 + .01720279*DAYS C Mean anomaly of Sun: G=6.24004076094 + .01720197*DAYS SING=SIN(G) COSG=COS(G) SIN2G=2.*SING*COSG COS2G=2.*COSG*COSG-1. C C Ecliptic longitude of Sun: ECL=BIGL + .033423*SING + .00035*SIN2G C C Convert star to ecliptic coordinates: COSD=COS(DEC) SIND=SIN(DEC) C CDSA=COSD*SIN(RA) COSB=SQRT(1.-(SIND*COSE-CDSA*SINE)**2) C Get star's longitude: STARL=ATAN2( CDSA*COSE + SIND*SINE , COSD*COS(RA)) C C Radius vector (AU): R=1.00014 - 0.01671*COSG - 1.4E-4*COS2G C Calculate heliocentric correction: HELCOR=-5.77552E-3 * R * COSB * COS(ECL-STARL) C RETURN END SUBROUTINE SHOPOS(CARD,I1,I2) C C Shows positions of 2 stars. C IMPLICIT NONE C CHARACTER*80 CARD INTEGER I1,I2 C INCLUDE 'MID_REL_INCL:mstars.inc' C PARAMETER (MSTARS=1650) CHARACTER *32 STARS COMMON /SCATA/ STARS(MSTARS) INCLUDE 'MID_REL_INCL:mbands.inc' C PARAMETER (MBANDS=9) REAL RAS, DECS, EQUINX, COLORS(MBANDS,MSTARS) COMMON /SCAT/ RAS(MSTARS), DECS(MSTARS), EQUINX(MSTARS), COLORS 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 CHARACTER*13 DEG2MS EXTERNAL DEG2MS C C C First star: CARD=' 1: '//STARS(I1) CALL TV(CARD) CALL TV(' h m s o '' "') CARD(:5)=' ' CARD(6:20)=DEG2MS(RAS(I1)*12./PI) CARD(21:34)=DEG2MS(DECS(I1)/DEGRAD) WRITE(CARD(35:44),13) INT(EQUINX(I1)) 13 FORMAT('(',I4,')') CALL TVN(CARD) CALL SPACE C Second star: CARD=' 2: '//STARS(I2) CALL TV(CARD) CALL TV(' h m s o '' "') CARD(4:5)=' ' CARD(6:20)=DEG2MS(RAS(I2)*12./PI) CARD(21:34)=DEG2MS(DECS(I2)/DEGRAD) WRITE(CARD(35:44),13) INT(EQUINX(I2)) CALL TVN(CARD) C RETURN END SUBROUTINE PLTRAN(BANDS,CARD,NONSTD,NPTS,DTYPE) C C Plot transformations: C IMPLICIT NONE C INTEGER NONSTD, NPTS CHARACTER CARD*80 INCLUDE 'MID_REL_INCL:obs.inc' CHARACTER DTYPE(MXOBS) C INCLUDE 'MID_REL_INCL:kingfit.inc' INCLUDE 'MID_REL_INCL:dlsq.inc' C INTEGER KMIN, KMAX, NKS, KMINM1, MPPN, MPPKN C EQUIVALENCE (KMIN,KDUM(1)), (KMAX,KDUM(2)), (NKS,KDUM(3)) EQUIVALENCE (KMINM1,KDUM(4)), (MPPN,KDUM(5)), (MPPKN,KDUM(6)) C INCLUDE 'MID_REL_INCL:mbands.inc' C REAL COLORM, COLRIN, XINV,YINV INTEGER NBANDS,LENB,LENC,KX1,KY1 COMMON /CMAGS1/ COLORM(MBANDS,MBANDS),COLRIN(MBANDS,MBANDS), 1 XINV,YINV,NBANDS,LENB,LENC,KX1,KY1 C C Common for plot limits: C REAL XLIM(2), YLIM(2) COMMON /PLTLIM/ XLIM, YLIM C C Scratch arrays for robust estimation: C REAL XDUM,YDUM,ZDUM COMMON /SCRAT/ XDUM(MXOBS), YDUM(MXOBS), ZDUM(MXOBS) C C Common for color baselines: C INTEGER K1S(MBANDS),K2S(MBANDS) COMMON /K12S/ K1S, K2S C C INTEGER MXCOLR PARAMETER (MXCOLR=3*MBANDS) CHARACTER*8 BANDS(MXCOLR) C INTEGER K, K1, K2, L, J, N, K1I, K2I C CHARACTER C1 C C CALL SPACE2 CALL CENTER('The next plots show the transformation residuals.') CALL PLOT(0,79.,22.,'P') CALL PLOT(0,0.,1.,'O') DO 828 K=KMIN,KMAX K1=K1S(K) IF (K1.EQ.0) THEN C H-Beta. IF (K.EQ.1 .OR. K.EQ.5) THEN C skip betaW: GO TO 828 ELSE CARD=' BETA-index resids.' END IF ELSE C Normal band. CARD=' '//BANDS(K)(:LENB)//' resids.' END IF K2=K2S(K) CALL NEED(24) CALL TV(CARD) N=0 DO 826 J=NONSTD+1,NPTS IF (KX(1,J).LT.2 .OR. KX(3,J).NE.K) GO TO 826 C here if datum is a std.value in band K. L=KX(2,J) N=N+1 IF (K1.EQ.0) THEN C H-Beta. XS(N)=P((L-1)*NKS+K-KMINM1) ELSE C Normal. K1I=(L-1)*NKS+K1-KMINM1 K2I=(L-1)*NKS+K2-KMINM1 XS(N)=P(K1I)-P(K2I) END IF YS(N)=Y(J)-REAL(YC(J)) C duplicate XS & YS for later sorting: XDUM(N)=XS(N) YDUM(N)=YS(N) C convert label to number: ZDUM(N)=ICHAR(DTYPE(J)) 826 CONTINUE C sort XDUM to get X-limits: CALL SORT1(XDUM,N) XLIM(1)=XDUM(1)-0.05 XLIM(2)=XDUM(N) C get Y-limits: median +/- 1.3*(approx.interquartile range) CALL SORT1(YDUM,N) C median. XDUM(1)=(YDUM((N+1)/2)+YDUM(N/2+1))*0.5 C range. XDUM(2)=(YDUM(N/4+1)-YDUM(N-N/4))*1.3 IF (XDUM(2).EQ.0.) XDUM(2)=0.02 YLIM(1)=XDUM(1)-XDUM(2) YLIM(2)=XDUM(1)+XDUM(2) CALL PLOT(0,XLIM,YLIM,'L') CALL XAXIS(XLIM) DO 827 J=1,N C1=CHAR(INT(ZDUM(J))) CALL PLOT(-1,XS(J),YS(J),C1) 827 CONTINUE XLIM(1)=10. CALL PLOT(1,XLIM,XLIM,' ') IF (K1.EQ.0) THEN C H-Beta. CARD=' Instrumental Beta' ELSE C Normal. CARD=' ('//BANDS(K1)(:LENB)//' - '//BANDS(K2)(:LENB)//')' END IF CALL RTNCON(CARD,2*LENB+15) CALL SPACE CALL PLOT(0,79.,24.,'P') 828 CONTINUE C CALL PLOT(0,0.,0.,'O') C RETURN END SUBROUTINE KOLCHK(IDAT,NAME,KOLNUM,HAS,NDATFIL) C C Checks HAS-flag to make sure data are consistent from file to file. C IMPLICIT NONE C INTEGER IDAT,KOLNUM, NDATFIL LOGICAL HAS CHARACTER*(*) NAME C C Common for long comments: C CHARACTER*79 PAGE(21) COMMON /SCREEN/PAGE C C IF (.NOT.HAS) THEN IF (KOLNUM.GT.0) THEN C something peculiar: IF (NDATFIL.EQ.1) THEN C set HAS: HAS=.TRUE. ELSE C Not expecting such data. PAGE(1)='Found '//NAME//' data, but did not expect them.' CALL TV(PAGE(1)) PAGE(1)=NAME//' data will be ignored.' CALL TVN(PAGE(1)) END IF ELSE C OK. END IF ELSE C expects such data. IF (KOLNUM.GT.0) THEN C OK. ELSE C something wrong: PAGE(1)='Missing '//NAME//' data' CALL TERROR(IDAT,311,PAGE(1)) END IF END IF C C RETURN END SUBROUTINE LEFTY(STRING) C C Left-justifies 24-character string. C C IMPLICIT NONE C CHARACTER*24 STRING C INTEGER K CHARACTER*24 BUF C C IF (STRING(1:1).NE.' ') RETURN C DO 10 K=2,24 IF (STRING(K:K).NE.' ') GO TO 20 10 CONTINUE C string all blanks. RETURN C 20 BUF=STRING(K:) STRING=BUF C C RETURN END SUBROUTINE SPLIT(STRING, NUM,PIECES) C C Splits a string at = signs into NUM (<=4) pieces. C C STRING is a star name string. C C IMPLICIT NONE C CHARACTER STRING*32, PIECES(4)*24 INTEGER NUM C INTEGER I C C I=INDEX(STRING,'=') C IF (I.EQ.0) THEN C One piece. NUM=1 PIECES(1)=STRING(:24) ELSE C 2 or more pieces. PIECES(1)=STRING(:I-1) PIECES(2)=STRING(I+1:) CALL LEFTY(PIECES(2)) I=INDEX(PIECES(2),'=') C IF (I.EQ.0) THEN C only 2 pieces. NUM=2 ELSE C more than 2 pieces. PIECES(3)=PIECES(2)(I+1:) PIECES(2)(I:)=' ' CALL LEFTY(PIECES(3)) I=INDEX(PIECES(3),'=') C IF (I.EQ.0) THEN C only 3 pieces. NUM=3 ELSE C more than 3 pieces. PIECES(4)=PIECES(3)(I+1:) PIECES(3)(I:)=' ' CALL LEFTY(PIECES(4)) C 4 pieces max. NUM=4 END IF END IF END IF C C RETURN END SUBROUTINE ADDALIAS(NSTAR,I) C C Adds new STDNAMES entries for star NSTAR to data for star I. C C IMPLICIT NONE C INTEGER NSTAR, I C C INCLUDE 'MID_REL_INCL:mstars.inc' C C Common for name matching: INTEGER MSTARK PARAMETER (MSTARK=2*MSTARS) CHARACTER*20 STDNAMES(MSTARK), STAR5(5) COMMON /STDNAM/ STDNAMES,STAR5 INTEGER KSTARS,NSTDNM, NUMBER COMMON /KSTDNM/ KSTARS(MSTARK),NSTDNM, NUMBER C INTEGER N1,N2, J, K, N, NREJ C C C Find entry range for old star I: N1=0 DO 2 J=1,NSTDNM-NUMBER IF (KSTARS(J).EQ.I) THEN N2=J IF (N1.EQ.0) N1=J END IF 2 CONTINUE C NREJ=0 C Scan list of new std.names: DO 20 J=NSTDNM-NUMBER+1,NSTDNM C Compare to list of old std.names: DO 5 N=N1,N2 IF (STDNAMES(N).EQ.STDNAMES(J)) THEN C J is redundant. Remove it. NREJ=NREJ+1 DO 4 K=J,NSTDNM-NREJ C Move list down: KSTARS(K)=KSTARS(K+1) STDNAMES(K)=STDNAMES(K+1) 4 CONTINUE C Done with this new name; loop to next one. GO TO 20 END IF 5 CONTINUE C Here when new name (J) has NO match. Keep it in list: C (new name points to I) KSTARS(J)=I C Test for done: IF (J.EQ.NSTDNM-NREJ) GO TO 30 20 CONTINUE C C Revise total name count: 30 NSTDNM=NSTDNM-NREJ NSTAR=NSTAR-1 C C RETURN END