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