C @(#)planbot.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
      SUBROUTINE PLANBOT(DJS,LASTD,NSTARS,NEEDST,JSYS,DRAT,BANDS,SALTS,
     1 PLACE,TELCM,TL,ITIME,ZONE)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT (c) Andrew T. Young, 1990
C.COPYRIGHT (c) European Southern Observatory, 1992
C.IDENT         program plan
C.MODULE        planbot.for
C.AUTHOR        Andrew T. Young
C.KEYWORD
C.LANGUAGE      FORTRAN 77
C.PURPOSE       Makes a photometric observing schedule
C.COMMENTS
C.VERSION       4.5
C.RETURNS       error numbers correspond to nearby statement numbers
C.ENVIRONMENT   MIDAS
C-----------------------------------------------------------------------------
C
C       Second half of old "plan" program.
C
C               Copyright (C) by Andrew T. Young, 1990
C
C
      IMPLICIT NONE
C
C *** SYSTEM-DEPENDENT FEATURES ARE FLAGGED BY *** COMMENTS LIKE THIS.
C
C   F I L E S :
C   -----------
C
      CHARACTER*80  DATFIL
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
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  BANDS(3*MBANDS), CNAMES(2,MBANDS)
      DIMENSION COLORS(MBANDS,MSTARS)
      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)
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 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,NEEDIM,CODEDS,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,DMS*32,TL*4,FL(2)*5,
     1 TWILIT(MSG+2)*27,IDS(MTIM)*8,OSTAR*32,FF,
     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
C
C  MSET IS MAX.LENGTH OF SUBSET CHOSEN FOR EXT./STD. STARS.  STORAGE:
C
C   NCAT(NOBJ)   IS  STAR-CATALOG INDEX OF OBJECT  NOBJ  IN SUBSET.
C   KTYPE(NOBJ)  IS  TYPE OF OBJECT.
C
C   XS(NOBJ) & YS(NOBJ)  ARE PLOTTING ARRAYS.
C
      REAL SALTS, DJS, XS,YS, RALIMS,DECLIM,REDS,BLUES
      INTEGER KTYPE
      DIMENSION SALTS(MSG),DJS(2),NCAT(MSET),XS(MSET),YS(MSET),
     1 KTYPE(MSET),RALIMS(2),DECLIM(2),REDS(2),BLUES(2)
C
C
      LOGICAL REDUCD,NEEDED,BAD,DIMMED
C
      INTEGER LASTD, NSTARS, NEEDST, JSYS, ITIME,
     1   NEEDH, NASSMP,
     2   NCAT, J, LD, NDIG, I, NEEDEX, NEEDS, NEXCES, NSET,
     3   NUMEXT, NB, K, NOBJ, NTYPE, N, NIGHT, LOOP, I1, NTIMES,
     4         LPP, LINE
C
      REAL DRAT, TELCM, ZONE, DJ,
     1    DAYN, T, OLDEQ, DATEP, OBLIQ, COSMIN, ZDMIN, SINDH, DH, STBGN,
     2    RABGN, STEND, RAEND, DELMAX, DELMIN, DEXMAX, DEXMIN, DUM,
     3    COSANG, AMAG, STZROT, PHASE, DMAG, SIND, COSD, COSZ, ARG,
     4         OLDCOS, RA, DEC, COSHA, HA, UT2ST
C
C   CHARACTER FCNS.:
C   ----------------
      CHARACTER DEG2MS*13, DEG2M1*8
C
C   LOGICAL FCNS.:
C   -------------
      LOGICAL HELP
C
C   INTEGER FCNS.:
C   -------------
      INTEGER LWORD
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
C  SYSTEM DATA:
C
C     DATA SYSTMS/'UBV','UBVRI','UVBY','H-BETA','UVBYHB','GENEVA','DDO',
C    1 'OTHER'/
C     DATA JBANDS/ 3,      5,      4,      2,      6,      7,      6,
C    1   0/
C
C     DATA STDFLS/'UBVSTD','UBVSTD','UVBYST','UVBYST','UVBYST','GENSTD',
C    1 'DDOSTD',' '/
C
C     DATA LENBS/2,2,1,6,6,2,2,1/,LENCS/3,3,3,4,4,5,6,0/
C
C   BAND NAMES.
C     DATA BNDS/'U','B','V','RL',MBM4*' ',
C    2  'U','B','V','R','I','RL',MBM6*' ',
C    3  'U','V','B','Y',MBM4*' ',
C    4  'WIDE','NARROW',MBM2*' ',
C    5  'U','V','B','Y','WIDE','NARROW',MBM6*' ',
C    6  'U','B','V','B1','B2','V1','G',MBM7*' ',
C    7  '48','45','42','41','38','35',MBM6*' '     ,MBANDS*' '/
C
C   MAGNITUDE AND COLOR NAMES FOR EXTERNAL LISTS.
C     DATA BNDVAR/'V','U-B','B-V',MBM3*' ',
C    2  'V','U-B','B-V','V-R','R-I',MBM5*' ',
C    3  'V','B-Y','M1','C1',MBM4*' ',
C    4  'BETA','M4861',MBM2*' ',
C    5  'V','B-Y','M1','C1','BETA','M4861',MBM6*' ',
C    6  'VM','U-B','B-V','U-B2','B1-B2','B2-V1','V1-G',MBM7*' ',
C    7 'M48','C45-48','C42-45','C41-42','C38-41','C35-38',MBM6*' ',
C    8 MBANDS*' '/
C
C   EFF.WAVELENGTHS.
C     UBV:BUSER,A.&AP.62,411(1979); OTHERS FROM DUDLEY OBS.REPT.
C     DATA STDWLS/3652.,4417.,5505.,7000.,MBM4*0.,
C    2  3652.,4417.,5505.,6400.,8000.,7000.,MBM6*0.,
C    3  3425.,4110.,4670.,5510.,MBM4*0.,
C    4  4861.,4861.,MBM2*0.,
C    5  3425.,4110.,4670.,5510.,4861.,4861.,MBM6*0.,
C    6  3458.,4248.,5508.,4022.,4480.,5408.,5814.,MBM7*0.,
C    7  4886.,4517.,4257.,4166.,3815.,3460.,MBM6*0.     ,MBANDS*0./
C
C   WIDTHS.  THESE ARE ABOUT 2.64 X MU2.
C     DATA FWHMS/535.,980.,800.,300.,MBM4*0.,
C    2  535.,980.,800.,1400.,1700.,600.,MBM6*0.,
C    3  375.,200.,175.,250.,MBM4*0.,
C    4  150.,30.,MBM2*0.,
C    5  375.,200.,175.,250.,150.,30.,MBM6*0.,
C    6  450.,800.,800.,450.,440.,530.,540.,MBM7*0.,
C    7  186.,76.,73.,83.,330.,383.,MBM6*0.     ,MBANDS*0./
C   PEAK TRANSMISSIONS.
C     DATA TRANSS/.86,.73,.9,.9,MBM4*0.,
C    2  .86,.73,.9,.77,.86,.9,MBM6*0.,
C    3  .39,.49,.48,.53,MBM4*0.,
C    4  .75,.6,MBM2*0.,
C    5  .39,.49,.48,.53,.75,.6,MBM6*0.,
C    6  .65,.65,.5,.5,.34,.3,.3,MBM7*0.,
C    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
C     DATA  KYS /2, 2, 4, 0, 4, 4, 2, 0/
C     DATA  KXS /3, 3, 2, 0, 2, 6, 3, 0/
C     DATA YINVS/1.,1.,0.,0.,0.,1.,0.,0./
C     DATA XINVS/0.,0.,0.,0.,0.,0.,0.,0./
C
C
      DATA FL/'FIRST',' LAST'/
C
C  DATA FOR SUN/MOON SET/RISE AND TWILIGHTS: (set in plantop)
C
C     DATA SALTS/-.0145,-.1045,-.208,-.309,-.309,-.208,-.1045,-.0145,
C   SUN ABOVE, MOON BELOW.
C    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', 'BE SURE COOLING IS ON'/
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
C...................... EXECUTION resumes HERE ...............................
C
C
C  DJ IS JULIAN DATE FOR 0.HOURS U.T.
C
      DJ=DJS(1)+(INT(DJS(2)-DJS(1))/2)
C    PICK DAY IN MIDDLE OF RUN.
      CALL JD2DAT(DJ,DAT)
      PAGE(1)='MIDDLE U.T. DATE = '//DAT
      CALL TV(PAGE(1))
C   CREATE DATFIL.
       IF(CODEDS)THEN
      J=5
      IF(DAT(5:5).EQ.' ')J=6
      LD=12-J
      DATFIL=DAT(:3)//DAT(J:6)//'ID'
      OPEN(K7,FILE=DATFIL,STATUS='UNKNOWN')
       END IF
      OPEN(K9,FILE='PROUT',STATUS='UNKNOWN')
      CALL REHEAD(NDIG,DAT,CODEDS)
C     hope we use ASCII collating sequence...
      FF=CHAR(12)
C
      DAYN=DJ-2451545.0
C    DAYS FROM J2000.0 (SEE P.C24 OF 1984 A.A.).
      T=DAYN/36525.
C
C  PRECESS STARS HERE.
C
      OLDEQ=0.
      DATEP=2000.+T*100.
      DO 325 I=1,NSTARS
       IF(EQUINX(I).EQ.3.E33)THEN
C   MISSING EPOCH.
      IF(OLDEQ.EQ.0.)CALLTV('NO START EPOCH; stars cannot be precessed.'
     1)
      OLDEQ=3.E33
      GO TO 324
       END IF
C   Data referred to equinox of date:
      IF(EQUINX(I).EQ.0.)GOTO 325
C   PRECESS.
       IF(EQUINX(I).NE.OLDEQ)THEN
C    SET UP NEW INTERVAL.
      CALL PRECEP(EQUINX(I),DATEP,RAS(I),DECS(I))
      OLDEQ=EQUINX(I)
       ELSE
C    USE OLD INTERVAL.
      CALL PRECST(RAS(I),DECS(I))
       END IF
  324 EQUINX(I)=DATEP
  325 CONTINUE
C
       IF(OLDEQ.NE.3.E33)THEN
      WRITE(PAGE,328)DATEP
      CALL TV(PAGE(1))
      CALL TVN(' ')
      WRITE(K9,328)DATEP
  328 FORMAT(14X,'STARS HAVE BEEN PRECESSED TO',F9.2/)
       END IF
      OBLIQ=(23.43929-T*(1.30042E-2+T*(1.639E-7-T*5.036E-7)))*DEGRAD
      COSOB=COS(OBLIQ)
      SINOB=SIN(OBLIQ)
C    SET STUTZ (RADIANS).
      CALL STUTZR(T)
C
  330 SZMIN=1.1
      REDUCD=.FALSE.
C
C   HERE after SZMIN reset.
  331 IF(SZMIN.GT.1.2)WRITE(ASSUME(8),'(11X,''MIN.SEC Z ='',F6.3)')SZMIN
      COSMIN=1./SZMIN
      ZDMIN=ACOS(COSMIN)
      SINDH=SIN(ZDMIN)/COSPHI
C
      IF(SINDH.LE.1.)THEN
C   DH is the hour angle tangent to SZMIN almucantar.
        DH=ASIN(SINDH)
      ELSE
C   DH flags limit.
        DH=TWOPI
      END IF
C
C
C   Find STBGN,STEND & RABGN, RAEND.
      DO 340 I=3,6,3
        CALL UTSUN(DAYN,SALTS,I,*340)
C    UTROT is passed via /SPHERE/, HASUN via /CSUN/.
        IF(I.EQ.3)THEN
          UTBGN=UTROT
          STBGN=MOD(RASUN+HASUN+TWOPI,TWOPI)
          RABGN=MOD(RASUN+HASUN+TWOPI-DH,TWOPI)
        ELSE
          STEND=MOD(RASUN+HASUN+TWOPI,TWOPI)
          RAEND=MOD(RASUN+HASUN+TWOPI+DH,TWOPI)
          UTEND=UTROT
        END IF
  340 CONTINUE
C         STBGN is LST at start (end of nautical twilight); etc.
      IF(DH.EQ.TWOPI)THEN
        STBGN=0.
        STEND=TWOPI
      END IF
C
      DARKT=MOD(UTEND-UTBGN+1.,1.)
C    FEWER EXT.STARS NEEDED AT HIGH ELEVATIONS.
      NEEDEX=40.*DARKT*DRAT
C    ADD EXTRAS TO GET DEAD TIME.
      IF(NEEDED)NEEDEX=NEEDEX+4
      NEEDS=MAX(NEEDST,NEEDEX)
      NEXCES=(NEEDS*3)/2
C
C  SELECT EXTINCTION STARS.
C
      DELMAX=MIN(ALAT+ZDMIN,PI/2.)
      DELMIN=MAX(ALAT-ZDMIN,-PI/2.)
C   DELs limit stds.zone; DEXs limit ext.star zone.
      IF(JSYS.EQ.0)THEN
C   all ext.if no std.system.
         NEEDST=NEEDEX
      END IF
C
      XS(1)=SIN(DELMAX)
      XS(2)=SIN(DELMIN)
C===
      IF(NEEDEX.GE.NEEDST)THEN
          DEXMAX=DELMAX
          DEXMIN=DELMIN
      ELSE
C         DUM is zone height needed.
          DUM=((XS(1)-XS(2))*NEEDEX)/NEEDST
C         sines first.
          DEXMAX=(SINPHI+DUM)/2.
          DEXMIN=(SINPHI-DUM)/2.
C
          IF(DEXMAX.GT.XS(1))THEN
              DEXMAX=XS(1)
              DEXMIN=XS(1)-DUM
          ELSE IF(DEXMIN.LT.XS(2))THEN
              DEXMAX=XS(2)+DUM
              DEXMIN=XS(2)
          END IF
C
C         back to angles.
          DEXMAX=ASIN(DEXMAX)
          DEXMIN=ASIN(DEXMIN)
       END IF
C===
C
C   HERE AFTER FAINTS RESET.
  342 NSET=0
      NUMEXT=0
C
      DO 350 I=1,LASTD
C
C   Tests for POSITION:
C
C                  increasing R.A. -->
C
C  RA =  RABGN  STBGN            STEND  RAEND
C            |  |                    |  |
C            +-  --------------------  -+        <-- DELMAX
C            : /:                    :\ :
C            :/ :                    : \:
C      West  |  +                    +  |  East  <-- Delta = Phi
C            :\ :                    : /:
C            : \:                    :/ :
C            +-  --------------------  -+        <-- DELMIN
C
C   First, REJECT all OUTside "Bounding Box":
C        DEC limits violated...
      IF(DECS(I).GT.DELMAX .OR. DECS(I).LT.DELMIN  .OR.
C        ...or V.E. outside box and RA limits violated...
     1 (RABGN.LT.RAEND .AND. (RAS(I).LT.RABGN .OR. RAS(I).GT.RAEND))
C        ...or V.E. inside box and RA limits violated.
     2 .OR. (RAS(I).GT.RAEND .AND. RAS(I).LT.RABGN) ) GO TO 350
C       (note that this guarantees RABGN.GT.RAEND.)
C
C   Next, ACCEPT all INside "inscribed rectangle":
C        V.E. outside box and ST limits safe...
      IF ( (RAS(I).GT.STBGN .AND. RAS(I).LT.STEND)  .OR.
C        or V.E. inside box and ST limits safe.
     1 (STBGN.GT.STEND .AND. (RAS(I).LT.STEND .OR. RAS(I).GT.STBGN) )
     2  ) GO TO 343
C
C   We are now left with only the ends.
C     West end:
C        V.E. outside box and star between RABGN and STBGN...
      IF ( (RAS(I).GT.RABGN .AND. RAS(I).LT.STBGN)  .OR.
C        or V.E. inside box and ST limits safe.
     1 (RABGN.GT.STBGN .AND. (RAS(I).LT.STBGN .OR. RAS(I).GT.RABGN) )
     2  ) THEN
C       Check distance from Western pivot, at R.A.=STBGN, Dec.=Phi:
        COSANG=SIN(DECS(I))*SINPHI+COS(DECS(I))*COSPHI*COS(RAS(I)-STBGN)
        IF (COSANG.LT.COSMIN) GO TO 350
      ELSE
C     East end:
C       Check distance from Eastern pivot, at R.A.=STEND, Dec.=Phi:
        COSANG=SIN(DECS(I))*SINPHI+COS(DECS(I))*COSPHI*COS(RAS(I)-STEND)
        IF (COSANG.LT.COSMIN) GO TO 350
      END IF
C     Whatever falls through here is IN the semicircles at ends.
C
C   Test for MAGNITUDES.
  343 DO 345 NB=1,NBANDS
      AMAG=0.
      DO 344 K=1,NBANDS
  344 AMAG=AMAG+COLORS(K,I)*COLRIN(K,NB)
      IF(AMAG.GT.FAINTS(NB) .OR.
     1(.NOT.DC .AND.  AMAG.LT.BRITES(NB)))GO TO 350
  345 CONTINUE
      NSET=NSET+1
C   Is subset full?
      IF(NSET.GT.MSET)THEN
          CALL EXCEED(NSET,'MSET',MSET)
          CALL TV('REDUCE ACCEPTABLE RANGE.')
          NSET=MSET
          GO TO 385
      END IF
C   NO. File in list.
      XS(NSET)=RAS(I)*12./PI
      YS(NSET)=DECS(I)/DEGRAD
      DECLIM(1)=MIN(DECLIM(1),YS(NSET))
      DECLIM(2)=MAX(DECLIM(2),YS(NSET))
C    KTYPE =1 for STD., 2 for regular EXT., 3 for Special stars.
      KTYPE(NSET)=1
C    NCAT is catalog number.
      NCAT(NSET)=I
      IF(DECS(I).LT.DEXMAX .AND. DECS(I).GT.DEXMIN)THEN
         NUMEXT=NUMEXT+1
         KTYPE(NSET)=2
      END IF
C
       IF(.NOT.REDUCD .AND. NSET.GT.NEXCES)THEN
C    SHRINK ZONE IF TOO MANY STDS.
      SZMIN=(1.+3.*SZMIN)/4.
      REDUCD=.TRUE.
      GO TO 331
       END IF
  350 CONTINUE
C
      IF(NSET.LT.2 .OR. JSYS.EQ.0)GOTO356
C   GET COLOR RANGES.
      REDS(1)=COLORS(KY,NCAT(1))
      BLUES(1)=COLORS(KY,NCAT(1))
      REDS(2)=COLORS(KX,NCAT(1))
      BLUES(2)=COLORS(KX,NCAT(1))
      DO 351 NOBJ=2,NSET
      I=NCAT(NOBJ)
      REDS(1)=MAX(REDS(1),COLORS(KY,I))
      BLUES(1)=MIN(BLUES(1),COLORS(KY,I))
      REDS(2)=MAX(REDS(2),COLORS(KX,I))
  351 BLUES(2)=MIN(BLUES(2),COLORS(KX,I))
C    TEST NON-EXTINCTION STDS. FOR EXTREME COLORS.
      DO 352 NOBJ=1,NSET
      I=NCAT(NOBJ)
       IF(COLORS(KY,I).EQ.REDS(1) .OR. COLORS(KX,I).EQ.REDS(2) .OR.
     1 COLORS(KY,I).EQ.BLUES(1) .OR. COLORS(KX,I).EQ.BLUES(2))THEN
C    USE EXTREME-COLOR STAR FOR EXTINCTION.
      IF(KTYPE(NOBJ).EQ.1)NUMEXT=NUMEXT+1
      KTYPE(NOBJ)=3
       END IF
  352 CONTINUE
       IF(NEEDED)THEN
C$$$USE BRIGHTEST STARS TO IMPROVE DEAD TIME. (SET KTYPE=3)
       END IF
C
C   ENOUGH EXT.STARS?
C===
  356 IF(NUMEXT.LT.NEEDEX .OR. NSET.LT.NEEDST)THEN
C   NO. WIDEN ZONE.
C --
       IF(SZMIN.LT.1.25)THEN
      SZMIN=SZMIN+.05
      WRITE(PAGE,'(''  ONLY'',I3,'' STARS.  Expand min.secz to'',F6.3)')
     1 NSET,SZMIN
      CALL TV(PAGE(1))
      GO TO 331
C --
       ELSE
C --
       IF(NUMEXT.LT.NEEDEX)THEN
      WRITE(ASSUM4,358) NEEDEX,' EXTINCTION ',NUMEXT
      CALL TV(ASSUME(4))
      CALL TV(ASSUME(5))
       END IF
       IF(NSET.LT.NEEDST)THEN
      WRITE(ASSUM6,358) NEEDST,'TRANSFORMATION',NSET
      CALL TV(ASSUME(6))
      CALL TV(ASSUME(7))
       END IF
  358 FORMAT('You need about ',I2,1X,A,' stars,'/7X,'but only ',I2,
     1' are available.')
C    REVISE BRITES IF IT WILL HELP.
       IF(PC .AND. .NOT.(DC .OR. NEEDIM .OR. DIMMED))THEN
      NEEDIM=.TRUE.
      CALL BRITEN(BANDS,DIMMED)
      IF(DIMMED)GO TO 330
      NEEDIM=.FALSE.
       END IF
      CALL TV(' You need more STD.stars.')
      CALL ASK('Give up?',A)
      IF(A.EQ.'Y' .OR. A.EQ.'O')THEN
         IF(CODEDS)CLOSE(K7,STATUS='DELETE')
         CLOSE(K9,STATUS='DELETE')
         CALL TV('Too few stds. -- ABANDONED')
         CALL STSEPI
      END IF
C
       END IF
C --
      END IF
C===
C
      WRITE(PAGE,359)SZMIN,NUMEXT,NSET
  359 FORMAT(4X,'min.airmass =',F6.3,/I6,' Extinction stars,',I6,
     1' Total standards.')
      CALL TVN(PAGE(1))
      CALL TVN(PAGE(2))
      CALL TVN(' ')
      CALL RTNCON(' ',1)
C   LIST STDS.
      IF(NSET.EQ.0) GO TO 387
C
       IF(CODEDS)THEN
      WRITE(K9,360)'STANDARD'
  360 FORMAT(/4X,'CODE',2X,A8,' STARS'/)
      DO 370 NOBJ=1,NSET
      I=NCAT(NOBJ)
C     WRITE(K7,F361)NOBJ,STARS(I)
        CALL OUT361(K7,F361,NOBJ,STARS,I)
  370 CALL OUT361(K9,F361,NOBJ,STARS,I)
       END IF
C
      IF(NSET.LT.(3*NEEDST)/4)GO TO 387
C
      CALL PLOT(0,RALIMS,DECLIM,'L')
      CALL PLOT(0,79.,21.,'P')
      IF(NEEDH.GT.1)CALL TV('Standard Stars on sky  --   $  = overlaps')
      CALL TV(DECLBL)
      CALL PLOT(NSET,XS,YS,'*')
      CALL RTNCON(RALBL,22)
C   Plot on PROUT.
      DUM=K9
      CALL PLOT(0,DUM,DUM,'U')
      CALL PLOT(0,RALIMS,DECLIM,'L')
C     CALL PLOT(0,103.,(DECLIM(2)-DECLIM(1))/6.+6.,'P')
      CALL PLOT(0,79.,(DECLIM(2)-DECLIM(1))/6.+6.,'P')
      WRITE(K9,'(/1X,A)')DECLBL
      CALL PLOT(NSET,XS,YS,'*')
      WRITE(K9,'(A)')RALBL
      DUM=KTV
      CALL PLOT(0,DUM,DUM,'U')
C
      IF(NBANDS.LE.2)GO TO 385
      IF(NEEDH.GT.1) CALL TV(
     1'            X = EXTINCTION,  S = STD.STAR    $ = OVERLAP')
      WRITE(PAGE,381)CNAMES(1,KY)(:LENC),CNAMES(1,KX)(:LENC)
  381 FORMAT(/4X,A,'  vs. ',A,'  two-color diagram')
      CALL TV(PAGE(2))
      CALL PLOT(0,60.,23.,'P')
      CALL PLOT(0,XINV,YINV,'I')
      A='X'
C    MUST DO X FIRST TO SET LIMITS.
      DO 384 NTYPE=1,2
      N=0
      DO 382 NOBJ=1,NSET
      J=NCAT(NOBJ)
       IF(NTYPE.NE.2)THEN
      IF(KTYPE(NOBJ).LT.2) GO TO 382
       ELSE
      IF(KTYPE(NOBJ).GE.2) GO TO 382
       END IF
      N=N+1
      XS(N)=COLORS(KX,J)
      YS(N)=COLORS(KY,J)
  382 CONTINUE
      IF(N.NE.0) CALL PLOT(-N,XS,YS,A)
  384 A='S'
      CALL PLOT(1,99.,99.,A)
      TITLE='            ('//CNAMES(1,KX)(:LENC)//')'
      CALL RTNCON(TITLE,LENC+14)
C
  385 WRITE(PAGE,359)SZMIN,NUMEXT,NSET
      CALL TVN(PAGE(1))
      CALL TVN(PAGE(2))
       IF(NSET.GT.NEXCES)THEN
      WRITE(PAGE,'(/'' only'',I3,'' Stds.needed.'')')NEEDS
      CALL TV(PAGE(2))
      IF(NSET.GT.NEXCES+NEXCES)GO TO 387
       END IF
  386 CALL ASK('Are these stars OK?',A)
      IF(A.EQ.'Y' .OR. A.EQ.'O') GO TO 400
C
C  REVISE STAR LIST.
C
  387 IF(NEEDH.GT.0) THEN
          CALL TVN(' ')
          CALL TV(
     1      '(Reply "NO" to the next question if you want no changes.)')
      END IF
      CALL ASK('Change Sky Area or Magnitude Limits?',A)
C
C===
       IF(A.EQ.'S' .OR. A.EQ.'A')THEN
C
C   SKY AREA.
C --
       IF(NSET.LT.NEEDST)THEN
      A='E'
      CALL TV('TOO FEW Stds., so expand.')
       ELSE IF(NSET.GT.NEXCES)THEN
      A='S'
      CALL TV('TOO MANY Stds.,so shrink.')
       ELSE
      CALL ASK('Shrink or Expand?',A)
       END IF
C --
      IF(A.EQ.'S')THEN
       SZMIN=(1.+2.*SZMIN)/3.
      ELSE IF(A.EQ.'E')THEN
       SZMIN=SZMIN+.05
      ELSE
       GO TO 385
      END IF
C --
      WRITE(PAGE,'(/'' Try min.airmass ='',F6.3/)')SZMIN
      CALL TV(PAGE(2))
      IF(SZMIN.GE.1.2)CALL TV('CAUTION -- Should not exceed 1.25')
      CALL REHEAD(NDIG,DAT,CODEDS)
      IF(OLDEQ.NE.3.E33)WRITE(K9,328)DATEP
      GO TO 331
C =
       ELSE IF(A.EQ.'M' .OR. A.EQ.'L')THEN
C =
C   MAG.LIMITS.
C
      CALL MAGSET(BANDS)
      CALL REHEAD(NDIG,DAT,CODEDS)
      IF(OLDEQ.NE.3.E33)WRITE(K9,328)DATEP
      GO TO 342
C =
       ELSE IF(A.EQ.'N')THEN
      GO TO 386
C =
       ELSE IF(HELP(A))THEN
      CALL TV(
     1'You can expand sky area or set fainter limits to get more stars.'
     2)
      GO TO 387
C =
       ELSE
      GO TO 385
C =
       END IF
C===
C
  400 IF(NSTARS.EQ.LASTD)GO TO 405
C
C  ADD PROGRAM STARS.
C
      IF(CODEDS)WRITE(K9,360)'PROGRAM'
      J=NSET
      OSTAR=' '
      DO 402 I=LASTD+1,NSTARS
      IF(COLORS(MBANDS,I).GT.100. .AND. STARS(I).EQ.OSTAR) GO TO 402
C   USE 1ST EPHEMERIS ENTRY.
      J=J+1
C
       IF(J.GT.MSET)THEN
         CALL EXCEED(J,'MSET',MSET)
         CALL STETER(401, 'NOT ENOUGH ROOM FOR PGM.STARS')
       END IF
C
       IF(CODEDS .AND. STARS(I).NE.STARS(I-1))THEN
C          use 1st entry for ephemeris object.
           CALL OUT361(K7,F361,J,STARS,I)
           CALL OUT361(K9,F361,J,STARS,I)
       END IF
C
      KTYPE(J)=0
      NCAT(J)=I
  402 OSTAR=STARS(I)
      NSET=J
C
  405 IF(NBANDS.LE.2)GO TO 410
C
C       plot 2-color diagram on printed o/p.
C
      WRITE(K9,'(//18X,A)')'X = Extinction,  S = Std.star,  $ = overlap'
      WRITE(K9,381)CNAMES(1,KY)(:LENC),CNAMES(1,KX)(:LENC)
        DUM=K9
        CALL PLOT(0,DUM,DUM,'U')
      CALL PLOT(0,60.,32.,'P')
      CALL PLOT(0,XINV,YINV,'I')
      A='X'
C    MUST DO X FIRST TO SET LIMITS.
      DO 407 NTYPE=1,2
      N=0
      DO 406 NOBJ=1,NSET
      J=NCAT(NOBJ)
       IF(NTYPE.NE.2)THEN
      IF(KTYPE(NOBJ).LT.2) GO TO 406
       ELSE
      IF(KTYPE(NOBJ).GE.2) GO TO 406
       END IF
      N=N+1
      XS(N)=COLORS(KX,J)
      YS(N)=COLORS(KY,J)
  406 CONTINUE
      IF(N.NE.0) CALL PLOT(-N,XS,YS,A)
  407 A='S'
      CALL PLOT(1,99.,99.,A)
      TITLE='                               ('//CNAMES(1,KX)(:LENC)//')'
      WRITE (K9,'(A)')TITLE
C
      WRITE (K9,'(A)')FF
C       Generate "Special Instructions" page:
      WRITE(K9,'(10X,''S P E C I A L   I N S T R U C T I O N S :'')')
      WRITE(K9,'(10X,''-----------------------------------------''//)')
      IF (FUNK)
     1    WRITE(K9,'(10X,''FIND OUT if RED-LEAK filter is cemented''/)')
      IF (FCORN)
     1    WRITE(K9,'(10X,''FIND OUT if RED-LEAK filter is Pyrex''/)')
      WRITE(K9,'(10X,''FIND OUT the ACTUAL condition of the optics:'')')
      WRITE(K9,'(54X,''.............''/)')
C
  410 CONTINUE
C
C   SUMMARIZE FINAL CONDITIONS.
C
       IF(NUMEXT.LT.NEEDEX)THEN
      NASSMP=NASSMP+2
      ASSMPS(NASSMP-1)=ASSUME(4)
      ASSMPS(NASSMP)=ASSUME(5)
       END IF
       IF(NSET.LT.NEEDST)THEN
      NASSMP=NASSMP+2
      ASSMPS(NASSMP-1)=ASSUME(6)
      ASSMPS(NASSMP)=ASSUME(7)
       END IF
       IF(SZMIN.GT.1.25)THEN
      NASSMP=NASSMP+1
      ASSMPS(NASSMP)=ASSUME(8)
       END IF
C
      IF(DC) TSUGG=TSUGG+TSUGG
      WRITE(K9,412)INT(TSUGG),SIGTOT
  412 FORMAT(//' Use integrations of AT LEAST',I3,' SECONDS to get',F6.3
     1,' mag.precision.'/)
C
      WRITE(K9,
     1 '(/'' BE SURE to fill in Temp. & R.H. data when you start a page.
     2'')')
C
C
C  *****  BEGIN LOOP OVER NIGHTS.
C
      DO 700 NIGHT=1,INT(DJS(2)-DJS(1)+1.5)
C
      DJ=(NIGHT-1)+DJS(1)
C   assemble double date.
      CALL JD2DAT(DJ-1.,DAT)
      CALL JD2DAT(DJ,DMS)
C   same YEAR?
      IF(DMS(8:11).EQ.DAT(8:11))THEN
C    same MONTH?
       IF(DMS(:3).EQ.DAT(:3))THEN
        DAT(7:)='-'//DMS(5:11)
C    Different MONTHS.
       ELSE
        DAT(7:)='/'//DMS(:11)
       END IF
C   Different YEARS.
      ELSE
       DAT(12:)='/'//DMS
      END IF
C
        PAGE(1)='Working on: '//DAT
        CALL TV(PAGE(1))
      DAYN=DJ-2451545.0
      T=DAYN/36525.
      CALL STUTZR(T)
      STZROT=STUTZ/TWOPI
C
C  SUN & MOON AT MIDNIGHT.
      CALL SUN(DAYN-ELROT)
C   STORED SOLONG; MOON NEXT.
      CALL MOON(T-ELROT/36525.,0.)
C    DOT PROD. IS COS(PHASE).
      PHASE=ACOS(COS(ELMOON)*COS(BMOON)*COS(SOLONG+PI) +
     1 SIN(ELMOON)*COS(BMOON)*SIN(SOLONG+PI))
C    ROUGIER'S PHASE FCN.(P&S,P.289), IN RAD.
      DMAG=PHASE*(1.748+PHASE*(-.335+PHASE*.197))
      NT=10
C
       IF(DMAG.LT.6.8)THEN
C   TWILIGHT LIMIT.
      SALTS(11)=.0154*DMAG-.12
      SALTS(12)=SALTS(11)
      NT=12
       END IF
C
       IF(PHASE.GT.2.)GO TO 425
C   AIR-MASS CHANGES .04/MIN.=9.17/RAD.  N.B.:MOON IN SOLAR SLOTS.
      SIND=SIN(DESUN)
      COSD=COS(DESUN)
C   STARTING VALUE: ASSUME SIN H = 1.
      COSZ=SQRT(COSD*COSPHI/9.17)
      BAD=.FALSE.
  420 DO 423 LOOP=1,9
      ARG=COSD*COSD*COSPHI*COSPHI-(COSZ-SIND*SINPHI)**2
       IF(ARG.LT.0.)THEN
      IF(BAD) GO TO 425
      BAD=.TRUE.
      COSZ=0.09
      GO TO 420
       ELSE
      OLDCOS=COSZ
      COSZ=SQRT(SQRT(ARG)/9.17)
      IF(BAD)COSZ=(COSZ+OLDCOS)*.5
       END IF
      IF(ABS(COSZ-OLDCOS).LT..001)GO TO 424
  423 CONTINUE
  424 NT=14
C    ALT.IS COMP.OF Z.
      SALTS(13)=ASIN(COSZ)
      SALTS(14)=SALTS(13)
C
  425 UTBGN=0.
      UTEND=0.
      DO 430 I=1,NT
      TIMES(I)=3.E33
C
       IF(I.LE.8)THEN
C   SUN.
      CALL UTSUN(DAYN,SALTS,I,*430)
      IF(I.EQ.3)UTBGN=UTROT
      IF(I.EQ.6)UTEND=UTROT
       ELSE
C   MOON.
      CALL UTMOON(T,SALTS,I,*430)
      IF(UTROT.LT.UTBGN .OR. UTROT.GT.UTEND) GO TO 430
       END IF
C
C  STORE EVENTS IN LOG.
      TIMES(I)=UTROT
C    NEG.NOBJS FLAGS NONSTELLAR EVENT.
      NOBJS(I)=-I
  430 CONTINUE
C
      IF(UTEND.EQ.UTBGN)THEN
          CALL TV('TWILIGHT ALL NIGHT')
          CALL STETER(431, 'NO DARKNESS.')
      END IF
      DARKT=MOD(UTEND-UTBGN+1.,1.)
C    NEEDED BY FILL.
C
      IF (DARK) THEN
C   DO N DARKS.
          N=72.*DARKT+2.
          DUM=DARKT/(N-1)
          I1=NT+1
          NT=NT+N
          DO 432 I=I1,NT
          TIMES(I)=UTBGN+DUM*(I-I1)
  432     NOBJS(I)=-15
      END IF
C
C     add reminder about cooling...
      IF(COOLED)THEN
          NT=NT+1
          NOBJS(NT)=-16
          TIMES(NT)=UTBGN-1./8.
      END IF
C
C  LOOP OVER STARS.
C
      DO 450 NOBJ=1,NSET
      I=NCAT(NOBJ)
       IF(COLORS(MBANDS,I).LT.100.)THEN
C   NORMAL STAR.
      RA=RAS(I)
      DEC=DECS(I)
       ELSE
C   EPHEMERIS OBJECT AT MIDNIGHT.
      CALL EPHEM(I,(DJ-2400000.)-ELROT,COLORS,RA,DEC)
       END IF
C
C   SET UP FOR RISE/SET FIRST.
      COSZ=0.423
C    FIND HA FOR SECZ=2.36
C
      DO 443 J=1,2
      COSHA=(COSZ-SIN(DEC)*SINPHI)/(COSPHI*COS(DEC))
      IF(ABS(COSHA).GT.1.0)GOTO445
      HA=ACOS(COSHA)
C    USE TRANSIT ONLY, IF E/W ARE CLOSE.
      IF(HA.LT.0.1)GO TO 445
C    EAST.
      CALL FILL(RA-HA,NOBJ,*442)
C    FINDS NT; STORES UTROT IN TIMES(NT) IF UT IS OK;
C    GOES TO 442 IF UT NOT IN (UTBGN,UTEND).
      IDS(NT)=ELABEL(J)
C    WEST.
  442 CALL FILL(RA+HA,NOBJ,*443)
      IDS(NT)=WLABEL(J)
C
C    SET FOR ZENITH STARS.
  443 COSZ=COSMIN
C
      IF(HA.GT.0.1)GO TO 450
C    SKIP TRANSIT IF EAST/WEST ZENITH ALREADY.
C
C   TRANSIT.
  445 CALL FILL(RA,NOBJ,*450)
      IDS(NT)=' TRANSIT'
  450 CONTINUE
      NTIMES=NT
        CALL SORTBL(NTIMES,TIMES,NOBJS,IDS)
C
C  LIST FINAL RESULTS.
C
      N=INDEX(PLACE,'Obs')
      IF (N.GT.0) PLACE(N:)=' '
      N=LWORD(PLACE)
      IF(N.LE.12) WRITE(PLACE(N+1:),'(I5,''-cm'')') INT(TELCM)
C
      UT2ST=1./ST2UT
C     lines/page:
      LPP=55
C     page heading:
      WRITE(K9,640)FF,DAT,DJ,PLACE,TEMPRH,TL,(CNAMES(1,NB),NB=1,NBANDS)
  640 FORMAT(A1/1X,A28,'  Julian Date ',F10.1,3X,'at',2X,A20//17X,A34/
     1 23X,'......',8X,'......',8X,'..........'//
     2 3X,A4,10X,'EVENT',27X,'R.A.',10X,'DEC.',7X,A6/' -------',3X,
     3 '----------------------------',7X,'----------',4X,'----------',
     4 3X,A6/(73X,1A6))
      LINE=NBANDS+5
C
C               ****  BEGIN output loop over stars  ****
C
      DO 670 I=1,NTIMES
      IF(TIMES(I).EQ.3.E33)GO TO 670
C   Page Heading:
C    Zone time.
      IF(ITIME.EQ.2) TIMES(I)=TIMES(I)-ZONE
C    LST.
      IF(ITIME.EQ.3) TIMES(I)=TIMES(I)*UT2ST+STZROT+ELROT
      UTSTR=DEG2M1(MOD(TIMES(I)+2.,1.)*24.)
C=====
      IF(NOBJS(I).GT.0) GOTO 660
      IF(LINE.GT.LPP-3) THEN
          WRITE(K9,640)FF,DAT,DJ,PLACE,TEMPRH,TL,
     1                 (CNAMES(1,NB),NB=1,NBANDS)
          LINE=NBANDS+5
      END IF
C   Do SUN & MOON.
      WRITE(K9,650) UTSTR,TWILIT(-NOBJS(I))
  650 FORMAT(3X,'h  m'/A9,1X,A28/)
C =
      LINE=LINE+3
      GOTO 670
C =
C   Here for other objects.
  660 J=NCAT(NOBJS(I))
      IF(LINE.GT.LPP-(NBANDS+2)) THEN
          WRITE(K9,640)FF,DAT,DJ,PLACE,TEMPRH,TL,
     1                 (CNAMES(1,NB),NB=1,NBANDS)
          LINE=NBANDS+5
      END IF
C --
      IF(COLORS(MBANDS,J).GT.100.)GOTO 663
C    FIXED STAR.
      RASTR=DEG2MS(RAS(J)/DEGRAD/15.)
      DESTR=DEG2MS(DECS(J)/DEGRAD)
       GOTO 665
C    Moving.
  663 CALL EPHEM(J,(DJ-2400000.)+TIMES(I),COLORS,RA,DEC)
      RASTR=DEG2MS(MOD(RA/TWOPI+1.,1.)*24.)
      DESTR=DEG2MS(DEC/DEGRAD)
C --
  665 CALL OUTP(UTSTR,STARS,I,J,IDS,NOBJS,RASTR,DESTR,COLORS,NBANDS)
      LINE=LINE+NBANDS+2
C=====
  670 CONTINUE
C
C               ****  END output loop over stars  ****
C
      WRITE(K9,'(/17X,A34)')TEMPRH
C
C  END LOOP OVER NIGHTS.
C
  700 CONTINUE
C
C
C  EPILOGUE:
C
      CALL TVN(' ')
       IF(NASSMP.LE.NEEDH+2)THEN
      WRITE(K9,'(//'' END OF RUN.'')')
      CALL TV('Thanks for using PEPSYS3''s Planner.')
       END IF
C
      CALL TV('DON''T FORGET to send (PROUT) to the printer.')
      CALL TVN(' ')
C
      NOBJ=3+(NSET/NEEDST)+(NUMEXT/NEEDEX)
       IF(NASSMP.NE.0 .AND. NASSMP.LT.NOBJ)THEN
      CALL TV('     * * *   C A U T I O N :   * * *')
      CALL TVN(' ')
      WRITE(K9,'(///6X,''C A U T I O N :''/)')
C     WRITE(PAGE,'(A40,A39)')(ASSMPS(I),I=1,NASSMP)
      CALL TV(' ')
      DO 997 I=1,NASSMP
  997 CALL TVN(ASSMPS(I))
      WRITE(K9,'(1X,A40/)')(ASSMPS(I),I=1,NASSMP)
      CALL TVN(' ')
       ELSE IF(NASSMP.GE.NOBJ)THEN
C    NEW PAGE IF NEEDED.
      IF(LINE.GT.LPP-NASSMP*2-3)WRITE(K9,640)
      WRITE(K9,'(//)')
      CALL SXB(K9,ASSMPS,NASSMP)
      CALL SXB(KTV,ASSMPS,NASSMP)
       END IF
C
      REWIND K9
      CLOSE(K9,STATUS='KEEP')
      IF(CODEDS)CLOSE(K7,STATUS='KEEP')
C
      CALL TV('NORMAL END of PLANNER')
C       Restore flags:
      CALL STECNT('PUT',JCONT,JLOG,JDISP)
      CALL STSEPI
C  return code = 0 if no argument.
      END
        SUBROUTINE OUT361(KUNIT,FMT,NOBJ,STARS,I)
C
      IMPLICIT NONE
C
      INTEGER KUNIT, NOBJ, I
C
        CHARACTER FMT*13 ,STARS(I)*32
        WRITE(KUNIT,FMT)NOBJ,STARS(I)
        RETURN
        END
      SUBROUTINE SORTBL(NTIMES,TIMES,NOBJS,IDS)
C
      IMPLICIT NONE
C
      REAL TIMES,DUM
      INTEGER NTIMES,NOBJS,I,M,J,JJ
C
      DIMENSION TIMES(NTIMES),NOBJS(NTIMES)
        CHARACTER*8 IDS(NTIMES), STR8
C
C  SORT ENTRIES.
C
      I=1
  453 I=I+I
      IF(I.LE.NTIMES)GO TO 453
      M=I-1
  455 M=M/2
      IF(M.EQ.0) RETURN
      DO 460 JJ=1,NTIMES-M
      DO 458 I=JJ,1,-M
      IF(TIMES(I+M).GE.TIMES(I)) GO TO 460
      DUM=TIMES(I)
      TIMES(I)=TIMES(I+M)
      TIMES(I+M)=DUM
      J=NOBJS(I)
      NOBJS(I)=NOBJS(I+M)
      NOBJS(I+M)=J
      STR8=IDS(I)
      IDS(I)=IDS(I+M)
      IDS(I+M)=STR8
  458 CONTINUE
  460 CONTINUE
      GO TO 455
      END
      SUBROUTINE OUTP(UTSTR,STARS,I,J,ID,NOBJ,RA,DE,COLORS,NBANDS)
C
      IMPLICIT NONE
      INTEGER I, J, NOBJ, NBANDS, KB, KTV, K2, K3, K4, K7, K8, K9, LEN,
     1         LOWER, KBR, K
      REAL COLORS
C
      INCLUDE 'MID_REL_INCL:mstars.inc'
      INCLUDE 'MID_REL_INCL:mbands.inc'
C     PARAMETER (MBANDS=9,MSTARS=1650)
      DIMENSION NOBJ(I),COLORS(MBANDS,MSTARS)
      CHARACTER*32 STARS(J)
      CHARACTER*20 STAR1,STAR2,RA,DE
      CHARACTER*8 UTSTR,ID(I)
      CHARACTER COMENT(MSTARS)*32,SPTYPE(MSTARS)*12,EMAG(MSTARS)*16
      COMMON /NOTES/COMENT,SPTYPE,EMAG
      COMMON /FILNOS/ KB, KTV, K2, K3, K4, K7, K8, K9
C
C     check name for >20 chars:
      DO 5 LEN=32,19,-1
      IF(STARS(J)(LEN:LEN).NE.' ') GO TO 8
    5 CONTINUE
      LEN=19
    8 CONTINUE
      IF (LEN.LE.20)THEN
          STAR1=STARS(J)
          STAR2=' '
      ELSE
C         split name to fit:
          LOWER=MAX(6,LEN-20)
          KBR=INDEX(STARS(J)(LOWER:21),'=')
          IF(KBR.EQ.0) THEN
              KBR=INDEX(STARS(J)(LOWER:23),'   ')
              IF (KBR.EQ.0)THEN
                  KBR=INDEX(STARS(J)(LOWER:22),'  ')
                  IF (KBR.EQ.0) THEN
                      KBR=INDEX(STARS(J)(LEN-20:21),'=')
                      IF(KBR.EQ.0) KBR=INDEX(STARS(J)(LEN-20:21),':')
                      IF(KBR.EQ.0) KBR=INDEX(STARS(J)(LEN-20:21),',')
                      IF(KBR.EQ.0) KBR=INDEX(STARS(J)(LEN-20:21),'.')
                      IF(KBR.EQ.0) KBR=INDEX(STARS(J)(LEN-20:21),' ')
                      KBR=KBR+LEN-21
                  ELSE
                      KBR=KBR+LOWER-1
                  END IF
              ELSE
                  KBR=KBR+LOWER-1
              END IF
          ELSE
              KBR=KBR+LOWER-1
          END IF
          STAR1=STARS(J)(:KBR-1)
          STAR2=STARS(J)(KBR:)
      END IF
C
      WRITE(K9,666) UTSTR,STAR1,ID(I),NOBJ(I),RA,DE,COLORS(1,J),
     1 STAR2, COLORS(2,J),
     2 COMENT(J),EMAG(J),SPTYPE(J), (COLORS(K,J),K=3,NBANDS)
  666 FORMAT(3X,'h  m',34X,'No.',4X,'h  m  s       o  ''  "'/
     1 A8,3X,A20,A8,I4,2(2X,A12),1X,F5.2/11X,A20,41X,F5.2/11X,A32,A16,
     2 1X,A12,F5.2/(72X,F5.2))
      IF (NBANDS.LT.3) WRITE(K9,'(1X)')
        RETURN
         END
