C @(#)subs1.for	17.1.1.1 (ES0-DMD) 01/25/02 17:17:18
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  @(#)subs1.for	4.5  (ESO-IPG)  3/26/93  15:40:53
C *************  COMMON FUNCTIONS AND SUBROUTINES  **********************
C
C       Copyright (C) Andrew T. Young, 1990
C       Copyright (C) European Southern Observatory, 1992
C
C
      FUNCTION GETIME(STR,HRS,TMIN,SEC)
C
C  RETURNS TIME IN RADIANS.    AUG.1985
C
C
      IMPLICIT NONE
C
      REAL GETIME, HRS, TMIN, SEC, DEGRAD, DEG10
C
      CHARACTER STR*20, STR2*40
      DATA DEGRAD/0.017453292519943/
C
        IF(STR.NE.' ')THEN
      GETIME=DEG10(STR)*15.*DEGRAD
        ELSE
      IF(SEC.EQ.3.E33)SEC=0.
      IF(TMIN.EQ.3.E33)TMIN=0.
       IF(HRS.GT.24. .OR. TMIN.GT.60. .OR. SEC.GT.60.)THEN
      CALLTV('Time not legal')
      WRITE(STR2,5)HRS,TMIN,SEC
    5 FORMAT(' HRS =',F5.1,'  MIN =',F5.1,'  SEC =',F5.1)
      CALL TV(STR2)
      CALL STETER(900, 'BAD TIME')
       END IF
      GETIME=(HRS+(TMIN+SEC/60.)/60.)*15.*DEGRAD
        END IF
      RETURN
      END
      FUNCTION DEG10(STRING)
C
C       Copyright (C) Andrew T. Young, 1990
C
C  CONVERTS CHARACTER STRING FROM DEG MIN SEC TO DECIMAL DEGREES.
C     NOMINAL STRING FORMAT (3F3.0)            5 JAN.'87
C
C
      IMPLICIT NONE
C
      REAL DEG10, DEG, DMIN, SEC
      INTEGER L, LCOL, LDOT
C
      CHARACTER STRING*(*),LINE*20,LDUM*20
C
      LINE=STRING
C  LEFT-JUSTIFY.
      DO 1 L=1,10
      IF(LINE(L:L).NE.' ') GO TO 2
    1 CONTINUE
      DEG10=0.
      RETURN
C
    2 LDUM=LINE(L:)
C  FIND SEPARATORS.
    3 LCOL=INDEX(LDUM,':')
C
       IF(LCOL.NE.0)THEN
C   REPLACE COLONS.
      LDUM(LCOL:LCOL)=' '
      GO TO 3
       END IF
C
      LDOT=INDEX(LDUM,'.')
      L=INDEX(LDUM,' ')
        IF(LDOT.EQ.0 .OR. L.LT.LDOT)THEN
C   LINE UP.
      LINE=' '
      LINE(6-L:)=LDUM
      IF(LDOT.NE.0) LDOT=LDOT+5-L
C   DEGREES ARE IN COL.1-4.
C
       IF(LDOT.EQ.11 .OR. (LDOT.EQ.0 .AND. LINE(5:5).EQ.' '))THEN
C    DECIMAL SECONDS.
      READ(LINE,'(F4.0,F3.0,BZ,F6.3)',ERR=99) DEG,DMIN,SEC
       ELSE IF(LDOT.EQ.8)THEN
C    MINUTES AND TENTHS.
      READ(LINE,'(F4.0,F5.1)',ERR=99) DEG,DMIN
      SEC=0.
       ELSE
      GO TO 99
       END IF
C
        ELSE
C    DECIMAL DEGREES.
      READ(LDUM,'(F11.8)',ERR=99) DEG10
      RETURN
        END IF
C
      DEG10=ABS(DEG)+((SEC/60.+DMIN)/60.)
      IF(SEC.GT.60. .OR. DMIN.GT.60.) GO TO 98
      IF(INDEX(LDUM,'-').NE.0) DEG10=-DEG10
      RETURN
C
C
   98 CALL TV('More than 60 min.or sec.')
   99 CALL TV('BADLY FORMATTED DATA:')
      CALL TV(LINE)
      DEG10=3.E33
      RETURN
      END
      FUNCTION DEG2MS(DEG)
C
C       Copyright (C) Andrew T. Young, 1990
C
C  CONVERT DECIMAL DEG TO DEG/MIN/SEC STRING.     4 JAN.87
C
C
      IMPLICIT NONE
C
      REAL DEG, FMIN, SEC
      INTEGER LDEG, MIN, LSEC, LT
C
      CHARACTER*13 DEG2MS,B13
C
      LDEG=DEG
C   USE TRUNCATED DEG.
      FMIN=ABS(DEG-(LDEG))*60.
      MIN=FMIN
C   USE TRUNCATED MINUTE.
      SEC=(FMIN-(MIN))*60.
      LSEC=SEC
C   ROUND.
      LT=(SEC-LSEC)*10.+.5
      IF(LT.LT.10) GO TO 10
      LT=0
      LSEC=LSEC+1
      IF(LSEC.LT.60)GO TO 10
      LSEC=0
      MIN=MIN+1
      IF(MIN.LT.60)GO TO 10
      MIN=0
      LDEG=LDEG+SIGN(1.,DEG)
   10 WRITE(B13,'(3I3.2,''.'',I1)')LDEG,MIN,LSEC,LT
C    ASSUME NO NEGATIVE VALUES LARGER THAN 99.
      IF(LDEG.EQ.0 .AND. DEG.LT.0.) B13(:1)='-'
        DEG2MS=B13
      RETURN
      END
      FUNCTION MON2M(MON)
C
C       Copyright (C) Andrew T. Young, 1990
C       Copyright (C) European Southern Observatory, 1992
C
C  CONVERTS 1ST 3 LETTERS OF MONTH TO INTEGER.
C   RETURNS 0 IF NAME NOT RECOGNISED.
C
C
      IMPLICIT NONE
C
      INTEGER MON2M, M
C
      CHARACTER*3 MON, MONTHS(12), LMON(12)
      CHARACTER*20 EMSG
C
      DATA MONTHS/'JAN','FEB','MAR','APR','MAY','JUN','JUL',
     1 'AUG','SEP','OCT','NOV','DEC'/
      DATA LMON/'Jan','Feb','Mar','Apr','May','Jun','Jul',
     1 'Aug','Sep','Oct','Nov','Dec'/
C
      DO 403 M=1,12
      IF(MON.EQ.MONTHS(M))GO TO 405
  403 CONTINUE
c	Try lower-case if not found:
      DO 404 M=1,12
      IF(MON.EQ.LMON(M))GO TO 405
  404 CONTINUE
c	Complain if not found:
      EMSG='Incorrect month:'//MON
      CALL TV(EMSG)
      M=0
  405 MON2M=M
      RETURN
      END
      FUNCTION M2MON(M)
C
C       Copyright (C) Andrew T. Young, 1990
C
C  CONVERT INTEGER TO MON(TH NAME).
C
C
      IMPLICIT NONE
C
      INTEGER M
C
      CHARACTER*3 MONTHS(12), M2MON
C
      DATA MONTHS/'JAN','FEB','MAR','APR','MAY','JUN','JUL',
     1 'AUG','SEP','OCT','NOV','DEC'/
C
      M2MON=MONTHS(M)
      RETURN
      END
      SUBROUTINE DECOLR(COLORS,CNAMES,BANDS,SYSTEM,CANNED)
C
C       Copyright (C) Andrew T. Young, 1990
C       Copyright (C) European Southern Observatory, 1992
C
C  SETS UP COLOR MATRICES, ETC.      31 JAN. 1987
C
C
C	Deduces relation between bands and indices from color names CNAMES
C	and band names BANDS, and stores this matrix in COLORM.  Copies this
C	to COLORS (used as scratch space), and forms inverse in COLRIN.
C
C
      IMPLICIT NONE
C
      REAL COLORS, COLORM, COLRIN, XINV, YINV, DUM, BIG, PMULT
      INTEGER NBANDS, LENB, LENC, KX, KY, MAGS, K, J, N, MINUS, NB, L, 
     1         LWORD, I, IP1, NBGRW, NCOLB, NROW, NXS, KK
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
      SAVE /CMAGS1/
C
      INCLUDE 'MID_REL_INCL:mstars.inc'
C     PARAMETER (MSTARS=1650)
      CHARACTER *8 BANDS(3*MBANDS), CNAMES(2,MBANDS), SYSTEM*6, A*1
      CHARACTER *80 PAGE(MBANDS)
      DIMENSION COLORS(MBANDS,MSTARS)
      LOGICAL CANNED
C
      MAGS=0
C
      DO 4 K=1,NBANDS
      DO 1 J=1,NBANDS
      COLRIN(J,K)=0.
    1 COLORM(J,K)=0.
      COLRIN(K,K)=1.
      N=0
      MINUS=INDEX(CNAMES(1,K),'-')
C
       IF(MINUS.NE.0)THEN
C   COLOR INDEX.
C
      DO 2 NB=1,NBANDS
      L=LWORD(BANDS(NB))
      J=INDEX(CNAMES(1,K),BANDS(NB)(:L))
       IF(J.NE.0)THEN
C
        IF(J.LT.MINUS .AND. L.EQ.MINUS-J)THEN
      COLORM(NB,K)=1.
      N=N+1
        ELSE IF(J.GT.MINUS .AND. BANDS(NB).EQ.CNAMES(1,K)(MINUS+1:))THEN
      COLORM(NB,K)=-1.
      N=N+1
        END IF
C
       END IF
    2 CONTINUE
      IF(N.NE.2) MAGS=5
C
       ELSE
C   MAGNITUDE.
C
      DO 3 NB=1,NBANDS
      IF(CNAMES(1,K).EQ.BANDS(NB) .OR. CNAMES(1,K)(2:).EQ.BANDS(NB))
     1 COLORM(NB,K)=1.
    3 CONTINUE
      MAGS=MAGS+1
C
       END IF
    4 CONTINUE
C
C   SPECIALS for uvby, etc.
       IF(SYSTEM(:4).EQ.'UVBY')THEN
C    MAG.IS Y, NOT V.
         COLORM(2,1)=0.
         COLORM(4,1)=1.
C    M1 IN ROW 3, C1 IN 4.
         COLORM(2,3)=1.
         COLORM(3,3)=-2.
         COLORM(4,3)=1.
         COLORM(1,4)=1.
         COLORM(2,4)=-2.
         COLORM(3,4)=1.
       END IF
C   FIX H-BETAS.
       IF(SYSTEM.EQ.'UVBYHB')THEN
         COLORM(5,5)=-1.
         COLORM(6,5)=1.
         COLORM(5,6)=1.
       ELSE IF(SYSTEM.EQ.'H-BETA') THEN
         COLORM(1,1)=-1.
         COLORM(2,1)=1.
         COLORM(1,2)=1.
C   FIX GENEVA (VM = V).
       ELSE IF(SYSTEM.EQ.'GENEVA') THEN
         COLORM(3,1)=1.
       END IF
      IF(CANNED) MAGS=1
C   Detect problems.
    5 IF(.NOT.CANNED .OR. MAGS.GT.1)THEN
    6   CALL TV('Please check this transformation matrix:')
        WRITE(PAGE,7)(BANDS(I),I=1,NBANDS)
    7   FORMAT(/17X,9A7)
        DO 10 I=1,(NBANDS+17)/9
   10     CALL TVN(PAGE(I))
        DO 20 I=1,NBANDS
        DO 20 N=1,NBANDS,9
          WRITE(PAGE,15)I,CNAMES(1,I),(COLORM(J,I),J=N,MIN(NBANDS,N+8))
   15     FORMAT(/I2,2X,A6,' = ',9F7.1/(12X,9F7.1))
          DO 18 J=1,(NBANDS+17)/9
   18       CALL TVN(PAGE(J))
   20   CONTINUE
        CALL ASK('OK?',A)
        IF(A.EQ.'N')THEN
          CALLQF('Which ROW (number) is wrong?',DUM)
          N=DUM
   25     CALL ASK('Enter correct values for entire row.',PAGE(1))
          READ(PAGE(1),*,ERR=25) (COLORM(I,N),I=1,NBANDS)
          GO TO 6
        END IF
      END IF
C
C  COPY & INVERT MATRIX.
      DO 160 J=1,NBANDS
      DO 160 I=1,NBANDS
  160 COLORS(I,J)=COLORM(I,J)
C   START SYSTEM REDUCTION.
      DO 166 I=1,NBANDS-1
C   FIND COLUMN PIVOT, IN ROW NBGRW.
      IP1=I+1
      BIG=COLORS(I,I)
      NBGRW=I
      DO 161 J=IP1,NBANDS
      IF(ABS(BIG).GE.ABS(COLORS(I,J))) GO TO 161
      BIG=COLORS(I,J)
      NBGRW=J
  161 CONTINUE
      IF(BIG.EQ.0.)THEN
      CALL TV('MATRIX is SINGULAR')
      MAGS=5
      GO TO 5
      END IF
C    SWAP ROW I WITH ROW NBGRW UNLESS I=NBGRW.
      IF(NBGRW.NE.I)THEN
      DO 162 J=I,NBANDS
      DUM=COLORS(J,NBGRW)
      COLORS(J,NBGRW)=COLORS(J,I)
  162 COLORS(J,I)=DUM
      DO 163 J=1,NBANDS
      DUM=COLRIN(J,NBGRW)
      COLRIN(J,NBGRW)=COLRIN(J,I)
  163 COLRIN(J,I)=DUM
      END IF
C   ELIMINATE UNKNOWNS FROM FIRST COLUMN.
      DO 166 K=IP1,NBANDS
      PMULT=-COLORS(I,K)/BIG
      DO 164 J=IP1,NBANDS
  164 COLORS(J,K)=PMULT*COLORS(J,I)+COLORS(J,K)
      DO 165 L=1,NBANDS
  165 COLRIN(L,K)=PMULT*COLRIN(L,I)+COLRIN(L,K)
  166 CONTINUE
      IF(COLORS(NBANDS,NBANDS).EQ.0.)THEN
      CALL TV('MATRIX is SINGULAR')
      MAGS=5
      GO TO 5
      END IF
C   BACK SUBSTITUTION.
      DO 169 NCOLB=1,NBANDS
      DO 169 I=1,NBANDS
      NROW=NBANDS+1-I
      DUM=0.0
C    NUMBER OF PREVIOUSLY COMPUTED UNKNOWNS = NXS
      NXS=NBANDS-NROW
      IF(NXS.NE.0)THEN
      DO 168 K=1,NXS
      KK=NBANDS+1-K
  168 DUM=DUM+COLRIN(NCOLB,KK)*COLORS(KK,NROW)
      END IF
      DUM=COLRIN(NCOLB,NROW)-DUM
      COLRIN(NCOLB,NROW)=DUM/COLORS(NROW,NROW)
  169 CONTINUE
C
       IF(.NOT.CANNED .OR. MAGS.GT.1)THEN
      CALL TV('Inverse matrix:')
      WRITE(PAGE,7)(CNAMES(1,I),I=1,NBANDS)
      DO 170 I=1,(NBANDS+17)/18
  170 CALL TVN(PAGE(I))
      DO 180 I=1,NBANDS
  180 WRITE(PAGE,15)I,BANDS(I),(COLRIN(J,I),J=1,NBANDS)
      DO 200 I=1,(NBANDS+17)/9
  200 CALL TVN(PAGE(I))
       END IF
C
      RETURN
      END
      SUBROUTINE EXCEED(N,LABEL,M)
C
C       Copyright (C) Andrew T. Young, 1990
C       Copyright (C) European Southern Observatory, 1992
C
C                                     16 MAR.1987
C
      IMPLICIT NONE
C
      INTEGER M, N
C
      CHARACTER*6 LABEL
      CHARACTER*46 LINE(5)
C
      WRITE(LINE,2)N,LABEL,M
    2 FORMAT(I5,' EXCEEDS PARAMETER (',A6,'=',I3,').'/
     1 /' INCREASE PARAMETER AND RECOMPILE.'//' (FATAL ERROR)')
      CALL TV(LINE(1))
      CALL TVN(LINE(2))
      CALL TVN(LINE(3))
      CALL TVN(LINE(4))
      CALL TVN(LINE(5))
      RETURN
      END
      SUBROUTINE MDY(CARD,MONTH,DAY,YEAR)
C
C       Copyright (C) Andrew T. Young, 1990
C
C  EXTRACTS 3-CHAR.MONTH, FLOATING DAY & YEAR FROM STRING CARD.   3 JAN.87
C
C
      IMPLICIT NONE
C
      REAL DAY, YEAR
      INTEGER I, NEXT, LAST, I1, J
C
      CHARACTER CARD*80, MONTH*3, FIELD*5, CHAR
C
    1 FORMAT(A4)
C    SET ILLEGAL VALUES TO FLAG ERROR RETURNS.
      MONTH='XXX'
      DAY=99.
      YEAR=0.
      DO 2 I=1,80
      IF(CARD(I:I).NE.' ') GO TO 5
    2 CONTINUE
      RETURN
C
    4 FORMAT(BN,F4.0)
C
C  FIRST NON-BLANK...
    5 ASSIGN 25 TO NEXT
      ASSIGN 21 TO LAST
      IF(CARD(I:I).GT.'9' .OR. CARD(I:I).LT.'0') GO TO 14
C   FIRST FIELD NUMERIC, SO MONTH SECOND.
      I1=I
      DO 6 I=I,80
      CHAR=CARD(I:I)
      IF(CHAR.GT.'9' .OR. CHAR.LT.'0') GO TO 10
    6 CONTINUE
      RETURN
C
C   FIRST FIELD ENDS AT (I-1), I NON-NUM.
   10 WRITE(FIELD,1) CARD(I1:I-1)
      IF(I-I1-3) 11,24,20
C    1ST FIELD IS DAY.
   11 READ(FIELD,4)DAY
      ASSIGN 18 TO LAST
C     MONTH STARTS W.LETTER.
   12 DO 13 I=I,80
      CHAR=CARD(I:I)
      IF(CHAR.GE.'A' .AND. CHAR.LE.'Z') GO TO 14
   13 CONTINUE
      RETURN
C
C      GET MONTH.
   14 MONTH=CARD(I:I+2)
      I=I+3
C     FIND LAST NUMERIC FIELD.
   15 DO 16 I=I,80
      CHAR=CARD(I:I)
      IF(CHAR.GE.'0' .AND. CHAR.LE.'9') GO TO LAST,(18,21)
   16 CONTINUE
      RETURN
C    YEAR LAST.
   18 J=I+3
      IF(CARD(I+2:J).EQ.'  ')J=I+1
      WRITE(FIELD,1) CARD(I:J)
      READ(FIELD,4,ERR=19)YEAR
   19 RETURN
C
C    YEAR FIRST.
   20 READ(FIELD,4,ERR=24)YEAR
      ASSIGN 24 TO NEXT
      GO TO 12
C     (TO DO MONTH.)
C
C    DAY LAST. ENDS AT NON-NUM.I1.
   21 DO 22 I1=I+1,80
      CHAR=CARD(I1:I1)
      IF(CHAR.GT.'9' .OR. CHAR.LT.'0') GO TO 23
   22 CONTINUE
      RETURN
C
   23 WRITE(FIELD,1) CARD(I:I1-1)
      READ(FIELD,4,ERR=24) DAY
c	fudged to fool stupid MIDAS pre-processor:
      IF(.TRUE.)GO TO NEXT,(24,25)
   24 RETURN
C
C     SKIP 2ND PART OF DOUBLE DATE.
   25 I=I1+1
      ASSIGN 18 TO LAST
      IF(CARD(I1:I1).NE.'/' .AND. CARD(I1:I1).NE.'-') GO TO 15
C     DOUBLE DATE.  SKIP TO SEPARATOR.
      I=INDEX(CARD(I1:I1+3),',')
      IF(I.EQ.0) I=INDEX(CARD(I1:I1+3),' ')
      IF(I.EQ.0) GO TO 24
      I=I+I1
      GO TO 15
      END
      SUBROUTINE GETJD(DJ)
C
C       Copyright (C) Andrew T. Young, 1990
C
C  GETS DP JULIAN DAY FROM DATSTR, in common block /NAMES/.
C  Note: DJ is double precision.
C
C
      IMPLICIT NONE
C
      REAL RAHRS, RAMIN, RASEC, DEDEG, DEMIN, DESEC, EPOCH, SIGNAL,TINT, 
     1     CVARS, FMM, DD, YY, YEAR, DAY, UTHRS, UTMIN, UTSEC, CLKERR, 
     2     STHRS, STMIN, STSEC, ZTHRS, ZTMIN, ZTSEC, VSPARE, RAS, DECS, 
     3     EPOCHS, COLORS, DDAY, Y
      INTEGER NAM1, NAM2, NGRPS, MURAT, MURAA, MUDEC
      INTEGER M, MON2M, NSTAR, N, K
C
      DOUBLE PRECISION DJ
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
      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
      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
      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 MON*3
C
      INCLUDE 'MID_REL_INCL:mstars.inc'
C     PARAMETER (MSTARS=1650)
C       commons for star catalog:
      CHARACTER *32 STARS
      COMMON /SCATA/ STARS(MSTARS)
      COMMON /SCAT/ RAS(MSTARS), DECS(MSTARS), EPOCHS(MSTARS), COLORS
      DIMENSION COLORS(MBANDS,MSTARS)
C          MONTH, DAY, YEAR, MM, DD, YY   ARE EXTERNAL NAMES.
C
C    MONTH IS NAME OF MONTH,  MON IS 1ST 3 LETTERS,  MM & M ARE NUMBER.
C    YEAR IS FULL YEAR,  YY IS LAST 2 DIGITS,  Y IS INTERNAL.
C
       IF(DATSTR.NE.' ' .OR. MONTH.NE.' ')THEN
        IF(DATSTR.NE.' ')THEN
      CALL MDY(DATSTR,MON,DDAY,Y)
        ELSE
      MON=MONTH
      DDAY=DAY
      Y=YEAR
        END IF
C   CONVERT MON TO INTEGER:
      M=MON2M(MON)
      IF(M.EQ.0) CALL STETER(901, 'BAD MONTH IN DATA')
       ELSE IF(FMM.NE.3.E33 .AND. DD.NE.3.E33 .AND. YY.NE.3.E33)THEN
      DDAY=DD
      M=FMM
      Y=YY+1900.
       ELSE
      CALL TV('NO DATE. FATAL ERROR.')
      CALL STETER(902, 'NO DATE')
       END IF
C    CHECK YEAR.
      IF(Y.LT.100.)Y=Y+1900.
C  J.D.: SEE SKY & TEL.61,312 (1981).
      IF(M.GT.2)GO TO 416
      M=M+12
      Y=Y-1
  416 DJ=AINT(365.25*Y) + AINT(30.6001*(M+1)) + DDAY + 1720981.5D0
C
      RETURN
C
C
      ENTRY GETSN(NSTAR)
C
C  GETS STAR NAME FROM HEADED FILE VIA /NAMES/.   10 MAR.'85
C
      IF(STAR.NE.' ')THEN
       STARS(NSTAR)=STAR
C   HD.
      ELSE IF (HD.NE.' ') THEN
       CALL CATHED(HD,'HD ')
       STARS(NSTAR)=HD
C   BD OR OTHER DM.
      ELSE IF (DM.NE.' ') THEN
       STARS(NSTAR)=DM
C   HR.
      ELSE IF (BSHR.NE.' ') THEN
       CALL CATHED(BSHR,'HR ')
       STARS(NSTAR)=BSHR
C   BAYER/FLAMSTEED.
      ELSE IF (BAYER.NE.' ') THEN
       N=INDEX(BAYER,'  ')
       STARS(NSTAR)=BAYER(:N)//CONSTL
C    FLAMSTEED.
       IF(FLAMST.NE.' ')THEN
        N=INDEX(FLAMST,'   ')
        FLAMST(N+1:)=STARS(NSTAR)
        STARS(NSTAR)=FLAMST
       END IF
C   FLAMSTEED ALONE.
      ELSE
       IF(FLAMST.NE.' ') THEN
        N=INDEX(FLAMST,'   ')
        STARS(NSTAR)=FLAMST(:N)//CONSTL
       ELSE
C   NO NAME AT ALL.
        STARS(NSTAR)='ANON.'
      WRITE(STARS(NSTAR)(6:),'(I4)')NSTAR
       END IF
      END IF
C  ADD SECOND NAME IF SPACE.
      N=INDEX(STARS(NSTAR),'        ')
       IF(N.NE.0)THEN
      IF(BAYER.NE.' ')THEN
       K=INDEX(BAYER,'   ')
       STARS(NSTAR)(N+2:)=BAYER(:MIN(K,16-N))//CONSTL
      ELSE IF(FLAMST.NE.' ')THEN
       K=INDEX(FLAMST,'    ')
       STARS(NSTAR)(N+2:)=FLAMST(:MIN(K,16-N))//CONSTL
      ELSE IF(HD.NE.' ' .AND. BSHR.NE.' ')THEN
       CALL CATHED(BSHR,'HR ')
       STARS(NSTAR)(N+2:)=BSHR
      ELSE IF(HD.NE.' ' .AND. DM.NE.' ')THEN
       STARS(NSTAR)(N+2:)=DM
      END IF
       END IF
C
      RETURN
C
      END
      SUBROUTINE JD2DAT(DJ,DATSTR)
C
C       Copyright (C) Andrew T. Young, 1990
C
C  CONVERTS JD (IN DJ) TO DATE-STRING IN STD.FORMAT.   15 FEB.'85
C  Note: argument DJ is real, *NOT* double-precision!
C
C
      IMPLICIT NONE
C
      REAL DJ, Z, A, B, C, FK, E, D, Y
      INTEGER K,M
C
      CHARACTER DATSTR*(*),M2MON*3,A11*11
C
      EXTERNAL M2MON
C
C  SEE SKY & TEL.61, 312 (1981).
C
C     ASSUME 0 H U.T.; ROUND TO INTEGER DAY.
      Z=AINT(DJ+0.6)
      A=AINT((Z-1867216.25D0)/36524.25D0)
      B=Z+A-AINT(A/4.)+1525.
      C=AINT((B-122.1)/365.25)
      K=365.25*C
      FK=K
      E=AINT((B-FK)/30.6001)
      D=B-FK-AINT(30.6001*E)
      IF(E.LT.13.5)THEN
        M=E-1.
      ELSE
        M=E-13.
      END IF
      IF(M.GE.3)THEN
        Y=C-4716.
      ELSE
        Y=C-4715.
      END IF
C  FORMAT STRING.
      WRITE(A11,7)M2MON(M),INT(D),INT(Y)
    7 FORMAT(A3,I3,I5)
      DATSTR=A11
      RETURN
      END
      SUBROUTINE EPHEM(I1,DJMOD,COLORS,RA,DEC)
C
C       Copyright (C) Andrew T. Young, 1990
C
C  INTERPOLATES EPHEMERIS OBJECTS TO DJMOD.      15 AUG.'85
C
C
      IMPLICIT NONE
C
      REAL DJMOD, COLORS, RA, DEC, RECT, DIF, DEN, F
      INTEGER I1, I2, I, MID, J
C
C  RECT.COORDS.IN COLORS(MBM1...MBM3,I).
C
      INCLUDE 'MID_REL_INCL:mbands.inc'
C     PARAMETER (MBANDS=9)
      INTEGER MBM1,MBM2,MBM3,MBM4
      PARAMETER(MBM1=MBANDS-1,MBM2=MBANDS-2,MBM3=MBANDS-3,MBM4=MBANDS-4)
      INCLUDE 'MID_REL_INCL:mstars.inc'
C     PARAMETER (MSTARS=1650)
      DIMENSION COLORS(MBANDS,MSTARS), RECT(3)
      CHARACTER A, DATSTR*11, EMSG*38
C
C   FIND END OF TABLE.
      I2=COLORS(MBM4,I1)
      DIF=3.E33
      DO 10 I=I1,I2
       IF(ABS(COLORS(MBANDS,I)-DJMOD).LT.DIF)THEN
      DIF=ABS(COLORS(MBANDS,I)-DJMOD)
      MID=I
       ELSE
      GO TO 20
       END IF
   10 CONTINUE
      IF(DJMOD.GT.COLORS(MBANDS,I2))CALL TV('Extrapolation required.')
C    ASSUME TIMES INCREASE.
   20 IF(MID.GE.I2) MID=I2-1
      DEN=COLORS(MBANDS,MID+1)-COLORS(MBANDS,MID)
       IF(DEN.EQ.0.)THEN
      CALL TV('Duplicated dates in table.  Interpolation impossible.')
      CALL ASK('Do you want to continue?',A)
      IF(A.EQ.'N')CALL STETER(903, 'BAD TABLE')
      RECT(1)=COLORS(MBM1,MID)
      RECT(2)=COLORS(MBM2,MID)
      RECT(3)=COLORS(MBM3,MID)
      GO TO 90
       END IF
C    START AT I1+1 FOR 3-POINT FORM.
      IF(I2.GT.I1+1 .AND. MID.EQ.I1)MID=I1+1
C
C    GET WEIGHTS.
      F=(DJMOD-COLORS(MBANDS,MID))/DEN
      IF(F.LT.-2.) GO TO 99
       IF(F.GT.2.)THEN
      CALLTV('*** FATAL ERROR')
      CALL JD2DAT(DJMOD+2400001.,DATSTR)
      EMSG='Please extend tables to '//DATSTR
      CALL TV(EMSG)
      GO TO 999
       END IF
C
C   DETERMINE ORDER.
C
       IF(I2.EQ.I1+1)THEN
C
C   LINEAR INTERPOLATION.
      IF(MID.EQ.I1 .AND. F.LT.0.) CALL TV('Extrapolate backward.')
      DO 25 J=1,3
   25 RECT(J)=(1.-F)*COLORS(MBANDS-J,MID) + F*COLORS(MBANDS-J,MID+1)
C
       ELSE
C
C   QUADRATIC (3-POINT).
C
      IF(MID.EQ.I1+1 .AND. F.LT.-1.)CALL TV('Extrapolate backward.')
      DO 30 J=1,3
   30 RECT(J)=((F-1.)*COLORS(MBANDS-J,MID-1) + (F+1.)*COLORS(MBANDS-J,
     1      MID+1))*F/2. -(F+1.)*(F-1.)*COLORS(MBANDS-J,MID)
       END IF
C
   90 RA=ATAN2(RECT(2),RECT(1))
      DEC=ATAN2(RECT(3),SQRT(RECT(1)*RECT(1)+RECT(2)*RECT(2)))
      RETURN
C
   99 CALL JD2DAT(DJMOD+2399999.,DATSTR)
      EMSG='Please begin tables at '//DATSTR
      CALL TV(EMSG)
      CALLTV('*** FIRST DATE PRECEDES EPHEMERIS -- FATAL ERROR')
  999 CALL STETER(905, 'INADEQUATE EPHEMERIS')
      END