C @(#)plansubs.for	17.1.1.1 (ES0-DMD) 01/25/02 17:17:17
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
C  @(#)plansubs.for	4.5  (ESO-IPG)  3/26/93  15:40:54
      BLOCK DATA
C					Copyright (C) by Andrew T. Young 1990
C                     MAR.5,1987
C
C
      IMPLICIT NONE
      INTEGER  KB, KTV, K2, K3, K4, K7, K8, K9
      INTEGER  NAM1,NAM2,NGRPS,MURAT,MURAA,MUDEC
      REAL RAHRS,RAMIN,RASEC,DEDEG,DEMIN,DESEC,EPOCH,SIGNAL,TINT
      REAL CVARS,FMM,DD,YY,YEAR,DAY,UTHRS,UTMIN,UTSEC,CLKERR
      REAL STHRS,STMIN,STSEC,ZTHRS,ZTMIN,ZTSEC,VSPARE
C
C   F I L E S :
C   -----------
C
C *** LENGTH OF FILE NAMES MAY BE SYSTEM-DEPENDENT.
C     FULL SET FOR SUBROUTINE COMPATIBILITY.
      COMMON /FILNOS/ KB, KTV, K2, K3, K4, K7, K8, K9
C *** UNITS MAY BE SYSTEM-DEPENDENT.
C
C
      INCLUDE 'MID_REL_INCL:mbands.inc'
C     PARAMETER (MBANDS=9)
C
C  Declare integer parameters for stupid compilers:
C
      INTEGER MGAINS,MG2,MA,MCAT,MN,MV,MGRPS,MAREST,MNREST
C
C  PARAMETERS FOR RDLIST/RDBLOK.
C
      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           (21 & 15 ARE LAST ASSIGNED SLOTS IN AVAR & VALUES)
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   CHARACTER VARIABLES THAT 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
C
C   REAL VARIABLES THAT REPLACE VAR(MN):
C     COMMON /VALUES/ NAM1(MGRPS),NAM2(MGRPS),NGRPS,VAR(MN)
C
      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
      CHARACTER ASSMPS(8)*40,ASSUME(8)*40
      COMMON /ASSUME/ ASSMPS,ASSUME
c
C   D A T A :
C   =========
C
C *** UNITS:
      DATA KB/5/, KTV/6/, K2/2/, K3/3/, K4/4/, K7/7/, K8/8/, K9/9/
C
C
C  NUMERICAL VARIABLE NAMES ...
C
C       NAMX() =    1       2       3       4       5       6       7
      DATA NAMES/'RAHRS','RAMIN','RASEC','DEDEG','DEMIN','DESEC','EPOCH'
C
C         8       9      10      11      12
     1,'MURAT','MURAA','MUDEC','SIGNAL','TINT',
C
C        13 TO MCAT....        +1   +2   +3    +4    +5
     2  MBANDS*' ',MBANDS*' ','MM','DD','YY','YEAR','DAY',
C
C   MCAT + 6      +7      +8      +9      +10     +11    +12
     3 'UTHRS','UTMIN','UTSEC','CLKERR','STHRS','STMIN','STSEC',
C
C   MCAT+13      +14     +15     +16  TO  MCAT +30
     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
     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
     6 ,'SPECT','DESGN','DATSTR','MONTH','REM1','REM2','STSTR','ZTSTR',
C
C        MN+18   MN+19    MN+20    MN+21   MN+22  TO
     7  'UTSTR','FILTCD','STARCD','STRSKY',MGAINS*' ',MGAINS*' ',
C
C        MN+
     8  MAREST*' '/
C
C
      DATA ASSUME/'NEGLECT RED-LEAK CORRECTIONS.',
     2 '           DEAD TIME UNKNOWN.',
C       0987654321098765432112345678901234567890
     3 ' ASSUME dead time will be known to 10%.',
     4 ' ',' ',' ',' ',' '/
      END
      SUBROUTINE FINDPM(STRING,VALUE,SVAL)
C
C  READ DATA LIKE:  VALUE +/- SVAL          (02 JAN.'87)
C
      IMPLICIT NONE
C
      REAL VALUE,SVAL
      INTEGER IPM
C
      CHARACTER STRING*(*),FMT*9,CARD*20,A
C
      CARD=STRING
    1 IPM=INDEX(CARD,'+/-')
      IF(IPM.EQ.0) GO TO 3
      FMT='(BN,F9.0)'
      IF(IPM.GT.9) GO TO 2
      WRITE(A,'(I1)')IPM-1
      FMT(6:6)=A
    2 READ(CARD(:IPM-1),FMT,ERR=9)VALUE
      READ(CARD(IPM+3:),'(BN,F9.0)',ERR=9)SVAL
      RETURN
C
    3 READ(CARD,'(BN,F9.0)',ERR=9)VALUE
      CALL QF('+/- what Std. Error?',SVAL)
      RETURN
C
    9 CALL TV('BAD DATA; Please re-enter value:')
      CALL ASK('?',CARD)
      GO TO 1
      END
      SUBROUTINE STUTZR(T)
C
C  SETS STUTZ IN RADIANS FOR T IN JULIAN CENTURIES FROM 2000.
C
C
      IMPLICIT NONE
C
      DOUBLE PRECISION DSTUTZ
C
      REAL T, SINPHI, COSPHI, ELONG, ELROT, UTROT, STUTZ, TWOPI, ST2UT, 
     1         TNOON1, TNOON2, PI, DEGRAD, ALAT
C
      COMMON /SPHERE/ SINPHI,COSPHI,ELONG,ELROT,UTROT,STUTZ,TWOPI,ST2UT,
     1 TNOON1,TNOON2,PI,DEGRAD,ALAT
      SAVE /SPHERE/
C
      DSTUTZ=(24110.54841D0+T*(8640184.812866D0+T*(.093104-T*6.21E-6)))
     1 /86400.
      STUTZ=DSTUTZ-INT(DSTUTZ)
      IF(STUTZ.LT.0.)STUTZ=STUTZ+1.
      STUTZ=STUTZ*TWOPI
      RETURN
      END
      SUBROUTINE SUN(DAYN)
C
C  DAYN IS DAYS FROM J2000.0 -- SEE P. C24 OF 1984 A.A.
C  GENERATES SOLAR POSITION (APPROX.) -- CERTIFIED BY ATY, 18 MARCH'84.
C
C
      IMPLICIT NONE
C
      REAL DAYN, COSOB, SINOB, RASUN, DESUN, HASUN, SOLONG, ELMOON, 
     1         BMOON, SINPHI, COSPHI, ELONG, ELROT, UTROT, STUTZ, TWOPI, 
     2         ST2UT, TNOON1, TNOON2, PI, DEGRAD, ALAT, G
C
C   COMMONS FOR SUN.
C
      COMMON /CSUN/ COSOB,SINOB,RASUN,DESUN,HASUN,SOLONG,ELMOON,BMOON
      COMMON /SPHERE/ SINPHI,COSPHI,ELONG,ELROT,UTROT,STUTZ,TWOPI,ST2UT,
     1 TNOON1,TNOON2,PI,DEGRAD,ALAT
C
      SAVE /SPHERE/, /CSUN/
C
C
      G=(357.528+0.9856003*DAYN)*DEGRAD
      SOLONG=(280.46+0.9856474*DAYN+1.915*SIN(G)+.02*SIN(G+G))*DEGRAD
      RASUN=ATAN(COSOB*TAN(SOLONG))
      IF(RASUN.LT.0.)RASUN=RASUN+TWOPI
      IF(ABS(RASUN-STUTZ).GT.3.0 .AND. ABS(RASUN-STUTZ).LT.3.5)GO TO 3
      IF(RASUN.LT.PI)THEN
       RASUN=RASUN+PI
      ELSE
       RASUN=RASUN-PI
      END IF
  3   DESUN=ASIN(SINOB*SIN(SOLONG))
      RETURN
      END
      SUBROUTINE UTSUN(DAYN,SALTS,I,*)
C
C  CONVERTS SALTS(I) TO UTROT AND HASUN ON DAYN.     9 FEB.'85
C   ALT.RETURN IF SUN DOES NOT REACH SALTS(I).
C
C
      IMPLICIT NONE
C
      REAL DAYN, SALTS, COSOB, SINOB, RASUN, DESUN, HASUN, SOLONG, 
     1     ELMOON, BMOON, SINPHI, COSPHI, ELONG, ELROT, UTROT, STUTZ, 
     2     TWOPI, ST2UT, TNOON1, TNOON2, PI, DEGRAD, ALAT, COSHA, UT
      INTEGER I,J
C
      COMMON /CSUN/ COSOB,SINOB,RASUN,DESUN,HASUN,SOLONG,ELMOON,BMOON
      COMMON /SPHERE/ SINPHI,COSPHI,ELONG,ELROT,UTROT,STUTZ,TWOPI,ST2UT,
     1 TNOON1,TNOON2,PI,DEGRAD,ALAT
      INTEGER MSG
      PARAMETER (MSG=14)
C
      SAVE /SPHERE/, /CSUN/
C
      DIMENSION SALTS(MSG)
C
      UTROT=-ELROT
      DO 425 J=1,2
      CALL SUN(UTROT+DAYN)
      COSHA=(SALTS(I)-SIN(DESUN)*SINPHI)/(COSPHI*COS(DESUN))
      IF(COSHA.LT.-1.)RETURN 1
      HASUN=ACOS(COSHA)
      IF(I.GT.4)HASUN=TWOPI-HASUN
      UT=MOD(HASUN+RASUN-STUTZ-ELONG,TWOPI)*ST2UT
  425 UTROT=UT/TWOPI
      IF(UTROT+ELROT.GT.0.5) UTROT=UTROT-ST2UT
      IF(UTROT+ELROT.LT.-.5) UTROT=UTROT+ST2UT
      RETURN
      END
      SUBROUTINE MOON(T,TLST)
C
C  USE MOON LOW-PRECISION FORMULA, P.D46, AA 1985.
C  INPUT: T (JULIAN CENTURIES FROM B2000.0), LST (RADIANS).   10 FEB.'85
C  OUTPUT: RASUN, DESUN (VIA /CSUN/) ARE TOPOCENTRIC.
C
C
      IMPLICIT NONE
C
      REAL T, TLST, COSOB, SINOB, RASUN, DESUN, HASUN, SOLONG, ELMOON, 
     1       BMOON, SINPHI, COSPHI, ELONG, ELROT, UTROT, STUTZ, TWOPI, 
     2       ST2UT, TNOON1, TNOON2, PI, DEGRAD, ALAT, ARG1, ARG2, ARG3, 
     3       ARG4, PAR, R, COSB, SINB, CBSL, ELL, EMM, ENN, X, Y, Z
C
      COMMON /CSUN/ COSOB,SINOB,RASUN,DESUN,HASUN,SOLONG,ELMOON,BMOON
      COMMON /SPHERE/ SINPHI,COSPHI,ELONG,ELROT,UTROT,STUTZ,TWOPI,ST2UT,
     1 TNOON1,TNOON2,PI,DEGRAD,ALAT
C
      SAVE /SPHERE/, /CSUN/
C
      ARG1=2.354+8328.6912*T
      ARG2=4.5239-7214.0633*T
      ARG3=4.114+15542.7544*T
      ARG4=4.711+16657.3823*T
C   GEOCENTRIC ECLIPTIC COORDS.
      ELMOON=3.8104 + 8399.70915*T + .1098*SIN(ARG1) -.0222*SIN(ARG2)
     2 +.0115*SIN(ARG3) +.0037*SIN(ARG4)
     3 -.0033*SIN(6.24+628.302*T) -.0019*SIN(3.257+16866.9326*T)
      BMOON=.0895*SIN(1.628+8433.4664*T) +.0049*SIN(3.983+16762.1573*T)
     1 -.0049*SIN(5.555+104.7753*T) -.003*SIN(3.798-7109.288*T)
      PAR=.016595 + .000904*COS(ARG1) +.000166*COS(ARG2)
     2 +.000136*COS(ARG3) +.000049*COS(ARG4)
      R=1./SIN(PAR)
      COSB=COS(BMOON)
      SINB=SIN(BMOON)
      CBSL=COSB*SIN(ELMOON)
C   DIRECTION COSINES:
      ELL=COSB*COS(ELMOON)
      EMM=0.9175*CBSL-0.3978*SINB
      ENN=0.3978*CBSL+0.9175*SINB
C
C   TOPOCENTRIC REDUCTION.
      X=R*ELL-COSPHI*COS(TLST)
      Y=R*EMM-COSPHI*SIN(TLST)
      Z=R*ENN-SINPHI
      R=SQRT(X*X+Y*Y+Z*Z)
C   STORE RESULTS IN SUN SLOTS.
      RASUN=ATAN2(Y,X)
      DESUN=ASIN(Z/R)
      RETURN
      END
      SUBROUTINE UTMOON(T,SALTS,I,*)
C
C  CONVERTS SALTS(I) TO UTROT AND HASUN AT DAY T.
C   ALT.RETURN IF MOON DOES NOT REACH SALTS(I).     9 FEB.'85
C
C
      IMPLICIT NONE
C
      REAL T, SALTS, COSOB, SINOB, RASUN, DESUN, HASUN, SOLONG, ELMOON, 
     1         BMOON, SINPHI, COSPHI, ELONG, ELROT, UTROT, STUTZ, TWOPI, 
     2         ST2UT, TNOON1, TNOON2, PI, DEGRAD, ALAT, TLST, COSHA, UT
      INTEGER I,J
C
      COMMON /CSUN/ COSOB,SINOB,RASUN,DESUN,HASUN,SOLONG,ELMOON,BMOON
      COMMON /SPHERE/ SINPHI,COSPHI,ELONG,ELROT,UTROT,STUTZ,TWOPI,ST2UT,
     1 TNOON1,TNOON2,PI,DEGRAD,ALAT
      INTEGER MSG
      PARAMETER (MSG=14)
C
      SAVE /SPHERE/, /CSUN/
C
      DIMENSION SALTS(MSG)
      LOGICAL UP,DOWN
C
      UP=.FALSE.
      DOWN=.FALSE.
C   Start at local Midnight.
      TLST=STUTZ-ELONG
C     STUTZ was set by STUTZR.
      UTROT=-ELROT
      DO 425 J=1,4
      CALL MOON(T+UTROT/36525.,TLST)
C     MOON puts lunar coords. at TLST in RASUN & DESUN.
      COSHA=(SALTS(I)-SIN(DESUN)*SINPHI)/(COSPHI*COS(DESUN))
      IF(ABS(COSHA).GT.1.)RETURN 1
      HASUN=ACOS(COSHA)
C     East (rise) if I is odd, West (set) if even.
      IF(MOD(I,2).EQ.1)HASUN=-HASUN
      TLST=RASUN+HASUN
      UT=MOD(TLST-STUTZ-ELONG,TWOPI)*ST2UT
      UTROT=UT/TWOPI
C      TNOON1 and TNOON2 (-ELROT+/-.5 rotations) must be set by calling pgm.
       IF(UTROT.LT.TNOON1)THEN
         UTROT=UTROT+ST2UT
C    Prevent oscillations if no event in time window.
         IF(UP.AND.DOWN) RETURN1
         UP=.TRUE.
       ELSE IF(UTROT.GT.TNOON2)THEN
         UTROT=UTROT-ST2UT
         IF(UP.AND.DOWN) RETURN1
         DOWN=.TRUE.
       END IF
  425 CONTINUE
      RETURN
      END
      FUNCTION DEG2M1(DEG)
C
C  CONVERTS DECIMAL DEGREES TO DEG MIN.1
C
C $$$ CAUTION: USE ONLY WITH POSITIVE ARGUMENTS.  SEE DEG2MS FOR
C              CORRECT TREATMENT OF -00 ZONE.
C
C
      IMPLICIT NONE
C
      REAL DEG,FMIN
      INTEGER LDEG
C
      CHARACTER*8 DEG2M1,dum
C
      LDEG=DEG
      FMIN=ABS(DEG-(LDEG))*60.
      WRITE(dum,'(I3,F5.1)')LDEG,FMIN
      DEG2M1=dum
      RETURN
      END
      SUBROUTINE FILL(TLST,NOBJ,*)
C
C  FILLS EMPTY SLOTS IN TIMES().     26 JAN.'87
C
C
      IMPLICIT NONE
C
      REAL TLST, UTBGN, UTEND, DARKT, TIMES, SINPHI, COSPHI, ELONG, 
     1   ELROT, UTROT, STUTZ, TWOPI, ST2UT, TNOON1, TNOON2, PI, DEGRAD, 
     2   ALAT, UT
      INTEGER NOBJ, NOBJS, NT
C
      INCLUDE 'MID_REL_INCL:mstars.inc'
C     PARAMETER (MSTARS=1650)
      INTEGER MSET,MROOM,MSG,MTIM
      PARAMETER (MSET=MSTARS-100,MROOM=2,MSG=14,MTIM=MROOM*MSET+MSG)
      COMMON /CFILL/ UTBGN,UTEND,DARKT,TIMES(MTIM),NOBJS(MTIM),NT
      COMMON /SPHERE/ SINPHI,COSPHI,ELONG,ELROT,UTROT,STUTZ,TWOPI,ST2UT,
     1 TNOON1,TNOON2,PI,DEGRAD,ALAT
C
      SAVE /CFILL/,/SPHERE/
C
      UT=MOD(TLST-STUTZ-ELONG,TWOPI)*ST2UT
C
      UTROT=UT/TWOPI
      IF(UTROT+ELROT.GT.0.5) UTROT=UTROT-ST2UT
      IF(UTROT+ELROT.LT.-.5) UTROT=UTROT+ST2UT
C    WATCH FOR STD.STARS IN EXTENSIONS.
      IF ((UTBGN.LT.UTEND .AND. (UTROT.GT.UTEND.OR.UTROT.LT.UTBGN)) .OR.
     1 (UTBGN.GT.UTEND .AND. UTROT.GT.UTEND .AND. UTROT.LT.UTBGN))
     2 RETURN 1
      NT=NT+1
      TIMES(NT)=UTROT
      NOBJS(NT)=NOBJ
      RETURN
      END
      SUBROUTINE RTNCON(STRING,L)
C
C  PRINTS 'STRING' AND 'HIT RETURN TO CONTINUE'.
C
C
      IMPLICIT NONE
C
      INTEGER L, N, IUNIT, NULLS, ISTAT
C
      CHARACTER STRING*40,A, C80*79
C
C
      C80=STRING(:L)//'   (Hit RETURN to continue.)'
      CALL STKPRC(C80,'INPUTC',1,1,1,N,A,IUNIT,NULLS,ISTAT)
      RETURN
      END
      SUBROUTINE REHEAD(NDIG,DAT,CODEDS)
C
C  REWINDS FILES 7 & 9 AND RE-HEADS THEM.    (1 DEC. '84)
C
C
      IMPLICIT NONE
C
C     Note: this routine refers to K7 and K9.
      INTEGER NDIG, KB, KTV, K2, K3, K4, K7, K8, K9
C
      COMMON /FILNOS/ KB, KTV, K2, K3, K4, K7, K8, K9
      CHARACTER*30 DAT
      LOGICAL CODEDS
C
      REWIND K9
C     WRITE(K9,'(1H1)')
      IF(.NOT.CODEDS) RETURN
      REWIND K7
      WRITE(K7,3)DAT,7-NDIG,NDIG
  3   FORMAT('STAR IDENTIFICATION TABLE FOR ',A/'STARCD,STAR'/'(',I1,'X,
     1 A',I1,', 2X, A20)'/)
C  THIS GENERATES FILE-HEAD FORMAT TO MATCH DATA WRITTEN AT 370 IN PLAN.
      RETURN
      END
      SUBROUTINE SXB(NUNIT,MSG,NL)
C
C  WRITES NL (UP TO 9) LINES OF MSG, ON UNIT NUNIT.      AUG.16,1985
C
C
      IMPLICIT NONE
C
      INTEGER NUNIT, NL, I, J
C
      CHARACTER*40 MSG(NL),BLANK*1
      CHARACTER*79 PAGE(21)
      COMMON /SCREEN/ PAGE
C
      DATA BLANK/' '/
C
    1 FORMAT(15X,9('X'),28X,A15/11X,17('X'),24X,15('-')/9X,21('X'),8X/
     X9X,'XXXX',4X,5('X'),4X,4('X'),9X,A/9X,'XXX',6X,'XXX',6X,'XXX',8X/
     X10X,'XXX',4X,5('X'),4X,'XXX',10X,A/12X,7('X'),1X,7('X')/14X,'XXXX'
     X,3X,4('X'),14X,A/14X,11('X'),13X/15X,'X I I I X',15X,A/'   XXX',
     X9X,'XI I I IX',9X,'XXX  '/'   XXXX',9X,7('X'),9X,'XXXX   ',A/
     X2X,8('X'),19X,8('X')/1X,13('X'),11X,13('X'),1X,A/' XXX',6X,8('X'),
     X3X,8('X'),6X,'XXX'/14X,11('X'),14X,A/13X,13('X'),12X/'  XXX',4X,
     X8('X'),5X,8('X'),4X,'XXX  ',A/3X,10('X'),13X,10('X'),2X/4X,5('X'),
     X21X,5('X'),4X,A/4X,'XXXX',23X,'XXXX')
      IF (NUNIT.EQ.6)THEN
        WRITE(PAGE,1) 'D A N G E R  !!',(MSG(I),I=1,NL),(BLANK,J=1,9-NL)
        DO 5 I=1,21
    5   CALL TVN(PAGE(I))
      ELSE
        WRITE(NUNIT,1)'D A N G E R  !!',(MSG(I),I=1,NL),(BLANK,J=1,9-NL)
      END IF
      RETURN
      END
      SUBROUTINE MAGSET(BANDS)
C
C  ALTERS FAINTS.
C
C
      IMPLICIT NONE
C
      REAL COLORM, COLRIN, XINV, YINV, PHOMAG, FAINTS, BRITES, SZMAX, 
     1         SZMIN, EXTIN, SIGTOT, TINT1, TSUGG, XMAGS, DIMMAG
      INTEGER NBANDS, LENB, LENC, 
     1         KX, KY, NEEDH, NASSMP, NPASS, N, LINE, NB, I, NEW
C
      INCLUDE 'MID_REL_INCL:mbands.inc'
C     PARAMETER (MBANDS=9)
      COMMON /CMAGS1/ COLORM(MBANDS,MBANDS),COLRIN(MBANDS,MBANDS),
     1 XINV,YINV,NBANDS,LENB,LENC,KX,KY
      COMMON /CMAGS2/PHOMAG(MBANDS),FAINTS(MBANDS),BRITES(MBANDS),SZMAX,
     1 SZMIN,EXTIN(MBANDS),SIGTOT,TINT1,TSUGG
C
      COMMON /HELPS/ NEEDH,NASSMP
      CHARACTER ASSMPS(8)*40,ASSUME(8)*40
      COMMON /ASSUME/ ASSMPS,ASSUME
      CHARACTER*79 PAGE(21)
      COMMON /SCREEN/ PAGE
C
      SAVE /CMAGS1/,/CMAGS2/,/HELPS/, NPASS
C
      CHARACTER*8 BANDS(MBANDS),A
C
      DIMENSION XMAGS(MBANDS,5)
      LOGICAL CHANGE,SAME,  HELP
C
      DATA NPASS/0/
C
      SAME=.TRUE.
      DO 4 N=1,NBANDS
      XMAGS(N,1)=PHOMAG(N)-EXTIN(N)*SZMAX+10.*LOG10(SZMAX)
      XMAGS(N,2)=PHOMAG(N)-EXTIN(N)*SZMAX+7.5*LOG10(SZMAX)
      XMAGS(N,3)=PHOMAG(N)-EXTIN(N)*SZMIN+10.*LOG10(SZMIN)
      XMAGS(N,4)=PHOMAG(N)-EXTIN(N)*SZMIN+7.5*LOG10(SZMIN)
      XMAGS(N,5)=PHOMAG(N)-EXTIN(N)*SZMAX+2.5*LOG10(TSUGG/TINT1)
      IF(FAINTS(N).EQ.3.E33) FAINTS(N)=XMAGS(N,4)-1.5
    4 CONTINUE
C
         IF(NEEDH.GT.2+NPASS) THEN
      WRITE(PAGE,7)
    7 FORMAT(/4X,'PEPSYS suggests that extinction stars be limited only 
     Xby'/4X,'scintillation noise.  It offers a suitable faint limit for
     X'/4X,'each band.  You may decline any and propose another limit.'/
     X)
      DO 8 LINE=1,5
    8 CALL TVN(PAGE(LINE))
         END IF
      NPASS=NPASS+1
C
C     Changed to cater to brain-damaged f2c library:
   10 CALL BRAINDEAD(BANDS, XMAGS)
      NEW=4
C   new counts new lines on screen, to flag refresh.
      DO 30 NB=1,NBANDS
      NEW=NEW+3
      PAGE(1)= 'Change '//BANDS(NB)(:LENB)//' limit?'
      CALL ASK(PAGE(1),A)
      IF(A(:1).EQ.'N')GO TO 26
       IF(HELP(A))THEN
      CALL TV('Too complicated to explain on-line.')
      CALL TV('Please see User''s Guide for details.')
      WRITE(PAGE,7)
      DO 23 LINE=1,5
   23 CALL TVN(PAGE(LINE))
      GO TO 10
       END IF
c  get new limit.
      SAME=.FALSE.
      READ(A,'(F6.0)',ERR=24)FAINTS(NB)
      GOTO 25
   24 CALL QF('New limit?',FAINTS(NB))
      NEW=NEW+3
   25  IF(FAINTS(NB).GT.XMAGS(NB,5))THEN
      CALL TV('Photon noise exceeds error budget; limit will be used.')
      FAINTS(NB)=XMAGS(NB,5)
      NEW=NEW+2
       END IF
   26  IF(NEW.GE.24-NB .AND. NB.NE.NBANDS)THEN
C   REFRESH SCREEN.
      CALL BRAINDEAD(BANDS, XMAGS)
      NEW=4
       END IF
   30 CONTINUE
      IF(SAME) GO TO 99
C
      CALL BRAINDEAD(BANDS, XMAGS)
      CALL ASK('OK?',A)
      IF(A(:1).EQ.'N')GO TO 10
      GO TO 99
C
C
      ENTRY BRITEN(BANDS,CHANGE)
C
C  REVISE BRIGHT LIMITS.
C
      CALL ASK('Do you have an attenuator (e.g., neutral filter)?',A)
       IF(A(:1).EQ.'Y')THEN
      CHANGE=.TRUE.
      CALL QF('How many magnitudes of dimming?',DIMMAG)
      CALL TV('New BRIGHT limits:')
      DO 50 NB=1,NBANDS
      BRITES(NB)=BRITES(NB)-DIMMAG
      WRITE(PAGE,46)BRITES(NB),BANDS(NB)
   46 FORMAT(/3X,F5.1,' IN ',A6)
      DO 48 I=1,2
   48 CALL TVN(PAGE(I))
        IF(BRITES(NB).GT.FAINTS(NB))THEN
       CALL TV('Not enough dimming available.')
       CHANGE=.FALSE.
        END IF
   50 CONTINUE
       END IF
C   HERE IF NO DIMMER.
C
   99 RETURN
      END
      SUBROUTINE BRAINDEAD(BANDS, XMAGS)
C
C     Caters to brain-damaged f2c library.
C
      IMPLICIT NONE
C
      INCLUDE 'MID_REL_INCL:mbands.inc'
      REAL COLORM, COLRIN, XINV, YINV, PHOMAG, FAINTS, BRITES, SZMAX, 
     1         SZMIN, EXTIN, SIGTOT, TINT1, TSUGG, XMAGS
      INTEGER NBANDS, LENB, LENC, 
     1         KX, KY, NB, I
      COMMON /CMAGS1/ COLORM(MBANDS,MBANDS),COLRIN(MBANDS,MBANDS),
     1 XINV,YINV,NBANDS,LENB,LENC,KX,KY
      COMMON /CMAGS2/PHOMAG(MBANDS),FAINTS(MBANDS),BRITES(MBANDS),SZMAX,
     1 SZMIN,EXTIN(MBANDS),SIGTOT,TINT1,TSUGG
C
      CHARACTER*79 PAGE(21)
      COMMON /SCREEN/ PAGE
C
      CHARACTER*8 BANDS(MBANDS)
C
      DIMENSION XMAGS(MBANDS,5)
C
C
   10 WRITE(PAGE,11) SZMAX,SZMIN,TSUGG,SIGTOT*.5
   11 FORMAT(/6X,'SCINTILLATION = PHOTON NOISE   Photon Noise   Present'
     1/4X,'at',2('  secZ =',F5.2,1X),'  of',F4.0,'sec.int.   FAINT'/3X,
     22(7X,'between'),5X,'is',F5.3,' mag.at   limit')
      DO 12 I=1,4
   12 CALL TVN(PAGE(I))
C     Changed to cater to brain-damaged f2c library:
      DO 14 NB=1,NBANDS
      WRITE(PAGE,13) BANDS(NB)(:LENB),(XMAGS(NB,I),I=1,5),FAINTS(NB)
   13 FORMAT(1X,A6,2(F5.1,' &',F5.1,2X),F10.1,F12.1)
   14 CALL TVN(PAGE)
      RETURN
      END