C @(#)reduce.for	19.1 (ES0-DMD) 02/25/03 13:29:09
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
