LOCAL INCLUDE 'CLCOR.INC'
C                                                         Include CLCOR
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:PCLTAB.INC'
C                                       Inputs and general info
      INTEGER NDAT
      PARAMETER (NDAT= 100000)
      INTEGER   NLINES, IAN(NDAT), REFANT
      DOUBLE PRECISION TMES(NDAT), SPACEX(NDAT), SPACEY(NDAT),
     *   SPACEZ(NDAT)
C                                       for 'EOPS'
      INTEGER MAXGRO, MAXROW
      PARAMETER (MAXGRO = 200)
      PARAMETER (MAXROW = MAXGRO*10)
      INTEGER   BCOUNT, ECOUNT, NCOUNT, NCTROW, ICASE,
     *   NACUMU(MAXGRO), NATGRO(MAXGRO), NGROUP
C                                       for 'IONO'
      INTEGER ISFAC
      REAL RATIO
C
      DOUBLE PRECISION UT1TAI(100), XYWOB(2,100), JD, JDDIFF
      DOUBLE PRECISION UT1C(MAXROW), WOBX(MAXROW), WOBY(MAXROW),
     *   LEAPS(MAXROW), TBEG(MAXGRO), TEND(MAXGRO), INDAY(MAXROW)
      REAL VERDEL(NDAT), CLKDEL(NDAT), DVERDE(NDAT), DCLKDE(NDAT),
     *   RADR(NDAT), DECDR(NDAT)
C
      INTEGER   SEQIN, SUBA, DISKIN, CNOIN, NUMHIS, CLVER, CLUSE,
     *   NSOUWD, SOUWAN(30), NANTSL, ANTENS(50), BIF, EIF, ISTOK,
     *   FREQID, NTERM
      INTEGER    NPLANE
      CHARACTER  PLANET(10)*12
      DOUBLE PRECISION PLMASS(10)
      LOGICAL   DOSWNT, DOAWNT, DESEL
      REAL      XSIN, XDISIN, XFQID, XBAND, XFREQ, XBIF, XEIF, XTIME(8),
     *   XANT(50), XSUBA, XGVER, XGUSE, BPARM(20), XBAD(10), SELBAN,
     *   AXOFF
      CHARACTER  HISCRD(30)*64, NAMEIN*12, CLAIN*6, XSOUR(30)*16,
     *   XSTOK*4, OPCODE*4, INFILE*48
      HOLLERITH XNAMEI(3), XCLAIN(2), XXSOUR(4,30), XXSTOK, XOPCOD,
     *   XINFIL(12)
      DOUBLE PRECISION FRQOFF(MAXIF), SELFRQ, JD0
C                                       Buffers and file info
      INTEGER   BUFFER(1024)
C                                       Important constants
      INCLUDE 'INCS:PSTD.INC'
C                                       Internal storage
      INTEGER   CLRECI(13+32*MAXIF), CLKOLS(MAXCLC), CLNUMV(MAXCLC),
     *   NUMANT, NUMPOL, NUMIF, ICODE, FIXCNT, TIMCL,  INTCL, SOUCL,
     *   ANTCL, SUBCL, FRQCL, IFRCL, GDLCL, DOPCL, ATMCL, DATMCL,
     *   MBD1CL, CLK1CL, DCK1CL, DIS1CL, DDS1CL, RE1CL, IM1CL, DE1CL,
     *   RA1CL, WE1CL, RF1CL, MBD2CL, CLK2CL, DCK2CL, DIS2CL, DDS2CL,
     *   RE2CL, IM2CL, DE2CL, RA2CL, WE2CL, RF2CL
      REAL      GMMOD, CLRECR(13+32*MAXIF), PARM(40), PANGLE(MAXANT)
      DOUBLE PRECISION COSDEC, SINDEC, CLRECD(13+32*MAXIF)
C                                       Inputs and general info
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XXSOUR, XXSTOK,
     *   XBAND, XFREQ, XFQID, XBIF, XEIF, XTIME, XANT, XSUBA, XGVER,
     *   XGUSE, XOPCOD, BPARM, XBAD, XINFIL, SELBAN, SEQIN,
     *   DISKIN, CNOIN, SUBA, CLVER, CLUSE
      COMMON /CINFO/ FRQOFF, SELFRQ, JD0, DOSWNT, DOAWNT, DESEL, NSOUWD,
     *   SOUWAN, NANTSL, ANTENS, BIF, EIF, ISTOK, FREQID, NUMHIS
      COMMON /GETA/ NLINES, IAN, VERDEL, CLKDEL, DVERDE, DCLKDE,
     *   RADR, DECDR, REFANT
      COMMON /GETAD/ TMES, SPACEX, SPACEY, SPACEZ, UT1TAI, XYWOB, JD,
     *   JDDIFF
      COMMON /CHRCOM/ HISCRD, NAMEIN, CLAIN, XSOUR, XSTOK, OPCODE,
     *   INFILE
C                                       Buffers and file info
      COMMON /BUFRS/ BUFFER
C                                       Common for selected planets
      COMMON /PLANI/ NPLANE
      COMMON /PLANC/ PLANET
      COMMON /PLANM/ PLMASS
C                                       for 'EOPS'
      COMMON /EOPS/ UT1C, WOBX, WOBY, LEAPS, TBEG, TEND, INDAY, BCOUNT,
     *   ECOUNT, NCOUNT, NCTROW, ICASE, NACUMU, NATGRO, NGROUP
C                                       for 'IONO'
      COMMON /IONO/ ISFAC, RATIO
C                                       Internal storage
      COMMON /CLRECC/ COSDEC, SINDEC, CLRECD, GMMOD, PARM, PANGLE,
     *   AXOFF, NTERM, FIXCNT, CLKOLS, CLNUMV, NUMANT, NUMPOL, NUMIF,
     *   ICODE
      EQUIVALENCE (CLRECI, CLRECR, CLRECD)
      EQUIVALENCE (CLKOLS(CLDTIM), TIMCL), (CLKOLS(CLRTMI), INTCL),
     *   (CLKOLS(CLISID),SOUCL), (CLKOLS(CLIANT),ANTCL),
     *   (CLKOLS(CLISUB),SUBCL), (CLKOLS(CLIFQI),FRQCL),
     *   (CLKOLS(CLRIFR),IFRCL), (CLKOLS(CLDDEL),GDLCL),
     *   (CLKOLS(CLRDOP),DOPCL), (CLKOLS(CLRATM),ATMCL),
     *   (CLKOLS(CLRDAT),DATMCL)
      EQUIVALENCE (CLKOLS(CLRMD1),MBD1CL),
     *   (CLKOLS(CLRCK1),CLK1CL), (CLKOLS(CLRDC1),DCK1CL),
     *   (CLKOLS(CLRDS1),DIS1CL), (CLKOLS(CLRDD1),DDS1CL),
     *   (CLKOLS(CLRRE1),RE1CL), (CLKOLS(CLRIM1),IM1CL),
     *   (CLKOLS(CLRRA1),RA1CL), (CLKOLS(CLRDE1),DE1CL),
     *   (CLKOLS(CLRWE1),WE1CL), (CLKOLS(CLIRF1),RF1CL)
      EQUIVALENCE (CLKOLS(CLRMD2),MBD2CL),
     *   (CLKOLS(CLRCK2),CLK2CL), (CLKOLS(CLRDC2),DCK2CL),
     *   (CLKOLS(CLRDS2),DIS2CL), (CLKOLS(CLRDD2),DDS2CL),
     *   (CLKOLS(CLRRE2),RE2CL), (CLKOLS(CLRIM2),IM2CL),
     *   (CLKOLS(CLRRA2),RA2CL), (CLKOLS(CLRDE2),DE2CL),
     *   (CLKOLS(CLRWE2),WE2CL), (CLKOLS(CLIRF2),RF2CL)
C                                                          End CLCOR
LOCAL END
      PROGRAM CLCOR
C-----------------------------------------------------------------------
C! Determines applies calibration corrections to the CL table.
C# UV Calibration EXT-appl
C-----------------------------------------------------------------------
C;  Copyright (C) 1995-1999, 2001-2012, 2014-2020
C;  Associated Universities, Inc. Washington DC, USA.
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 Massachusetts Ave, Cambridge,
C;  MA 02139, USA.
C;
C;  Correspondence concerning AIPS should be addressed as follows:
C;         Internet email: aipsmail@nrao.edu.
C;         Postal address: AIPS Project Office
C;                         National Radio Astronomy Observatory
C;                         520 Edgemont Road
C;                         Charlottesville, VA 22903-2475 USA
C-----------------------------------------------------------------------
C   Task CLCOR applies corrections to CL tables.
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      DATA PRGM /'CLCOR '/
C-----------------------------------------------------------------------
C                                       Get input parameters
      CALL CLCLIN (PRGM, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Apply corrections
      CALL CLCUV (IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Copy and update HI file.
      CALL CLCLHI
C                                       Close down files, etc.
 990  CALL DIE (IRET, BUFFER)
 999  STOP
      END
      SUBROUTINE CLCLIN (PRGN, JERR)
C-----------------------------------------------------------------------
C   CLCLIN gets input parameters for CLCOR.
C   Inputs:  PRGN    C*6       Program name
C   Output:  JERR    I         Error code: 0 => ok
C                                1 => Invalid request
C                                5 => catalog troubles
C                                8 => can't start
C   Commons: /INPARM/ all input adverbs in order given by INPUTS
C                     file
C            /MAPHDR/ output file catalog header
C-----------------------------------------------------------------------
      CHARACTER PRGN*6
      INTEGER   JERR
C
      CHARACTER STAT*4, UTYPE*2
      LOGICAL   T, F, ALLANT, MATCH
      INTEGER   NPARM, IERR, I, NEXT, IARG, LIMIT, J, IROUND, LUN,
     *   LUN2, IIVER, NUMCL, TABUFF(512)
      INCLUDE 'CLCOR.INC'
      INTEGER   DUMMY(MAXIF)
      REAL      FINC(MAXIF), BUFF1(2048)
      CHARACTER BNDCOD(MAXIF)*8, OBSDAT*8
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DANT.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DUVH.INC'
      DATA T, F /.TRUE.,.FALSE./
      DATA LUN, LUN2  /29, 28/
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (T)
      CALL VHDRIN
      NUMHIS = 0
      REFANT = 0
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      JERR = 0
C                                       Get input parameters.
      NPARM = 237
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, BUFFER, IERR)
      IF (IERR.EQ.0) GO TO 10
         RQUICK = .TRUE.
         JERR = 8
         IF (IERR.EQ.1) GO TO 999
            WRITE (MSGTXT,1000) IERR
            CALL MSGWRT (8)
C                                       Restart AIPS
 10   IF (RQUICK) CALL RELPOP (JERR, BUFFER, IERR)
      IF (JERR.NE.0) GO TO 999
      JERR = 5
C                                       Crunch input parameters.
      SEQIN = IROUND (XSIN)
      DISKIN = IROUND (XDISIN)
      SUBA = XSUBA + 0.5
      IF (SUBA.LE.0) SUBA = 1
C
      DO 20 I = 1,10
         IBAD(I) = IROUND (XBAD(I))
 20      CONTINUE
C                                       Convert characters
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      CALL H2CHR (4, 1, XXSTOK, XSTOK)
      CALL H2CHR (4, 1, XOPCOD, OPCODE)
      CALL H2CHR (48, 1, XINFIL, INFILE)
      DO 25 I = 1,30
         CALL H2CHR (16, 1, XXSOUR(1,I), XSOUR(I))
 25      CONTINUE
C                                       Find file, read CATBLK
      CNOIN = 1
      STAT = 'SRCH'
      UTYPE = 'UV'
      CALL CATDIR ('SRCH', DISKIN, CNOIN, NAMEIN, CLAIN, SEQIN, UTYPE,
     *   NLUSER, STAT, BUFFER, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1030) IERR, NAMEIN, CLAIN, SEQIN, DISKIN,
     *      NLUSER
         GO TO 990
         END IF
      CALL CATIO ('READ', DISKIN, CNOIN, CATBLK, 'WRIT', BUFFER, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1040) IERR
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = CNOIN
      FRW(NCFILE) = 1
C                                       Get uv header info.
      CALL UVPGET (JERR)
      IF (JERR.NE.0) GO TO 999
      NRPARM = CATBLK(KIPCN)
C                                       Find time of observation
      CALL H2CHR (8, 1, CATH(KHDOB), OBSDAT)
C                                       Find Julian day, JD
      CALL JULDAY (OBSDAT, JD)
      JDDIFF = 0.0D0
C                                       Freq id
      IF (XBAND.GT.0.0) SELBAN = XBAND
      IF (XFREQ.GT.0.0) SELFRQ = XFREQ
      FREQID = IROUND (XFQID)
      CALL FQMATC (DISKIN, CNOIN, CATBLK, LUN, SELBAN, SELFRQ,
     *   MATCH, FREQID, JERR)
      IF (.NOT.MATCH) THEN
         MSGTXT = 'NO MATCH TO SELBAND/SELFREQ ADVERBS - CHECK INPUTS'
         JERR = 1
         GO TO 990
         END IF
      IF (JERR.GT.0) GO TO 999
C                                       determine number of CL tables
      CALL FNDEXT ('CL', CATBLK, NUMCL)
      IF (NUMCL.LE.0) THEN
         MSGTXT = 'NO CL TABLES FOUND, CANNOT CLCOR'
         JERR = 1
         GO TO 990
         END IF
      CLVER = IROUND (XGVER)
      IF ((CLVER.LE.0) .OR. (CLVER.GT.NUMCL)) CLVER = NUMCL
      CLUSE = IROUND (XGUSE)
C                                       copy CLVER table to CLUSE table
      IF (CLUSE.NE.CLVER) THEN
         CLUSE = NUMCL + 1
         CALL TABCOP ('CL', CLVER, CLUSE, LUN, LUN2, DISKIN, DISKIN,
     *      CNOIN, CNOIN, CATBLK, BUFF1, TABUFF, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1050) IERR
            GO TO 990
            END IF
      ELSE IF (CLUSE.EQ.1) THEN
         JERR = 1
         MSGTXT = 'MODIFYING CL TABLE VER. 1 IS NOT ALLOWED'
         CALL MSGWRT (8)
         MSGTXT = 'USE GAINUSE = 0 TO MAKE A NEW ONE'
         GO TO 990
         END IF
      WRITE (MSGTXT,1055) CLVER, CLUSE
      CALL MSGWRT (4)
C                                       IF range
      BIF = IROUND (XBIF)
      EIF = IROUND (XEIF)
      IF (BIF.LE.0) BIF = 1
      IF ((EIF.LE.0) .AND. (JLOCIF.GT.0)) EIF = CATBLK(KINAX+JLOCIF)
      IF (EIF.LE.0) EIF = 1
      IF ((JLOCIF.GT.0) .AND. (BIF.GT.CATBLK(KINAX+JLOCIF)))
     *   BIF = CATBLK(KINAX+JLOCIF)
      IF ((JLOCIF.GT.0) .AND. (EIF.GT.CATBLK(KINAX+JLOCIF)))
     *   EIF = CATBLK(KINAX+JLOCIF)
C                                       Stokes' type.
      ISTOK = 0
      IF (XSTOK.EQ.'R   ') ISTOK = 1
      IF (XSTOK.EQ.'L   ') ISTOK = 2
      IF (XSTOK.EQ.'I   ') ISTOK = -1
C                                       Check Stokes'
      IF (ISTOK.EQ.0) THEN
C                                       If none selected take what you
C                                       have.
         IF ((CATBLK(KINAX+JLOCS).EQ.1) .AND. (ABS (CATD(KDCRV+JLOCS)
     *      +1.0D0).LE.0.5D0)) ISTOK = 1
         IF ((CATBLK(KINAX+JLOCS).EQ.1) .AND. (ABS (CATD(KDCRV+JLOCS)
     *      +2.0D0).LE.0.5D0)) ISTOK = 2
         IF ((CATBLK(KINAX+JLOCS).EQ.1) .AND. (ABS (CATD(KDCRV+JLOCS)
     *      -1.0D0).LE.0.5D0)) ISTOK = -1
      ELSE
C                                       Is selected Stokes' available?
         IF ((CATBLK(KINAX+JLOCS).EQ.1) .AND.
     *      (ABS (CATD(KDCRV+JLOCS)+ISTOK).GT.0.5D0)) THEN
            JERR = 1
            MSGTXT = 'STOKES ' // XSTOK // ' UNAVAILABLE IN DATA'
            GO TO 990
            END IF
         END IF
      IF ((ISTOK.EQ.2) .AND. (NCOR.EQ.1)) ISTOK = 1
C                                       Check sort order of input
      IF (ISORT(1:2).NE.'TB') THEN
         WRITE (MSGTXT,1060) ISORT
         JERR = 1
         GO TO 990
         END IF
      JERR = 0
C                                       Antenna list
      ALLANT = T
      DESEL = F
      DO 100 I = 1,50
         ANTENS(I) = 0
         ALLANT = ALLANT .AND. (ABS (XANT(I)).LE.1.0E-10)
         DESEL = DESEL .OR. (XANT(I).LT.-0.5)
 100     CONTINUE
      NEXT = 1
      IF (ALLANT) GO TO 160
C                                       Not all selected - make list
C                                       ANTENNAS array.
         DO 150 I = 1,50
            IARG = ABS (XANT(I)) + 0.5
            IF (IARG.EQ.0) GO TO 150
C                                       See if already have
               LIMIT = NEXT - 1
               IF (LIMIT.LT.1) GO TO 140
               DO 130 J = 1,LIMIT
                  IF (IARG.EQ.ANTENS(J)) GO TO 150
 130              CONTINUE
C                                       New antenna
 140              ANTENS(NEXT) = IARG
                  NEXT = NEXT + 1
 150           CONTINUE
 160  DOAWNT = .NOT. DESEL
      NANTSL = NEXT - 1
C                                       Get source numbers
      CALL FNDSOU (DISKIN, CNOIN, XSOUR, BUFFER, NSOUWD, DOSWNT,
     *   SOUWAN, JERR)
      IF (JERR.NE.0) GO TO 999
C                                       Get antenna info
      CALL GETANT (DISKIN, CNOIN, SUBA, CATBLK, BUFFER, JERR)
      IF (JERR.NE.0) GO TO 999
      CALL JULDAY (RDATE, JD0)
C                                       Get IF information
      IIVER = 1
      CALL CHNDAT ('READ', BUFFER, DISKIN, CNOIN, IIVER, CATBLK, LUN,
     *   NUMIF, FRQOFF, DUMMY, FINC, BNDCOD, FREQID, JERR)
      IF (JERR.NE.0) GO TO 999
C                                       Get observing bandwidth. Assume
C                                       all IFs have same increment.
      BANDW  = CATBLK(KINAX+JLOCF) * FINC(BIF)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('CLCLIN: ERROR',I3,' OBTAINING INPUT PARAMETERS')
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
     *   I3,' USID=',I5)
 1040 FORMAT ('ERROR',I3,' COPYING CATBLK ')
 1050 FORMAT ('ERROR: COPYING INPUT CL TO OUTPUT:',I4)
 1055 FORMAT ('CL version input',I4,' output',I4)
 1060 FORMAT ('INPUT VIS RECORDS MISORDERED, SORTED = ',A2,
     *   ' SHOULD BE = TB')
       END
      SUBROUTINE CLCUV (IERR)
C-----------------------------------------------------------------------
C   CLCUV is called from CLCOR. CLCUV reads throught the CL table,
C   passing the records selected to the correction routine CLCCOR.
C   Output: IERR  I    Return code, 0=OK, else failed
C-----------------------------------------------------------------------
      INTEGER   IERR
C
      INTEGER   LUN, IRCODE, THSOU, LSTSOU, ANT, I, JERR, IFNO(2),
     *   ICLRNO, NUMREC, LOOP
      LOGICAL   SLCTD
      DOUBLE PRECISION TIMBEG, TIMEND
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      DATA LUN /29/
C-----------------------------------------------------------------------
      FIXCNT = 0
C                                       If OPCODE='POLR' modify AN table
      IF (OPCODE.EQ.'POLR') THEN
         IFNO(1) = BIF
         IFNO(2) = EIF
C                                       Too many IFs, > 20.
         IF ((EIF-BIF+1).GT.20) THEN
            IERR = 10
            I = EIF - BIF + 1
            WRITE (MSGTXT,1000) I
            GO TO 990
            END IF
         CALL ANTCOR (DISKIN, CNOIN, SUBA, CATBLK, IFNO, BPARM, BUFFER,
     *      FREQID, IERR)
         IF (IERR.GT.0) GO TO 999
         IERR = 0
         END IF
C                                       Timerange
      TIMBEG = XTIME(1) + XTIME(2) / 24.0 + XTIME(3) / (24.0*60.0) +
     *   (XTIME(4) / (24.0*60.0*60.0))
      TIMEND = XTIME(5) + XTIME(6) / 24.0 + XTIME(7) / (24.0*60.0) +
     *   (XTIME(8) / (24.0*60.0*60.0))
      IF ((TIMEND.LT.TIMBEG) .OR. (TIMEND.LT.1.0E-5)) TIMEND = 1.0E20
C                                       If OPCODE='ANAX' modify AN table
C                                       and exclude time influence
      IF (OPCODE.EQ.'ANAX') THEN
         CALL AXCOR (DISKIN, CNOIN, SUBA, CATBLK, BUFFER, NANTSL,
     *      ANTENS, BPARM, IERR)
         IF (IERR.NE.0) GO TO 999
         TIMBEG = 0.0
         TIMEND = 1.0E20
         END IF
C                                       Open CL table
      NUMPOL = 1
      IF (CATBLK(KINAX+JLOCS).GT.1) NUMPOL = 2
      NUMIF = 1
      IF (JLOCIF.GT.0) NUMIF = CATBLK(KINAX+JLOCIF)
C                                       Reformat table?
      CALL CLREFM (DISKIN, CNOIN, CLUSE, CATBLK, LUN, IERR)
      IF (IERR.NE.0) GO TO 999
      CALL CALINI ('WRIT', BUFFER, DISKIN, CNOIN, CLUSE, CATBLK, LUN,
     *   ICLRNO, CLKOLS, CLNUMV, NUMANT, NUMPOL, NUMIF, NTERM, GMMOD,
     *   IERR)
      IF (IERR.NE.0) GO TO 999
C                                       Get number of records
      NUMREC = BUFFER(5)
      IF (NUMREC.LE.0) GO TO 999
      IRCODE = 0
C                                       Initial call to CLCCOR
      CALL CLCCOR (1, IERR)
      IF (IERR.NE.0) GO TO 999
C                                       Update table
      DO 500 LOOP = 1,NUMREC
         ICLRNO = LOOP
         CALL TABIO ('READ', IRCODE, ICLRNO, CLRECR, BUFFER, IERR)
         IF (IERR.GT.0) GO TO 900
         IF (IERR.LT.0) GO TO 500
C                                       Check data
C                                       Time:
         IF ((CLRECD(TIMCL).LT.TIMBEG) .OR.
     *       (CLRECD(TIMCL).GT.TIMEND)) GO TO 500
C                                       Subarray
         IF ((CLRECI(SUBCL).NE.SUBA) .AND. (CLRECI(SUBCL).GT.0))
     *      GO TO 500
C                                       Freq id
         IF ((CLRECI(FRQCL).NE.FREQID) .AND. (CLRECI(FRQCL).GT.0) .AND.
     *      (FREQID.GT.0)) GO TO 500
         IF (NSOUWD.LE.0) GO TO 70
C                                       Check source
         THSOU = CLRECI(SOUCL)
         IF (.NOT.SLCTD (THSOU, SOUWAN, NSOUWD, DOSWNT)) GO TO 500
 70      LSTSOU = THSOU
C                                       Check antenna
         ANT = CLRECI(ANTCL)
         IF (.NOT.SLCTD (ANT, ANTENS, NANTSL, DOAWNT)) GO TO 500
C                                       Correct record.
         IF (OPCODE.EQ.'ANAX') THEN
            DO 100 I = 1, NANTSL
               IF (ANTENS(I).EQ.ANT) AXOFF = PARM(I)
  100          CONTINUE
            END IF
         CALL CLCCOR (2, JERR)
         IF (JERR.NE.0) GO TO 500
C                                       Rewrite record
         CALL TABIO ('WRIT', IRCODE, ICLRNO, CLRECR, BUFFER, IERR)
         IF (IERR.GT.0) GO TO 900
 500     CONTINUE
C                                       Final call to CLCCOR
      CALL CLCCOR (3, JERR)
C                                       Close table.
      CALL TABIO ('CLOS', IRCODE, LOOP, CLRECR, BUFFER, IERR)
      IF (IERR.NE.0) GO TO 900
      GO TO 999
C                                       TABIO error
 900  WRITE (MSGTXT,1900) IERR
C                                       Error.
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('TOO MANY IFS SPECIFIED, ',I3,' > 10')
 1900 FORMAT ('TABIO ERROR',I3,' CORRECTING CL TABLE')
      END
      SUBROUTINE CLCCOR (IOP, IERR)
C-----------------------------------------------------------------------
C   CLCCOR applies corrections to the CL record passed thru common
C   /CLRECC/.
C   Input:
C    IOP        I    Operation code, 1=init, 2=process, 3=finish
C   Input from common:
C    CLRECI(*)  I    The CL table record to be corrected.
C    BIF        I    First IF number
C    EIF        I    Highest IF number
C    ISTOK      I    Stokes number, 0=both, 1=first, 2=second.
C    OPCODE     C*4  Operation code.
C    ICODE      I    Operation code number, set on first call.
C    BPARM(20)  R    parameters.
C   Output in common:
C    CLRECI(*)  I    Modified record.
C   Output:
C    IERR       I    Error code, 0=OK, else failed.
C-----------------------------------------------------------------------
      INTEGER   IOP, IERR
C
      DOUBLE PRECISION  DEG2RD
      INTEGER   NOP
C                                       CT table
C      INTEGER CTVER, BCOUNT, ECOUNT, XINC, NCOUNT
      INTEGER CTVER
C
      PARAMETER (NOP=26, DEG2RD=57.29577951D0)
C
      CHARACTER CHTM8*8, OPS(NOP)*4, STRING*8
      CHARACTER OBSDAT*8
      INTEGER   I, IANT, LSTSOU, THSOU, LUN, NTERMS, LIM1, LIM2, J,
     *   IPNT, IINC, ANTNO, DAYS(12), IDATE(3), MONTHN, DAYST, NHUNDR,
     *   IROUND
      LOGICAL   LEAP, ISPLNT
      REAL      XT, YT, XXT, YYT, FACTOR, HA, ZA, ELV, POLYN, PFAC,
     *   CFAC, SFAC, AZ, RHUNDR, TIME, REARTH, HIONO
      DOUBLE PRECISION FREQS, SINLAT, COSLAT, CLTIME, R8T1, R8T2, DX,
     *   DY, TIMED, DRA, DDEC
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DANT.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:PSTD.INC'
      DATA OPS /'PHAS','OPAC','ADEL','GAIN','CLOC','POLR','PANG','PONT',
     *          'IONS','ANTP','PCAL','SBDL','SSLO','RATE','PCFX','MBDL',
     *          'ANAX','ATMO','TROP','ANTC','SUND','EOPS','IONO','POGN',
     *          'DISP','DUMY'/
      DATA DAYS /31,28,31,30,31,30,31,31,30,31,30,31/
      DATA LUN /28/
C-----------------------------------------------------------------------
C                                       Determine operation
      IF (IOP.EQ.2) GO TO 200
      IF (IOP.EQ.3) GO TO 900
C                                       Initialize - find OPCODE
      ICODE = -1
      DO 30 I = 1,NOP
         IF (OPS(I).EQ.OPCODE) ICODE = I
 30      CONTINUE
C                                       If an invalid opcode
      IF (ICODE.LE.0) THEN
         IERR = 1
C                                       Tell User
         WRITE (MSGTXT,1030) OPCODE
         GO TO 990
         END IF
C                                       History - OPCODE
      NUMHIS = NUMHIS + 1
      WRITE (HISCRD(NUMHIS),2040) OPCODE
C                                       Setup
      GO TO (50, 55, 55, 60, 70, 50, 75, 80,
     *   85, 90, 95, 100, 105, 45, 110, 100,
     *   120, 130, 130, 90, 140, 170, 130, 60,
     *   135), ICODE
C                                       'RATE' (14)
C                                       Phase rotation
C                                       Phase at "origin"
 45      PARM(1) = BPARM(1) / DEG2RD
C                                       History
         WRITE( MSGTXT, 1045) BPARM(1), BIF, EIF
         CALL MSGWRT(3)
C                                       Else 'RATE' Phase Rotation
C                                       Phase rate (deg/day -> rad/sec)
         PARM(2) = BPARM(2) / DEG2RD / 86400.0
C                                       Time of "origin"
         PARM(3) = BPARM(3) + BPARM(4)/24.0 + BPARM(5)/(24.0*60.0)
     *           + BPARM(6)/(24.0*60.0*60.0)
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),2100) BPARM(1)
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),2110) BPARM(2)
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),2120) (BPARM(I),I=3,6)
         WRITE (MSGTXT,2100) BPARM(1)
         CALL MSGWRT(3)
         WRITE (MSGTXT,2110) BPARM(2)
         CALL MSGWRT(3)
         WRITE (MSGTXT,2120) (BPARM(I),I=3,6)
         CALL MSGWRT(3)
C                                       Source number
         PARM(12) = -10
         GO TO 999
C                                       OPCODE='PHAS' (1) or 'POLR' (6)
C                                       Phase rotation
 50      LIM1 = 1
         LIM2 = EIF - BIF + 1
         DO 52 I = LIM1,LIM2
            IPNT = (I-1) * 2 + 1
            PARM(IPNT) = COS (BPARM(I) / DEG2RD)
            PARM(IPNT+1) = SIN (BPARM(I) / DEG2RD)
C                                       History
            NUMHIS = NUMHIS + 1
            WRITE (HISCRD(NUMHIS),2050) I, BPARM(I)
C                                       Tell user
            WRITE( MSGTXT, 1050) I, BPARM(I), BIF + I - 1
            CALL MSGWRT(3)
 52         CONTINUE
C                                       Set only the 0th term for 'PHAS'
         IF (ICODE.EQ.1) THEN
            MSGTXT = 'Use OPCODE = "RATE" to Rotate Phase with Time'
            CALL MSGWRT(3)
            END IF
         GO TO 999
C                                       Atmosphere
C                                       Either opacity(2) or pressure(3)
 55      PARM(1) = BPARM(1)
C                                       Partial pressure of water (3)
         PARM(2) = BPARM(2)
C                                       Temperature
         PARM(3) = BPARM(3)
C                                       Tropospheric lapse rate
         IF (ABS (BPARM(4)).GT.1.0E-10) THEN
            PARM(4) = BPARM(4)
         ELSE
            PARM(4) = -4.0
            END IF
C                                       Height of tropospause
         IF (ABS (BPARM(5)).GT.1.0E-10) THEN
            PARM(5) = BPARM(5)
         ELSE
            PARM(5) = 15.0
            END IF
C                                       Scale height of water
         IF (ABS (BPARM(6)).GT.1.0E-10) THEN
            PARM(6) = BPARM(6)
         ELSE
            PARM(6) = 2.2
            END IF
C                                       Source number
         PARM(7) = -10
C                                       History
         NUMHIS = NUMHIS + 1
         IF (ICODE.EQ.2) WRITE (HISCRD(NUMHIS),2055) BPARM(1)
         IF (ICODE.EQ.3) THEN
            WRITE (HISCRD(NUMHIS),2056) PARM(1), PARM(2), PARM(3)
            NUMHIS = NUMHIS + 1
            WRITE (HISCRD(NUMHIS),2057) PARM(4), PARM(5), PARM(6)
            END IF
         GO TO 999
C                                       Poly. gain curve
C                                       OPCODE='GAIN' (4)
C                                       OPCODE='POGN' (24)
 60      NTERMS = 0
         DO 65 I = 1,10
            PARM(I+1) = BPARM(I)
            IF (ABS (BPARM(I)).GT.1.0E-20) NTERMS = I
 65         CONTINUE
         PARM(1) = NTERMS
C                                       Last source number
         PARM(12) = -10
C                                       History
         NUMHIS = NUMHIS + 1
         CHTM8 = 'Voltage'
         IF (ICODE.EQ.24) CHTM8 = 'Power'
         WRITE (HISCRD(NUMHIS),2065) BPARM(1), BPARM(2), CHTM8
         IF (NTERMS.GT.2) THEN
            NUMHIS = NUMHIS + 1
            WRITE (HISCRD(NUMHIS),2066) (BPARM(I),I=3,6)
            END IF
         IF (NTERMS.GT.6) THEN
            NUMHIS = NUMHIS + 1
            WRITE (HISCRD(NUMHIS),2066) (BPARM(I),I=7,10)
            END IF
         GO TO 999
C                                       OPCODE = 'CLOC' (5)
C                                       Clock rate (nsec/day -> sec/sec)
 70      PARM(1) = BPARM(1) * 1.0E-9 / 86400.0
C                                       Clock value at origin
C                                       (nsec -> sec)
         PARM(2) = BPARM(2) * 1.0E-9
C                                       Time of origin
         PARM(3) = BPARM(3) + BPARM(4)/24.0 + BPARM(5)/(24.0*60.0)
     *           + BPARM(6)/(24.0*60.0*60.0)
C                                       Correction mode
         PARM(4) = BPARM(7)
         IF (BPARM(7).EQ.0) PARM(2) = 0.0
         IF (BPARM(7).LT.0.0 .OR. BPARM(7).GT.2) THEN
            WRITE (MSGTXT,1040) BPARM(7)
            IERR = 2
            GO TO 990
            END IF
C                                       Source number
         PARM(12) = -10
C                                       History
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),2070) BPARM(1)
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),2071) BPARM(2)
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),2072) BPARM(3),BPARM(4),BPARM(5),
     *      BPARM(6)
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),2073) BPARM(7)
         GO TO 999
C                                       OPCODE = 'PANG' (7)
C                                       Parallactic angle (PA) corr.
C                                       PARM(1) = +/- 1.0 factor
C                                       PARM(2) = fract. last time of PA
C                                       PARM(3) = last source id.
C                                       Set PARM(1) to remove or add
C                                       P.A. corrections. NOTE:
C                                       phase of R (pol. 1) decreases
C                                       with increasing PA.
 75      PARM(1) = 1.0
         IF (BPARM(1).GT.0.0) PARM(1) = -1.0
C                                       Initialize last time , source
         PARM(2) = -1.0
         PARM(3) = -2.0
C                                       History
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),2075) BPARM(1)
         IF (BPARM(1).GT.0.0) WRITE (HISCRD(NUMHIS),2076) BPARM(1)
         GO TO 999
C                                       OPCODE = 'PONT' (8)
C                                       Corrects antenna gain for
C                                       gross pointing error.
C                                       Temp(1) = time gain measured
C                                       Temp(2) = rate of change of gain
 80      PARM(1) = XTIME(1) + XTIME(2)/24.0 + XTIME(3)/(24.0*60.0)
     *           + XTIME(4)/(24.0*60.0*60.0)
         PARM(2) = BPARM(1)
C                                       History
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),2077) BPARM(1)
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),2078) XTIME(1),XTIME(2),XTIME(3),
     *      XTIME(4)
         GO TO 999
C                                       OPCODE = 'IONS' (9)
C                                       Ionispheric Faraday rot. corr.
C                                       PARM(1) = model type
C                                       PARM(2) = last source number
 85      PARM(2) = -10
         IF (BPARM(1).GT.0.0) THEN
C                                       Chiu model, type 1
C                                       PARM(3)=Zurich sunspot number
C                                       PARM(4)=annual time (mo)
            PARM(1) = 1.0
            PARM(3) = BPARM(3)
C                                       Get day of year number
            CALL H2CHR (8, 1, CATH(KHDOB), CHTM8)
            CALL JULDAY (CHTM8, R8T1)
            IF (CHTM8(3:3).EQ.'/') THEN
               STRING = '01/01' // CHTM8(6:8)
            ELSE
               STRING = CHTM8(:4) // '0101'
               END IF
            CALL JULDAY (STRING, R8T2)
C                                       Annual time in months since
C                                       15 Dec
            PARM(4) = ((R8T1 - R8T2) + 16.0) / 30.0
            IF (PARM(4).GT.12.0) PARM(4) = PARM(4) - 12.0
C                                       History
            NUMHIS = NUMHIS + 1
            WRITE (HISCRD(NUMHIS),2085) BPARM(1)
            GO TO 999
            END IF
C                                       No recognizible model
         IERR = 5
         MSGTXT = 'ERROR: NO RECOGNIZABLE IONISPHERIC MODEL'
         GO TO 990
C                                       OPCODE = 'ANTP' (10) ANTC (20)
C                                       Antenna and source
C                                       position error,
C                                       Position correction:
 90      PARM(1) = BPARM(1)
         PARM(2) = BPARM(2)
         PARM(3) = BPARM(3)
C
         IF ((PARM(1).NE.0) .OR. (PARM(2).NE.0) .OR.
     *      (PARM(3).NE.0)) THEN
C                                       Must select one antenna
C                                       if antenna position
C                                       is corrected
            IF (DESEL .OR. NANTSL.NE.1) THEN
               IERR = 9
               WRITE (MSGTXT,1060)
               GO TO 990
               END IF
C                                       correct AN table
            ANTNO = XANT(1)
            CALL ANTMOD (DISKIN, CNOIN, SUBA, ANTNO, PARM, IERR)
            IF (IERR.NE.0) GO TO 990
C                                       The warning
            WRITE (MSGTXT,1075)
            CALL MSGWRT (8)
            WRITE (MSGTXT,1065)
            CALL MSGWRT (8)
            WRITE (MSGTXT,1066)
            CALL MSGWRT (8)
            WRITE (MSGTXT,1067)
            CALL MSGWRT (8)
            WRITE (MSGTXT,1075)
            CALL MSGWRT (8)
C                                       history
            NUMHIS = NUMHIS + 1
            WRITE (HISCRD(NUMHIS),2088)
            END IF
C                                       correction RA and
C                                       declination in radians
         PARM(6) = BPARM(5)/3600.0D0/DEG2RD
         PARM(7) = BPARM(6)/3600.0D0/DEG2RD
C                                       Must select one source
C                                       if source position
C                                       is corrected
         IF ((PARM(6).NE.0) .OR. (PARM(7).NE.0)) THEN
            IF (.NOT.DOSWNT .OR. NSOUWD.NE.1) THEN
               IERR = 9
               WRITE (MSGTXT,1070)
               GO TO 990
               END IF
C                                       correct SU table
C                                       corrections in degrees,
C                                       given at the picture plane
            DX = BPARM(5) / 3600.0D0
            DY = BPARM(6) / 3600.0D0
            J = ICODE / 10 - 1
            CALL SOUMOD (J, DISKIN, CNOIN, SOUWAN(1), DX, DY, IERR)
            IF (IERR.NE.0) GO TO 990
            PARM(6) = DX / DEG2RD
            PARM(7) = DY / DEG2RD
C                                       The warning
            WRITE (MSGTXT,1075)
            CALL MSGWRT (8)
            WRITE (MSGTXT,1080)
            CALL MSGWRT (8)
            WRITE (MSGTXT,1081)
            CALL MSGWRT (8)
            WRITE (MSGTXT,1082)
            CALL MSGWRT (8)
            WRITE (MSGTXT,1075)
            CALL MSGWRT (8)
C                                       history
            NUMHIS = NUMHIS + 1
            WRITE (HISCRD(NUMHIS),2089)
            END IF
C                                       Last source number
         PARM(5) = -10
C                                       variable correction of the
C                                       source position
         IF (INFILE.EQ.' ') THEN
C                                       drift of RA, DEC in rad/day
C                                       of the given mas/hr
            PARM(9) = BPARM(8) / 3.6D6 *24.0 / DEG2RD
            PARM(10) = BPARM(9) / 3.6D6 *24.0 / DEG2RD
         ELSE
C                                       read RA,DEC drift from INFILE
            CALL GETRAD (INFILE, IERR)
            IF (IERR.NE.0) THEN
               MSGTXT = 'Error reading INFILE'
               GO TO 990
               END IF
            END IF
C                                       History
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),2090) BPARM(1), BPARM(2), BPARM(3)
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),2092) BPARM(5), BPARM(6)
         NUMHIS = NUMHIS + 1
         IF (INFILE.EQ.' ') THEN
            WRITE (HISCRD(NUMHIS),2093) BPARM(8), BPARM(9)
         ELSE
            WRITE (HISCRD(NUMHIS),3000) INFILE
            END IF
         GO TO 999
C                                       OPCODE='PCAL' (11)
C                                       Replace complex gains
 95      LIM1 = 1
         LIM2 = EIF - BIF + 1
         IPNT = 1
         DO 97 I = LIM1,LIM2
            PARM(IPNT) = COS (BPARM(I) / DEG2RD)
            PARM(IPNT+1) = SIN (BPARM(I) / DEG2RD)
            IPNT = IPNT + 2
C                                       History
            NUMHIS = NUMHIS + 1
            WRITE (HISCRD(NUMHIS),2095) I, BPARM(I)
 97         CONTINUE
         GO TO 999
C                                       OPCODE='SBDL'(12) or 'MBDL'(16)
C                                       Correction to residual delays
C                                       or corresponded multiband phase
 100     LIM1 = 1
         LIM2 = EIF - BIF + 1
         IPNT = 1
         DO 102 I = LIM1,LIM2
            PARM(IPNT) = BPARM(IPNT) * 1.0E-9
            IPNT = IPNT + 1
C                                       History
            NUMHIS = NUMHIS + 1
            WRITE (HISCRD(NUMHIS),2099) I, BPARM(I)
 102        CONTINUE
         GO TO 999
C                                       OPCODE='SSLO' (13)
C                                       Correction for fringe stopping
C                                       using the wrong Signed Sum LOs.
C
 105     CONTINUE
         PARM(1) = BPARM(1) * 1.0E6
C                                       Last source number
         PARM(5) = -10
C                                       History
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),2130) BPARM(1)
         GO TO 999
C                                       OPCODE='PCFX' (15)
C                                       Patch up phase cals.
 110     LIM1 = 1
         LIM2 = EIF - BIF + 1
         IPNT = 1
         DO 112 I = LIM1,LIM2
            PARM(IPNT) = BPARM(I) / DEG2RD
            IPNT = IPNT + 1
C                                       History
            NUMHIS = NUMHIS + 1
            WRITE (HISCRD(NUMHIS),2111) I, BPARM(I)
 112        CONTINUE
         GO TO 999
C                                       OPCODE='ANAX'(17) Correction
C                                       for antennas axis offset
 120     CONTINUE
         DO 125 I = 1, NANTSL
            PARM(I) = BPARM(I)
C                                       History
            NUMHIS = NUMHIS + 1
            WRITE (HISCRD(NUMHIS),2200) I, BPARM(I), ANTENS(I)
  125       CONTINUE
C                                       last source number
         PARM(NANTSL+1) = -10
         GO TO 999
C                                       OPCODE='ATMO'(18) or
C                                       OPCODE='TROP'(19) correction
C                                       of the antenna list by the
C                                       vertical atmosphere delay or
C                                       OPCODE='IONO'(23)) correction
C                                       of the antenna list by the
C                                       vertical ionosphere delay
C
C                                       given at the INFILE
 130     CONTINUE
C
         ISFAC = 1
C                                       change the sign of phase-delay
C                                       correction if OPCODE='IONO'
         IF (ICODE.EQ.23) THEN
            ISFAC = -1
            REARTH = 6378.0
            HIONO = 400.0
            RATIO = REARTH / (REARTH + HIONO)
            END IF
C                                       Source number
         PARM(1) = -10
C                                       PARM(2) = 0  =>
C                                       only atmosphere is corrected
C                                       PARM(2) = 1  =>
C                                       sum of atmosphere and clock
C                                       is corrected
         PARM(2) = BPARM(1)
         CALL GETINP (INFILE, IERR)
         IF (IERR.NE.0) THEN
            MSGTXT = 'Error reading INFILE'
            GO TO 990
            END IF
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),3000) INFILE
         GO TO 999
C                                       OPCODE='DISP' (25)
C                                       vertical dispersion
C                                       in INFILE
 135     CONTINUE
C                                       Source number
         PARM(1) = -10
C                                       read infile
         CALL GETINP (INFILE, IERR)
         IF (IERR.NE.0) THEN
            MSGTXT = 'Error reading INFILE'
            GO TO 990
            END IF
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),3000) INFILE
         GO TO 999
C
 140     CONTINUE

C                                       OPCODE='SUND'(21) correction
C                                       to the time delay caused by
C                                       the binding of the light ray
C                                       passing through  the
C                                       gravitational field of the
C                                       Sun.
C                                       initial source number
         PARM(1) = -10
C                                       initial CL time
         PARM(2) = -10
C                                       Get observation time in string
         CALL H2CHR (8, 1, CATH(KHDOB), CHTM8)
C                                       Get date
         CALL DATEST (CHTM8, IDATE)
C                                       Year
         PARM(3) = IDATE(1)
C                                       leaps year?
         LEAP = .FALSE.
         NHUNDR = IDATE(1)/100
         RHUNDR = IDATE(1) - NHUNDR*100
C                                       Julian calendar
         IF (MOD(IDATE(1),4).EQ.0) LEAP = .TRUE.
C                                       Gregorian calendar
         IF (RHUNDR.EQ.0 .AND.MOD(NHUNDR,4).NE.0) LEAP = .FALSE.
C                                       Month
         MONTHN = IDATE(2)
C
         DAYST = 0
         DO 160 I = 1, MONTHN-1
            DAYST = DAYST + DAYS(I)
C                                       leap year?
            IF (LEAP .AND. I.EQ.2) DAYST = DAYST + 1
  160       CONTINUE
C                                       Day number since the beginning
C                                       of the year
C         PARM(4) = DAYST + IDATE(3)
C                                       Month number
         PARM(4) = MONTHN
C                                       Day of month
         PARM(5) = IDATE(3)
C                                       0 => correct actual space craft
C                                       position minus ifinite position
C                                       1 => correct just actual space
C                                       craft position
         PARM(6) = BPARM(1)
C
C                                       Print out the test data?
C                                       0 => yes
C                                       1 => no
         PARM(7) = BPARM(2)
C                                       Print additional test data?
C                                       0 => no:
C                                       1 => yes
         PARM(8) = BPARM(3)
C                                       initial row in CL table
         PARM(10) = -10
C                                       get the spacecraft position
C                                       XSPACE, YSPACE, ZSPACE
C                                       at the coordinate system
C                                       origin at the Earth center
         CALL SPACES (IERR)
C                                       read the planet list from
C                                       the INFILE
         CALL PLLIST (INFILE, IERR)
         IF (IERR.NE.0) THEN
            MSGTXT = 'Error reading INFILE'
            GO TO 990
            END IF
         GO TO 999
C
 170     CONTINUE
C                                       OPCODE='EOPS'(22) correction
C                                       of UT1-UTC, and the Earth
C                                       pole position
         MSGTXT = '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
         CALL MSGWRT (8)
         MSGTXT = '!  OPTYPE=EOPS is used for proper CT tables only !'
         CALL MSGWRT (8)
         MSGTXT = '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
         CALL MSGWRT (8)
C
C                                       Use CT table
C                                       CT table version
         CTVER = 1
C                                       fix NCTROW to 5, because
C                                       John Benson told that
C                                       5 first row used always!
C     reset in CTTAB
         NCTROW = 5
C                                       get arrays UT1C, WOBX, WOBY
C                                       from CT table
         CALL CTTAB (DISKIN, CNOIN, CTVER, IERR)

C                                       UT1C in sec, WOBX,WOBY in arcsec
         IF (IERR.NE.0) THEN
            MSGTXT = 'Bad CT table.'
            GO TO 990
            END IF
C                                       Last source number
         PARM(7) = -10
C                                       Find time of observation
         CALL H2CHR (8, 1, CATH(KHDOB), OBSDAT)
C                                       Find Julian day, JD
         CALL JULDAY(OBSDAT, JD)
C                                       Read the file USNO with EOP
C                                       data
         IF (BPARM(1).LE.0.0) BPARM(1) = 1.0
         BCOUNT = IROUND (BPARM(1))
         IF (BPARM(2).LE.0.0) BPARM(2) = 5.0
         NCOUNT = IROUND (BPARM(2))
C                                       read the USNO file with the
C                                       right eop data
         CALL USNORE (INFILE, IERR)
         IF (IERR.GT.0) GO TO 999
C                                       History
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),3000) INFILE
         NUMHIS = NUMHIS + 1
         WRITE (HISCRD(NUMHIS),3010) CLVER, CLUSE
         GO TO 999
C                                       Process record
 200  FIXCNT = FIXCNT + 1
      IANT = CLRECI(ANTCL)
      GO TO (250, 300, 300, 350, 400, 280, 450, 500,
     *       550, 600, 610, 620, 630, 250, 640, 810,
     *       820, 830, 830, 600, 850, 860, 830, 350,
     *       840), ICODE
C                                       'PHAS' (1) or 'RATE' (14)
 250     IF (ISTOK.NE.2) THEN
            CLTIME = CLRECD(TIMCL)
            IPNT = 1
            IINC = 2
C                                       If correcting Phase vs time
            IF (ICODE.EQ.14) THEN
               PFAC = ((CLTIME-PARM(3))*86400.0*PARM(2)) + PARM(1)
               CFAC = COS (PFAC)
               SFAC = SIN (PFAC)
               END IF
            DO 270 I = BIF,EIF
C                                       Use precomputed phases
               IF (ICODE.EQ.1) THEN
                  CFAC = PARM(IPNT)
                  SFAC = PARM(IPNT+1)
                  END IF
               XT = CLRECR(RE1CL+I-1)
               YT = CLRECR(IM1CL+I-1)
               IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
                  CLRECR(RE1CL+I-1) = XT * CFAC - YT * SFAC
                  CLRECR(IM1CL+I-1) = XT * SFAC + YT * CFAC
                  END IF
               IPNT = IPNT + IINC
 270           CONTINUE
            END IF
         IF (ABS(ISTOK).EQ.1) GO TO 999
C                                       'PHAS' (1) or 'RATE' (14)
C                                          for 2nd polarization
C                                       'POLR' (6)  (LCP only)
 280     IPNT = 1
         IINC = 2
C                                       If correcting Phase vs time
         CLTIME = CLRECD(TIMCL)
         IF (ICODE.EQ.14) THEN
            PFAC = ((CLTIME-PARM(3))*86400.0*PARM(2)) + PARM(1)
            CFAC = COS (PFAC)
            SFAC = SIN (PFAC)
            END IF
C                                       For all IFs
         DO 290 I = BIF,EIF
C                                       Use precomputed phases
            IF ((ICODE.EQ.1) .OR. (ICODE.EQ.6)) THEN
               CFAC = PARM(IPNT)
               SFAC = PARM(IPNT+1)
               END IF
            XT = CLRECR(RE2CL+I-1)
            YT = CLRECR(IM2CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE2CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM2CL+I-1) = XT * SFAC + YT * CFAC
               END IF
            IPNT = IPNT + IINC
 290        CONTINUE
         GO TO 999
C                                       Atmosphere
C                                       Either opacity(2) or delay(3)
 300     CALL ATMOS (IERR)
         GO TO 999
C                                       Polynomial gain curve
C                                       GAIN, POGN
 350     LSTSOU = PARM(12) + 0.5
         THSOU = CLRECI(SOUCL)
         TIMED = CLRECD(TIMCL)
         TIME = TIMED
C                                       get source info
         CALL FNDCOO (0, JD0, THSOU, DISKIN, CNOIN, CATBLK, LUN, TIME,
     *      DRA, DDEC, ISPLNT, IERR)
         IF (IERR.NE.0) GO TO 999
         PARM(12) = THSOU
         FREQS = FREQ + FREQO(BIF)
         SINDEC = SIN (DDEC)
         COSDEC = COS (DDEC)
C                                       Compute zenith angle (deg).
         CALL COOELV (IANT, TIMED, DRA, DDEC, HA, ELV, AZ)
         COSLAT = COS (STNLAT(IANT))
         SINLAT = SIN (STNLAT(IANT))
         ZA = (1.570796327 - ELV)
         ZA = 180.0 * ZA / PI
         NTERMS = PARM(1) + 0.5
C                                       Polynomial expansion.
         FACTOR = POLYN (NTERMS, ZA, PARM(2))
         IF (ICODE.EQ.24) FACTOR = SQRT (MAX (0.0, FACTOR))
         IF (ISTOK.NE.2) THEN
            DO 360 I = BIF,EIF
               XT = CLRECR(RE1CL+I-1)
               YT = CLRECR(IM1CL+I-1)
               IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
                  CLRECR(RE1CL+I-1) = XT * FACTOR
                  CLRECR(IM1CL+I-1) = YT * FACTOR
                  END IF
 360           CONTINUE
            END IF
         IF (ABS(ISTOK).NE.1) THEN
            DO 380 I = BIF,EIF
               XT = CLRECR(RE2CL+I-1)
               YT = CLRECR(IM2CL+I-1)
               IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
                  CLRECR(RE2CL+I-1) = XT * FACTOR
                  CLRECR(IM2CL+I-1) = YT * FACTOR
                  END IF
 380           CONTINUE
            END IF
         GO TO 999
C                                       Clock error
C                                       OPCODE='CLOK' (5)
 400     CALL CLOKER (IERR)
         GO TO 999
C                                       OPCODE='PANG' (7)
C                                       Parallactic angle correction
C                                       Check if source info current
 450     THSOU = CLRECI(SOUCL)
         LSTSOU = PARM(3) + 0.5
C                                       Check time.
         XT = CLRECD(TIMCL)
         I = XT
         YT = CLRECD(TIMCL) - I
C                                       Get new source info.
C                                       0.02 sec. tolerance.
         IF ((LSTSOU.NE.THSOU) .OR. (ABS(YT-PARM(2)).GT.2.315E-7)) THEN
            CALL FNDCOO (0, JD0, THSOU, DISKIN, CNOIN, CATBLK, LUN, XT,
     *         DRA, DDEC, ISPLNT, IERR)
C            CALL GETSOU (THSOU, DISKIN, CNOIN, CATBLK, LUN, IERR)
            IF (IERR.NE.0) GO TO 999
            PARM(3) = THSOU
            CALL PARACO (XT, DRA, DDEC, PANGLE)
            PARM(2) = YT
            END IF
C                                       Apply (remove) correction
         IANT = CLRECI(ANTCL)
         XT = COS (PARM(1) * PANGLE(IANT))
         YT = SIN (PARM(1) * PANGLE(IANT))
C                                       Polarization 1 corrections:
         IF (ISTOK.NE.2) THEN
            DO 455 I = BIF,EIF
               XXT = CLRECR(RE1CL+I-1)
               YYT = CLRECR(IM1CL+I-1)
               IF ((XXT.NE.FBLANK) .AND. (YYT.NE.FBLANK)) THEN
                  CLRECR(RE1CL+I-1) = XXT*XT - YYT*YT
                  CLRECR(IM1CL+I-1) = XXT*YT + YYT*XT
                  END IF
 455           CONTINUE
            END IF
C                                       Polarization 2 corrections:
         IF (ABS(ISTOK).NE.1) THEN
            DO 460 I = BIF,EIF
               XXT = CLRECR(RE2CL+I-1)
               YYT = CLRECR(IM2CL+I-1)
               IF ((XXT.NE.FBLANK) .AND. (YYT.NE.FBLANK)) THEN
C                                       Opposite phase for Pol. 2.
                  CLRECR(RE2CL+I-1) = XXT*XT + YYT*YT
                  CLRECR(IM2CL+I-1) = -XXT*YT + YYT*XT
                  END IF
 460           CONTINUE
            END IF
         GO TO 999
C                                       Pointing correction
C                                       'PONT' (8)
 500     CLTIME = CLRECD(TIMCL)
         IF (CLTIME.LT.PARM(1)) GO TO 999
         FACTOR = (CLTIME - PARM(1)) * 24.0 * PARM(2)
         IF (ISTOK.NE.2) THEN
            DO 510 I = BIF,EIF
               IF ((CLRECR(RE1CL+I-1).NE.FBLANK) .AND.
     *            (CLRECR(IM1CL+I-1).NE.FBLANK)) THEN
                  XT = SQRT (CLRECR(RE1CL+I-1) * CLRECR(RE1CL+I-1) +
     *               CLRECR(IM1CL+I-1) * CLRECR(IM1CL+I-1))
                  XT = XT + FACTOR
                  CLRECR(RE1CL+I-1) = CLRECR(RE1CL+I-1) / SQRT(XT)
                  CLRECR(IM1CL+I-1) = CLRECR(IM1CL+I-1) / SQRT(XT)
                  END IF
 510           CONTINUE
            END IF
         IF (ABS(ISTOK).NE.1) THEN
            DO 520 I = BIF,EIF
               IF ((CLRECR(RE2CL+I-1).NE.FBLANK) .AND.
     *            (CLRECR(IM2CL+I-1).NE.FBLANK)) THEN
                  XT = SQRT (CLRECR(RE2CL+I-1) * CLRECR(RE2CL+I-1) +
     *               CLRECR(IM2CL+I-1) * CLRECR(IM2CL+I-1))
                  XT = XT + FACTOR
                  CLRECR(RE2CL+I-1) = CLRECR(RE2CL+I-1) / SQRT(XT)
                  CLRECR(IM2CL+I-1) = CLRECR(IM2CL+I-1) / SQRT(XT)
                  END IF
 520           CONTINUE
            END IF
         GO TO 999
C                                       Ionispheric Faraday rot (9)
 550     CALL FARADA (IERR)
         GO TO 999
C                                       Antenna and source
C                                       position error (10,20)
 600     CALL ANTPOS (IERR)
         GO TO 999
C                                       OPCODE='PCAL' (11)
C                                       Replace complex gains
 610     CALL REPGAI
         GO TO 999
C                                       OPCODE='SBDL' (12)
C                                       Correction to residual delays.
 620     CALL CORSBD
         GO TO 999
C                                       OPCODE='SSLO' (13)
C                                       Correction for fringe stopping
C                                       using the wrong Signed Sum LOs.
 630     CONTINUE
         CALL CORRFQ (IERR)
         GO TO 999
C                                       OPCODE='PCFX' (15)
C                                       PAtch Phase cals.
 640     CALL PTCHPC
         GO TO 999
C                                       OPCODE='MBDL' (16)
C                                       Correction to multiband phase
 810     CALL CORMBD
         GO TO 999
C                                       OPCODE='ANAX' (17)
C                                       Correction for antenna axis
C                                       offset
 820     CALL ANAXIS (IERR)
         GO TO 999
C                                       OPCODE='ATMO' (18) or
C                                       'TROP' (19) or 'IONO' (23)
C                                       Correction of the antenna list
C                                       by the vertical atmosphere
C                                       delay given at the INFILE
C
 830     CALL ATMOV (IERR)
         GO TO 999
C                                       OPCODE='DISP' (25)
C                                       Vertical dispersion
 840     CALL DISPV (IERR)
         GO TO 999
C                                       OPCODE='SUND' (21)
C                                       correction to the time
C                                       delay caused by the binding of
C                                       the light ray passing at the
C                                       gravitational field of the Sun.
C
 850     CALL SUNDEL (IERR)
         GO TO 999
C                                       OPCODE='EOPS' (22)
C                                       correction of UT1-UTC and  the
C                                       Earth pole position
C
 860     CALL UTPOL (IERR)
         GO TO 999
C                                       Finish - number changed.
 900  NUMHIS= NUMHIS + 1
      WRITE (HISCRD(NUMHIS),2900) FIXCNT
      WRITE (MSGTXT,2901) FIXCNT
      CALL MSGWRT (6)
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1030 FORMAT ('ERROR: UNKNOWN OPCODE: ',A4)
 1040 FORMAT ('ERROR: UNKNOWN CORRECTION MODE: ',F3.0)
 1045 FORMAT ('CLPARM( 1)=',F8.2,' / Phase(deg) to rotation for',
     *   ' IF(s)',I3,' to',I3)
 1050 FORMAT ('CLPARM(',I2,')=',F8.2,' / Phase(deg) to rotation for',
     *   ' IF ',I3)
 1060 FORMAT ('You have to select the one antenna corrected')
 1065 FORMAT ('!!! AN table is corrected for the selected antenna !!!')
 1066 FORMAT ('!!! So you should apply the corrected CL table     !!!')
 1067 FORMAT ('!!! to match the data. See HELP.                   !!!')
 1070 FORMAT ('You have to select the one source corrected')
 1075 FORMAT ('!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!')
 1080 FORMAT ('!!! SU table is corrected for the selected source  !!!')
 1081 FORMAT ('!!! so you should apply the corrected CL table     !!!')
 1082 FORMAT ('!!! to match the data. See HELP.                   !!!')
 2040 FORMAT ('OPCODE = ''',A4,''' / Operation code')
 2050 FORMAT ('CLPARM(',I2,')=',F8.2,' / Phase(deg) to rotate gains')
 2055 FORMAT ('CLPARM(1)=',F8.2,' / Zenith opacity')
 2056 FORMAT ('CLPARM=',F8.2,',',F8.2,',',F8.2,
     *   ', / Atm. pres., PP H2O, Temp')
 2057 FORMAT ('      ',F8.2,',',F8.2,',',F8.2,' / Lapse, ht. ',
     *   ' tp, scl. ht. H20')
 2065 FORMAT ('CLPARM =',1PE12.5,',',E12.5,' / Gain curve ',A)
 2066 FORMAT ('      ,',1PE12.5,3(',',E12.5))
 2070 FORMAT ('CLPARM(1)=',F8.3,' / Clock drift (nanosec/day)')
 2071 FORMAT ('CLPARM(2)=',F12.3,' / Clock at "zero" time (nsec)')
 2072 FORMAT (F3.0,1X,F3.0,F3.0,F4.1,' / "Zero" time')
 2073 FORMAT ('CLPARM(7)=',F4.0,' / Delay correction mode')
 2075 FORMAT ('CLPARM(1)=',F4.0,' / Parallactic angle correction',
     *   ' removed')
 2076 FORMAT ('CLPARM(1)=',F4.0,' / Parallactic angle correction',
     *   ' APPLIED')
 2077 FORMAT ('CLPARM(2)=',F10.4,' / Rate of change of gain (/hour)')
 2078 FORMAT (F3.0,1X,F3.0,F3.0,F4.1,' / Time when antenna gain set')
 2085 FORMAT ('CLPARM(2)=',F10.2,' / Chiu model sunspot number')
 2088 FORMAT ('!!! AN table is corrected for the selected antenna !!!')
 2089 FORMAT ('!!! SU table is corrected for the selected source !!!')
 2090 FORMAT ('CLPARM =',1PE12.5,2(',',E12.5),' / Ant. pos error')
 2092 FORMAT ('CLPARM(5,6) =',2(F9.4),' / Source position error')
 2093 FORMAT ('CLPARM(8,9) =',2(F9.4),' / Source RA, DEC drift')
 2095 FORMAT ('CLPARM(',I2,')=',F8.2,' / Complex gain phase(deg)')
 2099 FORMAT ('CLPARM(',I2,')=',F8.2,' / Residual delay corr. (nsec)')
 2100 FORMAT ('CLPARM(1)=',F8.3,' / Phase at "Zero" time (degrees)')
 2110 FORMAT ('CLPARM(2)=',F10.3,' / Phase rate (deg/day)')
 2111 FORMAT ('CLPARM(',I2,')=',F8.2,' / Phase relationship(deg)')
 2120 FORMAT (F3.0,1X,F3.0,F3.0,F4.1,' / "Zero" time')
 2130 FORMAT ('CLPARM(1)=',F8.8,' / SSLO Frequency error (MHz)')
 2200 FORMAT ('CLPARM(',I2,')=',F6.2,' /Axis offset (meters) for',
     *        ' antenna', I3)
 2900 FORMAT (' / ',I6,' Records modified')
 2901 FORMAT (I6,' Records modified')
 3000 FORMAT ('INFILE=', A48)
 3010 FORMAT ('CLVER =', I3, 'CLUSE =', I3)
      END
      SUBROUTINE CLCLHI
C-----------------------------------------------------------------------
C   CLCLHI copies and updates history file.
C-----------------------------------------------------------------------
      CHARACTER HILINE*72, CTIME(2)*12, LABEL*8
      INTEGER   LUN1, IERR, I, TIME(3), DATE(3), LIMIT, LIMIT2, J
      REAL      TIMBEG, TIMEND
      LOGICAL   T
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      DATA LUN1 /27/
      DATA T /.TRUE./
C-----------------------------------------------------------------------
C                                       Write History.
      CALL HIINIT (3)
C                                       Copy/open history file.
      CALL HIOPEN (LUN1, DISKIN, FCNO(NCFILE), BUFFER, IERR)
      IF (IERR.LE.2) GO TO 10
         WRITE (MSGTXT,1000) IERR
         CALL MSGWRT (6)
         GO TO 100
C                                       Task message
 10   CALL ZDATE (DATE)
      CALL ZTIME (TIME)
      CALL TIMDAT (TIME, DATE, CTIME(2), CTIME)
      WRITE (HILINE,1010) TSKNAM, RLSNAM, CTIME
      CALL HIADD (LUN1, HILINE, BUFFER, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       Sources
      IF (NSOUWD.LE.0) THEN
         WRITE (HILINE,3000) TSKNAM
         CALL HIADD (LUN1, HILINE, BUFFER, IERR)
      ELSE
C                                       Included or excluded?
         WRITE (HILINE,3001) TSKNAM
         IF (DOSWNT) WRITE (HILINE,3002) TSKNAM
         CALL HIADD (LUN1, HILINE, BUFFER, IERR)
         IF (IERR.NE.0) GO TO 100
C                                       1st 2 and label.
         WRITE (HILINE,3003) TSKNAM, XSOUR(1), XSOUR(2)
         CALL HIADD (LUN1, HILINE, BUFFER, IERR)
         IF (IERR.NE.0) GO TO 100
         IF (NSOUWD.LE.2) GO TO 25
C                                       Rest of sources
         DO 20 I = 1,NSOUWD,2
            WRITE (HILINE,3004) TSKNAM, XSOUR(I), XSOUR(I+1)
            CALL HIADD (LUN1, HILINE, BUFFER, IERR)
            IF (IERR.NE.0) GO TO 100
 20         CONTINUE
         END IF
C                                       Antennas
 25   IF (NANTSL.LE.0) THEN
         WRITE (HILINE,3005) TSKNAM
         CALL HIADD (LUN1, HILINE, BUFFER, IERR)
      ELSE
C                                       Included or excluded?
         WRITE (HILINE,3006) TSKNAM
         IF (DOAWNT) WRITE (HILINE,3007) TSKNAM
         CALL HIADD (LUN1, HILINE, BUFFER, IERR)
         IF (IERR.NE.0) GO TO 100
C                                       1st 12 and label.
         LIMIT = MIN (12, NANTSL)
         WRITE (HILINE,3008) TSKNAM, (ANTENS(J),J=1,LIMIT)
         CALL HIADD (LUN1, HILINE, BUFFER, IERR)
         IF (IERR.NE.0) GO TO 100
         IF (NANTSL.LE.12) GO TO 35
C                                       Rest of antennas
         DO 30 I = 13,NANTSL,12
            LIMIT = I
            LIMIT2 = I + 11
            LIMIT2 = MIN (NANTSL, LIMIT2)
            WRITE (HILINE,3009) TSKNAM, (ANTENS(J),J=LIMIT,LIMIT2)
            CALL HIADD (LUN1, HILINE, BUFFER, IERR)
            IF (IERR.NE.0) GO TO 100
 30         CONTINUE
         END IF
C                                       Timerange
 35   TIMBEG = XTIME(1) + XTIME(2) / 24.0 + XTIME(3) / (24.0*60.0) +
     *   (XTIME(4) / (24.0*60.0*60.0))
      TIMEND = XTIME(5) + XTIME(6) / 24.0 + XTIME(7) / (24.0*60.0) +
     *   (XTIME(8) / (24.0*60.0*60.0))
      IF ((TIMEND.LT.TIMBEG) .OR. (TIMEND.LT.1.0E-5)) TIMEND = 1.0E20
      CALL HITIME (TIMBEG, TIMEND, LUN1, BUFFER, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       Stokes'
      WRITE (HILINE,2005) TSKNAM, XSTOK
      CALL HIADD (LUN1, HILINE, BUFFER, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       IF range
      WRITE (HILINE,2004) TSKNAM, BIF, EIF
      CALL HIADD (LUN1, HILINE, BUFFER, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       SUBARRAY, GAINVER, GAINUSE
      WRITE (HILINE,2002) TSKNAM, SUBA, CLVER, CLUSE
      CALL HIADD (LUN1, HILINE, BUFFER, IERR)
      IF (IERR.NE.0) GO TO 100
C                                      Add any other history.
      IF (NUMHIS.GT.0) THEN
         WRITE (LABEL,1011) TSKNAM
         HILINE(1:8) = LABEL(1:8)
         DO 90 I = 1,NUMHIS
            HILINE(9:72) = HISCRD(I)(1:64)
            CALL HIADD (LUN1, HILINE, BUFFER, IERR)
            IF (IERR.NE.0) GO TO 100
 90         CONTINUE
         END IF
C                                       Close HI file
 100  CALL HICLOS (LUN1, T, BUFFER, IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('CLCLHI: ERROR',I3,' OPENING HISTORY FILE')
 1010 FORMAT (A6,'RELEASE =''',A7,' ''  /********* Start ',
     *   A12,2X,A8)
 1011 FORMAT (A6,'  ')
 2002 FORMAT (A6, ' SUBARRAY =',I3,' GAINVER = ',I4,
     *   ' GAINUSE = ',I4,' /CL table')
 2004 FORMAT (A6,' BIF =',I4,', EIF =',I4,'/ IF range')
 2005 FORMAT (A6,' STOKES = ''',A4,''' / Stokes type')
 3000 FORMAT (A6,' SOURCES = ''''     /All sources selected')
 3001 FORMAT (A6,' /Sources excluded:')
 3002 FORMAT (A6,' /Sources included:')
 3003 FORMAT (A6,' SOURCES = ''',A16,''',''',A16,'''')
 3004 FORMAT (A6,'          ,''',A16,''',''',A16,'''')
 3005 FORMAT (A6,' ANTENNAS = 0     /All antennas selected')
 3006 FORMAT (A6,' /Antennas excluded:')
 3007 FORMAT (A6,' /Antennas included:')
 3008 FORMAT (A6,' ANTENNAS = ',12(I3,' '))
 3009 FORMAT (A6,'            ',12(I3,' '))
      END
      SUBROUTINE ANTCOR (DISK, CNO, INVER, CATBLK, IFNO, PCOR, BUFFER,
     *   FREQID, IERR)
C-----------------------------------------------------------------------
C   ANTCOR corrects the left hand polarization solutions by a specified
C   amount.  The correction depends on the polarization solution type
C   indicated by the table header keyword 'POLTYPE'.  Also corrects the
C   source table values of Q and U.
C   Inputs:
C      DISK      I      Volume number
C      CNO       I      Catalog slot number
C      INVER     I      Input version number (subarray number)
C      CATBLK(*) I      Catalog header block
C      IFNO(2)   I      Range of IFs; 0 => 1.
C      PCOR(*)   R      Phase offsets of IFs in degrees
C      BUFFER(*) I      I/O Buffer
C      FREQID    I      FQ ID user wishes to change
C   Output:
C      IERR      I      Error code, 0=OK, >0 failed, <0 not PCAL found
C-----------------------------------------------------------------------
      INTEGER   DISK, CNO, INVER, CATBLK(256), IFNO(2), BUFFER(8),
     *   FREQID, IERR
      REAL      PCOR(*)
C
      INCLUDE 'INCS:PUVD.INC'
      CHARACTER CHPOLT*8, CHSOL(4)*8, SOLTYP*8, CALCOD*4, SOUNAM*16,
     *   VELTYP*8, VELDEF*8
      INTEGER   IIF, LUN, IANT, INDEX, LOCS, KEYTYP, ISTYPE, BIF, EIF,
     *   NXIF, NUMREC, MSGSAV, IDSOU, SUKOLS(MAXSUC), SUNUMV(MAXSUC),
     * QUAL, NSOURC, ISURNO, SUFQID, NUMIF, IREF
      REAL      POLP1, POLP2, SPCOR, CPCOR, PD(MAXIF), FLUX(4,MAXIF)
      HOLLERITH XSOLTY(2)
      DOUBLE PRECISION    BANDW, RAEPO, DECEPO, EPOCH, RAAPP, DECAPP,
     *   PMRA, PMDEC,  LSRVEL(MAXIF), FREQO(MAXIF), LRESTF(MAXIF),
     *   RAOBS, DECOBS
      LOGICAL   ISOPEN
      INCLUDE 'INCS:DANT.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      DATA CHSOL /'ORI-ELP ', 'APPROX  ', 'X-Y LIN', 'VLBI'/
      DATA CHPOLT /'POLTYPE '/
      DATA LUN /28/
C-----------------------------------------------------------------------
      MSGSAV = MSGSUP
C                                      Open AN extension file.
      CALL ANTINI ('WRIT', BUFFER, DISK, CNO, INVER, CATBLK, LUN,
     *   IANRNO, ANKOLS, ANNUMV, ARRAYC, GSTIA0, DEGPDY, SAFREQ, RDATE,
     *   POLRXY, UT1UTC, DATUTC, TIMSYS, ANAME, XYZHAN, TFRAME, NUMORB,
     *   NOPCAL, ANTNIF, ANFQID, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING AN FILE FOR WRITE'
         GO TO 990
         END IF
      ISOPEN = .TRUE.
C                                       Check FREQID compatibility.
      IF ((ANFQID.GT.0) .AND. (FREQID.GT.0) .AND. (ANFQID.NE.FREQID)
     *   .AND. (ANAME.NE.'ATCA') .AND. (ANAME.NE.'ATLBA') .AND.
     *   (ANAME.NE.'LBA')) THEN
         MSGTXT = 'WARNING - POTENTIALLY FATAL ERROR'
         CALL MSGWRT (7)
         MSGTXT = '   The polarization variables in your AN table have'
         CALL MSGWRT (7)
         WRITE (MSGTXT,1030) ANFQID
         CALL MSGWRT (7)
         WRITE (MSGTXT,1040) FREQID
         CALL MSGWRT (7)
         MSGTXT = '   Are you sure this is what you want to do?'
         CALL MSGWRT (7)
         END IF
      NUMREC = BUFFER(5)
C                                       IF range to modify.
C                                       This is a risky to tell the
C                                       number of IFs.
      NXIF = ANTNIF
      BIF = IFNO(1)
      IF (BIF.GT.NXIF) BIF = NXIF
      IF (BIF.LE.0) BIF = 1
      EIF = IFNO(2)
      IF (EIF.GT.NXIF) EIF = NXIF
      IF (EIF.LE.0) EIF = 1
C                                       Check solution type keyword.
      MSGSUP = 32000
      CALL TABKEY ('READ', CHPOLT, 1, BUFFER, LOCS, XSOLTY, KEYTYP,
     *   IERR)
      MSGSUP = MSGSAV
      IF (IERR.NE.0) THEN
         IF (IERR.GT.20) THEN
            MSGTXT = 'WARNING: NO PCAL SOLUTION FOUND, ' //
     *         'SO NONE CORRECTED'
            CALL MSGWRT (7)
            GO TO 90
         ELSE
            WRITE (MSGTXT,1000) IERR, 'FINDING POL. SOLUTION TYPE'
     *         // ' KEYWORD'
            END IF
         GO TO 990
         END IF
C                                       Decide solution type:
      ISTYPE = 0
      CALL H2CHR (8, 1, XSOLTY, SOLTYP)
      IF (SOLTYP.EQ.CHSOL(1)) ISTYPE = 1
      IF (SOLTYP.EQ.CHSOL(2)) ISTYPE = 2
      IF (SOLTYP.EQ.CHSOL(3)) ISTYPE = 3
      IF (SOLTYP.EQ.CHSOL(4)) ISTYPE = 4
C                                       Unknown pol. solution type.
      IF (ISTYPE.EQ.0) THEN
         MSGTXT = 'WARNING: PCAL SOLUTION UNKNOWN, SO NOT CORRECTED'
         CALL MSGWRT (6)
         WRITE (MSGTXT,1070) SOLTYP
         CALL MSGWRT (6)
         GO TO 90
         END IF
C                                       For ISTYPE=1 (ORI-ELP) only need
C                                       to modify R-L phase differences
      IF (SOLTYP.EQ.'ORI-ELP ') THEN
C                                       Close AN table
         CALL TABIO ('CLOS', 1, IANRNO, BUFFER, BUFFER, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1200) IERR
            GO TO 990
            END IF
         ISOPEN = .FALSE.
C                                       Fetch old phase differences
         CALL PDRGET (DISK, CNO, INVER, LUN, CATBLK, NXIF, IREF, PD,
     *      BUFFER, IERR)
         IF (IERR.NE.0) GO TO 999
C                                       Update values (radians)
         INDEX = 1
         DO 20 IIF = BIF,EIF
            PD(IIF) = PD(IIF) + PCOR(INDEX) * 1.745329E-2
            INDEX = INDEX + 1
 20         CONTINUE
C                                       Save results
         CALL PDRSET (DISK, CNO, INVER, LUN, CATBLK, NXIF, IREF, PD,
     *      BUFFER, IERR)
C                                       Read AN records
      ELSE
         DO 50 IANT = 1,NUMREC
            IANRNO = IANT
            CALL TABAN ('READ', BUFFER, IANRNO, ANKOLS, ANNUMV, ANNAME,
     *         STAXYZ, ORBPRM, NOSTA, MNTSTA, STAXOF, DIAMAN, FWHMAN,
     *         POLTYA, POLAA, POLCA, POLTYB, POLAB, POLCB, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1100) IERR, 'READ'
               GO TO 990
               END IF
C                                       Feed polarizations
            INDEX = 1 + (BIF-1) * 2
            DO 30 IIF = BIF,EIF
C                                       Make appropriate correction
               IF ((ISTYPE.GE.2) .AND. (ISTYPE.LE.4)) THEN
C                                       Linear approximation
                  CPCOR = COS (PCOR(IIF-BIF+1) * 1.745329E-2)
                  SPCOR = SIN (PCOR(IIF-BIF+1) * 1.745329E-2)
C                                       Right hand (or X) parameters
                  POLP1 = POLCA(INDEX)
                  POLP2 = POLCA(INDEX+1)
                  POLCA(INDEX) = POLP1 * CPCOR - POLP2 * SPCOR
                  POLCA(INDEX+1) = POLP2 * CPCOR + POLP1 * SPCOR
C                                       Left hand (or Y) parameters
                  POLP1 = POLCB(INDEX)
                  POLP2 = POLCB(INDEX+1)
                  POLCB(INDEX) = POLP1 * CPCOR + POLP2 * SPCOR
                  POLCB(INDEX+1) = POLP2 * CPCOR - POLP1 * SPCOR
C                                       Nothing for now
               ELSE
                  CONTINUE
                  END IF
               INDEX = INDEX + 2
 30            CONTINUE
C                                       Write record
            IANRNO = IANT
            CALL TABAN ('WRIT', BUFFER, IANRNO, ANKOLS, ANNUMV, ANNAME,
     *         STAXYZ, ORBPRM, NOSTA, MNTSTA, STAXOF, DIAMAN, FWHMAN,
     *         POLTYA, POLAA, POLCA, POLTYB, POLAB, POLCB, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1100) IERR, 'WRIT'
               GO TO 990
               END IF
 50         CONTINUE
         END IF
C                                      Close AN extension files
 90   IF (ISOPEN) THEN
         CALL TABIO ('CLOS', 1, IANRNO, BUFFER, BUFFER, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'CLOSING AN FILE'
            GO TO 990
            END IF
         END IF
C                                       SU table
C                                       Open for READ first to set
C                                       all variables
C                                       Open SU table
      CALL SOUINI ('READ', BUFFER, DISK, CNO, 1, CATBLK, LUN, NUMIF,
     *   VELDEF, VELTYP, SUFQID, ISURNO, SUKOLS, SUNUMV, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING SU TABLE FOR READ'
         GO TO 990
         END IF
C                                       then close
      CALL TABIO ('CLOS', 0, 1, BUFFER, BUFFER, IERR)
C                                       Open for write
      CALL SOUINI ('WRIT', BUFFER, DISK, CNO, 1, CATBLK, LUN, NUMIF,
     *   VELDEF, VELTYP, SUFQID, ISURNO, SUKOLS, SUNUMV, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING SU TABLE FOR WRITE'
         GO TO 990
         END IF
C                                       Loop through SU rows modifing
C                                       the selected source position
      NSOURC = BUFFER(5)
      DO 150 IANT = 1,NSOURC
         ISURNO = IANT
         CALL TABSOU ('READ', BUFFER, ISURNO, SUKOLS, SUNUMV, IDSOU,
     *      SOUNAM, QUAL, CALCOD, FLUX, FREQO, BANDW, RAEPO, DECEPO,
     *      EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL, LRESTF, PMRA,
     *      PMDEC, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'READING SU TABLE'
            GO TO 990
            END IF
         DO 120 IIF = BIF,EIF
            CPCOR = COS (PCOR(IIF-BIF+1) * 1.745329E-2)
            SPCOR = SIN (PCOR(IIF-BIF+1) * 1.745329E-2)
            POLP1 = FLUX(2,IIF)
            POLP2 = FLUX(3,IIF)
            FLUX(2,IIF) = POLP1 * CPCOR - POLP2 * SPCOR
            FLUX(3,IIF) = POLP2 * CPCOR + POLP1 * SPCOR
 120        CONTINUE
         ISURNO = IANT
         CALL TABSOU ('WRIT', BUFFER, ISURNO, SUKOLS, SUNUMV, IDSOU,
     *      SOUNAM, QUAL, CALCOD, FLUX, FREQO, BANDW, RAEPO, DECEPO,
     *      EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL, LRESTF, PMRA,
     *      PMDEC, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'WRITING SU TABLE'
            GO TO 990
            END IF
 150     CONTINUE
      CALL TABIO ('CLOS', 0, 1, BUFFER, BUFFER, IANT)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('ANTCOR: ERROR',I3,' ON ',A)
 1030 FORMAT ('   previously been modified for FQID ',I3)
 1040 FORMAT ('   You are now changing them with FREQID =',I3)
 1070 FORMAT ('ANTCOR: UNKNOWN POLN. SOLN. TYPE = ',A8)
 1100 FORMAT ('ANTCOR: ERROR',I3,1X,A4,'ING AN FILE')
 1200 FORMAT ('ANTCOR: ERROR',I3,' CLOSING AN FILE')
      END
      SUBROUTINE AXCOR (DISK, CNO, INVER, CATBLK, BUFFER, NANTS, ANS,
     *   PAR, IERR)
C-----------------------------------------------------------------------
C   AXCOR corrects the axis offsets STAXOF in accordance of input
C   CLCORPRM
C   Inputs:
C      DISK      I      Volume number
C      CNO       I      Catalog slot number
C      INVER     I      Input version number (subarray number)
C      CATBLK(*) I      Catalog header block
C      NANTS     I      Number of selected antennas
C      ANS(*)    I      Array of selected anntennas' numbers
C      PAR(*)    R      Array of input parameters
C      BUFFER(*) I      I/O Buffer
C   Output:
C      IERR      I      Error code, 0=OK, else failed.
C-----------------------------------------------------------------------
      INTEGER   DISK, CNO, INVER, CATBLK(256), BUFFER(8), NANTS, ANS(*),
     *   IERR
      REAL      PAR(*)
C
      INTEGER   LUN, IANT, NUMREC, I
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:DANT.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      DATA LUN /28/
C-----------------------------------------------------------------------
C                                      Open AN extension file.
      CALL ANTINI ('WRIT', BUFFER, DISK, CNO, INVER, CATBLK, LUN,
     *   IANRNO, ANKOLS, ANNUMV, ARRAYC, GSTIA0, DEGPDY, SAFREQ, RDATE,
     *   POLRXY, UT1UTC, DATUTC, TIMSYS, ANAME, XYZHAN, TFRAME, NUMORB,
     *   NOPCAL, ANTNIF, ANFQID, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'WRIT'
         GO TO 990
         END IF
      NUMREC = BUFFER(5)
C                                       Read AN records
      DO 100 IANT = 1,NUMREC
         IANRNO = IANT
         CALL TABAN ('READ', BUFFER, IANRNO, ANKOLS, ANNUMV, ANNAME,
     *      STAXYZ, ORBPRM, NOSTA, MNTSTA, STAXOF, DIAMAN, FWHMAN,
     *      POLTYA, POLAA, POLCA, POLTYB, POLAB, POLCB, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1100) IERR, 'READ'
            GO TO 990
            END IF
C                                       Make appropriate correction
         DO 50 I = 1, NANTS
            IF (ANS(I).EQ.NOSTA) STAXOF = STAXOF + PAR(I)
   50       CONTINUE
C                                       Write record
         IANRNO = IANT
         CALL TABAN ('WRIT', BUFFER, IANRNO, ANKOLS, ANNUMV, ANNAME,
     *      STAXYZ, ORBPRM, NOSTA, MNTSTA, STAXOF, DIAMAN, FWHMAN,
     *      POLTYA, POLAA, POLCA, POLTYB, POLAB, POLCB, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1100) IERR, 'WRIT'
            GO TO 990
            END IF
 100     CONTINUE
C                                      Close AN extension files
      CALL TABIO ('CLOS', 1, IANRNO, BUFFER, BUFFER, IERR)
      IF (IERR.EQ.0) GO TO 999
         WRITE (MSGTXT,1200) IERR
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('AXCOR: ERROR',I3,' OPEN-FOR-',A4,'ING AN FILE')
 1100 FORMAT ('AXCOR: ERROR',I3,1X,A4,'ING AN FILE')
 1200 FORMAT ('AXCOR: ERROR',I3,' CLOSING AN FILE')
      END
      SUBROUTINE ATMOS (IERR)
C-----------------------------------------------------------------------
C   Routine to determine and correct neutral atmospheric corrections.
C   Corrections are applied to the CL record in Common.
C   Control info from common:
C      ICODE    I    2 => Opacity, 3 => delay.
C      PARM(*)  R    (1) = Opacity (ICODE=2) or Atmos. press.(mbar)
C                        (ICODE=3)
C                    (2) = partial pressure of H2O (mbar).
C                    (3) = Temperature (deg C)
C                    (4) = Tropospheric lapse rate (K/km) (negative)
C                    (5) = Height of the tropopause (km).
C                    (6) = Scale height of water vapor (km)
C                    (7) = Last source ID number
C      ISTOK    I    Polarization to correct, 1=first, 2=second,
C                    0 = both
C   Output:
C      IERR     I    Return error code , 0=OK else failed.
C-----------------------------------------------------------------------
      INTEGER   IERR
C
      INTEGER   LSTSOU, THSOU, LUN, IANT, I, ITEMP
      REAL      XT, YT, FACTOR, PDLY, DPDLY, CFAC, SFAC, FQFAC, ZA, ARG,
     *   ELV, HA, AZ, TIME
      DOUBLE PRECISION HRANG, DARG, FREQS, TIMED, DRA, DDEC
      LOGICAL   ISPLNT
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      DATA LUN /30/
C-----------------------------------------------------------------------
      LSTSOU = PARM(7) + 0.5
      THSOU = CLRECI(SOUCL)
      TIMED = CLRECD(TIMCL)
      TIME = TIMED
C                                       get source info
      CALL FNDCOO (0, JD0, THSOU, DISKIN, CNOIN, CATBLK, LUN, TIME,
     *   DRA, DDEC, ISPLNT, IERR)
      IF (IERR.NE.0) GO TO 999
      PARM(7) = THSOU
      FREQS = FREQ + FREQO(BIF)
      SINDEC = SIN (DDEC)
      COSDEC = COS (DDEC)
C                                       Compute zenith angle (deg).
      CALL COOELV (IANT, TIMED, DRA, DDEC, HA, ELV, AZ)
      IANT = CLRECI(ANTCL)
      CALL SOUELV (IANT, CLRECD(TIMCL), HA, ELV, AZ)
      HRANG = HA
      ZA = (1.570796327 - ELV)
      DARG = SIN (ELV)
      IF (ICODE.EQ.3) GO TO 500
C                                       Transmission factor:
C                                       Modified cosecant law from
C                                       Chopo Ma's thesis:
      ARG = PARM(1) / (DARG + (0.00143 / (TAN(ELV) + 0.0045)))
C                                       Need square root for
C                                       calibration table factor
      FACTOR = SQRT (EXP (ARG))
C
      IF (ISTOK.LE.1) THEN
         DO 100 I = BIF,EIF
            XT = CLRECR(RE1CL+I-1)
            YT = CLRECR(IM1CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE1CL+I-1) = XT * FACTOR
               CLRECR(IM1CL+I-1) = YT * FACTOR
               END IF
 100        CONTINUE
         END IF
      IF (ABS(ISTOK).NE.1) THEN
         DO 200 I = BIF,EIF
            XT = CLRECR(RE2CL+I-1)
            YT = CLRECR(IM2CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE2CL+I-1) = XT * FACTOR
               CLRECR(IM2CL+I-1) = YT * FACTOR
               END IF
 200        CONTINUE
         END IF
      GO TO 999
C                                       Phase delay
C                                       Get delay and rate
 500  CALL ATMFAZ (ELV, HA, STNLAT(IANT), DDEC, STNRAD(IANT), PARM(3),
     *   PARM(1), PARM(2), PARM(4), PARM(5), PARM(6), PDLY, DPDLY)
C                                       Atmospheric group delay
      IF (CLRECR(ATMCL).NE.FBLANK) CLRECR(ATMCL) = CLRECR(ATMCL) - PDLY
C                                       Atmospheric group delay rate
      IF (CLRECR(DATMCL).NE.FBLANK) CLRECR(DATMCL) = CLRECR(DATMCL) -
     *   DPDLY
      IF (ISTOK.NE.2) THEN
         DO 600 I = BIF,EIF
            FQFAC = (FREQS+FRQOFF(I)) * PDLY
            ITEMP = FQFAC
            FQFAC = TWOPI * (FQFAC - ITEMP)
            CFAC = COS (FQFAC)
            SFAC = SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE1CL+I-1)
            YT = CLRECR(IM1CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE1CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM1CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delay
            IF (CLRECR(DE1CL+I-1).NE.FBLANK)
     *         CLRECR(DE1CL+I-1) = CLRECR(DE1CL+I-1) + PDLY
C                                       Phase rate
            IF (CLRECR(RA1CL+I-1).NE.FBLANK)
     *         CLRECR(RA1CL+I-1) = CLRECR(RA1CL+I-1) + DPDLY
 600        CONTINUE
            END IF
      IF (ABS(ISTOK).NE.1) THEN
         DO 700 I = BIF,EIF
            FQFAC = (FREQS+FRQOFF(I)) * PDLY
            ITEMP = FQFAC
            FQFAC = TWOPI * (FQFAC - ITEMP)
            CFAC = COS (FQFAC)
            SFAC = SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE2CL+I-1)
            YT = CLRECR(IM2CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE2CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM2CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delay
            IF (CLRECR(DE2CL+I-1).NE.FBLANK)
     *         CLRECR(DE2CL+I-1) = CLRECR(DE2CL+I-1) + PDLY
C                                       Phase rate
            IF (CLRECR(RA2CL+I-1).NE.FBLANK)
     *         CLRECR(RA2CL+I-1) = CLRECR(RA2CL+I-1) + DPDLY
 700        CONTINUE
         END IF
C
 999  RETURN
      END
      REAL FUNCTION POLYN (NTERMS, ARG, COEF)
C-----------------------------------------------------------------------
C   Evaluates a polynomial function.
C    Inputs:
C     NTERMS    I    Number of terms (coefficients).
C     ARG       R    Argument of polynomial expansion.
C     COEF(*)   R    Coefficients.
C-----------------------------------------------------------------------
      INTEGER   NTERMS
      REAL      ARG, COEF(*)
C
      INTEGER   LOOP
      REAL      TEMP, SUM
C-----------------------------------------------------------------------
      SUM = COEF(1)
      TEMP = 1.0
      DO 100 LOOP = 2,NTERMS
         TEMP = TEMP * ARG
         SUM = SUM + COEF(LOOP) * TEMP
 100     CONTINUE
      POLYN = SUM
C
 999  RETURN
      END
      SUBROUTINE CLOKER (IERR)
C-----------------------------------------------------------------------
C   Routine to correct effects of clock error.
C   Corrections are applied to the CL record in Common.
C   Control info from common:
C    PARM(*)  R    (1) = Rate error (sec/sec)
C                  (2) = Clock error at t0 (sec)
C                  (3) = t0 (days)
C                  (4) = correction mode
C                        0 = rate correction added
C                        1 = rate + offset correction added
C                        2 = rate and offset replace table values.
C    ISTOK    I    Polarization to correct, 1=first, 2=second, 0 = both
C-----------------------------------------------------------------------
      INTEGER   IERR
C
      INTEGER   LSTSOU, THSOU, LUN, I
      REAL      XT, YT, CFAC, SFAC, FQFAC, GDELAY, DGDELY, OLDDEL
      DOUBLE PRECISION    FREQS, CLTIME
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      DATA LUN /30/
C-----------------------------------------------------------------------
      CONTINUE
      LSTSOU = PARM(12) + 0.5
      THSOU = CLRECI(SOUCL)
C                                       Get source info
      IF (LSTSOU.NE.THSOU) THEN
         CALL GETSOU (THSOU, DISKIN, CNOIN, CATBLK, LUN, IERR)
         IF (IERR.NE.0) GO TO 999
         PARM(12) = THSOU
         FREQS = FREQ + FREQO(BIF)
         END IF
      CLTIME = CLRECD(TIMCL)
      GDELAY = ((CLTIME - PARM(3)) * 86400.0 * PARM(1)) + PARM(2)
      DGDELY = PARM(1)
C                                       Clock
      IF (ISTOK.NE.2) THEN
         IF (CLRECR(CLK1CL).NE.FBLANK) THEN
            IF (BPARM(7).NE.2) THEN
               CLRECR(CLK1CL) = CLRECR(CLK1CL) - GDELAY
               CLRECR(DCK1CL) = CLRECR(DCK1CL) - DGDELY
            ELSE IF (BPARM(7).EQ.2) THEN
               CLRECR(CLK1CL) = -GDELAY
               CLRECR(DCK1CL) = -DGDELY
               END IF
            END IF
         DO 100 I = BIF,EIF
C         FQFAC = -TWOPI * (FREQS+FRQOFF(I)) * GDELAY
C        The sign has been changed by LK Jan 15, 2004
            FQFAC = TWOPI * (FREQS + FRQOFF(I)) * GDELAY
            CFAC = COS (FQFAC)
            SFAC = SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE1CL+I-1)
            YT = CLRECR(IM1CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE1CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM1CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delay
            IF (CLRECR(DE1CL+I-1).NE.FBLANK) THEN
               OLDDEL = CLRECR(DE1CL+I-1)
               IF (BPARM(7).NE.2) THEN
                  CLRECR(DE1CL+I-1) = CLRECR(DE1CL+I-1) + GDELAY
               ELSE IF (BPARM(7).EQ.2) THEN
                  CLRECR(DE1CL+I-1) = GDELAY
                  END IF
               END IF
C                                       Rate
            IF (CLRECR(RA1CL+I-1).NE.FBLANK) THEN
               CLRECR(RA1CL+I-1) = CLRECR(RA1CL+I-1) + DGDELY
               END IF
 100        CONTINUE
         END IF
      IF (ABS(ISTOK).NE.1) THEN
C                                       Clock error.
         IF (CLRECR(CLK2CL).NE.FBLANK) THEN
            IF (BPARM(7).NE.2) THEN
               CLRECR(CLK2CL) = CLRECR(CLK2CL) - GDELAY
               CLRECR(DCK2CL) = CLRECR(DCK2CL) - DGDELY
            ELSE IF (BPARM(7).EQ.2) THEN
               CLRECR(CLK2CL) = -GDELAY
               CLRECR(DCK2CL) = -DGDELY
               END IF
            END IF
         DO 200 I = BIF,EIF
C         FQFAC = -TWOPI * (FREQS + FRQOFF(I)) * GDELAY
C        The sign has been changed by LK Jan 15, 2004
            FQFAC = TWOPI * (FREQS + FRQOFF(I)) * GDELAY
            CFAC = COS (FQFAC)
            SFAC = SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE2CL+I-1)
            YT = CLRECR(IM2CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE2CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM2CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delay
            IF (CLRECR(DE2CL+I-1).NE.FBLANK) THEN
               OLDDEL = CLRECR(DE2CL+I-1)
               IF (BPARM(7).NE.2) THEN
                  CLRECR(DE2CL+I-1) = CLRECR(DE2CL+I-1) + GDELAY
               ELSE IF (BPARM(7).EQ.2) THEN
                  CLRECR(DE2CL+I-1) = GDELAY
                  END IF
               END IF
C                                       Rate
            IF (CLRECR(RA2CL+I-1).NE.FBLANK) THEN
               CLRECR(RA2CL+I-1) = CLRECR(RA2CL+I-1) + DGDELY
               END IF
 200        CONTINUE
         END IF
C
 999  RETURN
      END
      SUBROUTINE FARADA (IERR)
C-----------------------------------------------------------------------
C   Routine to determine and correct ionospheric Faraday rotation.
C   Corrections are applied to the CL record in Common.
C   Control info from common:
C    PARM(*)  R    (1) = Electron density model type.
C                        1 = Chiu, PARM(3) = Zurich Sunspot number,
C                                  PARM(4) = annual time (months).
C                  (2) = Last source ID number
C   Output:
C      IERR   I    Return error code, 0=OK
C-----------------------------------------------------------------------
      INTEGER   IERR
C
      INTEGER   LSTSOU, THSOU, LUN, IANT, I
      REAL      XT, YT, XXT, YYT, PDLY(2), DPDLY(2), ZA, ARG, HA, ELV,
     *   GDLY(2), DGDLY(2), GDLYIF, PDLYIF, DGDLYI, DPDLYI, AZ, FR,
     *   DELDT, TIME
      DOUBLE PRECISION HRANG, DARG, FREQS, SINLAT, COSLAT, TIMED, DRA,
     *   DDEC
      LOGICAL   ISPLNT
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      DATA LUN /30/
C-----------------------------------------------------------------------
      LSTSOU = PARM(2) + 0.5
      THSOU = CLRECI(SOUCL)
      TIMED = CLRECD(TIMCL)
      TIME = TIMED
C                                       get source info
      CALL FNDCOO (0, JD0, THSOU, DISKIN, CNOIN, CATBLK, LUN, TIME,
     *   DRA, DDEC, ISPLNT, IERR)
      IF (IERR.NE.0) GO TO 999
      PARM(2) = THSOU
      FREQS = FREQ + FREQO(BIF)
      SINDEC = SIN (DDEC)
      COSDEC = COS (DDEC)
C                                       Local apparent position and
C                                       derivitive.
      IANT = CLRECI(ANTCL)
      CALL COOELV (IANT, TIMED, DRA, DDEC, HA, ELV, AZ)
      HRANG = HA
      ZA = (1.570796327 - ELV)
      COSLAT = COS (STNLAT(IANT))
      SINLAT = SIN (STNLAT(IANT))
      DARG = SINLAT * SINDEC + COSLAT * COSDEC * COS (HRANG)
      DELDT = -(1.0 / SQRT (1.0 - DARG*DARG)) * COSLAT * COSDEC * SIN
     *   (HRANG) * TWOPI / 86400.0
C                                       Compute Faraday rotation
      CALL FAROT (CLRECD(TIMCL), STNLAT(IANT), STNLON(IANT),
     *   STNRAD(IANT), AZ, ELV, DELDT, PARM, FR, PDLY, GDLY, DPDLY,
     *   DGDLY)
C                                       Apply corrections
C                                       Polarization 1 corrections:
      IF (ISTOK.NE.2) THEN
C                                       Dispersive delay=phase delay at
C                                       1 m wavelength
         IF (CLRECR(DIS1CL).NE.FBLANK) CLRECR(DIS1CL) = CLRECR(DIS1CL) -
     *      PDLY(1) / (2.997925E8 ** 2)
         IF (CLRECR(DDS1CL).NE.FBLANK) CLRECR(DDS1CL) = CLRECR(DDS1CL) -
     *      DPDLY(1) / (2.997925E8 ** 2)
         DO 100 I = BIF,EIF
C                                       Following for RCP
            GDLYIF = GDLY(1) / ((FREQS + FRQOFF(I)) ** 2)
            PDLYIF = PDLY(1) / ((FREQS + FRQOFF(I)) ** 2)
            DGDLYI = DGDLY(1) / ((FREQS + FRQOFF(I)) ** 2)
            DPDLYI = DPDLY(1) / ((FREQS + FRQOFF(I)) ** 2)
            CLRECR(RA1CL+I-1) = CLRECR(RA1CL+I-1) + DPDLYI
            CLRECR(DE1CL+I-1) = CLRECR(DE1CL+I-1) + GDLYIF
C***??? SIGN???
            ARG = -FR * ((VELITE / (FREQS + FRQOFF(I))) ** 2) +
     *         PDLYIF * TWOPI * (FREQS + FRQOFF(I))
            XT = COS (ARG)
            YT = SIN (ARG)
            XXT = CLRECR(RE1CL+I-1)
            YYT = CLRECR(IM1CL+I-1)
            IF ((XXT.NE.FBLANK) .AND. (YYT.NE.FBLANK)) THEN
               CLRECR(RE1CL+I-1) = XXT*XT - YYT*YT
               CLRECR(IM1CL+I-1) = XXT*YT + YYT*XT
               END IF
 100        CONTINUE
         END IF
C                                       Polarization 2 corrections:
      IF (ABS(ISTOK).NE.1) THEN
C                                       Dispersive delay=phase delay at
C                                       1 m wavelength
         IF (CLRECR(DIS2CL).NE.FBLANK) CLRECR(DIS2CL) = CLRECR(DIS2CL) -
     *      PDLY(2) / (2.997925E8 ** 2)
         IF (CLRECR(DDS2CL).NE.FBLANK) CLRECR(DDS2CL) = CLRECR(DDS2CL) -
     *      DPDLY(2) / (2.997925E8 ** 2)
         DO 200 I = BIF,EIF
C                                       Following for LCP
            GDLYIF = GDLY(2) / ((FREQS + FRQOFF(I)) ** 2)
            PDLYIF = PDLY(2) / ((FREQS + FRQOFF(I)) ** 2)
            DGDLYI = DGDLY(2) / ((FREQS + FRQOFF(I)) ** 2)
            DPDLYI = DPDLY(2) / ((FREQS + FRQOFF(I)) ** 2)
            CLRECR(RA2CL+I-1) = CLRECR(RA2CL+I-1) + DPDLYI
            CLRECR(DE2CL+I-1) = CLRECR(DE2CL+I-1) + GDLYIF
C***??? SIGN???
            ARG = FR * ((VELITE / (FREQS + FRQOFF(I))) ** 2) +
     *         PDLYIF * TWOPI * (FREQS + FRQOFF(I))
            XT = COS (ARG)
            YT = SIN (ARG)
            XXT = CLRECR(RE2CL+I-1)
            YYT = CLRECR(IM2CL+I-1)
            IF ((XXT.NE.FBLANK) .AND. (YYT.NE.FBLANK)) THEN
C                                       Opposite phase for Pol. 2.
               CLRECR(RE2CL+I-1) = XXT*XT + YYT*YT
               CLRECR(IM2CL+I-1) = -XXT*YT + YYT*XT
               END IF
 200        CONTINUE
         END IF
C
 999  RETURN
      END
      SUBROUTINE FAROT (TIME, LAT, LONG, RHO, AZ, EL, DELDT, PARM,
     *   FR, PDLY, GDLY, DPDLY, DGDLY)
C-----------------------------------------------------------------------
C   Routine to compute Faraday rotation values from one of various
C   ionospheric models.  Also returns Group and phase delay and
C   derivatives.
C    Inputs:
C     TIME        D    Time in days since 0 iat on reference date
C     LAT         D    Latitude of station (rad)
C     LONG        D    Longitude of station (rad)
C     RHO         D    Distance of station from earth center (m).
C     AZ          R    Azimuth (radians)
C     EL          R    Elevation (radians)
C     DELDT       R    Time derivative of EL (rad/sec)
C     PARM(*)     R    Model dependent parameters
C                      PARM(1) = model type
C                       1.0 = Chiu model
C                             BPARM(3) = Zurich sunspot number
C                             BPARM(4) = Time of year (mo)
C    Output:
C     FR          R    Faraday rotation in rad/m**2
C     PDLY(2)     R    Phase delay correction (poln 1 and 2) in sec *
C                      frequency**2
C     GDLY(2)     R    Group delay correction (poln 1 and 2) in sec *
C                      frequency**2
C     DPDLY(2)    R    Phase delay derivitive correction (sec/sec) *
C                      frequency**2. Assumes constant ionosphere.
C     DGDLY(2)    R    Group delay derivitive correction (sec/sec) *
C                      frequency**2. Assumes constant ionosphere.
C-----------------------------------------------------------------------
      DOUBLE PRECISION    TIME, LAT, LONG, RHO
      REAL      AZ, EL, DELDT, PARM(*), FR, PDLY(2), GDLY(2), DPDLY(2),
     *   DGDLY(2)
C
      REAL      TWOPI, VELITE
      PARAMETER (TWOPI = 6.2831853)
      PARAMETER (VELITE = 2.997925E8)
      INTEGER   ITYPE
      REAL      PEAKF2, MLAT, MLONG, GLAT, GLONG, ANNTIM, HEIOLD,
     *   LOCTIM, SUNSPT, ZCD, FACT, HEIGHT, MAGFLD, ZAFACT, RAD,
     *   H(3), THICK, PIO2, DZAFDT
      EXTERNAL PEAKF2
C                                       HEIGHT = height of F2 slab in m
C                                       This is modeled in SLABF2
      DATA HEIGHT /0.0/
      DATA PIO2 /1.570796327/
C-----------------------------------------------------------------------
C                                       path length factor
C***??? can do better
      ZAFACT = 1.0 / COS (PIO2 - EL)
C                                       Time derivative
      DZAFDT = -ZAFACT * ZAFACT * SIN (PIO2 - EL) * DELDT
C                                       Initial values
      FR = 0.0
      PDLY(1) = 0.0
      PDLY(2) = 0.0
      GDLY(1) = 0.0
      GDLY(2) = 0.0
      DPDLY(1) = 0.0
      DPDLY(2) = 0.0
      DGDLY(1) = 0.0
      DGDLY(2) = 0.0
C                                       Restart here if need to iterate
C                                       height.
 10   HEIOLD = HEIGHT
C                                       Get lat, long for sub
C                                       ionispheric location.
      FACT = (PIO2 - EL - ASIN ((RHO/(RHO+HEIGHT)) *
     *   COS (EL)))
      GLAT = LAT + COS (AZ) * FACT
      GLONG = LONG + SIN (AZ) * FACT
C                                       Convert to magnetic coordinates.
      CALL MAGCRD (GLAT, GLONG, MLAT, MLONG)
C                                       Branch on model type
      ITYPE = PARM(1) + 0.1
      IF ((ITYPE.LT.1) .OR. (ITYPE.GT.1)) ITYPE = 2
      GO TO (100,750), ITYPE
C                                       Chiu model
C                                       PARM(3) = Sunspot number
C                                       PARM(4) = annual time.
 100     ANNTIM = PARM(4)
         LOCTIM = (TIME * 6.283185308D0) - GLONG
         SUNSPT = PARM(3)
C                                       Find peak height and integral
         CALL SLABF2 (MLAT, ANNTIM, LOCTIM, SUNSPT, THICK, HEIGHT)
C                                       If HEIGHT disagrees with older
C                                       value then redo.
         IF (ABS (HEIGHT-HEIOLD).GT.1.0E4) GO TO 10
C                                       Zenith column density:
C                                       Units = m**-2
         ZCD = PEAKF2 (MLAT, MLONG, ANNTIM, LOCTIM, SUNSPT) * THICK
         GO TO 800
C                                       Unknown model (shouldn't get
C                                       here).
 750     ZCD = 0.0
         GO TO 800
C                                       Magnetic field model
 800  RAD = RHO + HEIGHT
      CALL MAGDIP (GLAT, GLONG, RAD, H)
C                                       Project along line of sight.
      MAGFLD = H(3) * COS (AZ) * COS (EL) +
     *         H(2) * SIN (AZ) * COS (EL) +
     *         H(1) * SIN (EL)
C                                       Faraday rotation, from
C                                       Pacholczyk, Radio Astrophysics,
C                                       1970, p 57 (eq 2.81).
C                                       in Rad/m**2
      FR = 0.93E6 * ZCD * MAGFLD * ZAFACT * 1.0E-4 /
     *   (TWOPI * TWOPI * VELITE * VELITE)
C                                       Group and Phase delay
C                                       From: Hagfors, Methods of
C                                       Experimental Physics,
C                                       Vol 12 B, Meeks, ed
C***??? is this right???
      PDLY(1) = -40.28 * ZCD * ZAFACT / VELITE
      PDLY(2) = PDLY(1)
      DPDLY(1) = -40.28 * ZCD * DZAFDT / VELITE
      DPDLY(2) = DPDLY(1)
      GDLY(1) = 40.28 * ZCD * ZAFACT / VELITE
      GDLY(2) = GDLY(1)
      DGDLY(1) = 40.28 * ZCD * DZAFDT / VELITE
      DGDLY(2) = DPDLY(1)
C
 999  RETURN
      END
      SUBROUTINE MAGCRD (GLAT, GLONG, MLAT, MLONG)
C-----------------------------------------------------------------------
C   MAGCRD converts geographic latitude and longitude into magnetic
C   latitude and longitude. Note that geographic longitude increases to
C   the West while magnetic longitude increases to the East.
C   Inputs:   GLAT     R     geographic latitude (radians)
C             GLONG    R     geographic east-longitude (radians)
C   Outputs:  MLAT     R     magnetic latitude (radians)
C             MLONG    R     magnetic east-longitude (radians)
C   Programmer: C. Flatters, Oct. 1987
C-----------------------------------------------------------------------
      REAL   GLAT, GLONG, MLAT, MLONG
C
      REAL   PI, CMLONG, GLATMP, GLONMP, SMLONG
      PARAMETER (PI = 3.141 592 65)
C                                       Geographic coordinates of
C                                       North magnetic pole.
      PARAMETER (GLATMP = 78.63 * PI / 180)
      PARAMETER (GLONMP = 289.85 * PI / 180)
C-----------------------------------------------------------------------
      MLAT = ASIN (SIN(GLAT) * SIN(GLATMP)
     *             + COS(GLAT) * COS(GLATMP) * COS(GLONG - GLONMP))
      CMLONG = (SIN(GLATMP) * SIN(MLAT) - SIN(GLAT))
     *         / (COS(GLATMP) * COS(MLAT))
      SMLONG = SIN(GLONG - GLONMP) * COS(GLAT) / COS(MLAT)
      MLONG = ATAN2 (SMLONG, CMLONG)
  999 RETURN
C-----------------------------------------------------------------------
      END
      REAL FUNCTION PEAKF2 (MLAT, MLONG, ANNTIM, LOCTIM, SUNSPT)
C-----------------------------------------------------------------------
C   PEAKF2 returns the peak free electron density of the F2-layer in
C   electrons per cubic meter. This is derived from a phenomenological
C   model of the ionosphere (Chiu, J. At. Terr. Phys. 37, 1563; 1975).
C   Some formulae have been corrected according to the code fragment
C   IONDEM published as part of the International Reference Ionosphere
C   IRI-79 (Report UAG-82, 1981).
C   Inputs:
C      MLAT    R    magnetic latitude (radians)
C      MLONG   R    magnetic east-longitude (radians)
C      ANNTIM  R    annual time (months), beginning Dec 15th
C      LOCTIM  R    local time (radians)
C      SUNSPT  R    monthly smoothed Zurich relative sunspot
C                   number
C   Programmer: C. Flatters, Oct. 1987
C-----------------------------------------------------------------------
      REAL MLAT, MLONG, ANNTIM, LOCTIM, SUNSPT
C
      REAL   ANNFN, BETA, BIGG, DIPFN, DIURNL, EQUATR, FOLD, G, GAMMA,
     *   KAPPA, LATFN, LONGFN, LPRIME, MAGDIP, NONPLR, PI, POLAR, PSI,
     *   Q, RHO, SIGMA, SOLAR, SOLDEC, TILT, W, X, XLONG, Y, ZETA
      EXTERNAL GAMMA, PSI
      PARAMETER (PI = 3.141 592 65)
      PARAMETER (TILT = -23.5 * PI / 180)
C-----------------------------------------------------------------------
C                                     Calculate magnetic dip angle.
      MAGDIP = ATAN (2 * SIN(MLAT) / COS(MLAT))
C                                     Calculate solar declination angle
      SOLDEC = ASIN (0.39795 * SIN (PI/6 * (ANNTIM - 3.167)))
C                                     Calculate the seasonal anomoly
C                                     parameter zeta.
      ZETA = SIN(SOLDEC) * SIN(MLAT)
C                                     Normalize sunspot number.
      RHO = SUNSPT / 100
C                                     Calculate the layer peak function.
C                                     This consists of a polar function
C                                     folded with a non-polar function.
C                                     The polar function dominates at
C                                     high latitudes while the non-polar
C                                     function dominates for lower
C                                     latitudes.
C                                     First calculate the folding factor
      FOLD = EXP (-1 * ((2.4 + (0.4 + 0.1*RHO) * SIN(MLAT)) ** 6)
     *   * COS(MLAT) ** 6)
C                                     Now the polar function. This is
C                                     omitted from Chiu's paper and has
C                                     been reconstructed from a program
C                                     fragment printed in Report UAG-82
C                                     (IRI-79).
      IF (MLAT.GE.0.0) THEN
         POLAR = (2 + 1.2 * RHO) * (1 + 0.3 * SIN (PI/12 * ANNTIM))
     *      * EXP(-1.2*(COS(MLAT + TILT * COS(LOCTIM)) - COS(MLAT)))
      ELSE
         XLONG = SIN(PI/12 * ANNTIM) * (0.5 * SIN(MLONG/2)
     *      - 0.5 * SIN(MLONG) - (MLONG/2)**8) - (1 + SIN(PI/12 *
     *      ANNTIM)) * COS(PI/6 * ANNTIM) * SIN(MLONG) /
     *      SQRT(ABS(SIN(MLONG))) * EXP (-4 * SIN(MLONG/2)**2)
         POLAR = (1 + 0.4 * (1 - SIN(PI/12 * ANNTIM)**2)
     *      * EXP(-1 * COS(MLONG/2 - PI/20)**4 * SIN(PI/12 * ANNTIM)))
     *      * (2.5 + 2 * RHO + COS(PI/6 * ANNTIM) * (0.5 + (1.3 + 0.2 *
     *      RHO) * COS(MLONG/2 - PI/20)**4) + (1.3 + 0.5 * RHO) *
     *      COS(LOCTIM - PI * (1 + XLONG)))
         END IF
C                                     The non-polar function is the
C                                     product of a solar cycle function,
C                                     a diurnal function, a latitudinal
C                                     function, an annual function, an
C                                     equatorial anomoly function, a
C                                     longitudinal function and a
C                                     magnetic dip function.
C                                     First the solar cycle function.
      SIGMA = 1 + RHO + 0.204 * RHO**2 + 0.03 * RHO**3
      IF (RHO.LE.1.1) THEN
         SOLAR = SIGMA
      ELSE
         SOLAR = 2.39 + 1.53 * (SIGMA - 2.39) * SIN(MLAT)**2
         END IF
C                                     The diurnal function.
      DIURNL = (0.9 + 0.32 * ZETA)
     *      * (1 + ZETA * COS(LOCTIM - PI/4)**2)
     *      * EXP(-1.1 * (1 + COS (LOCTIM - 0.873)))
C                                     The latitudinal function.
      LPRIME = EXP(3.0 * COS(MLAT/2 * (SIN(LOCTIM) - 1)))
      Q = 1 - 0.15 * EXP(-1 * SQRT((12 * MLAT + 4*PI/3) ** 2
     *   + (ANNTIM/2 - 3) ** 2))
      LATFN = (1.2 - 0.5 * COS(MLAT)**2)
     *   * (1 + 0.05 * RHO * SIN(MLAT)**3
     *   * COS(PI/6 * ANNTIM)) * LPRIME * Q
C                                     The annual function.
      BETA = 1.3 + 0.278 * RHO ** 2 * COS(0.5 * (MLAT - PI/4)) ** 2
     *   + 0.051 * RHO ** 3
      W = EXP (-BETA * (COS(PSI(MLAT, LOCTIM, SOLDEC)) - COS(MLAT)))
      KAPPA = 1 + 0.085 * (COS(MLAT - PI/6)
     *   * COS(PI/12 * (ANNTIM - 2)) ** 3
     *   + COS (MLAT + PI/4) * COS(PI/12 * (ANNTIM - 8)) ** 2)
      X = 0.7 * (KAPPA + 0.178 * RHO**2
     *   * COS(PI/3 * (ANNTIM - 4.3)) / SOLAR) * W
      Y = 0.2 * (1 - SIN(ABS(MLAT) - PI/6))
     *   * (1 + 0.6 * COS(PI/3 * (ANNTIM - 3.94)))
     *   * COS(PI/6 * (ANNTIM - 1))
     *   + (0.13 - 0.06 * SIN(ABS(ABS(MLAT) - PI/9)))
     *   * COS(PI/3 * (ANNTIM - 4.5))
     *   - (0.15 + 0.3 * SIN(ABS(MLAT)))
     *   * (1 - COS(LOCTIM)) ** 0.25
     *   * COS(PSI(MLAT, 0.0, SOLDEC)) ** 3
      ANNFN = X + Y/SOLAR
C                                       The equatorial function.
      BIGG = (1 + 0.6 * SQRT(RHO) - 0.2 * RHO)
     *   * EXP (0.25 * (1 + COS(LOCTIM - 0.873)))
     *   * COS(MLAT)**8 * COS(ABS(MLAT) - 0.2618)**12
      EQUATR = GAMMA(0.05, 0.5, ANNTIM)
     *   * (1 + BIGG) * (1 - 0.4 * COS(MLAT) ** 10)
     *   * (1 + 0.6 * COS(MLAT)**10 * COS(ANNTIM - PI/4)**2)
C                                       The longitudinal function.
      LONGFN = 1 + 0.1 * COS(MLAT)**3
     *   * COS(2 * (MLONG - 7*PI/18))
      G = 0.15 - (1 + RHO) * SIN(MLAT/2)**2
     *   * EXP (-0.33 * (ANNTIM - 6)**2)
C                                       The dip function.
      DIPFN = GAMMA(0.03, 0.5, ANNTIM)
     *   * (1 + G * EXP (-18 * (ABS(MAGDIP) - 2*PI/9)**2))
C                                       Now everything can be put
C                                       together.
      NONPLR = SOLAR * DIURNL * LATFN * ANNFN * EQUATR * LONGFN
     *   * DIPFN
      PEAKF2 = 0.66E11 * (FOLD * POLAR + (1 - FOLD) * NONPLR)
  999 RETURN
C-----------------------------------------------------------------------
      END
      REAL FUNCTION PSI (XI, ETA, SDEC)
C-----------------------------------------------------------------------
C PSI is the seasonal anomoly parameter psi(xi,eta). Psi(lat, pi) is
C the solar zenith angle at noon.
C
C Inputs:   XI       R     dummy variable
C           ETA      R     dummy variable
C           SDEC     R     solar declination angle (radians)
C   Programmer: C. Flatters, Oct. 1987
C-----------------------------------------------------------------------
      REAL   XI, ETA, SDEC
C-----------------------------------------------------------------------
      PSI = XI + SDEC * COS (ETA)
  999 RETURN
C
      END
      SUBROUTINE SLABF2 (MLAT, ANNTIM, LOCTIM, SUNSPT, THICK, HEIGHT)
C-----------------------------------------------------------------------
C   SLABF2 returns the slab thickness of the F2-layer according to a
C   phenomenological model of the ionosphere (Chiu, J. At. Terr. Phys.
C   37, 1563; 1975) in meters and the effective height of the slab.
C   Inputs:
C    MLAT    R    magnetic latitude (radians)
C    ANNTIM  R    annual time (months), beginning Dec 15th
C    LOCTIM  R    local time (radians)
C    SUNSPT  R    monthly smoothed Zurich relative sunspot
C                 number
C   Outputs:
C    THICK   R    Effective thickness of slab (m).
C    HEIGHT  R    Effective height of the slab (m).
C   Programmer: C. Flatters, Oct. 1987
C-----------------------------------------------------------------------
      REAL      MLAT, ANNTIM, LOCTIM, SUNSPT, THICK, HEIGHT
C
      INTEGER   ALT, I, UPLIM
      REAL      STEP
C                                     Integration step (km).
      PARAMETER (STEP = 1.0)
C                                     Upper limit for integration
C                                     (units of STEP)
      PARAMETER (UPLIM = 1024)
      REAL   ALTPK, PI, PROF, R, RHO, SOLDEC, ZETA
      PARAMETER (PI = 3.141 592 65)
C-----------------------------------------------------------------------
C                                     Calculate the solar declination
C                                     angle.
      SOLDEC = ASIN (0.39795 * SIN (PI/6 * (ANNTIM - 3.167)))
C                                     Calculate the seasonal anomoly
C                                     parameter zeta.
      ZETA = SIN(SOLDEC) * SIN(MLAT)
C                                     Normalize sunspot number.
      RHO = SUNSPT / 100
C                                     The altitude of the layer peak
C                                     must be calculated before
C                                     integrating the layer profile
      ALTPK = 240 + 75 * RHO + 83 * RHO * ZETA * COS(MLAT)
     *   + COS(LOCTIM - 4.5 * ABS(MLAT) - PI)
     *   + 10 * COS(MLAT) * COS(PI/3 * (ANNTIM - 4.5))
C                                       Now integrate over the profile.
C                                       Simpson's method is used. Most
C                                       vector compilers should
C                                       vectorize this loop.
      THICK = 0.0
      DO 10 I = 1, UPLIM
         ALT = I * STEP
         IF (ALT.GE.ALTPK) THEN
            R = (ALT - ALTPK) / (40 + 0.2 * ALTPK)
         ELSE
            R = (ALT - ALTPK) / (40 + 0.2 * ALT)
            END IF
         IF ((I.EQ.1) .OR. (I.EQ.UPLIM)) THEN
            PROF = 2.0/3.0 * EXP(1 - R - EXP(-R)) * 1000
         ELSE IF (MOD(I, 2).EQ.0) THEN
            PROF = 2.0 * 2.0/3.0 * EXP(1 - R - EXP(-R)) * 1000
         ELSE
            PROF = 4.0 * 2.0/3.0 * EXP(1 - R - EXP(-R)) * 1000
            END IF
         THICK = THICK + PROF
   10 CONTINUE
C                                       Effective height
      HEIGHT = ALTPK * 1000.0
  999 RETURN
C-----------------------------------------------------------------------
      END
      REAL FUNCTION GAMMA (A, B, ANNTIM)
C-----------------------------------------------------------------------
C   GAMMA returns the gamma function used in the Chiu ionosphere model.
C    Inputs:
C          A        R       dummy parameter
C          B        R       dummy parameter
C          ANNTIM   R       annual time (months), beginning Dec 15th
C   Programmer: C. Flatters, Oct. 1987
C-----------------------------------------------------------------------
      REAL   A, B, ANNTIM
C
      REAL   PI
      PARAMETER (PI = 3.141 592 65)
C-----------------------------------------------------------------------
      GAMMA = 1 + A * (B - COS (PI/3 * ANNTIM) + COS (PI/6 * ANNTIM))
  999 RETURN
C-----------------------------------------------------------------------
      END
      SUBROUTINE MAGDIP (GLAT, GLONG, RADIUS, H)
C-----------------------------------------------------------------------
C   Routine to compute the earth's magnetic field strength from an
C   offset dipole model.  Adapted from Handbook of Geophysics and Space
C   Envirnoments (circa 1965) S. L. Valley ed. Air Force Cambridge
C   Research Laboratories and Chapman and Bartels, 1940, GEOPHYSICS,
C   Oxford)
C      NOTE: The Gaussian coefficients from Chapman and Bartels give
C   a slightly better representation of the field than Valley so these
C   values are used here.
C      Values of H returned are probably good to better than 20%.
C   At the VLA the model is 6% low in total intensity and 11 deg W in
C   magnetic declination.
C    Inputs:
C     GLAT    R    Geocentric latitude (radians)
C     GLONG   R    Geocentric EAST longitude (radians)
C     RADIUS  R    Distance from the center of the earth (m)
C    Output:
C     H(3)    R    Magnetic field vector (gauss),
C                  (1) = positive away from earth center,
C                  (2) = positive east,
C                  (3) = positive north.
C-----------------------------------------------------------------------
      REAL    GLAT, GLONG, RADIUS, H(3)
C
      REAL    RE, FACT, GLATMP, GLONMP, PI,H02, L0, L1, L2, E, SQRT3,
     *   G10, G11, G20, G21, G22, H11, H21, H22, X0, Y0, Z0
      PARAMETER (PI = 3.14159265)
C                                       Geographic coordinates of
C                                       North magnetic pole.
      PARAMETER (GLATMP = 78.63 * PI / 180)
      PARAMETER (GLONMP = 289.85 * PI / 180)
C                                       Gaussian coefficients(gauss):
C                                       From Handbook of Geophysics...
C                                       Epoch 1960.
C                                       Modified??????
C      PARAMETER (G10 = -0.30509)
C      PARAMETER (G11 = -0.02181/2.0)
C      PARAMETER (G20 = -0.02196/2.0)
C      PARAMETER (G21 =  0.05145/3.0)
C      PARAMETER (G22 =  0.01448/4.0)
C      PARAMETER (H11 =  0.05841/2.0)
C      PARAMETER (H21 = -0.03443/3.0)
C      PARAMETER (H22 =  0.00172/4.0)
C                                       Chapman values Epoch 1922
      PARAMETER (G10 = -.3095)
      PARAMETER (G11 = -.0226)
      PARAMETER (G20 = -.0067)
      PARAMETER (G21 = 0.0292)
      PARAMETER (G22 = 0.0143)
      PARAMETER (H11 = 0.0592)
      PARAMETER (H21 = -.0122)
      PARAMETER (H22 = 0.0113)
C                                       SQRT3 = sqrt (3.0)
      PARAMETER (SQRT3 = 1.732050808)
C                                       Compute dipole center in units
C                                       of earth radius.
      PARAMETER (H02 = G10*G10 + G11*G11 + H11*H11)
      PARAMETER (L0  = 2.0*G10*G20 + (G11*G21 + H11*H21) * SQRT3)
      PARAMETER (L1  = -G11*G20 + (G10*G21+G11*G22+H11*H22) * SQRT3)
      PARAMETER (L2 = -H11*G20 + (G10*H21-H11*G22+G11*H22) * SQRT3)
      PARAMETER (E = (L0*G10 + L1*G11 + L2*H11) / (4.0*H02))
      PARAMETER (X0 = (L1 - G11*E) / (3.0*H02))
      PARAMETER (Y0 = (L2 - H11*E) / (3.0*H02))
      PARAMETER (Z0 = (L0 - G10*E) / (3.0*H02))
      REAL   X0M, Y0M, Z0M, HMAG, HD(3), CLA, SLA, CLO, SLO
      DOUBLE PRECISION POS0(3), POS1(3), POSTMP(3), POST2(3), RADDIP,
     *   COLAT, LONDIP, CA, SA, CB, SB
C                                       RE = Radius of earth (avg polar
C                                       and equitorial)
      DATA RE /6367650.0/
C-----------------------------------------------------------------------
C                                       Center of dipole
      X0M = X0 * RE
      Y0M = Y0 * RE
      Z0M = Z0 * RE
C                                       Convert to earth center x,y,z
C                                       Here y=> 90 e long.
      POS0(1) = RADIUS * COS (GLAT) * COS (GLONG)
      POS0(2) = RADIUS * COS (GLAT) * SIN (GLONG)
      POS0(3) = RADIUS * SIN (GLAT)
C                                       Translate
      POSTMP(1) = POS0(1) - X0M
      POSTMP(2) = POS0(2) - Y0M
      POSTMP(3) = POS0(3) - Z0M
C                                       Rotate to dipole coord.
      CA = COS (GLONMP)
      SA = SIN (GLONMP)
      CB = SIN (GLATMP)
      SB = -COS (GLATMP)
      POST2(1) = (POSTMP(1)*CA + POSTMP(2)*SA) * CB +
     *   POSTMP(3) * SB
      POST2(2) = POSTMP(2) * CA - POSTMP(1) * SA
      POST2(3) = POSTMP(3) * CB - SB * (POSTMP(1)*CA + POSTMP(2)*SA)
C                                       Polar coordinates in dipole.
      RADDIP = SQRT (POST2(1)*POST2(1) + POST2(2)*POST2(2) +
     *   POST2(3)*POST2(3))
      COLAT = ACOS (POST2(3) / RADDIP)
      LONDIP = ATAN2 (POST2(2), POST2(1))
      CLA = SIN (COLAT)
      SLA = COS (COLAT)
      CLO = COS (LONDIP)
      SLO = SIN (LONDIP)
C                                       Terms of dipole, local
      FACT = SQRT (H02) * ((RE / RADDIP) ** 3)
      H(1) = -2.0 * FACT * COS (COLAT)
      H(2) = 0.0
      H(3) = FACT * SIN (COLAT)
C                                       Rotate to dipole centered
      HD(1) = (H(1)*CLA - H(3)*SLA) * CLO - H(2) * SLO
      HD(2) = H(2) * CLO + (H(1)*CLA - H(3)*SLA) * SLO
      HD(3) = H(3) * CLA + H(1) * SLA
C                                       Modulus of HD
      HMAG = SQRT (HD(1)*HD(1) + HD(2)*HD(2) + HD(3)*HD(3))
C                                       Find position 1 km from
C                                       position in the direction of HD.
      POST2(1) = POST2(1) + 1000.0 * HD(1) / HMAG
      POST2(2) = POST2(2) + 1000.0 * HD(2) / HMAG
      POST2(3) = POST2(3) + 1000.0 * HD(3) / HMAG
C                                       Rotate new position to earth
C                                       system.
      POSTMP(1) = (POST2(1)*CB - POST2(3)*SB) * CA - POST2(2) * SA
      POSTMP(2) = POST2(2) * CA + (POST2(1)*CB - POST2(3)*SB) * SA
      POSTMP(3) = POST2(3) * CB + POST2(1) * SB
C                                       Translate to earth center
      POS1(1) = POSTMP(1) + X0M
      POS1(2) = POSTMP(2) + Y0M
      POS1(3) = POSTMP(3) + Z0M
C                                       Earth centered field
      HD(1) = (POS1(1) - POS0(1)) * 0.001 * HMAG
      HD(2) = (POS1(2) - POS0(2)) * 0.001 * HMAG
      HD(3) = (POS1(3) - POS0(3)) * 0.001 * HMAG
C                                       Earth local field
      CLA = COS (GLAT)
      SLA = SIN (GLAT)
      CLO = COS (GLONG)
      SLO = SIN (GLONG)
      H(1) = (HD(1)*CLO + HD(2)*SLO) * CLA + HD(3) * SLA
      H(2) = HD(2) * CLO - HD(1) * SLO
      H(3) = HD(3) * CLA - (HD(1)*CLO + HD(2)*SLO) * SLA
C
 999  RETURN
      END
      SUBROUTINE ANTPOS (IERR)
C-----------------------------------------------------------------------
C   Routine to correct for errors in antenna and source position.
C   Corrections are applied to the CL record in Common.
C   Control info from common:
C      PARM(*)  R    (1) = "X" correction (m)
C                    (2) = "Y" correction (m)
C                    (3) = "Z" correction (m)
C                    (4) = 1 if RH, -1 if LH coordinates
C                    (5) = Last source ID number
C                    (6) = RA correction (radians)
C                    (7) = Declination correction (radians)
C                    (8) = 0 for VLBI; > 0 for VLA
C                    (9) = Right ascension drift in rad/day
C                    (10) = declination  drift in rad/day
C      ISTOK    I    Polarization to correct, 1=first, 2=second,
C                    0 = both
C   Output:
C      IERR     I    Return error code , 0=OK else failed.
C-----------------------------------------------------------------------
      INTEGER   IERR
C
      INTEGER   LSTSOU, THSOU, LUN, I, ITEMP, IANT
      DOUBLE PRECISION XT, YT, CFAC, SFAC, FQFAC, EL, RAL, RAR, DECL,
     *   DECR, RAINT, DECINT, TIMED, PRA, PDEC
      REAL      TIME
      LOGICAL   ISPLNT
      DOUBLE PRECISION TCLT, TMESA, TLEFT, TRIGHT, CHAD, SHAD, HA, HAD,
     *   FREQS, CIR, X, Y, Z, DELAYC, RATEC, DDEC, DRA, CI, RADSEC,
     *   DELAY, RATE, PDLY, DPDLY, HRANG,PII, TWOPII, SIND, COSD, COEF
C                                       CI = 1/speed of light
      PARAMETER (CI = 1.0D0 / 2.997925D8)
C                                       COEF: mas => degree
      PARAMETER (COEF = 3.141592653589793D0 /180.0 / 3.6D6)
C                                       RADSEC = earth rot rate in
C                                       rad/sec.
      PARAMETER (RADSEC = 3.1415926535897932384D0 / 43200.0D0)
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DANT.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      SAVE FREQS
      DATA LUN /30/
      DATA PII /3.141592653589793D0/, TWOPII /6.283185307179586D0/
C-----------------------------------------------------------------------
      LSTSOU = PARM(5) + 0.5
      THSOU = CLRECI(SOUCL)
      TIMED = CLRECD(TIMCL)
      TIME = TIMED
C                                       Get source info
      CALL FNDCOO (0, JD0, THSOU, DISKIN, CNOIN, CATBLK, LUN, TIME,
     *   PRA, PDEC, ISPLNT, IERR)
      IF (IERR.NE.0) GO TO 999
      PARM(5) = THSOU
      FREQS = FREQ + FREQO(BIF)
C                                       Declination: correct back
C                                       (SU table already updated)
      PDEC = PDEC - PARM(7)
      SINDEC = SIN (PDEC)
      COSDEC = COS (PDEC)
      PRA = PRA - PARM(6) / COSDEC
C                                       Get local Hour angle
      IANT = CLRECI(ANTCL)
C                                       HA is double precision im the
C                                       SOUEL output
      CALL CSOUEL (IANT, TIMED, PRA, PDEC, HA, EL)
C                                       Get Greenwich hour angle
C                                       for VLBI and stay local one
C                                       for VLA
      IF ((ABS(ARRAYC(1)).LT.1.D2) .AND. (ABS(ARRAYC(2)).LT.1.D2) .AND.
     *   (ABS(ARRAYC(3)).LT.1.D2)) THEN
         HRANG = HA - STNLON(IANT)
         HRANG = DMOD (HRANG, TWOPII)
         IF (HRANG.GT. PII) HRANG = HRANG - TWOPII
         IF (HRANG.LT.-PII) HRANG = HRANG + TWOPII
         HA = HRANG
         END IF
      HAD = HA
      CHAD = COS (HAD)
      SHAD = SIN (HAD)
      IF ((REFANT.LE.0) .OR. (STNX(REFANT).EQ.0.0D0)) THEN
         IF (RF1CL.GT.0) REFANT = CLRECI(RF1CL)
         IF ((REFANT.LE.0) .AND. (RF2CL.GT.0)) REFANT = CLRECI(RF2CL)
         END IF
      IF ((REFANT.LE.0) .OR. (STNX(REFANT).EQ.0.0D0)) THEN
         DO 10 I = 1,MAXANT
            IF ((STNX(I).NE.0.0D0) .AND. (STNY(I).NE.0.0D0) .AND.
     *         (STNZ(I).NE.0.0D0)) THEN
               REFANT = I
               GO TO 20
               END IF
 10         CONTINUE
         REFANT = 1
         END IF
C                                       Antenna coordinates:
C                                       correct for handedness of
C                                       coordinates.
 20   X = STNX(IANT) - STNX(REFANT)
      Y = STNY(IANT) - STNY(REFANT)
      Z = STNZ(IANT) - STNZ(REFANT)
      CIR = CI * RADSEC
C                                       Delay and rate in sec and
C                                       sec/sec. (want corrections).
C                                       The formulae are written
C                                       at the Right Hand coordinate
C                                       system.
C                                       not corrected delay and rate
      DELAY = CI * ((X * CHAD - Y * SHAD) * COSDEC + Z * SINDEC)
      RATE = CIR * (-X * SHAD - Y * CHAD) * COSDEC
      IF (ANAME.EQ.'GMRT') THEN
         DELAY = -DELAY
         RATE = -RATE
         END IF
C                                       correcte antenna coordinates
      X = X + PARM(1)
      Y = Y + PARM(2)
      Z = Z + PARM(3)
C                                       time at the CL table line,
C                                       in days
      TCLT = CLRECD(TIMCL)
C                                       start of variable source
C                                       position correction
      IF (INFILE.EQ.' ') THEN
C                                       TCLT is time relatively OBSTIM
C                                       given at the IMH
C
C                                       PARM(9) is source drift at RA
C                                       No COSDEC!
C                                       PARM(10) is source drift at DEC
         RAINT =  PARM(9) * TCLT
         DECINT = PARM(10) * TCLT
      ELSE
C                                       Interpolate the variable RA,DEC
C                                       correction to the TCLT using
C                                       the INFILE data
         TLEFT = 0.0D0
         TRIGHT = 100.0D0
         DO 100 I = 1, NLINES
C                                       find the nearest point at left
C                                       and right side of TCLT
            TMESA = TMES(I)
            IF ((TMESA.GT.TCLT) .AND. (TMESA.LT.TRIGHT)) THEN
               TRIGHT = TMESA
               RAR = RADR(I)
               DECR = DECDR(I)
               END IF
            IF ((TMESA.LT.TCLT) .AND. (TMESA.GT.TLEFT)) THEN
               TLEFT = TMESA
               RAL = RADR(I)
               DECL= DECDR(I)
               END IF
  100       CONTINUE
            IF (TRIGHT.EQ.100.0D0) THEN
               IF (TLEFT.EQ.0.0D0) THEN
                  RAINT = 0
                  DECINT = 0
               ELSE
                  RAINT = RAL
                  DECINT = DECL
                  END IF
            ELSE
               IF (TLEFT.EQ.0.0D0) THEN
                  RAINT = RAR
                  DECINT = DECR
               ELSE
C                                       make the interpolation itself
                  RAINT = RAL + (RAR-RAL) * (TCLT-TLEFT)/(TRIGHT-TLEFT)
                  DECINT =
     *               DECL+ (DECR-DECL) * (TCLT-TLEFT)/(TRIGHT-TLEFT)
                  END IF
               END IF
C                                       convert RAINT, DECINT from mas
C                                       to radians
         RAINT = COEF * RAINT
C                                       NO COSDEC in RAINT!!
         DECINT = COEF * DECINT
         END IF
C                                       end of variable source position
C                                       correction
C
C                                       Source position error in RA
C                                       direction at the picture plane
      DRA = 0.0
      IF (COSDEC.NE.0.0) DRA = PARM(6) / COSDEC
C                                       Source position error in
C                                       declination direction
      DDEC = PARM(7)
C                                       add the variable part of RA
C                                       correction
      DRA = DRA + RAINT
      DDEC = DDEC + DECINT
C                                       correct hour angle
      CHAD = COS (HAD - DRA)
      SHAD = SIN (HAD - DRA)
C                                       correct declination
      SIND = SIN (PDEC + DDEC)
      COSD = COS (PDEC + DDEC)
C                                       corrected delay and rate
      DELAYC = CI * ((X * CHAD - Y * SHAD) * COSD + Z * SIND)
      RATEC = CIR * (-X * SHAD - Y * CHAD) * COSD
      IF (ANAME.EQ.'GMRT') THEN
         DELAYC = -DELAYC
         RATEC = -RATEC
         END IF
C                                       correction of delay and rate
      PDLY = DELAYC - DELAY
      DPDLY = RATEC - RATE
C                                       exclude correct geom. delay
C                                       LK Sep 8,2005
C                                       Correct CL record
C                                       Geometric delay (2 terms)
C      IF (CLRECD(GDLCL).NE.DBLANK) CLRECD(GDLCL) = CLRECD(GDLCL) - PDLY
C                                       Second term
C      IF ((CLNUMV(CLDDEL).GE.2) .AND. (CLRECD(GDLCL+1).NE.DBLANK))
C     *   CLRECD(GDLCL+1) = CLRECD(GDLCL+1) - DPDLY
C
      IF (ISTOK.NE.2) THEN
         IF (CLRECR(MBD1CL).NE.FBLANK) CLRECR(MBD1CL) = CLRECR(MBD1CL)
     *      + PDLY
         DO 600 I = BIF,EIF
            FQFAC = (FREQS+FRQOFF(I)) * PDLY
            ITEMP = FQFAC
            FQFAC = TWOPI * (FQFAC - ITEMP)
            CFAC = COS (FQFAC)
            SFAC = SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE1CL+I-1)
            YT = CLRECR(IM1CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE1CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM1CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delay
            IF (CLRECR(DE1CL+I-1).NE.FBLANK)
     *         CLRECR(DE1CL+I-1) = CLRECR(DE1CL+I-1) + PDLY
C                                       Phase rate
            IF (CLRECR(RA1CL+I-1).NE.FBLANK)
     *         CLRECR(RA1CL+I-1) = CLRECR(RA1CL+I-1) + DPDLY
 600        CONTINUE
         END IF
      IF (ABS(ISTOK).NE.1) THEN
         IF (CLRECR(MBD2CL).NE.FBLANK) CLRECR(MBD2CL) = CLRECR(MBD2CL)
     *      + PDLY
         DO 700 I = BIF,EIF
            FQFAC = (FREQS+FRQOFF(I)) * PDLY
            ITEMP = FQFAC
            FQFAC = TWOPI * (FQFAC - ITEMP)
            CFAC = COS (FQFAC)
            SFAC = SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE2CL+I-1)
            YT = CLRECR(IM2CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE2CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM2CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delay
            IF (CLRECR(DE2CL+I-1).NE.FBLANK)
     *         CLRECR(DE2CL+I-1) = CLRECR(DE2CL+I-1) + PDLY
C                                       Phase rate
            IF (CLRECR(RA2CL+I-1).NE.FBLANK)
     *         CLRECR(RA2CL+I-1) = CLRECR(RA2CL+I-1) + DPDLY
 700        CONTINUE
         END IF
C
 999  RETURN
      END
      SUBROUTINE REPGAI
C-----------------------------------------------------------------------
C   Routine to replace the complex gains with unit vectors of user
C   specified phase.  New values are written into the CL record in
C   Common.
C   Control info from common:
C      PARM(*)  R    (1,2) real,imaginary part of IF=BIF
C                    (3,4) real,imaginary part of IF=BIF+1 etc.
C      ISTOK    I    Polarization to correct, 1=first, 2=second,
C                    0 = both
C-----------------------------------------------------------------------
C
      INTEGER   I, IP
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
C                                       First polarization
      IF (ISTOK.NE.2) THEN
         IP = 1
         DO 100 I = BIF,EIF
            CLRECR(RE1CL+I-1) = PARM(IP)
            CLRECR(IM1CL+I-1) = PARM(IP+1)
            IP = IP + 2
 100        CONTINUE
         END IF
C                                       Second polarization
      IF (ABS(ISTOK).NE.1) THEN
         IP = 1
         DO 200 I = BIF,EIF
            CLRECR(RE2CL+I-1) = PARM(IP)
            CLRECR(IM2CL+I-1) = PARM(IP+1)
            IP = IP + 2
 200        CONTINUE
         END IF
C
 999  RETURN
      END
      SUBROUTINE CORSBD
C-----------------------------------------------------------------------
C   Routine to make an additive correction to the IF delay residuals in
C   the CL record in common.
C   Control info from common:
C      PARM(*)  R    The corrections, 1 per IF from BIF to EIF.
C      ISTOK    I    Polarization to correct, 1=first, 2=second,
C                    0 = both
C      FRQOFF   D(*) IF frequency offset table (Hz)
C-----------------------------------------------------------------------
C
      INTEGER   I, IP
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
C                                       First polarization
      IF (ISTOK.NE.2) THEN
         IP = 1
         DO 100 I = BIF,EIF
            IF (CLRECR(DE1CL+I-1).NE.FBLANK) CLRECR(DE1CL+I-1) =
     *         CLRECR(DE1CL+I-1) + PARM(IP)
            IP = IP + 1
 100        CONTINUE
         END IF
C                                       Second polarization
      IF (ABS(ISTOK).NE.1) THEN
         IP = 1
         DO 200 I = BIF,EIF
            IF (CLRECR(DE2CL+I-1).NE.FBLANK) CLRECR(DE2CL+I-1) =
     *         CLRECR(DE2CL+I-1) + PARM(IP)
            IP = IP + 1
 200        CONTINUE
         END IF
C
 999  RETURN
      END
      SUBROUTINE CORMBD
C-----------------------------------------------------------------------
C   Routine to make an correction to the IF phase corresponded
C   to a given multiband delay
C   Control info from common:
C      PARM(*)  R    The corrections, 1 per IF from BIF to EIF.
C      ISTOK    I    Polarization to correct, 1=first, 2=second,
C                    0 = both
C      FRQOFF   D(*) IF frequency offset table (Hz)
C-----------------------------------------------------------------------
C
      INCLUDE 'CLCOR.INC'
      INTEGER   I, IP
      REAL      PCOR, CPCOR(MAXIF), SPCOR(MAXIF), GR, GI
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
C                                       Phase corrections
      IP = 1
      DO 50 I = BIF,EIF
         PCOR = -6.283185308 * FRQOFF(I) * PARM(IP)
         CPCOR(I) = COS (PCOR)
         SPCOR(I) = SIN (PCOR)
         IP = IP + 1
 50      CONTINUE
C                                       First polarization
      IF (ISTOK.NE.2) THEN
         IP = 1
         IF (CLRECR(MBD1CL).NE.FBLANK) CLRECR(MBD1CL) =
     *         CLRECR(MBD1CL) + PARM(IP)
         DO 100 I = BIF,EIF
C                                       Correct phase at each IF
            GR = CLRECR(RE1CL+I-1) * CPCOR(I) -
     *           CLRECR(IM1CL+I-1) * SPCOR(I)
            GI = CLRECR(RE1CL+I-1) * SPCOR(I) +
     *           CLRECR(IM1CL+I-1) * CPCOR(I)
            CLRECR(RE1CL+I-1) = GR
            CLRECR(IM1CL+I-1) = GI
            IP = IP + 1
 100        CONTINUE
         END IF
C                                       Second polarization
      IF (ABS(ISTOK).NE.1) THEN
         IP = 1
         IF (CLRECR(MBD2CL).NE.FBLANK) CLRECR(MBD2CL) =
     *         CLRECR(MBD2CL) + PARM(IP)
         DO 200 I = BIF,EIF
C                                       Correct phase at each IF
            GR = CLRECR(RE2CL+I-1) * CPCOR(I) -
     *           CLRECR(IM2CL+I-1) * SPCOR(I)
            GI = CLRECR(RE2CL+I-1) * SPCOR(I) +
     *           CLRECR(IM2CL+I-1) * CPCOR(I)
            CLRECR(RE2CL+I-1) = GR
            CLRECR(IM2CL+I-1) = GI
            IP = IP + 1
 200        CONTINUE
         END IF
C
 999  RETURN
      END
      SUBROUTINE CORRFQ (IERR)
C-----------------------------------------------------------------------
C   Routine to correct for a phase error caused by an error in the
C   Signed Sum of the LOs.
C   Corrections are applied to the CL record in Common.
C   Control info from common:
C      PARM(*)  R    (1) = Frequency error
C                    (4) = 1 if RH, -1 if LH coordinates
C                    (5) = Last source ID number
C      ISTOK    I    Polarization to correct, 1=first, 2=second,
C                    0 = both
C   Output:
C      IERR     I    Return error code , 0=OK else failed.
C-----------------------------------------------------------------------
      INTEGER   IERR
C
      INTEGER   LSTSOU, THSOU, LUN, I, ITEMP, IANT
      REAL      XT, YT, CFAC, SFAC, FQFAC, HA, EL, COSHA, SINHA, AZ,
     *   TIME
      DOUBLE PRECISION FREQS, D(3), S(3), CI, RADSEC, PDLY, TIMED, DRA,
     *   DDEC
      LOGICAL   ISPLNT
C                                       CI = 1/speed of light
      PARAMETER (CI = 1.0D0 / 2.997925D8)
C                                       RADSEC = earth rot rate in
C                                       rad/sec.
      PARAMETER (RADSEC = 3.1415926535897932384D0 / 43200.0D0)
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
C
      SAVE LSTSOU, THSOU, FREQS
      DATA LUN /30/
C-----------------------------------------------------------------------
      LSTSOU = PARM(5) + 0.5
      THSOU = CLRECI(SOUCL)
      TIMED = CLRECD(TIMCL)
      TIME = TIMED
C                                       get source info
      CALL FNDCOO (0, JD0, THSOU, DISKIN, CNOIN, CATBLK, LUN, TIME,
     *   DRA, DDEC, ISPLNT, IERR)
      IF (IERR.NE.0) GO TO 999
      PARM(5) = THSOU
      FREQS = FREQ + FREQO(BIF)
C                                       Declination
      SINDEC = SIN (DDEC)
      COSDEC = COS (DDEC)
C                                       Get Hour angle
      IANT = CLRECI(ANTCL)
      CALL COOELV (IANT, TIMED, DRA, DDEC, HA, EL, AZ)
      COSHA = COS (HA)
      SINHA = SIN (HA)
C                                       Antenna coordinates:
C                                       correct for handedness of
C                                       coordinates.
      D(1) = STNX(IANT)
      D(2) = STNY(IANT)
      D(3) = STNZ(IANT)
C                                       Source position
      S(1) =  COSDEC * COSHA
      S(2) = -COSDEC * SINHA
      S(3) =  SINDEC
C                                       Delay in sec.
      PDLY = CI * (S(1)*D(1) + S(2)*D(2) + S(3)*D(3))
C                                       Correct CL record
      IF (ISTOK.NE.2) THEN
         DO 600 I = BIF,EIF
            FQFAC = PARM(1) * PDLY
            ITEMP = FQFAC
            FQFAC = TWOPI * (FQFAC - ITEMP)
            CFAC = COS (FQFAC)
            SFAC = SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE1CL+I-1)
            YT = CLRECR(IM1CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE1CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM1CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delays and derivatives were
C                                       done correctly.
 600        CONTINUE
         END IF
C                                       2nd polarization
      IF (ABS(ISTOK).NE.1) THEN
         DO 700 I = BIF,EIF
            FQFAC = PARM(1) * PDLY
            ITEMP = FQFAC
            FQFAC = TWOPI * (FQFAC - ITEMP)
            CFAC = COS (FQFAC)
            SFAC = SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE2CL+I-1)
            YT = CLRECR(IM2CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE2CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM2CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delays and derivatives were
C                                       done correctly.
 700        CONTINUE
         END IF
C
 999  RETURN
      END
      SUBROUTINE PTCHPC
C-----------------------------------------------------------------------
C   Routine to patch phase cal values.
C   The expected relationship between the phase in the different IF is
C   given in PARM.  Any valid phases are used to estimate the blanked
C   phases.  If there are no blanked phases then the values in PARM are
C   used.   New values are written into the CL record in
C   Common.
C   Control info from common:
C      PARM(*)  R    Expected phase relationship of IF BIF-EIF (rad).
C      ISTOK    I    Polarization to correct, 1=first, 2=second,
C                    0 = both
C-----------------------------------------------------------------------
C
      INCLUDE 'CLCOR.INC'
      INTEGER   I, J, IP, COUNT
      REAL      FAZ(MAXIF), CSUM, SSUM
      LOGICAL   SOMGOD, ALGOOD, GOOD(MAXIF)
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
C                                       First polarization
      IF (ISTOK.NE.2) THEN
C                                       Get existing phases
         SOMGOD = .FALSE.
         ALGOOD = .TRUE.
         IP = 1
         DO 20 I = BIF,EIF
            IF ((CLRECR(RE1CL+I-1).NE.FBLANK) .AND.
     *         (CLRECR(IM1CL+I-1).NE.FBLANK)) THEN
               FAZ(IP) = ATAN2 (CLRECR(IM1CL+I-1),
     *            CLRECR(RE1CL+I-1)+1.0E-20)
               SOMGOD = .TRUE.
               GOOD(IP) = .TRUE.
            ELSE
               FAZ(IP) = 0.0
               GOOD(IP) = .FALSE.
               ALGOOD = .FALSE.
               END IF
            IP = IP + 1
 20         CONTINUE
C                                       If all valid skip
         IF (ALGOOD) GO TO 500
C                                       If any good values use them to
C                                       estimate the others.
         IP = 1
         IF (SOMGOD) THEN
            DO 60 I = BIF,EIF
               IF (.NOT.GOOD(IP)) THEN
C                                       Average good phases
                  CSUM = 0.0
                  SSUM = 0.0
                  COUNT = 0
                  DO 40 J = BIF,EIF
                     IF (GOOD(J-BIF+1)) THEN
                        COUNT = COUNT + 1
                        CSUM =  CSUM + COS (FAZ(J-BIF+1) - PARM(J-BIF+1)
     *                     + PARM(IP))
                        SSUM =  SSUM + SIN (FAZ(J-BIF+1) - PARM(J-BIF+1)
     *                     + PARM(IP))
                        END IF
 40                  CONTINUE
                  IF (COUNT.GT.0) THEN
                     FAZ(IP) = ATAN2 (SSUM/COUNT, (CSUM/COUNT)+1.0E-20)
                  ELSE
                     FAZ(IP) = PARM(IP)
                     END IF
                  END IF
               IP = IP + 1
 60            CONTINUE
         ELSE
C                                       All blanked - use PARM phases
            DO 80 I = BIF,EIF
               FAZ(IP) = PARM(IP)
               IP = IP + 1
 80            CONTINUE
            END IF
C                                       Replace blanked values
         IP = 1
         DO 100 I = BIF,EIF
            IF (.NOT.GOOD(IP)) THEN
               CLRECR(RE1CL+I-1) = COS (FAZ(IP))
               CLRECR(IM1CL+I-1) = SIN (FAZ(IP))
               END IF
            IP = IP + 1
 100        CONTINUE
         END IF
C                                       Second polarization
 500  IF (ABS(ISTOK).NE.1) THEN
C                                       Get existing phases
         SOMGOD = .FALSE.
         ALGOOD = .TRUE.
         IP = 1
         DO 520 I = BIF,EIF
            IF ((CLRECR(RE2CL+I-1).NE.FBLANK) .AND.
     *         (CLRECR(IM2CL+I-1).NE.FBLANK)) THEN
               FAZ(IP) = ATAN2 (CLRECR(IM2CL+I-1),
     *            CLRECR(RE2CL+I-1)+1.0E-20)
               SOMGOD = .TRUE.
               GOOD(IP) = .TRUE.
            ELSE
               FAZ(IP) = 0.0
               GOOD(IP) = .FALSE.
               ALGOOD = .FALSE.
               END IF
            IP = IP + 1
 520        CONTINUE
C                                       If all valid skip
         IF (ALGOOD) GO TO 999
C                                       If any good values use them to
C                                       estimate the others.
         IP = 1
         IF (SOMGOD) THEN
            DO 560 I = BIF,EIF
               IF (.NOT.GOOD(IP)) THEN
C                                       Average good phases
                  CSUM = 0.0
                  SSUM = 0.0
                  COUNT = 0
                  DO 540 J = BIF,EIF
                     IF (GOOD(J-BIF+1)) THEN
                        COUNT = COUNT + 1
                        CSUM =  CSUM + COS (FAZ(J-BIF+1) - PARM(J-BIF+1)
     *                     + PARM(IP))
                        SSUM =  SSUM + SIN (FAZ(J-BIF+1) - PARM(J-BIF+1)
     *                     + PARM(IP))
                        END IF
 540                 CONTINUE
                  IF (COUNT.GT.0) THEN
                     FAZ(IP) = ATAN2 (SSUM/COUNT, (CSUM/COUNT)+1.0E-20)
                  ELSE
                     FAZ(IP) = PARM(IP)
                     END IF
                  END IF
               IP = IP + 1
 560           CONTINUE
         ELSE
C                                       All blanked - use PARM phases
            DO 580 I = BIF,EIF
               FAZ(IP) = PARM(IP)
               IP = IP + 1
 580           CONTINUE
            END IF
C                                       Replace blanked values
         IP = 1
         DO 600 I = BIF,EIF
            IF (.NOT.GOOD(IP)) THEN
               CLRECR(RE2CL+I-1) = COS (FAZ(IP))
               CLRECR(IM2CL+I-1) = SIN (FAZ(IP))
               END IF
            IP = IP + 1
 600        CONTINUE
         END IF
C
 999  RETURN
      END
      SUBROUTINE ANAXIS (IERR)
C-----------------------------------------------------------------------
C   Routine to correct for errors in antenna axis offset
C   Corrections are applied to the CL record in Common.
C   Control info from common:
C      PARM(1)  R    (1) = axis offset (m)
C   Output:
C      IERR     I    Return error code , 0=OK else failed.
C   All IFs and all polarizations are corrected
C-----------------------------------------------------------------------
      INTEGER   IERR
C
      INTEGER   LSTSOU, THSOU, LUN, I, ITEMP, IANT, MOUNT
      REAL      XT, YT, CFAC, SFAC, FQFAC, HA, EL, CHA, SHA, AZ, TIME
      DOUBLE PRECISION FREQS, LAT, SL, CL, BRACK, SQR, CI, RADSEC,
     *   PDLY, DPDLY, TIMED, DRA, DDEC
      LOGICAL   ISPLNT
C                                       CI = 1/speed of light
      PARAMETER (CI = 1.0D0 / 2.997925D8)
C                                       RADSEC = earth rot rate in
C                                       rad/sec.
      PARAMETER (RADSEC = 3.1415926535897932384D0 / 43082.0D0)
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      SAVE  FREQS
      DATA LUN /30/
C-----------------------------------------------------------------------
      LSTSOU = PARM(NANTSL + 1) + 0.5
      THSOU = CLRECI(SOUCL)
      TIMED = CLRECD(TIMCL)
      TIME = TIMED
C                                       get source info
      CALL FNDCOO (0, JD0, THSOU, DISKIN, CNOIN, CATBLK, LUN, TIME,
     *   DRA, DDEC, ISPLNT, IERR)
      IF (IERR.NE.0) GO TO 999
      PARM(NANTSL + 1) = THSOU
      FREQS = FREQ + FREQO(BIF)
C                                       Declination
      SINDEC = SIN (DDEC)
      COSDEC = COS (DDEC)
      IANT = CLRECI(ANTCL)
      CALL COOELV (IANT, TIMED, DRA, DDEC, HA, EL, AZ)
C                                       Antenna mount
      MOUNT = MNTYP(IANT)
C                                       Altaz or Nasmyth mount
C                       (folded cassegrain is a varient of Nasmyth)
      IF (MOUNT.EQ.0) THEN
         CHA = COS (HA)
         SHA = SIN (HA)
C                                       Antenna latitude
         LAT = STNLAT(IANT)
         SL = DSIN(LAT)
         CL = DCOS(LAT)
         BRACK = SL*SINDEC + CL*COSDEC*CHA
         SQR = DSQRT(1.D0 - BRACK*BRACK)
C                                       Delay and rate in sec and
C                                       sec/sec. (want corrections).
         PDLY = (AXOFF*CI) * SQR
         DPDLY = ((AXOFF*CI)*BRACK/SQR) * CL * COSDEC * SHA * RADSEC
C                                       XY-EW mount
      ELSE IF (MOUNT.EQ.3) THEN
         CHA = COS (HA)
         SHA = SIN (HA)
C                                       Antenna latitude
         LAT = STNLAT(IANT)
         SL = DSIN(LAT)
         CL = DCOS(LAT)
         BRACK = SHA*COSDEC
         SQR = DSQRT(1.D0 - BRACK*BRACK)
C                                       Delay and rate in sec and
C                                       sec/sec. (want corrections).
         PDLY = (AXOFF*CI) * SQR
         DPDLY = ((AXOFF*CI)*BRACK/SQR) * CL * COSDEC * SHA * RADSEC

C                                       Equatorial mount
      ELSE IF (MOUNT.EQ.1) THEN
         PDLY = AXOFF*CI*COSDEC
         DPDLY = 0.0
         END IF
C                                       exclude correction of geom.
C                                       delay
C                                       LK Sep 8, 2005
C                                       Correct CL record
C                                       Geometric delay (2 terms)
C      IF (CLRECD(GDLCL).NE.DBLANK) CLRECD(GDLCL) = CLRECD(GDLCL) - PDLY
C                                       Second term
C      IF ((CLNUMV(CLDDEL).GE.2) .AND. (CLRECD(GDLCL+1).NE.DBLANK))
C     *   CLRECD(GDLCL+1) = CLRECD(GDLCL+1) - DPDLY
C                                       Correct the first polarization
      IF (ISTOK.NE.2) THEN
         DO 600 I = 1,NUMIF
            FQFAC = (FREQS+FRQOFF(I)) * PDLY
            ITEMP = FQFAC
            FQFAC = TWOPI * (FQFAC - ITEMP)
            CFAC = COS (FQFAC)
            SFAC = SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE1CL+I-1)
            YT = CLRECR(IM1CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE1CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM1CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delay
            IF (CLRECR(DE1CL+I-1).NE.FBLANK)
     *         CLRECR(DE1CL+I-1) = CLRECR(DE1CL+I-1) + PDLY
C                                       Phase rate
            IF (CLRECR(RA1CL+I-1).NE.FBLANK)
     *         CLRECR(RA1CL+I-1) = CLRECR(RA1CL+I-1) + DPDLY
 600        CONTINUE
         END IF
C                                       Correct the second polarization
C                                       if it exists
      IF (ABS(ISTOK).NE.1) THEN
         DO 700 I = 1, NUMIF
            FQFAC = (FREQS+FRQOFF(I)) * PDLY
            ITEMP = FQFAC
            FQFAC = TWOPI * (FQFAC - ITEMP)
            CFAC = COS (FQFAC)
            SFAC = SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE2CL+I-1)
            YT = CLRECR(IM2CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE2CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM2CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delay
            IF (CLRECR(DE2CL+I-1).NE.FBLANK)
     *         CLRECR(DE2CL+I-1) = CLRECR(DE2CL+I-1) + PDLY
C                                       Phase rate
            IF (CLRECR(RA2CL+I-1).NE.FBLANK)
     *         CLRECR(RA2CL+I-1) = CLRECR(RA2CL+I-1) + DPDLY
  700       CONTINUE
         END IF
C
 999  RETURN
      END
      SUBROUTINE CSOUEL (ANTNO, TIME, PRA, PDEC, HA, EL)
C-----------------------------------------------------------------------
C   Subroutine to compute the apparent source elevations based on source
C   and antenna coordinates in common.  The routines GETANT and GETSOU
C   should be called before this routine to but the correct values in
C   the relevant commons.
C   Inputs:
C      ANTNO      I    Antenna number
C      TIME       D    Current data time (days).
C      PRA        D    Apparent RA of source
C      PDEC       D    Apparent Declination of source.
C   Input from common:
C      STNLAT     D(*) Antenna latitude (rad).
C      STNLON     D(*) Antenna east longitudes (rad).
C      GSTIAT     D    GST at IAT=0 of reference day (rad).
C      ROTIAT     D    Rotation of the earth rate in IAT.
C   Output:
C      HA         D    Source hour angle (rad) wrt to telescope
C      EL         R    Source elevation (rad) at telescope
C-----------------------------------------------------------------------
      INTEGER   ANTNO
      DOUBLE PRECISION TIME, PRA, PDEC
      DOUBLE PRECISION    EL
      DOUBLE PRECISION    HRANG, ANTLST, DARG, DRA, DDEC, PI, TWOPI, HA
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DANS.INC'
      DATA PI /3.141592653589793/, TWOPI/6.283185307179586/
C-----------------------------------------------------------------------
C                                       Antenna LST
      ANTLST = GSTIAT + STNLON(ANTNO) + TIME * ROTIAT
C                                       Source position; if apparent
C                                       position missing use mean
C                                       position.
      DRA = PRA
      DDEC = PDEC
C                                       Hour angle
      HRANG = ANTLST - DRA
C                                       Limit to between 0 and 2pi
      HRANG = DMOD (HRANG, TWOPI)
C                                       translate to between -pi and pi
      IF (HRANG.GT. PI) HRANG = HRANG - TWOPI
      IF (HRANG.LT.-PI) HRANG = HRANG + TWOPI
      HA = HRANG
C                                       Elevation angle
      DARG = SIN (STNLAT(ANTNO)) * SIN (DDEC) + COS (STNLAT(ANTNO))
     *   * COS (DDEC) * COS (HRANG)
      EL = (1.570796327 - ACOS (DARG))
C
 999  RETURN
      END
      SUBROUTINE ANTMOD (DISK, CNO, SUBA, ANTNO, PARM, IERR)
C-----------------------------------------------------------------------
C   Subroutine to make the correction of the selected antenna position
C   if OPCODE ='ANTP' and the antenna correction parameters are not
C   equal zero.
C   Inputs:
C      DISK       I    The file disk number
C      CNO        I    The file catalog slot number.
C      ANTNO      I    The antenna number
C      SUBA       I    Subarray number (AN table number)
C      PARM(*)    R    Array of corrections
C   Input from common:
C-----------------------------------------------------------------------
      INTEGER   DISK, CNO, SUBA, ANTNO, IERR
      REAL      PARM(*)
C
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   I, LUN1, BUFFAN(512), NENTRY
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DANT.INC'
      DATA LUN1 /28/
C-----------------------------------------------------------------------
C                                       Open for write: existing file
C                                       so parameters need not be set
      CALL ANTINI ('WRIT', BUFFAN, DISK, CNO, SUBA, CATBLK, LUN1,
     *   IANRNO, ANKOLS, ANNUMV, ARRAYC, GSTIA0, DEGPDY, SAFREQ, RDATE,
     *   POLRXY, UT1UTC, DATUTC, TIMSYS, ANAME, XYZHAN, TFRAME, NUMORB,
     *   NOPCAL, ANTNIF, ANFQID, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1100) IERR
         CALL MSGWRT (8)
         GO TO 999
         END IF
C                                       Loop through AN rows correcting
C                                       the selected antenna position
      NENTRY = BUFFAN(5)
      DO 300 I = 1, NENTRY
         IANRNO = I
         CALL TABAN ('READ', BUFFAN, IANRNO, ANKOLS, ANNUMV, ANNAME,
     *      STAXYZ, ORBPRM, NOSTA, MNTSTA, STAXOF, DIAMAN, FWHMAN,
     *      POLTYA, POLAA, POLCA, POLTYB, POLAB, POLCB, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1200) IERR, I
            CALL MSGWRT (8)
            GO TO 999
            END IF
C                                       Put the correction here
         IF (NOSTA.EQ.ANTNO) THEN
            STAXYZ(1) = STAXYZ(1) + PARM(1)
            STAXYZ(2) = STAXYZ(2) + PARM(2)
            STAXYZ(3) = STAXYZ(3) + PARM(3)
            END IF
         IANRNO = I
         CALL TABAN ('WRIT', BUFFAN, IANRNO, ANKOLS, ANNUMV, ANNAME,
     *      STAXYZ, ORBPRM, NOSTA, MNTSTA, STAXOF, DIAMAN, FWHMAN,
     *      POLTYA, POLAA, POLCA, POLTYB, POLAB, POLCB, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1300) IERR, I
            CALL MSGWRT (8)
            GO TO 999
            END IF
 300     CONTINUE
C                                       Close table
      CALL TABIO ('CLOS', 1, IANRNO, BUFFAN, BUFFAN, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1400) IERR
         CALL MSGWRT (8)
         GO TO 999
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1100 FORMAT ('ANTMOD: ERROR',I3,' READING OUTPUT AN TABLE')
 1200 FORMAT ('ANTMOD: ERROR',I3,' READING AN ROW ',I4)
 1300 FORMAT ('ANTMOD: ERROR',I3,' WRITING AN ROW ',I4)
 1400 FORMAT ('ANTMOD: ERROR',I3,' CLOSING OUTPUT AN TABLE')
      END
      SUBROUTINE SOUMOD (IDIR, DISK, CNO, SOUS, DX, DY, IERR)
C-----------------------------------------------------------------------
C   Subroutine to make the correction of the selected source position
C   if OPCODE ='ANTP' and the source correction parameters are not
C   equal zero.
C   Inputs:
C      IDIR    I        Direction: 0 -> add to apparent, find mean
C                                  1 -> add to mean, find apparent
C      DISK    I        The file disk number
C      CNO     I        The file catalog slot number.
C      SOUS    I        The source ID number
C   In/out: out = correction in apparent coord
C      DX      D        Correction at the picture plane in RA direction,
C                       in degrees.
C      DY      D        Correction at DEC, in degrees.
C   Input from common /MAPHDR/
C      CATBLK  I(256)   Catalog header record.
C-----------------------------------------------------------------------
      INTEGER   IDIR, DISK, CNO, SOUS, IERR
      DOUBLE PRECISION DX, DY
C                                       Declarations for recalculation
C                                       aparent coordinates to epoch
      INTEGER   DIR
      REAL      POLAR(2)
      CHARACTER OBSDAT*8
      DOUBLE PRECISION JD, DELDAT, OBSPOS(3), RAATT, DECTT, DRA, COSDEC
      LOGICAL   GR
C
      INTEGER   BUFFER(512)
C                                       Declarations for SOUINI
      INCLUDE 'INCS:PUVD.INC'
      CHARACTER VELDEF*8, VELTYP*8, CALCOD*4, SOUNAM*16
      INTEGER   JERR, IDSOU, SUKOLS(MAXSUC), LUN, SUNUMV(MAXSUC),
     *   QUAL, NUMIF, NSOURC, I, ISURNO, SUFQID
      DOUBLE PRECISION    BANDW, RAEPO, DECEPO, EPOCH, RAAPP, DECAPP,
     *   PMRA, PMDEC, TRA, TDEC, LDX, LDY, RAOBS, DECOBS, TEPOCH, TAAPP,
     *   TECAPP
      REAL      FLUX(4,MAXIF)
      DOUBLE PRECISION    LSRVEL(MAXIF), FREQO(MAXIF), LRESTF(MAXIF)
      INCLUDE 'INCS:PSTD.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA DELDAT, OBSPOS, POLAR /1.D-6, 0.D0, 0.D0, 0.D0, 0., 0./
      DATA LUN /28/
C-----------------------------------------------------------------------
C                                       take RA, DEC(EPOC) from the
C                                       catalog
      RA = CATD(KDCRV+JLOCR)
      DEC = CATD(KDCRV+JLOCD)
      LDX = DX * 3.6D3
      LDY = DY * 3.6D3
C                                       Open for READ first to set
C                                       all variables
C                                       Open SU table
      CALL SOUINI ('READ', BUFFER, DISK, CNO, 1, CATBLK, LUN,
     *   NUMIF, VELDEF, VELTYP, SUFQID, ISURNO, SUKOLS, SUNUMV, JERR)
C                                       Go to modify the source
C                                       position at the header
C                                       if there is no SU table
      IF (JERR.NE.0) GO TO 400
C                                       then close
      CALL TABIO ('CLOS', 0, 1, BUFFER, BUFFER, JERR)
C                                       Open for write
      CALL SOUINI ('WRIT', BUFFER, DISK, CNO, 1, CATBLK, LUN,
     *   NUMIF, VELDEF, VELTYP, SUFQID, ISURNO, SUKOLS, SUNUMV, JERR)
      IF (JERR.NE.0) THEN
         WRITE (MSGTXT,1100)
         CALL MSGWRT (8)
         GO TO 999
         END IF
C                                       Loop through SU rows modifing
C                                       the selected source position
      NSOURC = BUFFER(5)
C                                       Find time of observation
      CALL H2CHR (8, 1, CATH(KHDOB), OBSDAT)
C                                       Find Julian day, JD
      CALL JULDAY(OBSDAT, JD)
      EPOCH = CATR(KREPO)
      GR = .TRUE.
      DO 300 I = 1, NSOURC
C                                       Read record
         ISURNO = I
         CALL TABSOU ('READ', BUFFER, ISURNO, SUKOLS, SUNUMV,
     *      IDSOU, SOUNAM, QUAL, CALCOD, FLUX, FREQO, BANDW, RAEPO,
     *      DECEPO, TEPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL,
     *      LRESTF, PMRA, PMDEC, JERR)
         IF (JERR.NE.0) THEN
            WRITE (MSGTXT,1200) I
            CALL MSGWRT (8)
            GO TO 999
            END IF
C                                       Do not trust apparent coords
C                                       recompute and compare
         RAATT = RAEPO * DG2RAD
         DECTT = DECEPO * DG2RAD
         DIR = 1
         CALL JPRECS (JD, EPOCH, DELDAT, DIR, GR, OBSPOS, POLAR,
     *      RAATT, DECTT, TAAPP, TECAPP)
         TAAPP = RAD2DG * TAAPP
         TECAPP = RAD2DG * TECAPP
         IF (RAEPO.LT.0.0) RAEPO = RAEPO + 360.0D0
         IF (TAAPP.LT.0.0) TAAPP = TAAPP + 360.0D0
         IF (RAAPP.LT.0.0) RAAPP = RAAPP + 360.0D0
         IF ((ABS(TAAPP-RAAPP).GT.1.0D-2) .OR.
     *      (ABS(DECAPP-TECAPP).GT.1.0D-2)) THEN
            MSGTXT = 'CORRECTING BAD APPARENT COORDINATES FOR ' //
     *         SOUNAM
            CALL MSGWRT (7)
            END IF
         RAAPP = TAAPP
         DECAPP = TECAPP
C                                       Put the correction here
         IF (IDSOU.EQ.SOUS) THEN
C                                       add to apparent, find epoch
            IF (IDIR.EQ.0) THEN
C                                       Recalculate the source position
C                                       error in RA from the error at
C                                       the picture plane
               COSDEC = COS (DECAPP * DG2RAD)
               DRA = 0.0
               IF (COSDEC.NE.0.0) DRA = DX / COSDEC
               TRA = RAEPO
               TDEC = DECEPO
               RAAPP  = RAAPP + DRA
               DECAPP = DECAPP + DY
C                                       Find RAEPO, DECEPO for
C                                       the given epoch
               RAATT = RAAPP * DG2RAD
               DECTT = DECAPP * DG2RAD
               DIR = -1
               CALL JPRECS (JD, EPOCH, DELDAT, DIR, GR, OBSPOS, POLAR,
     *            RAEPO, DECEPO, RAATT, DECTT)
               COSDEC = COS (DECEPO)
               RAEPO = RAEPO * RAD2DG
               DECEPO = DECEPO * RAD2DG
               TRA = (RAEPO - TRA) * 3.6D3 * COSDEC
               TDEC = (DECEPO - TDEC) * 3.6D3
               WRITE (MSGTXT,1000) 'Apparent', LDX, LDY
               CALL MSGWRT (3)
               WRITE (MSGTXT,1000) 'Epoch   ', TRA, TDEC
               CALL MSGWRT (3)
C                                       add to epoch, find apparent
            ELSE
               COSDEC = COS (DECEPO * DG2RAD)
               DRA = 0.0
               IF (COSDEC.NE.0.0) DRA = DX / COSDEC
               TRA = RAAPP
               TDEC = DECAPP
               RAEPO  = RAEPO + DRA
               DECEPO = DECEPO + DY
C                                       Find RAEPO, DECEPO for
C                                       the given epoch
               RAATT = RAEPO * DG2RAD
               DECTT = DECEPO * DG2RAD
               DIR = 1
               CALL JPRECS (JD, EPOCH, DELDAT, DIR, GR, OBSPOS, POLAR,
     *            RAATT, DECTT, RAAPP, DECAPP)
               COSDEC = COS (TDEC*DG2RAD)
               RAAPP = RAAPP * RAD2DG
               DECAPP = DECAPP * RAD2DG
               TRA = (RAAPP - TRA) * 3.6D3 * COSDEC
               TDEC = (DECAPP - TDEC) * 3.6D3
               WRITE (MSGTXT,1000) 'Epoch   ', LDX, LDY
               CALL MSGWRT (3)
               WRITE (MSGTXT,1000) 'Apparent', TRA, TDEC
               CALL MSGWRT (3)
               DX = TRA / 3.6D3
               DY = TDEC / 3.6D3
               END IF
            END IF
         ISURNO = I
         CALL TABSOU ('WRIT', BUFFER, ISURNO, SUKOLS, SUNUMV, IDSOU,
     *      SOUNAM, QUAL, CALCOD, FLUX, FREQO, BANDW, RAEPO, DECEPO,
     *      EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL, LRESTF, PMRA,
     *      PMDEC, JERR)
         IF (JERR.NE.0) THEN
            WRITE (MSGTXT,1300) I
            CALL MSGWRT (8)
            GO TO 999
            END IF
 300     CONTINUE
C
C                                       Close table
      CALL TABIO ('CLOS', 0, 1, BUFFER, BUFFER, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1400)
         CALL MSGWRT (8)
         GO TO 999
         END IF
C                                       Modify the epoc RA, DEC at the
C                                       header if there is only one
C                                       source at the SU table and
C                                       RA.NE.0 or DEC.NE.0 at the header
      IF ((NSOURC.EQ.1 .AND.
     *      (ABS(RA).GT.0.0001) .OR. ABS(DEC).GT.0.0001)) THEN
         CATD(KDCRV+JLOCR) = RAEPO
         CATD(KDCRV+JLOCD) = DECEPO
         CALL CATIO ('UPDT', DISK, CNO, CATBLK, 'REST', BUFFER, IERR)
         END IF
      GO TO 999
C                                       Modify the epoc RA, DEC at the
C                                       header if there is no SU table
 400  WRITE (MSGTXT,1400)
      CALL MSGWRT (4)
C                                       Find time of observation
      CALL H2CHR (8, 1, CATH(KHDOB), OBSDAT)
C                                       Find Julian day, JD
      CALL JULDAY(OBSDAT, JD)
C                                       Find RAAPP, DECAP for
C                                       observation date.
      EPOCH = CATR(KREPO)
      RAEPO = RA * DG2RAD
      DECEPO = DEC * DG2RAD
      GR = .TRUE.
      DIR = 1
      CALL JPRECS (JD, EPOCH, DELDAT, DIR, GR, OBSPOS, POLAR,
     *   RAEPO, DECEPO, RAAPP, DECAPP)
      IERR = 0
C                                       add to apparent
      IF (IDIR.EQ.0) THEN
         TRA = RAEPO
         TDEC = DECEPO
C                                       Recalculate the source position
C                                       error in RA from the error at
C                                       the picture plane
         COSDEC = COS (DECAPP)
         DRA = 0.0
         IF (COSDEC.NE.0.0) DRA = DX / COSDEC
         RAAPP  = RAAPP + DRA*DG2RAD
         DECAPP = DECAPP + DY*DG2RAD
C                                       Find RAEPO, DECEPO for the
C                                       corrected RAAPP, DECAPP
         GR = .TRUE.
         DIR = -1
         CALL JPRECS (JD, EPOCH, DELDAT, DIR, GR, OBSPOS, POLAR,
     *      RAEPO, DECEPO, RAAPP, DECAPP)
         COSDEC = COS (DECEPO)
         RAEPO = RAEPO * RAD2DG
         DECEPO = DECEPO * RAD2DG
         TRA = (RAEPO - TRA) * 3.6D3 * COSDEC
         TDEC = (DECEPO - TDEC) * 3.6D3
         WRITE (MSGTXT,1000) 'Epoch', TRA, TDEC
         CALL MSGWRT (3)
C                                       add to EPOCH
      ELSE
         TRA = RAAPP * RAD2DG
         TDEC = DECAPP * RAD2DG
         RAEPO = RA * DG2RAD
         DECEPO = DEC * DG2RAD
         COSDEC = COS (DECEPO)
         DRA = 0.0
         IF (COSDEC.NE.0.0) DRA = DX / COSDEC
         RAEPO  = RAEPO + DRA*DG2RAD
         DECEPO = DECEPO + DY*DG2RAD
         DIR = 1
         CALL JPRECS (JD, EPOCH, DELDAT, DIR, GR, OBSPOS, POLAR,
     *      RAEPO, DECEPO, RAAPP, DECAPP)
         COSDEC = COS (DECAPP)
         RAAPP = RAAPP * RAD2DG
         DECAPP = DECAPP * RAD2DG
         TRA = (RAAPP - TRA) * 3.6D3 * COSDEC
         TDEC = (DECAPP - TDEC) * 3.6D3
         WRITE (MSGTXT,1000) 'Apparent', TRA, TDEC
         CALL MSGWRT (3)
         DX = TRA / 3.6D3
         DY = TDEC / 3.6D3
         END IF
      CATD(KDCRV+JLOCR) = RAEPO * RAD2DG
      CATD(KDCRV+JLOCD) = DECEPO * RAD2DG
      RA = CATD(KDCRV+JLOCR)
      DEC = CATD(KDCRV+JLOCD)
      CALL CATIO ('UPDT', DISK, CNO, CATBLK, 'REST', BUFFER, IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SOUMOD: change in ',A,' RA,DEC',2(1PE13.5),' asec')
 1100 FORMAT ('SOUMOD: SU table is not modified.',
     *   ' Error opening SU table')
 1200 FORMAT ('SOUMOD: SU table is not modified. Error reading row',I4)
 1300 FORMAT ('SOUMOD: SU table is not modified. Error writing row',I4)
 1400 FORMAT ('SOUMOD: Error closing SU table')
      END
      SUBROUTINE GETINP (FILE, IERR)
C-----------------------------------------------------------------------
C  This subroutine reads, from an input file specified by name "file",
C  the list of the vertical atmosphere delays for the given antenna
C  and time.
C
C   Inputs:
C    FILE     C*48  File name
C   Outputs in common:
C    NLINES    I     Number of data lines
C    IAN(*)    I     The antenna number
C    TMES(*)   D     The measurement time, in days
C    VERDEL(*) R     The atmosphere vertical delay, in cm
C    CLKDEL(*) R     The clock delay, in cm
C    DVERDE(*) R     Zenith atmos. delay derivative, in sec/sec*1.0E14
C    DCLKDE(*) R     Clock drift in sec/sec*1.0E14
C   Outputs:
C    IERR     I     Return code, 0=>OK
C-----------------------------------------------------------------------
      CHARACTER FILE*48
      INTEGER   I, IERR
      INTEGER   LUN, FIND, NBYTES, KBP, IA, IIANT, NANSEL
      LOGICAL   F
      CHARACTER   CNUMBS(11)
      LOGICAL DONUM, DOCHA
      INTEGER IND
C
      INTEGER  DD, HH, MM, JT, JTRIM
      REAL SS
      CHARACTER LINE*80
      CHARACTER CX*3
      DOUBLE PRECISION X
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DANS.INC'
      DATA F /.FALSE./
      DATA CNUMBS /' ','0','1','2','3','4','5','6','7','8','9'/
C-----------------------------------------------------------------------
C                                       Open text file
      LUN = 10
      CALL ZTXOPN ('READ', LUN, FIND, FILE, F, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1001)
         GO TO 990
         END IF
C                                       Get number of lines
      CALL ZTXIO ('READ', LUN, FIND, LINE, IERR)
      IF (IERR.NE.0) GO TO 980
      JT = JTRIM (LINE)
C                                       Get value
      KBP = 1
      NBYTES = 80
      CALL GETNUM (LINE, NBYTES, KBP, X)
      NLINES = X + 0.1
C                                       check for date info
      KBP = INDEX (LINE, 'JD=')
      JDDIFF = 0.0D0
      IF (KBP.GT.0) THEN
         KBP = KBP + 3
         CALL GETNUM (LINE, NBYTES, KBP, X)
         IF (X.NE.DBLANK) JDDIFF = X - JD
         END IF

C                                       Tell user
      WRITE (MSGTXT,2000) NLINES, JDDIFF
      CALL MSGWRT (6)
C                                       antennas are in numbers or
C                                       in two characters?
C                                       Look the first line only!
      CALL ZTXIO ('READ', LUN, FIND, LINE, IERR)
      IF (IERR.NE.0) GO TO 980
      JT = JTRIM (LINE)
C                                       Get antenna value
      READ (LINE, 1111) CX
C                                       Antenna in characters if at
C                                       least one char (in 3 chars)
C                                       is not number
C      DOCHA = .FALSE.
C      DONUM = .TRUE.
      DO 10 IND = 1, 11
         IF (CX(1:1).EQ.CNUMBS(IND)) THEN
C                                       the first symbol is number
            DONUM = .TRUE.
            DOCHA = .FALSE.
            GO TO 15
            END IF
   10    CONTINUE
C                                       The first of 3 is char
      DOCHA = .TRUE.
      DONUM = .FALSE.
      GO TO 40
   15 CONTINUE
C
      DO 20 IND = 1, 11
         IF (CX(2:2).EQ.CNUMBS(IND)) THEN
C                                       the second symbol is number
            DONUM = .TRUE.
            DOCHA = .FALSE.
            GO TO 25
            END IF
   20    CONTINUE
C                                       The second of 3 is char
      DOCHA = .TRUE.
      DONUM = .FALSE.
      GO TO 40
   25 CONTINUE
      DO 30 IND = 1, 11
         IF (CX(3:3).EQ.CNUMBS(IND)) THEN
C                                       the third symbol is number
            DONUM = .TRUE.
            DOCHA = .FALSE.
            GO TO 40
            END IF
   30    CONTINUE
C                                       The third of 3 is char
      DOCHA = .TRUE.
      DONUM = .FALSE.
   40    CONTINUE
C
      NANSEL =  NANTSL
C                                       all antennas selected
C                                       (ANTENNAS = 0)
      IF (NANTSL.EQ.0) NANSEL = NSTNS
C                                       Read measurment info
      DO 100 I = 1,NLINES
         IF (I.GT.1) THEN
            CALL ZTXIO ('READ', LUN, FIND, LINE, IERR)
            IF (IERR.NE.0) GO TO 980
            JT = JTRIM (LINE)
            END IF
C                                       Get values
         IF (DONUM) THEN
C                                       Numbers stand for antennas
            KBP = 1
            CALL GETNUM (LINE, NBYTES, KBP, X)
            IAN(I) = X
         ELSE
C                                       characters stand for antennas
            READ (LINE, 1111) CX
C                                       identify IAN(I) to zero
            IAN(I) = 0
C                                       find the antenna number
C                                       corresponed to the name CX
            DO 60 IA = 1, NANSEL
               IF (NANTSL.EQ.0) THEN
                  IIANT = IA
               ELSE
                  IIANT = ANTENS(IA)
                  END IF
               IF (STNNAM(IIANT)(1:2).EQ.CX(1:2)) THEN
                  IAN(I) = IIANT
                  GO TO 80
                  END IF
   60          CONTINUE
   80       CONTINUE
C
            KBP = 4
            END IF
C
         CALL GETNUM (LINE, NBYTES, KBP, X)
         DD = X
         CALL GETNUM (LINE, NBYTES, KBP, X)
         HH = X
         CALL GETNUM (LINE, NBYTES, KBP, X)
         MM = X
         CALL GETNUM (LINE, NBYTES, KBP, X)
         SS = X
C                                       Tell user
         TMES(I) = DD + HH/24.0 + MM/(24.*60.) + SS/(24.*3600.) + JDDIFF
         CALL GETNUM (LINE, NBYTES, KBP, X)
         VERDEL(I) = X
         CALL GETNUM (LINE, NBYTES, KBP, X)
         CLKDEL(I) = X
         CALL GETNUM (LINE, NBYTES, KBP, X)
         DVERDE(I) = X
         CALL GETNUM (LINE, NBYTES, KBP, X)
         DCLKDE(I) = X
C         WRITE (MSGTXT,2001) I, IAN(I), DD, HH, MM, SS, TMES(I),
C     *      VERDEL(I), CLKDEL(I), DVERDE(I), DCLKDE(I)
C         CALL MSGWRT (6)
 100     CONTINUE
C                                       close input file
      CALL ZTXCLS (LUN, FIND, IERR)
C
      GO TO 999
C                                       Read error
 980  WRITE (MSGTXT,1980) IERR
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1001 FORMAT ('ERROR ',I3,' OPENING  INFO TEXT FILE')
 1111 FORMAT (A3)
 1980 FORMAT ('ERROR ',I3,' READING ANTENNA INFO TEXT FILE')
 2000 FORMAT ('Number of lines = ',I4,'  JD difference=',F5.2)
C2001 FORMAT (I4,I3,1X,3(I2,':'),F4.1,F12.8,F6.2,F6.2,F12.5,F12.5)
      END
      SUBROUTINE GETRAD (FILE, IERR)
C-----------------------------------------------------------------------
C  This subroutine reads, the list of the RA, DEC corrections and
C  the relevant times from an input file specified by name "file",
C
C   Inputs:
C    FILE     C*48  File name
C   Outputs in common:
C    NLINES    I     Number of data lines
C    TMES(*)   D     The measurement time, in days
C    RADR(*)   R     RA corrections, in mas
C    DECDR(*)  R     DEC corrections, in mas
C   Outputs:
C    IERR     I     Return code, 0=>OK
C-----------------------------------------------------------------------
      CHARACTER FILE*48
      CHARACTER OBSDAT*8
      INTEGER   I, IERR
      INTEGER   LUN, FIND, NBYTES, KBP, JT, JTRIM
      LOGICAL   F
C
      CHARACTER LINE*80
      DOUBLE PRECISION X
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA F /.FALSE./
C-----------------------------------------------------------------------
C                                       Find time of observation
      CALL H2CHR (8, 1, CATH(KHDOB), OBSDAT)
C                                       Find Julian day, JD
      CALL JULDAY(OBSDAT, JD)
C                                       Open text file
      LUN = 10
      CALL ZTXOPN ('READ', LUN, FIND, FILE, F, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1001)
         GO TO 990
         END IF
C                                       Get number of lines
      CALL ZTXIO ('READ', LUN, FIND, LINE, IERR)
      IF (IERR.NE.0) GO TO 980
      JT = JTRIM (LINE)
C                                       Get value
      KBP = 1
      NBYTES = 80
      CALL GETNUM (LINE, NBYTES, KBP, X)
      NLINES = X + 0.1
C                                       Tell user
      WRITE (MSGTXT,2000) NLINES
      CALL MSGWRT (6)
C                                       Read measurment info
      DO 100 I = 1,NLINES
         CALL ZTXIO ('READ', LUN, FIND, LINE, IERR)
         IF (IERR.NE.0) GO TO 980
         JT = JTRIM (LINE)
C                                       Get values
         KBP = 1
C
         CALL GETNUM (LINE, NBYTES, KBP, X)
         TMES(I) = X - JD
         CALL GETNUM (LINE, NBYTES, KBP, X)
         RADR(I) = X
         CALL GETNUM (LINE, NBYTES, KBP, X)
         DECDR(I) = X
 100     CONTINUE
C                                       close input file
      CALL ZTXCLS (LUN, FIND, IERR)
C
      GO TO 999
C                                       Read error
 980  WRITE (MSGTXT,1980) IERR
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1001 FORMAT ('ERROR ',I3,' OPENING  INFO TEXT FILE')
 1980 FORMAT ('ERROR ',I3,' READING ANTENNA INFO TEXT FILE')
 2000 FORMAT ('Number of lines = ',I4)
C2001 FORMAT (I4,I3,1X,3(I2,':'),F4.1,F12.8,F6.2,F6.2,F12.5,F12.5)
      END
      SUBROUTINE USNORE (FILE, IERR)
C-----------------------------------------------------------------------
C  This subroutine reads from an input file specified by name "file",
C  the list of the UT1-TAI, POLX, and POLY for the given JDs set
C  at the vicinity of the observation date.
C  The input file can be picked up from
C  http://gemini.gsfc.nasa.gov/solve_save/usno_finals.erp
C
C   Inputs:
C    FILE       C*48  File name
C   Input in common:
C    JD         D     Julian day of the observation
C    BCOUNT     I     Number of days preceeded JD of observation
C    NCOUNT     I     Number of day used starting JD-BCOUNT
C    Example BCOUNT=1, ECOUNT=5 => JD is the second day; and 3 days
C                                     follow the JD
C   Outputs in common:
C    UT1TAI(*)  D     UT1-TAI,  in sec
C    XYWOB(2,*) D     X,Y pole wobble, in milliarcsec
C   Outputs:
C    IERR     I     Return code, 0=>OK
C-----------------------------------------------------------------------
      CHARACTER FILE*48, LASDAT*8
      DOUBLE PRECISION JDLAS, JDOBS, DDDAY, NNDAY, JDFIRS
      INTEGER   IERR
      INTEGER   LUN, FIND, NBYTES, KBP
      INTEGER   YLAST, MLAST, DLAST
      LOGICAL   F, ISOPEN
C
      INTEGER  ILINE, JT, JTRIM, I
      DOUBLE PRECISION  JDFILE
      CHARACTER CLINE*80
      DOUBLE PRECISION X
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DMSG.INC'
      DATA F /.FALSE./
C-----------------------------------------------------------------------
C                                       Open text file
      LUN = 10
      ISOPEN = .FALSE.
      CALL ZTXOPN ('READ', LUN, FIND, FILE, F, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1001)
         GO TO 990
         END IF
      ISOPEN = .TRUE.

      MSGTXT = 'UT1-UTC(sec), POLX, POLY(milliasec) picked up ' //
     *   'from the USNO file'
      CALL MSGWRT (4)
C                                       Read the file lines
      ILINE = 0
  10  CONTINUE
         CALL ZTXIO ('READ', LUN, FIND, CLINE, IERR)
         IF (IERR.NE.0) GO TO 980
         JT = JTRIM (CLINE)
C                                       pick up the first real data
         IF (CLINE(3:12).EQ.'First date') THEN
            READ (CLINE(30:39),1010) YLAST, MLAST, DLAST
            WRITE (LASDAT, 1020) YLAST, MLAST, DLAST
            CALL JULDAY(LASDAT, JDFIRS)
            JDOBS = JD
            DDDAY = JDFIRS - JDOBS
            IF (DDDAY.GT.BCOUNT) THEN
               IERR = 1
      MSGTXT = '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
               CALL MSGWRT (8)
               WRITE (MSGTXT,1025)
               CALL MSGWRT (8)
      MSGTXT = '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
               GO TO 990
               END IF
            END IF
C                                       pick up the last real data
         IF (CLINE(18:21).EQ.'real') THEN
            READ (CLINE(30:39),1010) YLAST, MLAST, DLAST
            WRITE (LASDAT, 1020) YLAST, MLAST, DLAST
            CALL JULDAY(LASDAT, JDLAS)
            JDOBS = JD
            DDDAY = JDLAS - JDOBS
            NNDAY = NCOUNT - BCOUNT - 1
C                                       there is no enough days
C                                       with real data after OBSDAT
            IF (DDDAY.LT.NNDAY) THEN
               IERR = 1
      MSGTXT = '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
               CALL MSGWRT (8)
               WRITE (MSGTXT,1030) DDDAY
               CALL MSGWRT (8)
               WRITE (MSGTXT,1040) NNDAY
               CALL MSGWRT (8)
      MSGTXT = '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
               GO TO 990
               END IF
            END IF
C                                       skip the comment lines
         IF (CLINE(1:1).EQ.'#' .OR. CLINE(1:1).EQ.'E') GO TO 10
C
C                                       Get values
         KBP = 1
         NBYTES = 80
C
         CALL GETNUM (CLINE, NBYTES, KBP, X)
         JDFILE = X
C                                       look for the beginning line
C                                       JDFILE = JD-1
         IF (JDFILE.LT. JD-BCOUNT) GO TO 10
         ILINE = ILINE + 1
C                                       XPOLE in milli arcsec
         CALL GETNUM (CLINE, NBYTES, KBP, X)
         XYWOB(1,ILINE) = X*100
C                                       YPOLE in milli arcsec
         CALL GETNUM (CLINE, NBYTES, KBP, X)
         XYWOB(2,ILINE) = X*100
C                                       UT1TAI in sec
         CALL GETNUM (CLINE, NBYTES, KBP, X)
C         UT1TAI(ILINE) = MOD(X/1.D6, 1.D0)
         UT1TAI(ILINE) = X/1.D6
C                                       print out
C                                       the picked up values
         WRITE (MSGTXT, 1050) ILINE, JDFILE, UT1TAI(ILINE)+LEAPS(2),
     *            XYWOB(1,ILINE), XYWOB(2,ILINE)
         CALL MSGWRT (8)


C                                       the required number of days
         IF (ILINE.EQ.NCOUNT) GO TO 20
         GO TO 10
 20      CONTINUE
C
      GO TO 995
C                                       Read error
 980  WRITE (MSGTXT,1980) IERR
 990  CALL MSGWRT (8)
C                                       close input file
 995  IF (ISOPEN) CALL ZTXCLS (LUN, FIND, I)
C
 999  RETURN
C-----------------------------------------------------------------------
 1001 FORMAT ('ERROR ',I3,' OPENING  INFO TEXT FILE')
 1010 FORMAT (I4, 1X, I2, 1X, I2)
 1020 FORMAT (I4, I2, I2)
 1025 FORMAT ('! FIRST DAY IN INFILE MORE RECENT THAN REQUIRED BY THE',
     *   ' DATA')
 1030 FORMAT ('! LAST DAY WITH REAL DATA IN INFILE MINUS OBSDAT '
     *   ,F5.0,'!')
 1040 FORMAT ('! IS SMALLER THAN REQURED ONE AFTER OBSDAT       ',
     *   F5.0,'!')
 1050 FORMAT (I5, F10.1, 2X, F12.6, 2F10.3)
 1980 FORMAT ('ERROR ',I3,' READING USNO INFO TEXT FILE')
      END
      SUBROUTINE PLLIST (FILE, IERR)
C-----------------------------------------------------------------------
C  This subroutine reads the list of the planets from an input file
C  specified by name "file"
C
C   Inputs:
C    FILE     C*48  File name
C   Outputs in common:
C    NPLANE    I     Number of planets in the list
C    PLANET    C*12  The planet list
C    PLMASS    D(12) The planet masses
C   Outputs:
C    IERR     I     Return code, 0=>OK
C-----------------------------------------------------------------------
      CHARACTER FILE*48
      CHARACTER PLALL(10)*12
      INTEGER   I, IPL, KPL, IPLA, ISTA, IEND, IERR
      INTEGER   LUN, FIND, NBYTES, KBP, NFLINE, JT, JTRIM
      DOUBLE PRECISION PLM(10)
      LOGICAL   F
C
      CHARACTER LINE*80
      DOUBLE PRECISION X
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DMSG.INC'
C      INCLUDE 'INCS:DDCH.INC'
      DATA PLALL / 'MERCURY     ', 'VENUS       ', 'MOON        ',
     *             'MARS        ', 'JUPITER     ', 'SATURN      ',
     *             'URANUS      ', 'NEPTUNE     ', 'PLUTO       ',
     *             'SUN         ' /
      DATA PLM   / 3.18D23,        4.88D24,        7.36D22,
     *             6.42D23,        1.90D27,        5.68D26,
     *             8.68D25,        1.03D26,        1.40D22,
     *             1.99D30 /
      DATA F /.FALSE./
C-----------------------------------------------------------------------
      IF (FILE.EQ.' ') THEN
         NPLANE = 1
         PLANET(1)=  'SUN         '
         PLMASS(1) = 1.99D30
         GO TO 999
         END IF
C                                       Open text file
      LUN = 10
      CALL ZTXOPN ('READ', LUN, FIND, FILE, F, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1001)
         GO TO 990
         END IF
C                                       Get number of lines
      CALL ZTXIO ('READ', LUN, FIND, LINE, IERR)
      IF (IERR.NE.0) GO TO 980
      JT = JTRIM (LINE)
C                                       Get value
      KBP = 1
      NBYTES = 80
      CALL GETNUM (LINE, NBYTES, KBP, X)
      NFLINE = X + 0.1
C                                       Tell user
C     WRITE (MSGTXT,2000) NFLINE
C     CALL MSGWRT (6)
C                                       Read measurment info
C     IPLA = 0
      DO 100 I = 1,NFLINE
         CALL ZTXIO ('READ', LUN, FIND, LINE, IERR)
         IF (IERR.NE.0) GO TO 980
         JT = JTRIM (LINE)
C
         DO 80 IPL = 1, 60, 12
            IPLA = IPLA + 1
            ISTA = IPL
            IEND = IPL + 11
            PLANET(IPLA) = LINE(ISTA:IEND)
            IF (PLANET(IPLA).EQ.' ') THEN
               GO TO 90
            ELSE
C                                       associate the mass of the planet
               DO 60 KPL = 1, 10
                  IF (PLANET(IPLA).EQ.PLALL(KPL))
     *               PLMASS(IPLA) = PLM(KPL)
   60             CONTINUE
               END IF
   80       CONTINUE
C         WRITE (MSGTXT,2001) I, IAN(I), DD, HH, MM, SS, TMES(I),
C     *      VERDEL(I), CLKDEL(I), DVERDE(I), DCLKDE(I)
C         CALL MSGWRT (6)
            GO TO 100
   90       IPLA = IPLA - 1
 100     CONTINUE
      NPLANE = IPLA
C                                       close input file
      CALL ZTXCLS (LUN, FIND, IERR)
C
      GO TO 999
C                                       Read error
 980  WRITE (MSGTXT,1980) IERR
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1001 FORMAT ('ERROR ',I3,' OPENING  INFO TEXT FILE')
 1980 FORMAT ('ERROR ',I3,' READING ANTENNA INFO TEXT FILE')
C 2000 FORMAT ('Number of lines = ',I4)
C 2001 FORMAT (I4, I3, 1X, 3(I2,':'), F4.1, 2X, F10.8, F6.2, F6.2,
C     *   2X, F10.5, 2X, F10.5)
      END
      SUBROUTINE ATMOV (IERR)
C-----------------------------------------------------------------------
C   Routine to apply atmospheric corrections to the given antenna
C   and time based on array given at INFILE
C   Corrections are applied to the CL record in Common.
C   Control info from common:
C      NLINES    I    number of elements at the following arrays
C      IAN(*)    I    array of antenna numbers
C      TMES(*)   D    array of measurement times, in days
C      VERDEL(*) R    array of atmosphere vertical delay, in cm
C      CLKDEL(*) R     The clock delay, in cm
C      ISTOK     I    Polarization to correct, 1=first, 2=second,
C                    0 = both
C   Output:
C      IERR      I    Return error code , 0=OK else failed.
C-----------------------------------------------------------------------
      INTEGER   IERR
C
      INTEGER   LSTSOU, THSOU, LUN, IANT, I, ITEMP, PERR
      LOGICAL   DOCLAT, ISPLNT
      REAL      XT, YT, PDLY, DPDLY, CFAC, SFAC, FQFAC, ZA, ELV, HA,
     *   VERINT, CLKINT, DATINT, DCLINT, DELL, DELR, CLKL, CLKR, DATL,
     *   DATR, DCLL, DCLR, DELDT, AZ, PDLYAT, PDLYCL, DPDATZ, DPDLAT,
     *   DPDLCL, PRESS, MDRY, MWET, COSZI, TIME
      DOUBLE PRECISION FREQS, SINLAT, COSLAT, TCLT, TMESA, TLEFT,
     *   TRIGHT, STNHT, DRYDEL, TIMED, DRA, DDEC
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      DATA LUN /30/
C-----------------------------------------------------------------------
      IERR = 0
C                                       time at the CL table line,
C                                       in days
      TCLT = CLRECD(TIMCL)
C                                       antenna number at the CL table
C                                       line
      IANT = CLRECI(ANTCL)
C                                       If TROP then calulate dry zenith
C                                       delay using the pressure, station
C                                       lat. and station height.
C
      IF (ICODE.EQ.19) THEN
         CALL GETPRE (TCLT, IANT, PRESS, PERR)
         IF(PERR.EQ.0)
     *   DRYDEL= (2.2768D-03 * PRESS) / (1 - 0.00266 *
     *      COS(2.0D0 * STNLAT(IANT)) - 2.8D-07 * STNHT(IANT))
         END IF

C                                       Interpolate the vertical
C                                       atmosphere delay given at the
C                                       array VERDEL(*) and clock delay
C                                       CLKDEL(*) read from the
C                                       INFILE
      TLEFT = 0
      TRIGHT = 100
      DO 100 I = 1,NLINES
         TMESA = TMES(I)
         IF (IANT.EQ.IAN(I)) THEN
            IF ((TMESA.GT.TCLT) .AND. (TMESA.LT.TRIGHT)) THEN
               TRIGHT = TMESA
               DELR = VERDEL(I)
               CLKR = CLKDEL(I)
               DATR = DVERDE(I)
               DCLR = DCLKDE(I)
               END IF
            IF ((TMESA.LT.TCLT) .AND. (TMESA.GT.TLEFT)) THEN
               TLEFT = TMESA
               DELL = VERDEL(I)
               CLKL = CLKDEL(I)
               DATL = DVERDE(I)
               DCLL = DCLKDE(I)
               END IF
            END IF
  100    CONTINUE
      IF (TRIGHT.EQ.100) THEN
         IF (TLEFT.EQ.0) THEN
            VERINT = 0
            CLKINT = 0
            DATINT = 0
            DCLINT = 0
         ELSE
            VERINT = DELL
            CLKINT = CLKL
            DATINT = DATL
            DCLINT = DCLL
            END IF
      ELSE
         IF (TLEFT.EQ.0) THEN
            VERINT = DELR
            CLKINT = CLKR
            DATINT = DATR
            DCLINT = DCLR
         ELSE
C                                       make the interpolation itself
            VERINT = DELL + (DELR-DELL) * (TCLT-TLEFT)/(TRIGHT-TLEFT)
            CLKINT = CLKL + (CLKR-CLKL) * (TCLT-TLEFT)/(TRIGHT-TLEFT)
            DATINT = DATL + (DATR-DATL) * (TCLT-TLEFT)/(TRIGHT-TLEFT)
            DCLINT = DCLL + (DCLR-DCLL) * (TCLT-TLEFT)/(TRIGHT-TLEFT)
            END IF
         END IF
C
C                                       VERINT, CLKINT are
C                                       the interpolated vertical
C                                       atmosphere and clock delays
C                                       at time of the CL table line
C
C                                       previous source ID
      LSTSOU = PARM(1) + 0.5
C                                       Will only atmosphere or sum
C                                       of atmosphere and clock
C                                       be corrected at CL table
      DOCLAT = (PARM(2).LT.0.1)
C                                       source ID at the CL table line
      THSOU = CLRECI(SOUCL)
      TIMED = CLRECD(TIMCL)
      TIME = TIMED
C                                       get source info
      CALL FNDCOO (0, JD0, THSOU, DISKIN, CNOIN, CATBLK, LUN, TIME,
     *   DRA, DDEC, ISPLNT, IERR)
      IF (IERR.NE.0) GO TO 999
      PARM(1) = THSOU
      FREQS = FREQ + FREQO(BIF)
      SINDEC = SIN (DDEC)
      COSDEC = COS (DDEC)
      CALL COOELV (IANT, TIMED, DRA, DDEC, HA, ELV, AZ)
C                                       zenith angle of the source
C                                       from the antenna
      ZA = (PI/2.0D0 - ELV)
      COSLAT = COS (STNLAT(IANT))
      SINLAT = SIN (STNLAT(IANT))
C
      PDLYCL = CLKINT/100./VELITE
      DPDATZ = DATINT * 1.0E-14
      DPDLCL = DCLINT * 1.0E-14
C
      IF (ELV.GT.0.05) THEN
         IF (ICODE.EQ.18) THEN
C                                       'ATMO'
            PDLYAT = VERINT/100./SIN(ELV)/VELITE
         ELSE
            IF (ICODE.EQ.23) THEN
C                                       'IONO'
               COSZI = SQRT(1 - (RATIO*COS(ELV))**2)
               PDLYAT = VERINT/100./COSZI/VELITE
               END IF
            END IF

C                                       If TROP then subtract the input
C                                       total atmos. delay from the corr.
C                                       model to get the difference.
C                                       Then treat as OPCODE='ATMO'
         IF (ICODE.EQ.19) THEN
             IF(PERR.EQ.0)
     *          PDLYAT = (MDRY(ELV) * DRYDEL +
     *             MWET(ELV) * (VERINT/100 - DRYDEL)) / VELITE
             PDLYAT = CLRECR(ATMCL) - PDLYAT
         ENDIF
         IF (DOCLAT) THEN
            PDLY = PDLYAT
         ELSE
            PDLY = PDLYAT + PDLYCL
            END IF
      ELSE
         PDLY = 0
         END IF
C                                       Now evaluate derivative of delay
C
C                                       DELDT is derivative of SIN(ELV)
C                                       (by time) = COS(EL)* D(EL)/DT
C                                       COS(ELV)
      DELDT = -7.29211E-5 * SIN (HA) * COSLAT * COSDEC
C                                       derivative of atmosphere
C                                       in sec/sec without /SIN(ELV)
      DPDLAT = -PDLYAT * DELDT
C
      IF (ELV.GT.0.05) THEN
         IF (ICODE.EQ.23) THEN
C                                       'IONO'
            DPDLAT = (DPDLAT*(RATIO**2)/COSZI*SIN(ELV) + DPDATZ) /
     *         COSZI
         ELSE
            DPDLAT = (DPDLAT + DPDATZ) / SIN(ELV)
            END IF
      ELSE
         DPDLAT = 0
         END IF
C
C                                       Correct only atmosphere?
      IF (DOCLAT) THEN
         DPDLY = DPDLAT
      ELSE
         DPDLY = DPDLAT + DPDLCL
         END IF
C                                       Atmospheric group delay
      IF (CLRECR(ATMCL).NE.FBLANK) CLRECR(ATMCL) = CLRECR(ATMCL) -
     *   PDLYAT
C                                       Atmospheric group delay rate
      IF (CLRECR(DATMCL).NE.FBLANK) CLRECR(DATMCL) = CLRECR(DATMCL) -
     *   DPDLAT
      IF (ISTOK.NE.2) THEN
C                                       clock shift for first stokes
         IF (.NOT.DOCLAT .AND. CLRECR(CLK1CL).NE.FBLANK)
     *      CLRECR(CLK1CL) = CLRECR(CLK1CL) - PDLYCL
C                                       clock drift for first stokes
         IF (.NOT.DOCLAT .AND. CLRECR(DCK1CL).NE.FBLANK)
     *      CLRECR(DCK1CL) = CLRECR(DCK1CL) - DPDLCL
C                                       multiband delay for both stokes
         IF (CLRECR(MBD1CL).NE.FBLANK) CLRECR(MBD1CL) = CLRECR(MBD1CL)
     *      + PDLY
         DO 600 I = BIF,EIF
            FQFAC = (FREQS+FRQOFF(I)) * PDLY
            ITEMP = FQFAC
            FQFAC = TWOPI * (FQFAC - ITEMP)
            CFAC = COS (FQFAC)
C                                       change the sign (ISFAC=-1)
C                                       for 'IONO'
            SFAC = ISFAC*SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE1CL+I-1)
            YT = CLRECR(IM1CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE1CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM1CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delay
            IF (CLRECR(DE1CL+I-1).NE.FBLANK)
     *         CLRECR(DE1CL+I-1) = CLRECR(DE1CL+I-1) + PDLY
C                                       Phase rate
            IF (CLRECR(RA1CL+I-1).NE.FBLANK)
     *         CLRECR(RA1CL+I-1) = CLRECR(RA1CL+I-1) + DPDLY
 600        CONTINUE
         END IF
C                                       2nd polarization
      IF (ABS(ISTOK).NE.1) THEN
C                                       clock shift for second stokes
         IF (.NOT.DOCLAT .AND. CLRECR(CLK2CL).NE.FBLANK)
     *      CLRECR(CLK2CL) = CLRECR(CLK2CL) - PDLYCL
C                                       clock drift for second stokes
         IF (.NOT.DOCLAT .AND. CLRECR(DCK2CL).NE.FBLANK)
     *      CLRECR(DCK2CL) = CLRECR(DCK2CL) - DPDLCL
C                                       multiband delay for both stokes
         IF (CLRECR(MBD2CL).NE.FBLANK) CLRECR(MBD2CL) = CLRECR(MBD2CL)
     *      + PDLY
         DO 700 I = BIF,EIF
            FQFAC = (FREQS+FRQOFF(I)) * PDLY
            ITEMP = FQFAC
            FQFAC = TWOPI * (FQFAC - ITEMP)
            CFAC = COS (FQFAC)
C                                       change the sign (ISFAC=-1)
C                                       for 'IONO'
            SFAC = ISFAC*SIN (FQFAC)
C
C                                       Phase
            XT = CLRECR(RE2CL+I-1)
            YT = CLRECR(IM2CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE2CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM2CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delay
            IF (CLRECR(DE2CL+I-1).NE.FBLANK)
     *         CLRECR(DE2CL+I-1) = CLRECR(DE2CL+I-1) + PDLY
C                                       Phase rate
            IF (CLRECR(RA2CL+I-1).NE.FBLANK)
     *         CLRECR(RA2CL+I-1) = CLRECR(RA2CL+I-1) + DPDLY
 700        CONTINUE
         END IF
C
 999  RETURN
      END
      SUBROUTINE DISPV (IERR)
C-----------------------------------------------------------------------
C   Routine to apply dispersion corrections versus time based on array
C   given at INFILE.  Corrections are applied to the CL record in Common
C   Control info from common:
C      NLINES    I    number of elements at the following arrays
C      IAN(*)    I    array of antenna numbers
C      TMES(*)   D    array of measurement times, in days
C      VERDEL(*) R    array of atmosphere vertical dispersion, in 1/cm
C      CLKDEL(*) R    rate of change of VERDEL * 1.E14
C      ISTOK     I    Polarization to correct, 1=first, 2=second,
C                     0 = both
C   Output:
C      IERR      I    Return error code , 0=OK else failed.
C-----------------------------------------------------------------------
      INTEGER   IERR
C
      INTEGER   LSTSOU, THSOU, LUN, IANT, I
      REAL      PDLY, DPDLY, ZA, ELV, HA, VERINT, DATINT, DELL, DELR,
     *   DATL, DATR, DELDT, AZ, PDLYAT, DPDATZ, DPDLAT, TIME
      DOUBLE PRECISION FREQS, SINLAT, COSLAT, TCLT, TMESA, TLEFT,
     *   TRIGHT, TIMED, DRA, DDEC
      LOGICAL   ISPLNT
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      DATA LUN /30/
C-----------------------------------------------------------------------
      IERR = 0
C                                       time at the CL table line,
C                                       in days
      TCLT = CLRECD(TIMCL)
C                                       antenna number at the CL table
C                                       line
      IANT = CLRECI(ANTCL)
C                                       Interpolate the vertical
C                                       atmosphere delay given at the
C                                       array VERDEL(*) and clock delay
C                                       CLKDEL(*) read from the
C                                       INFILE
      TLEFT = 0
      TRIGHT = 100
      DO 100 I = 1, NLINES
         TMESA = TMES(I)
         IF (IANT.EQ.IAN(I)) THEN
            IF ((TMESA.GT.TCLT) .AND. (TMESA.LT.TRIGHT)) THEN
               TRIGHT = TMESA
               DELR = VERDEL(I)
               DATR = CLKDEL(I)
               END IF
            IF ((TMESA.LT.TCLT) .AND. (TMESA.GT.TLEFT)) THEN
               TLEFT = TMESA
               DELL = VERDEL(I)
               DATL = CLKDEL(I)
               END IF
            END IF
  100    CONTINUE
      IF (TRIGHT.EQ.100) THEN
         IF (TLEFT.EQ.0) THEN
            VERINT = 0
            DATINT = 0
         ELSE
            VERINT = DELL
            DATINT = DATL
            END IF
      ELSE
         IF (TLEFT.EQ.0) THEN
            VERINT = DELR
            DATINT = DATR
         ELSE
C                                       make the interpolation itself
            VERINT = DELL + (DELR-DELL) * (TCLT-TLEFT)/(TRIGHT-TLEFT)
            DATINT = DATL + (DATR-DATL) * (TCLT-TLEFT)/(TRIGHT-TLEFT)
            END IF
         END IF
C
C                                       VERINT, CLKINT are
C                                       the interpolated vertical
C                                       atmosphere and clock delays
C                                       at time of the CL table line
C
C                                       previous source ID
      LSTSOU = PARM(1) + 0.5
C                                       source ID at the CL table line
      THSOU = CLRECI(SOUCL)
      TIMED = CLRECD(TIMCL)
      TIME = TIMED
C                                       get source info
      CALL FNDCOO (0, JD0, THSOU, DISKIN, CNOIN, CATBLK, LUN, TIME,
     *   DRA, DDEC, ISPLNT, IERR)
      IF (IERR.NE.0) GO TO 999
      PARM(1) = THSOU
      FREQS = FREQ + FREQO(BIF)
      SINDEC = SIN (DDEC)
      COSDEC = COS (DDEC)
      CALL COOELV (IANT, TIMED, DRA, DDEC, HA, ELV, AZ)
C                                       zenith angle of the source
C                                       from the antenna
      ZA = (PI/2.0D0 - ELV)
      COSLAT = COS (STNLAT(IANT))
      SINLAT = SIN (STNLAT(IANT))
C
      DPDATZ = DATINT * 1.0E-14
C                                       'DISP'
      IF (ELV.GT.0.05) THEN
         PDLYAT = VERINT/100./SIN(ELV)/VELITE
         PDLY = PDLYAT
      ELSE
         PDLY = 0
         END IF
C                                       Now evaluate derivative of delay
C
C                                       DELDT is derivative of SIN(ELV)
C                                       (by time) = COS(EL)* D(EL)/DT
C                                       COS(ELV)
      DELDT = -7.29211E-5 * SIN (HA) * COSLAT * COSDEC
C                                       derivative of atmosphere
C                                       in sec/sec without /SIN(ELV)
      DPDLAT = -PDLYAT * DELDT
C
      IF (ELV.GT.0.05) THEN
         DPDLAT = (DPDLAT + DPDATZ) / SIN(ELV)
      ELSE
         DPDLAT = 0
         END IF
C
C                                       Correct only atmosphere?
      DPDLY = DPDLAT
C                                       Dispersion
      IF (CLRECR(DIS1CL).NE.FBLANK) CLRECR(DIS1CL) = CLRECR(DIS1CL) +
     *   PDLY
C                                       dispersion rate
      IF (CLRECR(DDS1CL).NE.FBLANK) CLRECR(DDS1CL) = CLRECR(DDS1CL) +
     *   DPDLAT
C                                       2nd polarization
      IF (ABS(ISTOK).NE.1) THEN
C                                       Dispersion
         IF (CLRECR(DIS2CL).NE.FBLANK) CLRECR(DIS2CL) = CLRECR(DIS2CL) +
     *      PDLY
C                                       dispersion rate
         IF (CLRECR(DDS2CL).NE.FBLANK) CLRECR(DDS2CL) = CLRECR(DDS2CL) +
     *      DPDLAT
         END IF
C
 999  RETURN
      END
      SUBROUTINE SUNDEL (IERR)
C-----------------------------------------------------------------------
C   Routine to apply the time delay correction caused by the binding
C   of the light ray passing through the gravitational field of the
C   Sun.
C
C   Control info from common:
C      NLINES    I    number of elements at the following arrays
C      TMES(*)   D    array of measurement times, in days
C      SPACEX(*) R    array of the spacecraft X, in meters
C      SPACEY(*) R    array of the spacecraft Y, in meters
C      SPACEZ(*) R    array of the spacecraft Z, in meters
C      ISTOK     I    Polarization to correct, 1=first, 2=second,
C                    0 = both
C   Output:
C      IERR      I    Return error code , 0=OK else failed.
C-----------------------------------------------------------------------
      INTEGER   IERR
C
      INTEGER   LSTSOU, THSOU, IANT, I, ITEMP, YEAR, DAY, MONTH, ITEST
      LOGICAL   LINUN
      CHARACTER NAME*12
      REAL      XT, YT, PDLY, DPDLY, CFAC, SFAC, FQFAC, FDAY,
     *   TCLNEW, TCLOLD
      DOUBLE PRECISION FREQS, TCLT, TMESA, TLEFT, TRIGHT, FDDAY,
     *   SUNCV(6), PLANX(10), PLANY(10), PLANZ(10)
      DOUBLE PRECISION SPACXR, SPACYR, SPACZR, SPACXL, SPACYL, SPACZL,
     *   SPX, SPY, SPZ, ANTX, ANTY, ANTZ, ANTRX, ANTRY, ANTRZ
      DOUBLE PRECISION  GCONST, COEFF(10), GSTRA,
     *   R1, R2, RS, RS1, RS2, RSIND, RS1IND, RS2IND, CIND,
     *   DR21X, DR21Y, DR21Z, R1X, R1Y, R1Z, RSX, RSY, RSZ,
     *   PDINF1, PDINF2
C
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DANT.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:PSTD.INC'
      DATA GCONST, CIND /6.672D-11, 1.0D3/
C-----------------------------------------------------------------------
      IERR = 0
C                                       antenna number at the CL table
C                                       line
      IANT = CLRECI(ANTCL)
C                                       time at the CL table line,
C                                       in days
      TCLT = CLRECD(TIMCL)
C
      TCLNEW = TCLT
C                                       previous time at the CL table
C                                       line
      TCLOLD = PARM(2)

      IF (TCLNEW.EQ.TCLOLD) GO TO 200
C                                       calculate spacecraft and Sun
C                                       only for the another CL time
      PARM(2) = TCLNEW


C                                       Interpolate the spacecraft
C                                       coordinates read from the
C                                       OB table
      TLEFT = -100
      TRIGHT = 100
      DO 100 I = 1, NLINES
         TMESA = TMES(I)
         IF ((TMESA.GT.TCLT) .AND. (TMESA.LT.TRIGHT)) THEN
C                                       find the nearest (from right)
C                                       OB table time to the CL time
            TRIGHT = TMESA
            SPACXR = SPACEX(I)
            SPACYR = SPACEY(I)
            SPACZR = SPACEZ(I)
            END IF
         IF ((TMESA.LT.TCLT) .AND. (TMESA.GT.TLEFT)) THEN
C                                       find the nearest (from left)
C                                       OB table time to the CL time
            TLEFT = TMESA
            SPACXL = SPACEX(I)
            SPACYL = SPACEY(I)
            SPACZL = SPACEZ(I)
            END IF
  100    CONTINUE

      IF (TRIGHT.EQ.100) THEN
C                                       all OB times are lefter CL time
         SPX = SPACXL
         SPY = SPACYL
         SPZ = SPACZL
      ELSE
         IF (TLEFT.EQ.-100) THEN
C                                       all OB times are righter CL time
            SPX = SPACXR
            SPY = SPACYR
            SPZ = SPACZR
         ELSE
C                                       make the interpolation itself
            SPX = SPACXL + (SPACXR-SPACXL) *
     *         (TCLT-TLEFT)/(TRIGHT-TLEFT)
            SPY = SPACYL + (SPACYR-SPACYL) *
     *         (TCLT-TLEFT)/(TRIGHT-TLEFT)
            SPZ = SPACZL + (SPACZR-SPACZL) *
     *         (TCLT-TLEFT)/(TRIGHT-TLEFT)
            END IF
         END IF
C                                       Position of the space craft
C                                       SPX, SPY, SPZ are
C                                       in the RH equatorial coordinate
C                                       system as it given in OB table.
C                                       X at RA=0
C
C                                       FDAY(Real) Fraction of day
      FDAY = TCLT
C                                       FDDAY (DP) Fraction of day
      FDDAY = TCLT
C                                       Year, for example 2004
C      YEAR = PARM(3)
C                                       Day in year (1 = Jan 1st)
C      DAY = PARM(4)
C      CALL SUN (YEAR, DAY, FDAY, SUNCV)
C                                       Bryan's (JPL) software to
C                                       calculate the SUN position
      YEAR = PARM(3)
      MONTH = PARM(4)
      DAY = PARM(5)
C                                       UNIX/LINUX

      LINUN = BYTFLP.GT.0
      DO 120 I = 1, NPLANE
         NAME = PLANET(I)
C                                       calculate position of the planet
         CALL SUNJPL (YEAR, MONTH, DAY, FDDAY, NAME, LINUN, SUNCV)
C                                       Planet coordinates relatively
C                                       Earth center, in meters
C                                       in the RH equatorial coordinate
C                                       system. X at RA=0.
         PLANX(I) = SUNCV(1) * 1000
         PLANY(I) = SUNCV(2) * 1000
         PLANZ(I) = SUNCV(3) * 1000
C                                       COEFF before Logarithm [sec]
         COEFF(I) = GCONST * PLMASS(I) / VELITE/VELITE/VELITE
  120    CONTINUE
C
  200 CONTINUE

C                                       Antenna coordinates at the LH
C                                       coordinate system fixed in EARTH
C                                       X to Greenwich
      ANTX = STNX(IANT)
C                                       Make LH so following works
      ANTY = -STNY(IANT)
      ANTZ = STNZ(IANT)

C
Ctemoprally GSTIA0 from almonach
C      GSTIA0 = 201.327D0
      GSTRA = (GSTIA0 + 1.00273790265D0*TCLT*360) * DG2RAD
C                                       Rotate to the RH sky equatorial
C                                       coordinate system X at RA=0
      ANTRX = ANTX*COS(GSTRA) + ANTY*SIN(GSTRA)
      ANTRY = ANTX*SIN(GSTRA) - ANTY*COS(GSTRA)
      ANTRZ = ANTZ
C
C                                       gravitational delay of all
C                                       listed planets
      PDLY = 0
      PDINF1 = 0
      PDINF2 = 0
      DO 140 I = 1, NPLANE
C                                       R2 distance ANT-SUN
         R2 = SQRT ((ANTRX-PLANX(I))**2 + (ANTRY-PLANY(I))**2 +
     *      (ANTRZ-PLANZ(I))**2)
C                                       R1 distance
C                                       EARTH center-SUN center
         R1 = SQRT (PLANX(I)**2 + PLANY(I)**2 + PLANZ(I)**2)
C                                       RS distance Spacecraft-SUN
         RS = SQRT ((SPX-PLANX(I))**2 + (SPY-PLANY(I))**2 +
     *      (SPZ-PLANZ(I))**2)
C                                       space craft is CIND time
C                                       further
         RSIND = SQRT ((SPX*CIND-PLANX(I))**2 + (SPY*CIND-PLANY(I))**2
     *      +(SPZ*CIND-PLANZ(I))**2)
C                                       RS2 distance Spacecraft-ANT
         RS2 = SQRT ((SPX-ANTRX)**2 + (SPY-ANTRY)**2 +
     *      (SPZ-ANTRZ)**2)
C                                       space craft is CIND time
C                                       further
         RS2IND = SQRT ((SPX*CIND-ANTRX)**2 +
     *      (SPY*CIND-ANTRY)**2 + (SPZ*CIND-ANTRZ)**2)
C                                       RS1 distance Spacecraft-
C                                       EARTH center
         RS1 = SQRT (SPX**2 + SPY**2 + SPZ**2)
C                                       space craft is CIND time
C                                       further
         RS1IND = SQRT ((SPX*CIND)**2 + (SPY*CIND)**2 +
     *      (SPZ*CIND)**2)
C                                       calculate the extra delay
C                                       because of the bending at the
C                                       gravity field of the Sun
C                                       spacecraft is at the given
C                                       position
         PDLY = PDLY +
     *      2*COEFF(I)* LOG(   ((RS+R2+RS2)/(RS+R1+RS1)) *
     *                      ((RS+R1-RS1)/(RS+R2-RS2))  )
C                                       Delay for infinite position
C                                       of the spacecraft
         PDINF1 = PDINF1 +
     *      2*COEFF(I)* LOG(   ((RSIND+R2+RS2IND)/(RSIND+R1+RS1IND))
     *    * ((RSIND+R1-RS1IND)/(RSIND+R2-RS2IND))  )
C                                       vector R2-R1
         DR21X = ANTRX
         DR21Y = ANTRY
         DR21Z = ANTRZ
C                                       unit vector along SUN->ANT1
C                                       ANT1 is at the EARTH center
         R1X = -PLANX(I) / R1
         R1Y = -PLANY(I) / R1
         R1Z = -PLANZ(I) / R1
C                                       unit vector along SUN->SPC
         RSX = (SPX*CIND-PLANX(I)) / RSIND
         RSY = (SPY*CIND-PLANY(I)) / RSIND
         RSZ = (SPZ*CIND-PLANZ(I)) / RSIND
C                                       Delay for infinite position
C                                       of the spacecraft (simpler
C                                       equation)
         PDINF2 = PDINF2 -
     *      2*COEFF(I) * (DR21X*(R1X+RSX) + DR21Y*(R1Y+RSY) +
     *                     DR21Z*(R1Z+RSZ)) / R1 /
     *                     (1 + R1X*RSX + R1Y*RSY + R1Z*RSZ)
  140    CONTINUE
C------------------------TEST PRINT-------------------------
         IF (PARM(7).EQ.0) THEN
            IF (PARM(10).EQ.-10) THEN
               WRITE (MSGTXT,1075)
 1075          FORMAT ('IANT', 2X, 'AN', 2X, 'TIME', 7X, 'DEL,psec',
     *            2X, 'DINF1,ps',2X, 'DINF2,ps',2X, 'DINF2-DEL,ps')
               CALL MSGWRT (8)
               END IF
C
            ITEST = PARM(10)
            IF (MOD(ITEST,10).EQ.0) THEN
               WRITE (MSGTXT,1100) IANT, STNNAM(IANT)(1:2), FDDAY,
     *            PDLY*1.0E12,
     *            PDINF1*1.0E12, PDINF2*1.0E12, (PDINF2-PDLY)*1.0E12
 1100          FORMAT (I3, 3X, A2, 2X, F7.5, 5X, F7.2, 1X, F7.2, 3X,
     *             F7.2, 7X, F7.2)
               CALL MSGWRT (8)
C                                       print positions of the
C                                       spacecraft, sun, baseline
C                                       print the test data only for SUN
               IF (NPLANE.EQ.1) THEN
                  IF (PARM(8).GT.0) THEN
                     WRITE (MSGTXT,1110) PLANET(1)(1:3),
     *                  PLANX(1)/1000, PLANY(1)/1000, PLANZ(1)/1000
 1110                FORMAT (A3, ' X,Y,Z, KM  ', 3F12.0)
                     CALL MSGWRT (8)
C
                     WRITE (MSGTXT,1120) SPX/1000, SPY/1000, SPZ/1000
 1120                FORMAT ('SPA X,Y,Z, KM  ', 3F12.0)
                     CALL MSGWRT (8)
C
                     WRITE (MSGTXT,1130) ANTRX/1000, ANTRY/1000, ANTRZ
     *                  /1000
 1130                FORMAT ('ANT X,Y,Z, KM  ', 3F12.0)
                     CALL MSGWRT (8)
                     END IF
                  END IF
               END IF
            END IF
C
      PARM(10) = PARM(10) + 1
C                                       source ID at the CL table line
      THSOU = CLRECI(SOUCL)
C                                       previous source ID
      LSTSOU = PARM(1) + 0.5
      IF (LSTSOU.NE.THSOU) THEN
C
         PARM(1) = THSOU
         FREQS = FREQ + FREQO(BIF)
         END IF
C                                       calculate the actual space craft
C                                       position correction minus
C                                       infinite space craft
      IF (PARM(6).EQ.0) THEN
C                                       -PDINF2  has been added by
C                                       correlator
C                                       put -PDLY instead
         PDLY = PDINF2 - PDLY
      ELSE
         PDLY = -PDLY
         END IF
      IF (ANAME.EQ.'GMRT') PDLY = -PDLY
C                                       calculate the derivative of
C                                       the extra delay because of
C                                       the bending at the gravity field
C                                       of the Sun
C      DPDLAT = ??????????????
C
      IF (ISTOK.NE.2) THEN
         IF (CLRECR(MBD1CL).NE.FBLANK) CLRECR(MBD1CL) = CLRECR(MBD1CL)
     *      + PDLY
         DO 600 I = BIF,EIF
            FQFAC = (FREQS+FRQOFF(I)) * PDLY
            ITEMP = FQFAC
            FQFAC = TWOPI * (FQFAC - ITEMP)
            CFAC = COS (FQFAC)
            SFAC = SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE1CL+I-1)
            YT = CLRECR(IM1CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE1CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM1CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delay
            IF (CLRECR(DE1CL+I-1).NE.FBLANK)
     *         CLRECR(DE1CL+I-1) = CLRECR(DE1CL+I-1) + PDLY
C                                       Phase rate
            IF (CLRECR(RA1CL+I-1).NE.FBLANK)
     *         CLRECR(RA1CL+I-1) = CLRECR(RA1CL+I-1) + DPDLY
 600        CONTINUE
         END IF
      IF (ABS(ISTOK).NE.1) THEN
         IF (CLRECR(MBD2CL).NE.FBLANK) CLRECR(MBD2CL) = CLRECR(MBD2CL)
     *      + PDLY
         DO 700 I = BIF,EIF
            FQFAC = (FREQS+FRQOFF(I)) * PDLY
            ITEMP = FQFAC
            FQFAC = TWOPI * (FQFAC - ITEMP)
            CFAC = COS (FQFAC)
            SFAC = SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE2CL+I-1)
            YT = CLRECR(IM2CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE2CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM2CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delay
            IF (CLRECR(DE2CL+I-1).NE.FBLANK)
     *         CLRECR(DE2CL+I-1) = CLRECR(DE2CL+I-1) + PDLY
C                                       Phase rate
            IF (CLRECR(RA2CL+I-1).NE.FBLANK)
     *         CLRECR(RA2CL+I-1) = CLRECR(RA2CL+I-1) + DPDLY
 700        CONTINUE
         END IF
C
 999  RETURN
      END
      SUBROUTINE UTPOL (IERR)
C-----------------------------------------------------------------------
C   Routine to correct for errors in UT1-UTC and the Earth pole position
C   Corrections are applied to the CL record in Common.
C   Control info from common:
C      PARM(*)  R    (1) = "UT1-UTC" correction (millisec)
C                    (2) = "X pole " correction (arcsec)
C                    (3) = "Y pole " correction (arcsec)
C      ISTOK    I    Polarization to correct, 1=first, 2=second,
C                    0 = both
C      JD       D    Julian day of the OBSDAT
C
C      INDAY    D(*)       Day numbers
C      UT1C     D(*)       UT1-UTC values (CT tab), in sec
C      WOBX     D(*)       Polar wobble (CT tab) at X, in milliarcsec
C      WOBY     D(*)       Polar wobble (CT tab) at Y, in milliarcsec
C      TBEG     D(*)       Begin time of each group
C      TEND     D(*)       End time of each group
C      NATGRO   I(*)       Number of rows at the group
C      NACUMU   I(*)       Number of rows accumulated
C      NGROUP   I          Number of groups at the CT table
C      ICASE    I          1,2,3 depending on the CT table content
C      UT1TAI   D(*)       UT1-UTC values (USNO file), in sec
C      XYWOB    D(2,*)     Polar wobble (USNO file) in milliarcsec

C      BCOUNT   I    Number of days preceeded JD of observation
C      NCOUNT   I    Number of day used starting JD-BCOUNT
C   Output:
C      IERR     I    Return error code , 0=OK else failed.
C-----------------------------------------------------------------------
      INTEGER   IERR
C
      INTEGER   LSTSOU, THSOU, LUN, I, ITEMP, IANT, KGROUP, INDEX,
     *   INGRP, J, K
      REAL      XT, YT, CFAC, SFAC, FQFAC, TIME
C                                       for UT1UTC
      DOUBLE PRECISION UT1IFX(4), UT1PTX(100), TAIUTC(100), XJDTIM,
     *   UT1VAL, XYWOBX(2,100), WOBVAL(2), LEAPS0
C
      DOUBLE PRECISION CHAD, SHAD, HAD, DRA, DDEC
      DOUBLE PRECISION FREQS, X, Y, Z, DELAYC, RATEC, RADSEC, DELAY,
     *   RATE, PDLY, DPDLY, XR, YR, ZR, DTCOR, XPCOR, YPCOR, TIMED
      LOGICAL   ISPLNT
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DANT.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:PSTD.INC'
C                                       RADSEC = earth rot rate in
C                                       rad/sec.
      PARAMETER (RADSEC = PI / 43200.0D0)
      SAVE  FREQS, DRA, DDEC
      DATA LUN /30/
C-----------------------------------------------------------------------
      LSTSOU = PARM(7) + 0.5
      THSOU = CLRECI(SOUCL)
      TIMED = CLRECD(TIMCL)
      TIME = TIMED
C                                       get source info
      CALL FNDCOO (0, JD0, THSOU, DISKIN, CNOIN, CATBLK, LUN, TIME,
     *   DRA, DDEC, ISPLNT, IERR)
      IF (IERR.NE.0) GO TO 999
      PARM(7) = THSOU
      FREQS = FREQ + FREQO(BIF)
C                                       Declination
      SINDEC = SIN (DDEC)
      COSDEC = COS (DDEC)
C
C                                       Get antenna number
      IANT = CLRECI(ANTCL)
C

C                                       Everything now RH no sign change
C                                       needed
      X = STNX(IANT)
      Y = STNY(IANT)
      Z = STNZ(IANT)
C
C                                       Inputs to the John's subroutine
C                                       to estimate UT1-UTC, XPOLE,
C                                       YPOLE, in sec, milli arcsec
C                                       Fix the first line = JD-1
C                                       and number of line = 5
C
      IF (ICASE.EQ.0) THEN
C                                       all CT table groups are
C                                       identical, so the first group
C                                       is used
         UT1IFX(1) = JD + INDAY(1)
         UT1IFX(2) = 1.0
         UT1IFX(3) = NCTROW
         UT1IFX(4) = 0
C                                       NCTROW =5 is tetermined in
C                                       CLCCOR before call CTTAB
         DO 10 I = 1, NCTROW
            UT1PTX(I) = UT1C(I)
            XYWOBX(1,I) = WOBX(I)
            XYWOBX(2,I) = WOBY(I)
            TAIUTC(I) = LEAPS(I)
 10         CONTINUE
      ELSE
C                                       CT table groups are not
C                                       identical; both
C                                       ICASE=1, and ICASE=2

         KGROUP = 1
         DO 20 I = 1,NGROUP
            IF (CLRECD(TIMCL).GE.TBEG(I) .AND.
     *         CLRECD(TIMCL).LT.TEND(I)) THEN
               KGROUP = I
               GO TO 30
               END IF
 20         CONTINUE
C                                       count number in group
 30      INGRP = 1
         K = NACUMU(KGROUP)+1
         J = INDAY(K)
         DO 35 I = 2,NCTROW - NACUMU(KGROUP)
            IF (INDAY(K+1).EQ.J+1) THEN
               K = K + 1
               J = J + 1
               INGRP = INGRP + 1
            ELSE
               GO TO 39
               END IF
 35         CONTINUE
C
 39      UT1IFX(1) = JD + INDAY(NACUMU(KGROUP) + 1)
         UT1IFX(2) = 1.0
         UT1IFX(3) = INGRP
         UT1IFX(4) = 0
C                                       NCTROW =5 is determined in
C                                       CLCCOR before call CTTAB
         DO 40 I = 1, NCTROW
            INDEX = NACUMU(KGROUP) + I
            UT1PTX(I) = UT1C(INDEX)
            XYWOBX(1,I) = WOBX(INDEX)
            XYWOBX(2,I) = WOBY(INDEX)
            TAIUTC(I) = LEAPS(INDEX)
 40         CONTINUE
         END IF
C                                       store the leaps second of
C                                       the observation day
C                                       (it is the second one!!?)
      LEAPS0 = LEAPS(2)


C                                       TAI-UTC (leap sec) for the
C                                       observation time
C                                       TAIUTC = 0 because CT table
C                                       has UT1-UTC column already
C      TAIUTC = 0
C                                       time to interpolate to:
C                                       the CL table row time
      XJDTIM = JD + CLRECD(TIMCL)
C                                       John's subroutine to
C                                       estimate UT1-UTC
      CALL UT1COR (UT1IFX, UT1PTX, TAIUTC, XJDTIM, UT1VAL)
C                                       interpolated UT1-UTC as it
C                                       used in correlator, radians
C
C                                       UT1-UTC in days
      DTCOR = UT1VAL /3.6D3/24.D0
C
      CALL PINTER (UT1IFX, XYWOBX, XJDTIM, WOBVAL)
C                                       interpolated X pole wobble
C                                       as it used in correlator,
C                                       radians
      XPCOR = WOBVAL(1) / 1000.0 * AS2RAD
C                                       interpolated Y pole wobble
C                                       as it used in correlator,
C                                       radians
      YPCOR = WOBVAL(2) / 1000.0 * AS2RAD
C
      HAD = GSTIAT + (CLRECD(TIMCL)+ DTCOR)* ROTIAT
      IF (HAD.GT. PI) HAD = HAD - TWOPI
      IF (HAD.GT. PI) HAD = HAD - TWOPI
      IF (HAD.GT. PI) HAD = HAD - TWOPI
      IF (HAD.LT.-PI) HAD = HAD + TWOPI
      IF (HAD.LT.-PI) HAD = HAD + TWOPI
      CHAD = COS(HAD)
      SHAD = SIN(HAD)
C                                       correcte antenna coordinates
C                                       using the matrix Q=U*X*Y
C                                       JPL publication 83-39, Rev.6
C                                       by O.J. Sovers, C.S. Lacobs
      XR = X*CHAD - Y*SHAD + Z*(-SIN(XPCOR)*CHAD - SIN(YPCOR)*SHAD)
      YR = X*SHAD + Y*CHAD + Z*(-SIN(XPCOR)*SHAD + SIN(YPCOR)*CHAD)
      ZR = X*SIN(XPCOR) - Y*SIN(YPCOR) + Z
C                                       delay using appar coordinates
      DELAY = ((XR*COS(DRA) + YR*SIN(DRA))*COSDEC +
     *   ZR*SINDEC) / VELITE
C
C                                       Calculate RATE taking into
C                                       account only rotation of the
C                                       Earth (not changing of the
C                                       poles and UT1-UTC in time)
      RATE = RADSEC/VELITE *(
     *   ((-X * SHAD - Y * CHAD)*COS(DRA)) +
     *   ((+X * CHAD - Y * SHAD)*SIN(DRA)) )
     *   * COSDEC
      IF (ANAME.EQ.'GMRT') THEN
         DELAY = -DELAY
         RATE = -RATE
         END IF
C
C------Finish calculating DELAY, RATE used by VLBA correlator-------
C
C                                       Inputs to the John's subroutine
C                                       to estimate UT1-UTC, XPOLE,
C                                       YPOLE, in sec, milli arcsec
C                                       Inputs taken from USNO file
C                                       Default BCOUNT=1, NCOUNT=5
      UT1IFX(1) = JD - BCOUNT
      UT1IFX(2) = 1.0
      UT1IFX(3) = NCOUNT
      UT1IFX(4) = 0
C
      DO 90 I = 1, NCOUNT
         UT1PTX(I) = UT1TAI(I)
C                                       we are at the UT1-TAI.
C                                       So leap seconds are not required
         TAIUTC(I) = 0
         XYWOBX(1,I) = XYWOB(1,I)
         XYWOBX(2,I) = XYWOB(2,I)
   90    CONTINUE
C
C                                       John's subroutine to
C                                       estimate UT1-UTC
      CALL UT1COR (UT1IFX, UT1PTX, TAIUTC, XJDTIM, UT1VAL)
C                                       back to UT1-UTC
      UT1VAL = UT1VAL + LEAPS0
C                                       interpolated UT1-UTC as it
C                                       taken from USNO, in days
      DTCOR = UT1VAL /3.6D3/24.D0
C                                       John's subroutine to
C                                       estimate pole wobble
      CALL PINTER (UT1IFX, XYWOBX, XJDTIM, WOBVAL)

C                                       interpolated X,Y pole wobble
C                                       as it taken from USNO, radians
      XPCOR = WOBVAL(1) / 1000.0 * AS2RAD
      YPCOR = WOBVAL(2) / 1000.0 * AS2RAD
C
      HAD = GSTIAT + (CLRECD(TIMCL)+ DTCOR)* ROTIAT
      IF (HAD.GT. PI) HAD = HAD - TWOPI
      IF (HAD.GT. PI) HAD = HAD - TWOPI
      IF (HAD.GT. PI) HAD = HAD - TWOPI
      IF (HAD.LT.-PI) HAD = HAD + TWOPI
      IF (HAD.LT.-PI) HAD = HAD + TWOPI
      CHAD = COS(HAD)
      SHAD = SIN(HAD)
C                                       correcte antenna coordinates
C                                       using the matrix Q=U*X*Y
C                                       JPL publication 83-39, Rev.6
C                                       by O.J. Sovers, C.S. Lacobs
      XR = X*CHAD - Y*SHAD + Z*(-SIN(XPCOR)*CHAD - SIN(YPCOR)*SHAD)
      YR = X*SHAD + Y*CHAD + Z*(-SIN(XPCOR)*SHAD + SIN(YPCOR)*CHAD)
      ZR = X*SIN(XPCOR) - Y*SIN(YPCOR) + Z
C                                       calculate delay projecting
C                                       XR,YR, ZR on the W axis
C                                       use apparent coordinates of
C                                       the source
      DELAYC = ((XR*COS(DRA) + YR*SIN(DRA))*COSDEC +
     *   ZR*SINDEC) / VELITE
C                                       Calculate RATE taking into
C                                       account only rotation of the
C                                       Earth (not changing of the
C                                       poles and UT1-UTC in time)
      RATEC = RADSEC/VELITE *(
     *   ((-X * SHAD - Y * CHAD)*COS(DRA)) +
     *   ((+X * CHAD - Y * SHAD)*SIN(DRA)) )
     *   * COSDEC
      IF (ANAME.EQ.'GMRT') THEN
         DELAYC = -DELAYC
         RATEC = -RATEC
         END IF
C-------finish calculating corected values of DELAY, RATE-----------
C                                       correction of delay and rate
      PDLY = DELAYC - DELAY
      DPDLY = RATEC - RATE
C
      IF (ISTOK.NE.2) THEN
         IF (CLRECR(MBD1CL).NE.FBLANK) CLRECR(MBD1CL) = CLRECR(MBD1CL)
     *      + PDLY
         DO 600 I = BIF,EIF
            FQFAC = (FREQS+FRQOFF(I)) * PDLY
            ITEMP = FQFAC
            FQFAC = TWOPI * (FQFAC - ITEMP)
            CFAC = COS (FQFAC)
            SFAC = SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE1CL+I-1)
            YT = CLRECR(IM1CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE1CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM1CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delay
            IF (CLRECR(DE1CL+I-1).NE.FBLANK)
     *         CLRECR(DE1CL+I-1) = CLRECR(DE1CL+I-1) + PDLY
C                                       Phase rate
            IF (CLRECR(RA1CL+I-1).NE.FBLANK)
     *         CLRECR(RA1CL+I-1) = CLRECR(RA1CL+I-1) + DPDLY
 600        CONTINUE
         END IF
      IF (ABS(ISTOK).NE.1) THEN
         IF (CLRECR(MBD2CL).NE.FBLANK) CLRECR(MBD2CL) = CLRECR(MBD2CL)
     *      + PDLY
         DO 700 I = BIF,EIF
            FQFAC = (FREQS+FRQOFF(I)) * PDLY
            ITEMP = FQFAC
            FQFAC = TWOPI * (FQFAC - ITEMP)
            CFAC = COS (FQFAC)
            SFAC = SIN (FQFAC)
C                                       Phase
            XT = CLRECR(RE2CL+I-1)
            YT = CLRECR(IM2CL+I-1)
            IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK)) THEN
               CLRECR(RE2CL+I-1) = XT * CFAC - YT * SFAC
               CLRECR(IM2CL+I-1) = XT * SFAC + YT * CFAC
               END IF
C                                       Delay
            IF (CLRECR(DE2CL+I-1).NE.FBLANK)
     *         CLRECR(DE2CL+I-1) = CLRECR(DE2CL+I-1) + PDLY
C                                       Phase rate
            IF (CLRECR(RA2CL+I-1).NE.FBLANK)
     *         CLRECR(RA2CL+I-1) = CLRECR(RA2CL+I-1) + DPDLY
 700        CONTINUE
         END IF
C
 999  RETURN
      END
      REAL FUNCTION MDRY (ELV)
C-----------------------------------------------------------------------
C   Function used in ATMOV for a mapping function which takes
C   the wet and dry delay into account.  The formula is based on
C   Chao (1974) and recently published in Sovers, Fanselow and
C   Jacobs, 1998, Reviews of Modern Physics, 70, 1393.
C
C   Input    ELV   R   Elevation in radians
C-----------------------------------------------------------------------
      REAL      ELV, ADRY, BDRY
C-----------------------------------------------------------------------
      ADRY = 0.00143
      BDRY = 0.0445
      MDRY = 1.0E0 / (SIN(ELV) + ADRY / (TAN(ELV) + BDRY))
      RETURN
      END
      REAL FUNCTION MWET(ELV)
C-----------------------------------------------------------------------
C   Function used in ATMOV for a mapping function which takes
C   the wet and dry delay into account.  The formula is based on
C   Chao (1974) and recently published in Sovers, Fanselow and
C   Jacobs, 1998, Reviews of Modern Physics, 70, 1393.
C
C   Input    ELV   R   Elevation in radians
C-----------------------------------------------------------------------
      REAL ELV, AWET, BWET
      AWET = 0.00035
      BWET = 0.017
      MWET = 1.0E0 / (SIN(ELV) + AWET / (TAN(ELV) + BWET))
      RETURN
      END
      SUBROUTINE GETPRE (TIME, IANT, PRESS, IERR)
C-----------------------------------------------------------------------
C   GETPRE gets the linearly interpolated pressure at a station from the
C   WX table at a specific time
C   INPUTS: TIME   D     Time in CL table
C           IANT   I     Antenna number
C   OUTPUT: PRESS  R     Pressure
C-----------------------------------------------------------------------
      INCLUDE 'INCS:DWXV.INC'
      DOUBLE PRECISION TIME, TIMEWX, PRETIM, POSTIM, FIRTIM, LASTIM
      REAL PRESS, DTIME, TEMP, DEWPT, WVEL, WDIR, WGUST, PRECIP, H2OCOL,
     *   IONCOL, PREPRE, POSPRE, FIRPRE, LASPRE, AVEPRE, TOTPRE
      INTEGER   WXBUFF(512), VER, LUNWX, IWXRNO, I, NROW,
     *   WXKOLS(MAXWXC), WXNUMV(MAXWXC), TABVER, IERR, IANT, ANT,
     *   SEQIN, SUBA, DISKIN, CNOIN, CLVER, JSUB, CLUSE
      CHARACTER OBSCOD*8, OBSDAT*8
      REAL XSIN, XDISIN, XFQID, XBAND, XFREQ, XBIF, XEIF, XTIME(8),
     *   XANT(50), XSUBA, XGVER, BPARM(20), XBAD(10), SELBAN, XGUSE
      HOLLERITH XNAMEI(3), XCLAIN(2), XXSOUR(4,30), XXSTOK, XOPCOD,
     *   XINFIL(12)
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XXSOUR, XXSTOK,
     *   XBAND, XFREQ, XFQID, XBIF, XEIF, XTIME, XANT, XSUBA, XGVER,
     *   XGUSE, XOPCOD, BPARM, XBAD, XINFIL, SELBAN, SEQIN, DISKIN,
     *   CNOIN, SUBA, CLVER, CLUSE
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DMSG.INC'
      DATA LUNWX /30/
C-----------------------------------------------------------------------
C                                                    Open WX table
      CALL WXINI('READ', WXBUFF, DISKIN, CNOIN, VER, CATBLK, LUNWX,
     *   IWXRNO, WXKOLS, WXNUMV, OBSCOD, OBSDAT, TABVER, IERR)
      NROW = WXBUFF(5)
      IF (IERR.EQ.0) THEN
         PRETIM=1.D10
         POSTIM=1.D10
         PREPRE=1.D10
         POSPRE=1.D10
         AVEPRE=0.
         TOTPRE=0
         DO 100 I=2, NROW
C                                                   Read all lines
            CALL TABWX ('READ', WXBUFF, I-1, WXKOLS, WXNUMV, TIMEWX,
     *         DTIME, ANT, JSUB, TEMP, PRESS, DEWPT, WVEL, WDIR, WGUST,
     *         PRECIP, H2OCOL, IONCOL, IERR)
            IF (IERR.EQ.0) THEN
               IF(ANT.EQ.IANT) THEN
                  AVEPRE=AVEPRE+PRESS
                  TOTPRE=TOTPRE+1
                  IF (TOTPRE.EQ.1) THEN
                     FIRPRE = PRESS
                     FIRTIM = TIMEWX
                  END IF
                  LASTIM = TIMEWX
                  LASPRE = PRESS
C                                                   Get pressure at times
C                                                   before and after TIME
                  IF (TIME.GT.TIMEWX) THEN
                     PRETIM = TIMEWX
                     PREPRE = PRESS
                  END IF
                  IF (TIME.LT.TIMEWX) THEN
                     POSTIM = TIMEWX
                     POSPRE = PRESS
                     GO TO 110
                  END IF
               END IF
            ELSE
              WRITE(MSGTXT,1000)
              CALL MSGWRT (8)
              WRITE(MSGTXT,1100)
              CALL MSGWRT (8)
              WRITE(MSGTXT,1200)
              CALL MSGWRT (8)
              GOTO 990
            END IF
 100     CONTINUE
C                                                  Calc average pressure
C                                                  to be used if TIME is more
C                                                  than an hour outside the
C                                                  timerange in the WX table.
 110     AVEPRE = AVEPRE / TOTPRE
         PRESS = AVEPRE
         IF (PRETIM.GT.9.D9) THEN
            IF ((FIRTIM - TIME).LT.0.0417) THEN
               PRESS = FIRPRE
            END IF
            GO TO 130
         END IF
         IF (POSTIM.GT.9.D9) THEN
            IF ((TIME - LASTIM).LT.0.0417) THEN
               PRESS = LASPRE
            END IF
            GO TO 130
         END IF
         PRESS = PREPRE + (TIME - PRETIM) * (POSPRE - PREPRE) /
     *      (POSTIM - PRETIM)
 130     CALL TABIO('CLOS',0,1,IWXRNO,WXBUFF,IERR)
      ELSE
         WRITE(MSGTXT,1300)
         CALL MSGWRT (8)
         WRITE(MSGTXT,1100)
         CALL MSGWRT (8)
         WRITE(MSGTXT,1200)
         CALL MSGWRT (8)
         END IF
 990  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('GETPRE: ERROR READING WX TABLE, WILL NOT USE PRESSURE')
 1100 FORMAT ('TO ESTIMATE THE DRY DELAY, THIS MEANS THE MAPPING')
 1200 FORMAT ('FUNCTION AT LOW ELEVATIONS WILL BE BAD')
 1300 FORMAT ('GETPRE: ERROR OPENING WX TABLE, WILL NOT USE PRESSURE')
      END
      DOUBLE PRECISION FUNCTION STNHT(IANT)
C-----------------------------------------------------------------------
C     STNHT returns the station height of an antenna
C     Inputs: IANT   I    Antenna number
C     Output: STNHT  D    Station height in meters
C-----------------------------------------------------------------------
      INTEGER IANT
      DOUBLE PRECISION  B, R, E, F, P, Q, D, NU, G, T
      DOUBLE PRECISION  X, Y, Z
      DOUBLE PRECISION  SMAXIS, FLATEN
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:PCLTAB.INC'
      INCLUDE 'INCS:DANS.INC'
      PARAMETER         (SMAXIS=6378137.D0)
      PARAMETER         (FLATEN=1.D0/298.257223563D0)
C-----------------------------------------------------------------------
      X = STNX(IANT)
      Y = STNY(IANT)
      Z = STNZ(IANT)
      R = SQRT( X**2 + Y**2 )
C
C           Reasonable range.
C
      B = DSIGN (SMAXIS * (1.D0 - FLATEN ), Z)
      E = (B * Z - (SMAXIS**2 - B**2)) / (SMAXIS * R)
      F = (B * Z + (SMAXIS**2 - B**2)) / (SMAXIS * R)
      P = (4.0D0 / 3.0D0) * (E * F + 1.D0)
      Q = 2.D0 * (E**2 - F**2)
      D = P**3 + Q**2
      IF( D.LT.0.D0) THEN
         NU = 2.D0 * SQRT (-P) * COS ((1.D0/3.D0) *
     *              ACOS( Q / (P * SQRT (-P))))
      ELSE
         NU = (SQRT (D) - Q )**(1.D0/3.D0) -
     *              (SQRT (D) + Q )**(1.D0/3.D0)
         END IF
C
C           Deal with cases near singularities as per Almanac.
C           The criteria are a wild guess.
C
      IF (Z.LT.SMAXIS / 1.D5 .OR. R.LT.SMAXIS / 1.D5) THEN
         NU = (-1.D0) * (NU**3 + 2.D0 * Q) / (3.D0 * P)
      END IF
      G = 0.5D0 * (SQRT (E**2 + NU) + E)
      T = SQRT (G**2 + (F - NU * G) / (2.D0 * G - E)) - G
      STNHT = (R - SMAXIS * T) * COS (STNLAT(IANT)) +
     *           (Z - B) * SIN (STNLAT(IANT))
      RETURN
      END
      SUBROUTINE SUN (YEAR, DAY, FDAY, SUNCV)
C-----------------------------------------------------------------------
C   Calculate three coordinates of the Sun and its velocity at
C   the equatorial system of coordinates originating at the Earth
C   center.
C   Acuracy for the time interval 1950-2050:
C                      10000 km in position
C                      0.004 km/s in speed
C
C   Inputs:
C      YEAR      I       Year, for example 1996
C      DAY       I       Day in year (1 = Jan 1st)
C      FDAY      R       Fraction of day
C
C   Outputs:
C      SUNCV     R(6)    Sun position & velocity vector
C                        Position part, SUNCV(1-3), is in km;
C                        Velocity part, SUNCV(4-6), is in km/sec.
C-----------------------------------------------------------------------
      REAL FDAY, SUNCV(6)
      INTEGER YEAR, DAY
C
      INCLUDE 'INCS:PSTD.INC'
      INTEGER YEAR4
      REAL SPEED, REMB, SEMB, Y1900, YF, T, ELM, GAMMA, EM, ELT, EPS0,
     *   ECCEN, ESQ, V, R, ELMM, COSELT, SINEPS, COSEPS, W1, W2, SELMM,
     *   CELMM, AU
C                                       Astronomical unit, km
      DATA AU /1.495979E8/
C-----------------------------------------------------------------------
      REMB = 3.12E-5
      SEMB = 8.31E-11
C                                       Mean orbital speed of Earth,
C                                       AU/s
      SPEED = 1.9913E-7
      Y1900 = YEAR-1900.0
      YEAR4 = MOD (MOD (YEAR, 4) +4, 4)
      YF=(FLOAT( 4 * (DAY - 1/(YEAR4 + 1)) - YEAR4 - 2) + 4.0 * FDAY)
     *   / 1461.0
      T=Y1900 + YF
C                                       Geometric mean longitude of Sun
      ELM = DMOD (4.881628 + TWOPI * YF + 0.00013420 * T, TWOPI)
C                                       Mean longitude of perihelion
      GAMMA = 4.908230 + 3.0005E - 4 * T
C                                       Mean anomaly
      EM = ELM - GAMMA
C                                       Mean obliquity
      EPS0 = 0.40931975 - 2.27E-6 * T
C                                       Eccentricity
      ECCEN = 0.016751 - 4.2E-7 * T
      ESQ = ECCEN * ECCEN
C                                       True anomaly
      V = EM + 2.0 * ECCEN * SIN(EM) + 1.25 * ESQ * SIN (2.0 * EM)

C                                       True ecliptic longitude
      ELT = V + GAMMA
C                                       True distance
      R = (1.0 - ESQ) / (1.0 + ECCEN * COS(V))

C                                       Moon's mean longitude
      ELMM = DMOD (4.72D0 + 83.9971D0 * T, TWOPI)
C
      COSELT = COS (ELT)
      SINEPS = SIN (EPS0)
      COSEPS = COS(EPS0)
      W1 = -R * SIN (ELT)
      W2 = -SPEED * (COSELT + ECCEN * COS (GAMMA))
      SELMM = SIN (ELMM)
      CELMM = COS (ELMM)
C                                       Sun position and velocity
      SUNCV(1) = (R * COSELT + REMB * CELMM) * AU
      SUNCV(2) = -(W1 - REMB * SELMM) * COSEPS * AU
      SUNCV(3) = -W1 * SINEPS * AU
      SUNCV(4) = -(SPEED * (SIN(ELT) + ECCEN * SIN(GAMMA)) +
     *   SEMB * SELMM) * AU
      SUNCV(5) = -(W2 - SEMB * CELMM) * COSEPS * AU
      SUNCV(6) = -W2 * SINEPS * AU
C
 999  RETURN
      END
      SUBROUTINE SUNJPL (YEAR, MONTH, DAY, FDAY, NAME, LINUN, SUNCV)
C-----------------------------------------------------------------------
C   Calculate three coordinates of the Sun and its velocity at
C   the equatorial system of coordinates originating at the Earth
C   center based on the JPL (B. Butler) software.
C   Works for the time interval 1950-2020:
C                      10000 km in position
C                      0.004 km/s in speed
C
C   Inputs:
C      YEAR      I       Year, for example 1996
C      MONTH     I       Month of the year
C      DAY       I       Day of the month
C      FDAY      D       Fraction of day
C      NAME      C       Name of the planet
C      LINUN     L       LINUX/UNIX/ computer
C
C   Outputs:
C      SUNCV     D(6)    Sun position & velocity vector
C                        Position part, SUNCV(1-3), is in km;
C                        Velocity part, SUNCV(4-6), is in km/sec.
C-----------------------------------------------------------------------
      DOUBLE PRECISION  FDAY, SUNCV(6)
      INTEGER YEAR, MONTH, DAY
C
      INCLUDE 'INCS:PSTD.INC'
C

      INTEGER IERR
      LOGICAL  TR
      LOGICAL   LINUN
      CHARACTER   NAME*12, FILEIN*48, PATHIN*256
      DOUBLE PRECISION MJD, XX, YY, DX, DY, ZZ, DZ
      DOUBLE PRECISION AU
C                                       Astronomical unit, meters
      DATA AU /1.4959787066D11/
      DATA TR /.TRUE./
C-----------------------------------------------------------------------
C                                       convert Gregorian Calendar date
C                                       to Modified Julian Date
      CALL SLCLDJ (YEAR, MONTH, DAY, MJD, IERR)
C
      MJD = MJD + FDAY
C                                       calculate the planet position
C                                       without time shift for
C                                       the delay Planet-Earth
C
C                                       LINUX/UNIX
      IF (LINUN) THEN
         FILEIN = 'AIPSTARS:JPLEPH.405.2.LINUX'
      ELSE
         FILEIN = 'AIPSTARS:JPLEPH.405.2.SUNOS'
         END IF
      CALL ZFULLN (FILEIN, '-1', ' ', PATHIN, IERR)
Ctemporally comment the first call jpleph
C
C      CALL JPLEPH (FILEIN, NAME, MJD, 0.0D0,
C     *             0.0D0, 0.0D0, 'J2000', 'GEO', XX, YY, DX, DY, ZZ,
C     *             DZ, FL, IERR)
Ctemporally
C      DIST = ZZ * AU
C                                       add the time of the light
C                                       traveling from Planet to Earth
C                                       to get agreement with John Bens.
Ctemporally do not add the propogation time
C      MJD = MJD + AU/VELITE/86400.D0
Ctemporaly commenr DIST
C      MJD = MJD + DIST/VELITE/86400.D0
C      MJD = MJD + 0.0038
C
C                                       calculate X,Y,Z and their rates
C                                       for the time of emmission
      CALL JPLEPH (PATHIN, NAME, MJD, 0.0D0,
     *             0.0D0, 0.0D0, 'J2000', 'GEO', XX, YY, DX, DY, ZZ,
     *             DZ, TR, IERR)
C                                       convert to km and km/sec
      SUNCV(1) = XX * (AU / 1000.0D0)
      SUNCV(2) = YY * (AU / 1000.0D0)
      SUNCV(3) = ZZ * (AU / 1000.0D0)
      SUNCV(4) = DX * (AU / 1000.0D0) / 86400.0D0
      SUNCV(5) = DY * (AU / 1000.0D0) / 86400.0D0
      SUNCV(6) = DZ * (AU / 1000.0D0) / 86400.0D0
C
 999  RETURN
      END
C
      SUBROUTINE SLCLDJ (IY, IM, ID, DJM, J)
*+
*     - - - - -
*      C L D J
*     - - - - -
*
*  Gregorian Calendar to Modified Julian Date
*
*  Given:
*     IY,IM,ID     int    year, month, day in Gregorian calendar
*
*  Returned:
*     DJM          dp     modified Julian Date (JD-2400000.5) for 0 hrs
*     J            int    status:
*                           0 = OK
*                           1 = bad year   (MJD not computed)
*                           2 = bad month  (MJD not computed)
*                           3 = bad day    (MJD computed)
*
*  The year must be -4699 (i.e. 4700BC) or later.
*
*  The algorithm is derived from that of Hatcher 1984
*  (QJRAS 25, 53-55).
*
*  P.T.Wallace   Starlink   December 1985
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*-

C IMPLICIT NONE

      INTEGER IY,IM,ID
      DOUBLE PRECISION DJM
      INTEGER J

*  Month lengths in days
      INTEGER MTAB(12)
      DATA MTAB/31,28,31,30,31,30,31,31,30,31,30,31/



*  Preset status
      J=0

*  Validate year
      IF (IY.LT.-4699) THEN
         J=1
      ELSE

*     Validate month
         IF (IM.GE.1.AND.IM.LE.12) THEN

*        Allow for leap year
            IF (MOD(IY,4).EQ.0) THEN
               MTAB(2)=29
            ELSE
               MTAB(2)=28
            END IF
            IF (MOD(IY,100).EQ.0.AND.MOD(IY,400).NE.0)
     :         MTAB(2)=28

*        Validate day
            IF (ID.LT.1.OR.ID.GT.MTAB(IM)) J=3

*        Modified Julian Date
               DJM=DBLE((1461*(IY-(12-IM)/10+4712))/4
     :                  +(306*MOD(IM+9,12)+5)/10
     :                  -(3*((IY-(12-IM)/10+4900)/100))/4
     :                  +ID-2399904)

*        Bad month
         ELSE
            J=2
         END IF

      END IF

      END
C
      SUBROUTINE SPACES (IERR)
C-----------------------------------------------------------------------
C   Routine to read positions of the space craft from the OB table
C
C   Control info from common:
C      NLINES    I    number of elements at the following arrays
C      TMES(*)   D    array of measurement times, in days
C      SPACEX(*) R    array of the spacecraft X, in meters
C      SPACEY(*) R    array of the spacecraft Y, in meters
C      SPACEZ(*) R    array of the spacecraft Z, in meters
C   Output:
C      IERR      I    Return error code , 0=OK else failed.
C-----------------------------------------------------------------------
      INTEGER   IERR
      INCLUDE 'INCS:POBV.INC'
      INTEGER OBVER, IOBRNO, LUN, OBKOLS(MAXOBC), OBNUMV(MAXOBC),
     *   IANTOB, ISUBOB, IORB, KORB, NUMREC, INVER, BUFFAN(512)
      INTEGER BUFFOB(512)
C
      REAL      ANGLOB(3), ECLPOB(4), ORIOB
      DOUBLE PRECISION DXYZOB(3), DVELOB(3), DTIMOB, TIMBEG, TIMEND
      INCLUDE 'CLCOR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DMSG.INC'
C      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DANT.INC'
C      INCLUDE 'INCS:DSOU.INC'
C      INCLUDE 'INCS:DDCH.INC'
C      INCLUDE 'INCS:DUVH.INC'
C      INCLUDE 'INCS:DHDR.INC'
      DATA LUN /30/
C-----------------------------------------------------------------------
C                                       Open  AN table to get GSTIA0
      INVER = 1
      CALL ANTINI ('READ', BUFFAN, DISKIN, CNOIN, INVER, CATBLK, LUN,
     *   IANRNO, ANKOLS, ANNUMV, ARRAYC, GSTIA0, DEGPDY, SAFREQ,
     *   RDATE, POLRXY, UT1UTC, DATUTC, TIMSYS, ANAME, NUMORB,
     *   NOPCAL, ANFQID, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1000)
         CALL MSGWRT (8)
         GO TO 999
         END IF
C                                      Close AN extension files
      CALL TABIO ('CLOS', INVER, IANRNO, BUFFAN, BUFFAN, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1100)
         CALL MSGWRT (8)
         GO TO 999
         END IF
      IERR = 0
C                                       Timerange
      TIMBEG = XTIME(1) + XTIME(2) / 24.0 + XTIME(3) / (24.0*60.0) +
     *   (XTIME(4) / (24.0*60.0*60.0))
      TIMEND = XTIME(5) + XTIME(6) / 24.0 + XTIME(7) / (24.0*60.0) +
     *   (XTIME(8) / (24.0*60.0*60.0))
      IF ((TIMEND.LT.TIMBEG) .OR. (TIMEND.LT.1.0E-5)) TIMEND = 1.0E20
C
      OBVER = 1
C                                       Open OB table
      CALL OBINI ('READ', BUFFOB, DISKIN, CNOIN, OBVER, CATBLK, LUN,
     *   IOBRNO, OBKOLS, OBNUMV, IERR)
      IF (IERR.NE.0) GO TO 999
C

C                                       Get number of records
      NUMREC = BUFFOB(5)
      IF (NUMREC.LE.0) GO TO 999
      KORB = 0
      DO 500 IORB = 1, NUMREC
C                                       read OB table
         IOBRNO = IORB
         CALL TABOB ('READ', BUFFOB, IOBRNO, OBKOLS, OBNUMV,
     *   IANTOB, ISUBOB, DTIMOB, DXYZOB, DVELOB, ANGLOB, ECLPOB,
     *   ORIOB, IERR)

C                                       check if record is flagged
         IF (IERR.LT.0) GO TO 500
C                                       timerange selection
         IF (DTIMOB.LT.TIMBEG) GO TO 500
         IF (DTIMOB.GT.TIMEND) GO TO 520
         KORB = KORB + 1
         TMES(KORB) = DTIMOB
         SPACEX(KORB) = DXYZOB(1)
         SPACEY(KORB) = DXYZOB(2)
         SPACEZ(KORB) = DXYZOB(3)
  500    CONTINUE
  520 CONTINUE
      NLINES = KORB
C                                       Close input OB table
      CALL TABIO ('CLOS', 0, IOBRNO, BUFFOB, BUFFOB, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1200) OBVER
         CALL MSGWRT (6)
         GO TO 999
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('ERROR: Missing AN table!')
 1100 FORMAT ('SPACES: ERROR',I3,' CLOSING AN FILE')
 1200 FORMAT ('ERROR closing OB table', I3)
      END
      SUBROUTINE UT1COR (UT1IFX, UT1PTX, TAIUTC, XJDTIM, UT1VAL)
C-----------------------------------------------------------------------
C  UT1COR interpolates UT1-UTC values using code fragments taken
C  from the GSFS program CALC, version 9.1. The interpolated values
C  are intended to be identical to what the CALC program produces
C  internally.
C  In particular this subroutine can be used to reproduce the
C  calculations carried out by the VLBA correlator.
C
C  J. Benson Aug 2005
C
C  Modified by L. Kogan Feb 2006: add the array of the leap second
C  with possible jump at the interpolation interval to go to smooth
C  UT1-TAI, interpolate it and then return back the interpolated
C  UT1-TAI to UT1-UTC subtracting TAIUTC(2) which is supposed to be
C  the leap second at the observation time.
C
C  Inputs:
C  UT1IFX(4)  D     The UT1 information array.
C                   1. The Julian day of the first tabular point
C                   2. The increment of the tabular points (expected 1),
C                      in days
C                   3. The number of tabular points (5 for VLBA correlator)
C                   4. is not used
C
C  UT1PTX(20) D     The tabular values of 'UT1 - UTC', in sec
C  TAIUTC(20) D     Leap second values, for example equal 32 for 2005
C                   TAIUTC(2) Leap second values for the observation date,
C  XJDTIM     D     Time to interpolate on, in JD
C
C  Output:
C  UT1VAL     D     Interpolated value, in sec
C-----------------------------------------------------------------------
      DOUBLE PRECISION UT1IFX(4), UT1PTX(*), TAIUTC(*), XJDTIM,
     *   UT1VAL
C
      INTEGER   KUT1C, NSPLIN, SHRTFL
      LOGICAL   USESPL
      DOUBLE PRECISION UT1IF(4), UT1PT(100), UT1RS(100), XT(100),
     *   YA(100), Y2S(100), XSPLIN, YSPLIN, YDOT, YDOT2, YDOT3, YP1,
     *   YPN, CT, XJD,  FA(5), FAD(5), TC2000,  ATMUT1, SHORTP, DUT,
     *   DLOD, DOMEGA, SECDAY
      INTEGER   ITAB, II, TABLEN, IERR4, I
C-----------------------------------------------------------------------
      KUT1C   = 0
      SHRTFL = 1
      USESPL = .TRUE.
      SECDAY  = 86400.0
      DO 10 I = 1,4
         UT1IF(I) = UT1IFX(I)
 10      CONTINUE
      TABLEN = UT1IF(3) + 0.01
      DO 15 I = 1,TABLEN
C         UT1PT(i) = TAIUTC - UT1PTX(i)
C                                       change LK
C                                       add the leap second possibly
C                                       with jump to convert to smooth
C                                       UT1-TAI
         UT1PT(I) = TAIUTC(I) - UT1PTX(I)
 15      CONTINUE
C
C  Logic for TAI-UT1S tables (default)
      IF (KUT1C.EQ.0 .OR. KUT1C.EQ.3 .OR. KUT1C.EQ.2) THEN
C
         DO 20 ITAB = 1, TABLEN
C                                       !Already UT1S
            IF(SHRTFL .EQ. -2) THEN
               UT1RS(ITAB) = UT1PT(ITAB)
            ELSE
C                                       ! Fraction of day
               CT  = 0.0D0
               XJD = UT1IF(1) + (ITAB-1)*UT1IF(2)
               CALL NUTFA  (XJD, CT, TC2000, FA, FAD)
               CALL UT1SZT (FA, FAD, DUT, DLOD, DOMEGA)
C
C          DUT = 0.0
C                                       !starting with true UT1
               IF (SHRTFL.EQ.1) THEN
                  UT1RS(ITAB) = UT1PT(ITAB) + DUT
C            write (6,'(1x, f10.6, f10.6)') UT1PT(Itab),UT1RS(Itab)
                  END IF
               END IF
 20         CONTINUE
C
C     Place the UT1 module flow control message into the database.
C     UT1 module on, Tidal terms from UT1S model
C          apply_tidal_correction = .true.
C          Call PUTA('UT1 CFLG      ',LUT1S,40,1,1)
C
         END IF
C ***************
C   Code for spline interpolation initialization, 93DEC08  -DG-
C                                       ! Initialize spline routine
      IF (USESPL) THEN
         NSPLIN = TABLEN
C
         DO 25 II=1,NSPLIN
            YA(II) = UT1RS(II)
 25         CONTINUE
C
         DO 30 II = 1,NSPLIN
            XT(II) =  UT1IF(1) + (II-1)*UT1IF(2)
C        write (6, '(1x, f12.2, d16.8)') XT(ii), ya(ii)
 30         CONTINUE
C
C   If interval (UT1IF(2)) not 1.0 days, then divide by interval ?????
         IF (ABS(UT1IF(2) - 1.D0) .GT. 1.D-10) THEN
            DO 40 II = 1,NSPLIN
               XT(II) = XT(II) / UT1IF(2)
 40            CONTINUE
            END IF
C
C   Take first derivatives at endpoints
         YP1 = (YA(2)-YA(1)) / UT1IF(2)
         YPN = (YA(NSPLIN)-YA(NSPLIN-1))/ UT1IF(2)
C
C  call spline initialization subroutine
         CALL SPLINE (XT, YA, NSPLIN, YP1, YPN, Y2S, IERR4)
C                                       ! Initialize spline routine
         END IF
C ***************
C  Begin interpolation:
C
C***************************************
C                                       !Cubic spline interpolation
      IF (USESPL) THEN
C   Compute time of obs. and divide by interval
         XSPLIN = XJDTIM
C        write (6, '(1x, f12.2)') x_spline
C
C   Do the spline interpolation
         CALL SPLIN4 (XT, YA, Y2S, NSPLIN, XSPLIN, YSPLIN, YDOT,
     *      YDOT2, YDOT3, IERR4)
C                                        fraction of day
         CT  = 0.0D0
         XJD = XJDTIM
         CALL NUTFA  (XJD, CT, TC2000, FA, FAD)
         CALL UT1SZT (FA, FAD, DUT, DLOD, DOMEGA)
         SHORTP = -DUT
         ATMUT1 = YSPLIN + SHORTP
C        DIVUTC = ydot / (UT1IF(2) * SECDAY) + SHORTP_DOT
C                                       change LK
C                                       add the leap second of the
C                                       observe time to return back
C                                       to UT1-UTC
C        UT1VAL = TAIUTC - ATMUT1
         UT1VAL = TAIUTC(2) - ATMUT1
C                                       !Cubic spline interpolation
         END IF
C
      END
      SUBROUTINE PINTER (WOBIFX, XYWOBX, XJDTIM, WOBVAL)
C-----------------------------------------------------------------------
C  PINTER interpolates xpol, ypol values using code fragments taken
C  from the GSFS program CALC, version 9.1. The interpolated values
C  are intended to be identical to what the CALC program produces
C  internally.
C  In particular this subroutine can be used to reproduce the
C  calculations carried out by the VLBA correlator.
C
C  J. Benson Aug 2005
C
C  Inputs:
C  WOBIFX(4)    D    The wobble information array.
C                    1. The Julian day of the first tabular point
C                    2. The increment of the tabular points (expected 1),
C                      in days
C                    3. The number of tabular points
C                      (5 for VLBA correlator)
C                    4. not used
C
C  XYWOBX(2,20) D     The wobble tabular points for the polar motion
C                     (wobble) X & Y offsets. (milliarcsec)
C                     (Note: Based on old BIH conventions, offsets
C                           are assumed to be left-handed.)
C  XJDTIM       D     Time to interpolate on, in JD
C
C  Output:
C  WOBVAL(2)    D     Interpolated value, in milliarcsec
C-----------------------------------------------------------------------
      DOUBLE PRECISION WOBIFX(4), XYWOBX(2,20), XJDTIM, WOBVAL(2)
C
      INTEGER   NSPLIN
      LOGICAL   USESPL
      DOUBLE PRECISION XSPLIN, YP1X, YPNX, YP1Y, YPNY, YYSPLN,
     *   YYDOT, YYDOT2, YYDOT3, YXSPLN, YXDOT, YXDOT2, YXDOT3, SECDAY
      INTEGER  II, TABLEN, IERR4, I
      DOUBLE PRECISION WOBIF(3), XYWOB(2,40), XA(40), YAX(40), YAY(40),
     *   Y2SX(40), Y2SY(40)
C-----------------------------------------------------------------------
      SECDAY = 86400.0
      USESPL = .TRUE.

      DO 10 I = 1, 3
         WOBIF(I) = WOBIFX(I)
 10      CONTINUE
      TABLEN   = WOBIF(3) + 0.01
      DO 20 I = 1, TABLEN
         XYWOB(1,I) = XYWOBX(1,I)
         XYWOB(2,I) = XYWOBX(2,I)
 20      CONTINUE

C ***************
C   Code for spline interpolation initialization, 93DEC08  -DG-
C                                       ! INITIALIZE spline routine
      IF (USESPL) THEN
         NSPLIN = TABLEN
C
         DO 30 II = 1,NSPLIN
            YAX(II) = XYWOB(1,II)
            YAY(II) = XYWOB(2,II)
 30         CONTINUE
C
         XA(1) = WOBIF(1)
         DO 40 II = 2,NSPLIN
            XA(II) = XA(II-1) + WOBIF(2)
 40         CONTINUE
C
C   If interval (WOBIF(2)) not 1.0 days, then divide by interval
         IF (ABS(WOBIF(2) - 1.D0) .GT. 1.D-10) THEN
            DO 50 II = 1,NSPLIN
               XA(II) = XA(II) / WOBIF(2)
 50            CONTINUE
            END IF
C
C   Take first derivatives at endpoints for X-wobble
         YP1X = (YAX(2)-YAX(1)) / (XA(2)-XA(1))
         YPNX = (YAX(NSPLIN)-YAX(NSPLIN-1))/
     .      (XA(NSPLIN)-XA(NSPLIN-1))
C  call spline initialization subroutine for X-wobble
         CALL SPLINE (XA,YAX, NSPLIN, YP1X, YPNX, Y2SX, IERR4)
C  Take first derivatives at endpoints for Y-wobble
         YP1Y = (YAY(2)-YAY(1)) / (XA(2)-XA(1))
         YPNY = (YAY(NSPLIN)-YAY(NSPLIN-1))/
     .      (XA(NSPLIN)-XA(NSPLIN-1))
C  call spline initialization subroutine for Y-wobble
         CALL SPLINE (XA, YAY, NSPLIN, YP1Y, YPNY, Y2SY, IERR4)
C                                       ! Initialize spline routine
         END IF
C ***************
C  Begin interpolation:
C
C***************************************
C                                       !Cubic spline interpolation
      IF (USESPL) THEN
C   Compute time of obs. and divide by interval
         XSPLIN = XJDTIM
C        write (6, '(1x, f12.2)') x_spline
C
C  Perform cubic spline for X-wobble interpolation
         CALL SPLIN4 (XA, YAX, Y2SX, NSPLIN, XSPLIN, YXSPLN,
     *      YXDOT, YXDOT2, YXDOT3, IERR4)
         WOBVAL(1) = YXSPLN
C
C  Perform cubic spline for Y-wobble interpolation
         CALL SPLIN4 (XA, YAY, Y2SY, NSPLIN, XSPLIN, YYSPLN,
     *      YYDOT, YYDOT2, YYDOT3, IERR4)
         WOBVAL(2) = YYSPLN
C                                       !Cubic spline interpolation
         END IF
C
      END
C***********************************************************************
      SUBROUTINE NUTFA (XJD, CT, CENT, FA, FAD)
C-----------------------------------------------------------------------
C   NUTFA computes the number of Julian centuries since J2000 and the
C   fundamental arguments and derivatives to be used in the nutation
C   series.
C
C   References: D.McCarthy, IERS Technical Note 13, 'IERS Conventions
C                          (1992)', Paris 1992
C              T.C. van Flandern, Lunar Occult. Work (fundam.argum.)
C              D.McCarthy, IERS Technical Note 21, 'IERS Conventions
C                          (1996)', Paris 1996
C
C   Calling sequence:
C   input:
C      1. XJD  -  The Julian date at zero hours UTC of the date in
C                      question. (days)
C      2. CT   -  The coordinate time fraction of the coordinate time
C                      day. (days)
C   output:
C      1. CENT -  The number of Julian centuries elapsed since the
C                      epoch January 1.5 2000.(centuries)
C      2. FA(5)-  The fundamental arguments for the nutation theory.
C                      (arcseconds)
C               1 = mean anomaly of the moon
C                 = mean longitude of the moon minus the
C                   mean longitude of the moon's perigee     (l)
C               2 = mean anomaly of the sun
C                 = mean longitude of the sun minus the
C                   mean longitude of the sun's perigee      (l')
C               3 = mean longitude of the moon minus omega   (F)
C               4 = mean elongation of the moon from the sun (D)
C               5 = longitude of the asc.node of the moon's
C                   mean orbit on the ecliptic,
C                   measured from the mean equinox of date   (omega)
C      3. FAD(5)- The CT time derivatives of the fundamental arguments.
C                      (arcsec/century)
C-----------------------------------------------------------------------
      DOUBLE PRECISION XJD, CT, CENT, FA(5), FAD(5), EL, ELP, F, D, OM,
     *   ELC(5), ELPC(5), FC(5), DC(5), OMC(5), CENT2, CENT3, CENT4,
     *   DAYSJ, SEC360
C
      DOUBLE PRECISION CENTJ, DJ2000, EC(4), ARGP(2,6)
      INTEGER   NOT, NOP, IDP(6)
      COMMON / NUTCM / CENTJ, DJ2000, EC, ARGP, NOT, NOP, IDP
C     Variables from:
C        1. centj   -  the number of coordinate time days per Julian century.
C                      (days/century)
C        2. dj2000  -  the Julian date of the epoch January 1.5, 2000. (days)
C
      EXTERNAL NUTCMB
C      INCLUDE 'ccon.i'
      INTEGER   KNUTD
C     Variables from:
C        1. KNUTD  -  nutation module debug flag
C
C     Subroutine interface:
C       Caller subroutines: DRIVR, UT1I
C       Called subroutines: DMOD
C
C     Constants used -
C       ELC(5)   - COEFFICIENTS USED IN THE CALCULATION OF EL
C       ELPC(5)  - COEFFICIENTS USED IN THE CALCULATION OF ELP
C       FC(5)    - COEFFICIENTS USED IN THE CALCULATION OF F
C       DC(5)    - COEFFICIENTS USED IN THE CALCULATION OF D
C       OMC(5)   - COEFFICIENTS USED IN THE CALCULATION OF OM
C
C     DATA statements for the fundamental arguments.
C     Simons et al., 1994 values
C      -Conform to IERS Conventions (1996)-
      DATA ELC    / -0.00024470D0,       0.051635D0,  31.8792D0,
     .          1717915923.2178D0,  485868.249036D0/
      DATA ELPC   / -0.00001149D0,      -0.000136D0,  -0.5532D0,
     .           129596581.0481D0,  1287104.79305D0/
      DATA FC     /  0.00000417D0,      -0.001037D0, -12.7512D0,
     .          1739527262.8478D0,  335779.526232D0/
      DATA DC     / -0.00003169D0,       0.006593D0,  -6.3706D0,
     .          1602961601.2090D0,  1072260.70369D0/
      DATA OMC    /-0.00005939D0,        0.007702D0,   7.4722D0,
     .           -6962890.2665D0,   450160.398036D0/
C                                       ! arcseconds in one turn
      DATA SEC360 / 1296000.0D0 /
C
C  Programmer:
C    93.09.01  Norbert Zacharias - Fundamental arguments computation put into
C              separate subroutine, taken from old NUTG subroutine.
C    98.01.28  David Gordon - Coefficients and computations modified to conform
C              to IERS Conventions (1996).
C
C-------------------------------------------------------------------------------
      KNUTD = 0

C  Compute the number of Julian days elapsed since the epoch January 1.5, 2000.
      DAYSJ = XJD + CT - DJ2000
C
C  Compute the number of Julian centuries elapsed since the epoch January 1.5,
C   2000.
      CENT  = DAYSJ / CENTJ
      CENT2 = CENT * CENT
      CENT3 = CENT * CENT2
      CENT4 = CENT2 * CENT2
C
C  Computation of the fundamental arguments and derivatives
C
      EL = ELC(1)*CENT4 + ELC(2)*CENT3 + ELC(3)*CENT2
     .   + ELC(4)*CENT  + ELC(5)
      FA (1) = DMOD( EL, SEC360 )
      FAD(1) = 4.D0*ELC(1)*CENT3 + 3.D0*ELC(2)*CENT2
     .       + 2.D0*ELC(3)*CENT  +      ELC(4)
C
      ELP = ELPC(1)*CENT4 + ELPC(2)*CENT3 + ELPC(3)*CENT2
     .    + ELPC(4)*CENT  + ELPC(5)
      FA (2) = DMOD( ELP, SEC360 )
      FAD(2) = 4.D0*ELPC(1)*CENT3 + 3.D0*ELPC(2)*CENT2
     .       + 2.D0*ELPC(3)*CENT  +      ELPC(4)
C
      F = FC(1)*CENT4 + FC(2)*CENT3 + FC(3)*CENT2
     .  + FC(4)*CENT  + FC(5)
      FA (3) = DMOD( F, SEC360 )
      FAD(3) = 4.D0*FC(1)*CENT3 + 3.D0*FC(2)*CENT2
     .       + 2.D0*FC(3)*CENT  +      FC(4)
C
      D = DC(1)*CENT4 + DC(2)*CENT3 + DC(3)*CENT2
     .  + DC(4)*CENT  + DC(5)
      FA (4) = DMOD( D, SEC360 )
      FAD(4) = 4.D0*DC(1)*CENT3 + 3.D0*DC(2)*CENT2
     .       + 2.D0*DC(3)*CENT  +      DC(4)
C
      OM = OMC(1)*CENT4 + OMC(2)*CENT3 + OMC(3)*CENT2
     .   + OMC(4)*CENT  + OMC(5)
      FA (5) = DMOD( OM, SEC360 )
      FAD(5) = 4.D0*OMC(1)*CENT3 + 3.D0*OMC(2)*CENT2
     .       + 2.D0*OMC(3)*CENT  +      OMC(4)
C-------------------------------------------------------------------------------
C  Debug output
      IF (KNUTD.NE.0) THEN
        WRITE (6,'(1X,A)') 'Debug output for subroutine NUTFA'
        WRITE (6,'(1X,A,D25.16)') 'CENT  = ', CENT
    8         FORMAT(A,4D25.16/(7X,5D25.16))
        WRITE(6,8)' ELC     ',ELC
        WRITE(6,8)' EL      ',FA (1)
        WRITE(6,8)' ELD     ',FAD(1)
        WRITE(6,8)' ELPC    ',ELPC
        WRITE(6,8)' ELP     ',FA (2)
        WRITE(6,8)' ELPD    ',FAD(2)
        WRITE(6,8)' FC      ',FC
        WRITE(6,8)' F       ',FA (3)
        WRITE(6,8)' FD      ',FAD(3)
        WRITE(6,8)' DC      ',DC
        WRITE(6,8)' D       ',FA (4)
        WRITE(6,8)' DD      ',FAD(4)
        WRITE(6,8)' OMC     ',OMC
        WRITE(6,8)' OM      ',FA (5)
        WRITE(6,8)' OMD     ',FAD(5)
      END IF
C
      END
C***********************************************************************
      SUBROUTINE UT1SZT (FA, FAD, DUT, DLOD, DOMEGA)
C-----------------------------------------------------------------------
C   Purpose: This subroutine evaluates the effects of zonal Earth tides
C   on the rotation of the Earth. The model used is from Yoder,
C   Williams, and Park (1981) and modified by the ocean effects as
C   given in Dickman (1991) as recommended by the IERS Standards,
C    p. 117, 119-120 (1992).
C
C   Special Note: Under the UT1S definition, and as done by this
C   routine, zonal tides of _all_ periods are evaluated, including even
C   those of 18.6 year period. Results will be substantially different
C   (tenths of seconds) from those evaluated with the "UT1R" algorithm,
C   which only includes the 41 terms for periods under 35 days. If you
C   wish to determine the effects from only those periods, please use
C   the original Luzum "zontids" routine, with N set to 41.  (B.A.)
C
C   Input Variables:
C      FA(5)  = Fundamental arguments from subroutine NUTFA (arcseconds)
C      FAD(5) = Time derivatives of fundamental arguments
C              (arcsec/century)
C   Output Variables:
C      DUT    - 'UT1 minus UT1S'. Effect on UT (Subtract from
C                observation,    add to IERS UT1). (sec)
C      DLOD   = Effect on length of day. (seconds).
C      DOMEGA = Effect on rotational speed (radians/second).
C
C     Written by:
C       Brian J. Luzum     92.08.11
C     Modifications:
C       Brent A. Archinal  92.08.27  Name changed from zontids to
C                                    ut1szt, N dropped from argument
C                                    list, comments improved.
C       "     "  "         92.10.27  Special note added above.
C       "     "  "         92.12.17  All real variables set to double
C                                    precision, at Jim Ray's suggestion
C                                    (email of 92.11.20).
C       David Gordon       93.03.17  Array X changed to XS, debug printout
C                                    added for calc 8.0.
C       Norbert Zacharias  93.09.16  Take fundam. arg. from subr. NUTFA
C       David Gordon       94.04.06  Changed to 'Implicit None'.
C       David Gordon       98.01.21  Extensive mods from John Gipson to use
C                                    the series expansion of DUT to calculate
C                                    DUT, DLOD, and DOMEGA instead of seperate
C                                    series expansions. fad(5) added to
C                                    subroutine call. DBLE's removed. CMATH
C                                    common block added. Variable SECCON
C                                    removed and replaced with 1/CONVDS. Sign
C                                    of X(7,62) corrected.
C
      DOUBLE PRECISION DUT, DLOD, DOMEGA, F, D, OM, ARG
      DOUBLE PRECISION L, LP, FA(5), FAD(5), ARGDOT
      INTEGER   N, I
      DOUBLE PRECISION XS(11,62), X1(220), X2(220), X3(220), X4(22)
      EQUIVALENCE (XS(1,  1), X1(1))
      EQUIVALENCE (XS(1, 21), X2(1))
      EQUIVALENCE (XS(1, 41), X3(1))
      EQUIVALENCE (XS(1, 61), X4(1))
C
C      INCLUDE 'ccon.i'
      INTEGER   KNUTD, KUT1D
      INCLUDE 'INCS:DMSG.INC'
      DOUBLE PRECISION TWOPI, CONVDS, SECDAY
C     DOUBLE PRECISION PI, TWOPI, HALFPI, CONVD, CONVDS, CONVHS, SECDAY
C     COMMON / CMATH / PI, TWOPI, HALFPI, CONVD, CONVDS, CONVHS, SECDAY
C     DATA PI     /3.1415926535897932D0/,
      DATA TWOPI  /6.2831853071795865D0/
C     DATA HALFPI /1.5707963267948966D0/
C     DATA CONVD  /1.7453292519943296D-02/
      DATA CONVDS /4.8481368110953599D-06/
C     DATA CONVHS /7.2722052166430399D-05/
      DATA SECDAY /8.6400D04/

C          Variables 'from':
C            1. SECDAY -  The number of seconds in a day. (s/day)
C            2. TWOPI  -  PI times 2.0D0
C            3. CONVDS -  THE CONVERSION FACTOR FROM ARCSECONDS TO RADIANS
C                 (RAD/ARCSECOND)
C
C  N=Number of tidal terms to be used (62 for full set).
C  (This was an argument in the original zontids routine.)
C
      DATA  N /62/
C
C***********************************************************************
C     Table of multiples of arguments and coefficients
C      (DLOD and DOMEGA tables no longer used, 98JAN21 -DG-)
C
C                  Multiple of            DUT        DLOD      DOMEGA
C             l   l'  F   D OMEGA     sin   cos    cos  sin   cos   sin
      DATA X1/1., 0., 2., 2., 2.,    -0.02, 0.00,  0.3, 0.0, -0.2,  0.0,
     /        2., 0., 2., 0., 1.,    -0.04, 0.00,  0.4, 0.0, -0.3,  0.0,
     /        2., 0., 2., 0., 2.,    -0.10, 0.00,  0.9, 0.0, -0.8,  0.0,
     /        0., 0., 2., 2., 1.,    -0.05, 0.00,  0.4, 0.0, -0.4,  0.0,
     /        0., 0., 2., 2., 2.,    -0.12, 0.00,  1.1, 0.0, -0.9,  0.0,
     /        1., 0., 2., 0., 0.,    -0.04, 0.00,  0.3, 0.0, -0.2,  0.0,
     /        1., 0., 2., 0., 1.,    -0.40, 0.01,  2.7, 0.1, -2.3, -0.1,
     /        1., 0., 2., 0., 2.,    -0.98, 0.03,  6.7, 0.2, -5.7, -0.2,
     /        3., 0., 0., 0., 0.,    -0.02, 0.00,  0.1, 0.0, -0.1,  0.0,
     /       -1., 0., 2., 2., 1.,    -0.08, 0.00,  0.5, 0.0, -0.5,  0.0,
     /       -1., 0., 2., 2., 2.,    -0.20, 0.00,  1.3, 0.0, -1.1,  0.0,
     /        1., 0., 0., 2., 0.,    -0.08, 0.00,  0.5, 0.0, -0.4,  0.0,
     /        2., 0., 2.,-2., 2.,     0.02, 0.00, -0.1, 0.0,  0.1,  0.0,
     /        0., 1., 2., 0., 2.,     0.03, 0.00, -0.1, 0.0,  0.1,  0.0,
     /        0., 0., 2., 0., 0.,    -0.30, 0.00,  1.4, 0.0, -1.2,  0.0,
     /        0., 0., 2., 0., 1.,    -3.20, 0.09, 14.7, 0.4,-12.4, -0.4,
     /        0., 0., 2., 0., 2.,    -7.73, 0.21, 35.6, 1.0,-30.0, -0.8,
     /        2., 0., 0., 0.,-1.,     0.02, 0.00, -0.1, 0.0,  0.1,  0.0,
     /        2., 0., 0., 0., 0.,    -0.34, 0.00,  1.5, 0.0, -1.3,  0.0,
     /        2., 0., 0., 0., 1.,     0.02, 0.00, -0.1, 0.0,  0.1,  0.0/
      DATA X2/0.,-1., 2., 0., 2.,    -0.02, 0.00,  0.1, 0.0, -0.1,  0.0,
     /        0., 0., 0., 2.,-1.,     0.05, 0.00, -0.2, 0.0,  0.2,  0.0,
     /        0., 0., 0., 2., 0.,    -0.72, 0.02,  3.1, 0.1, -2.6, -0.1,
     /        0., 0., 0., 2., 1.,    -0.05, 0.00,  0.2, 0.0, -0.2,  0.0,
     /        0.,-1., 0., 2., 0.,    -0.05, 0.00,  0.2, 0.0, -0.2,  0.0,
     /        1., 0., 2.,-2., 1.,     0.05, 0.00, -0.1, 0.0,  0.1,  0.0,
     /        1., 0., 2.,-2., 2.,     0.10, 0.00, -0.3, 0.0,  0.2,  0.0,
     /        1., 1., 0., 0., 0.,     0.04, 0.00, -0.1, 0.0,  0.1,  0.0,
     /       -1., 0., 2., 0., 0.,     0.05, 0.00, -0.1, 0.0,  0.1,  0.0,
     /       -1., 0., 2., 0., 1.,     0.18, 0.00, -0.4, 0.0,  0.3,  0.0,
     /       -1., 0., 2., 0., 2.,     0.44, 0.00, -1.0, 0.0,  0.9,  0.0,
     /        1., 0., 0., 0.,-1.,     0.53, 0.00, -1.2, 0.0,  1.0,  0.0,
     /        1., 0., 0., 0., 0.,    -8.33, 0.12, 19.0, 0.3,-16.0, -0.2,
     /        1., 0., 0., 0., 1.,     0.54, 0.00, -1.2, 0.0,  1.0,  0.0,
     /        0., 0., 0., 1., 0.,     0.05, 0.00, -0.1, 0.0,  0.1,  0.0,
     /        1.,-1., 0., 0., 0.,    -0.06, 0.00,  0.1, 0.0, -0.1,  0.0,
     /       -1., 0., 0., 2.,-1.,     0.12, 0.00, -0.2, 0.0,  0.2,  0.0,
     /       -1., 0., 0., 2., 0.,    -1.84, 0.02,  3.6, 0.0, -3.0,  0.0,
     /       -1., 0., 0., 2., 1.,     0.13, 0.00, -0.3, 0.0,  0.2,  0.0,
     /        1., 0.,-2., 2.,-1.,     0.02, 0.00,  0.0, 0.0,  0.0,  0.0/
      DATA X3/-1.,-1.,0., 2., 0.,    -0.09, 0.00,  0.2, 0.0, -0.1,  0.0,
     /        0., 2., 2.,-2., 2.,    -0.06, 0.00,  0.0, 0.0,  0.0,  0.0,
     /        0., 1., 2.,-2., 1.,     0.03, 0.00,  0.0, 0.0,  0.0,  0.0,
     /        0., 1., 2.,-2., 2.,    -1.88, 0.00,  1.0, 0.0, -0.8,  0.0,
     /        0., 0., 2.,-2., 0.,     0.25, 0.00, -0.1, 0.0,  0.1,  0.0,
     /        0., 0., 2.,-2., 1.,     1.17, 0.00, -0.4, 0.0,  0.3,  0.0,
     /        0., 0., 2.,-2., 2.,   -48.84, 0.11, 16.8, 0.0,-14.2,  0.0,
     /        0., 2., 0., 0., 0.,    -0.19, 0.00,  0.1, 0.0, -0.1,  0.0,
     /        2., 0., 0.,-2.,-1.,     0.05, 0.00,  0.0, 0.0,  0.0,  0.0,
     /        2., 0., 0.,-2., 0.,    -0.55, 0.00,  0.2, 0.0, -0.1,  0.0,
     /        2., 0., 0.,-2., 1.,     0.04, 0.00,  0.0, 0.0,  0.0,  0.0,
     /        0.,-1., 2.,-2., 1.,    -0.05, 0.00,  0.0, 0.0,  0.0,  0.0,
     /        0., 1., 0., 0.,-1.,     0.09, 0.00,  0.0, 0.0,  0.0,  0.0,
     /        0.,-1., 2.,-2., 2.,     0.83, 0.00, -0.1, 0.0,  0.1,  0.0,
     /        0., 1., 0., 0., 0.,   -15.55, 0.02,  2.6, 0.0, -2.2,  0.0,
     /        0., 1., 0., 0., 1.,    -0.14, 0.00,  0.0, 0.0,  0.0,  0.0,
     /        1., 0., 0.,-1., 0.,     0.03, 0.00,  0.0, 0.0,  0.0,  0.0,
     /        2., 0.,-2., 0., 0.,    -0.14, 0.00,  0.0, 0.0,  0.0,  0.0,
     /       -2., 0., 2., 0., 1.,     0.42, 0.00,  0.0, 0.0,  0.0,  0.0,
     /       -1., 1., 0., 1., 0.,     0.04, 0.00,  0.0, 0.0,  0.0,  0.0/
      DATA X4/0., 0., 0., 0., 2.,     7.90, 0.00,  0.1, 0.0, -0.1,  0.0,
     /        0., 0., 0., 0., 1., -1637.68,-0.10,-10.4, 0.0,  8.8,  0.0/
C       X4(18) corrected, old value +0.10, new value -0.10
C    /        0., 0., 0., 0., 1., -1637.68, 0.10,-10.4, 0.0,  8.8,  0.0/
C
C***********************************************************************
C     Fundamental arguments from subroutine NUTFA in file cnutm.f:
C
C     L = fa (1)
C     LP= fa (2)
C     F = fa (3)
C     D = fa (4)
C     OM= fa (5)
C
      KNUTD  = 0
      KUT1D = 0

      DUT    = 0.0D+0
      DLOD   = 0.0D+0
      DOMEGA = 0.0D+0
C
C     Sum zonal tide terms
C
      DO 10 I = 1,N
C   Formation of multiples of arguments
         ARG = XS(1,I)*FA(1) + XS(2,I)*FA(2) + XS(3,I)*FA(3)
     *      + XS(4,I)*FA(4) + XS(5,I)*FA   (5)
         ARG = DMOD(ARG,1296000.0D0) * CONVDS
C   First derivative
         ARGDOT = XS(1,I)*FAD(1)  + XS(2,I)*FAD(2) + XS(3,I)*FAD(3)
     *      + XS(4,I)*FAD(4) + XS(5,I)*FAD(5)
C     Evaluate zonal tidal terms
         DUT    = XS(6,I)*DSIN(ARG) + XS(7,I)*DCOS(ARG) + DUT
         DLOD   = (XS(6,I)*DCOS(ARG) - XS(7,I)*DSIN(ARG) )*ARGDOT +
     *      DLOD
   10    CONTINUE
      DUT    = DUT    * 1.0D-4
      DLOD   = -DLOD * 1.0D-4 / (3.6525D+4 / CONVDS)
      DOMEGA = -DLOD * TWOPI / SECDAY**2
C
C     Check for debug output.
      IF (KUT1D.EQ.1) THEN
         MSGTXT = 'Debug output for subroutine UT1SZT'
         CALL MSGWRT (4)
         WRITE (MSGTXT,1000) L, LP
         CALL MSGWRT (4)
         WRITE (MSGTXT,1001) F, D
         CALL MSGWRT (4)
         WRITE (MSGTXT,1002) OM, ARG
         CALL MSGWRT (4)
         WRITE (MSGTXT,1003) DUT, DLOD
         CALL MSGWRT (4)
         WRITE (MSGTXT,1004) DOMEGA
         CALL MSGWRT (4)
         END IF
C
      RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('L = ',1PD19.12,5X,'LP =',1PD19.12)
 1001 FORMAT ('F = ',1PD19.12,5X,'D =',1PD19.12)
 1002 FORMAT ('OM = ',1PD19.12,5X,'ARG =',1PD19.12)
 1003 FORMAT ('DUT = ',1PD19.12,5X,'DLOD =',1PD19.12)
 1004 FORMAT ('DOMEGA = ',1PD19.12)
      END
C***********************************************************************
      SUBROUTINE SPLINE (XA, YA, N, YP1, YPN, Y2, IERR4)
C-----------------------------------------------------------------------
C   Subroutine spline is the initialization section of a two subroutine
C   module used to do cubic spline interpolations. Spline is called each
C   time you change to a new set of tabular points. Subroutine splin4
C   is the second half and does the actual interpolation.
C
C   Given arrays xa(i), and ya(i) for i=1 to n containing a tabulated
C     function ya(i) = f(xa(i)) with xa(1) < xa(2) <..< xa(n) and values
C     yp1 and ypn whichc are the first derivatives of the function f( ) at
C     points 1 and n, respectively, this routine returns an array
C     y2(i) for i=1 to n which contains the second derivatives of the
C     function f( ) at the tabulated points xa(i). If yp1 and/or ypn are
C     greater than or equal to 1.d30, the routine is signaled to set the
C     corresponding boundary condition for a natural spline, with zero
C     second derivatives on the boundary.
C
C     The cubic spline has the following properties.
C     1) It is continuous and exactly fits at the tabular values.
C     2) The first and second derivatives are everywhere continuous,
C        even at the tabular points when points are added to and
C        deleted from the set of five points used to interpolate.
C     3) The third derivative is not continuous, but rather a series
C        of disconnected constant values.
C     4) The fourth derivative is zero.
C     5) It requires a minimum of five points and values of the first
C        derivative at the two endpoints.
C
C     In order to guarantee that this routine is only used in the modes in
C     which it has been tested, we require that the values of xa be exactly
C     one unit apart.
C
C  References:  'Numerical Recipes in FORTRAN, 2nd Edition' page 109-110.
C
C  Calling sequence -
C
C     Input Variables:
C       1. xa(n) - Array of tabular (time) values corresponding to the ya
C                  array. The xa's must be evenly spaced.
C       2. ya(n) - Array of EOP values at the times corresponding to those
C                  in the xa array. i.e. ya(i) = f(xa(i)).
C       3. n     - Number of points in the xa and ya arrays.
C       4. yp1   - First derivative of the EOP function at the point i=1.
C       5. ypn   - First derivative of the EOP function at the point i=n.
C
C     Output variables:
C       1. y2(n) - Array containing the second derivatives of the
C                   interpolating function at the tabular points xa(i).
C       2. ierr4 - Error return code (0=good, 1=bad)
C
      INTEGER   N, NMAX, IERR4
      DOUBLE PRECISION  YP1, YPN, XA(*), YA(*), Y2(*)
      PARAMETER (NMAX=100)
      INTEGER   I, K
      DOUBLE PRECISION P, QN, SIG, UN, U(NMAX)
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
C
C  Program variables:
C       1. NMAX    - The largest anticipated value of n.
C       2. p       -
C       3. qn      -
C       4. sig     -
C       5. un      -
C       6. u(NMAX) -
C
C  Programmer:
C     93.11.22  Jim Ryan     - Initial coding and modification for Calc.
C     93.12.07  David Gordon - Make variables same as in subroutine splin4,
C                              Calc-like documentation inserted.
C
C  SPLINE program structure:
C
C  Verify that the values of xa are one unit apart.
      DO 10 I = 2,N
        IF(ABS(XA(I)-XA(I-1)-1.D0) .GT. 1.D-8) THEN
          MSGTXT = 'spline: independent variable NOT one unit apart!'
          CALL MSGWRT (8)
          WRITE (MSGTXT,1000) I, XA(I), XA(I-1),(XA(I)-XA(I-1))
 1000 FORMAT ('SPLINE:I,XA(I),XA(I-1),DIFF',I5,3(1PD16.9))
          CALL MSGWRT (8)
          IERR4 = 1
          RETURN
        ELSE
          IERR4 = 0
          ENDIF
 10     CONTINUE
C
C  Set lower boundary condition to be "natural" or else to have a specified
C  first derivative.
      IF (YP1 .GT. .99E30) THEN
        Y2(1)=0.
        U(1)=0.
      ELSE
        Y2(1)=-0.5
        U(1)=(3./(XA(2)-XA(1)))*((YA(2)-YA(1))/(XA(2)-XA(1))-YP1)
      ENDIF
C
C  Decomposition loop of the tridiagonal algorithm. y2 and u used for temporary
C  storage of the decomposed factors.
      DO 11 I=2,N-1
        SIG=(XA(I)-XA(I-1))/(XA(I+1)-XA(I-1))
        P=SIG*Y2(I-1)+2.
        Y2(I)=(SIG-1.)/P
        U(I)=(6.*((YA(I+1)-YA(I))/(XA(I+1)-XA(I))-
     *       (YA(I)-YA(I-1))/(XA(I)-XA(I-1)))/(XA(I+1)-XA(I-1))-
     *       SIG*U(I-1))/P
  11  CONTINUE
C
C  Set upper boundary condition to be "natural" or else to have a specified
C  first derivative.
      IF (YPN .GT. .99E30) THEN
        QN=0.
        UN=0.
      ELSE
        QN=0.5
        UN=(3./(XA(N)-XA(N-1)))*(YPN-(YA(N)-YA(N-1))/(XA(N)-XA(N-1)))
      ENDIF
C
      Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.)
C
C  Backsubstitution loop of the tridiagonal algorithm.
      DO 12 K=N-1,1,-1
        Y2(K)=Y2(K)*Y2(K+1)+U(K)
  12  CONTINUE
C
      RETURN
      END
C  (C) Copr. 1986-92 Numerical Recipes Software *1(a)031..
C
C***********************************************************************
      SUBROUTINE SPLIN4 (XA, YA, Y2, N, X, Y, YDOT, YDOT2, YDOT3,
     *   IERR4)
C-----------------------------------------------------------------------
C     Given the arrays xa(i) and ya(i) for i = 1 to n, which tabulate
C     a function with the xa(i)'s in time order, and given the array
C     y2(i), which is the previous output of subroutine spline, and
C     given a value of x, this routine returns the cubic spline
C     interpolated value of y and its first three derivatives.
C
C  References: 'Numerical Recipes in FORTRAN, 2nd Edition' page 109-110.
C
C  Calling sequence -
C
C     Input Variables:
C       1. xa(n) - Array of tabular (time) values corresponding to the ya
C                  array. The xa's must be evenly spaced.
C       2. ya(n) - Array of EOP values at the times corresponding to those
C                  in the xa array. i.e. ya(i) = f(xa(i)).
C       3. y2(n) - Array containing the second derivatives of the
C                  interpolating function at the tabular points xa(i).
C       4. n     - Number of points in the xa and ya arrays.
C       5. x     - Input time for which the corresponding interpolated value
C                  of y (= f(x)) is to be determined.
C
C     Output variables:
C       1. y     - The interpolated value.
C       2. ydot  - The 1st derivative of the interpolated value.
C       3. ydot2 - The 2nd derivative of the interpolated value.
C       4. ydot3 - The 3rd derivative of the interpolated value.
C       5. ierr4 - Error return code (0=good, 1=bad)
C-----------------------------------------------------------------------
      INTEGER   N, IERR4
      DOUBLE PRECISION X, Y, XA(*), Y2(*), YA(*), YDOT, YDOT2, YDOT3
      INTEGER   K, KHI, KLO
      DOUBLE PRECISION A, B, H, ADOT, BDOT
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
C
C  Program variables - klo, khi, k, h, a, b, adot, bdot
C
C  Programmer:
C     93.11.22  Jim Ryan     - Initial coding and modification for Calc.
C                              First, second, and third derivatives added.
C     93.12.07  David Gordon - Make variables same as in subroutine spline,
C                              Calc-like documentation inserted.
C
C  SPLIN4 program structure:
C
C  Find right place in table by means of bisection. Optimized for sequential
C   calls being at random values of x.
      KLO=1
      KHI=N
1     IF (KHI-KLO.GT.1) THEN
        K=(KHI+KLO)/2
        IF(XA(K) .GT. X)THEN
          KHI=K
        ELSE
          KLO=K
        ENDIF
      GO TO 1
      ENDIF
C
C  Make sure the xa's aren't the same values.
      H=XA(KHI)-XA(KLO)
      IF (H.EQ.0.) THEN
        MSGTXT = 'BAD XA INPUT IN SPLIN4'
        CALL MSGWRT (8)
        IERR4 = 1
      ELSE
        IERR4 = 0
      ENDIF
C
C  Evaluate cubic spline polynomial
      A=(XA(KHI)-X)/H
      B=(X-XA(KLO))/H
      Y=A*YA(KLO)+B*YA(KHI)+((A**3-A)*Y2(KLO)+(B**3-B)*Y2(KHI))*
     *  (H**2)/6.
C
C  First derivative
      ADOT = -1.D0/H
      BDOT =  1.D0/H
      YDOT = ADOT*YA(KLO) + BDOT*YA(KHI)
     .       + ((3.D0*A**2-1.D0)*ADOT*Y2(KLO)
     .       + (3.D0*B**2-1.D0)*BDOT*Y2(KHI)) * (H**2/6.D0)
C
C  Second derivative.
      YDOT2 = (A*(ADOT**2)*Y2(KLO) + B*(BDOT**2)*Y2(KHI)) * (H**2)
C
C  Third derivative.
      YDOT3 = ((ADOT**3)*Y2(KLO) + (BDOT**3)*Y2(KHI)) * (H**2)
C
      RETURN
      END
C  (C) Copr. 1986-92 Numerical Recipes Software *1(a)031..
C******************************************************************************
      BLOCK DATA NUTCMB
C
C 7.    NUTBD
C
C 7.1   NUTBD PROGRAM SPECIFICATION
C
C 7.1.1 NUTBD IS THE NUTATION MODULE BLOCK DATA INITIALIZATION SECTION.
C       THE NUTATION SERIES IS ESTABLISHED HERE. THIS VERSION CONTAINS
C       THE 1980 IAU THEORY OF NUTATION, FROM THE WORK OF J. M. WAHR,
C       SPECIFICALLY, THE WAHR NUTATION SERIES FOR AXIS B OF GILBERT &
C       DZIEWONSKI EARTH MODEL 1066A.
C
C 7.1.3 REFERENCES - 1) 'THE EXPLANATORY SUPPLEMENT TO THE AMERICAN
C                    EPHEMERIS AND NAUTICAL ALMANAC", P. 41-45, 98
C
C                    2) LIESKE, J.H., ET AL., EXPRESSIONS FOR THE
C                    PRECESSIONAL QUANTITIES BASED ON THE IAU (1976)
C                    SYSTEM OF ASTRONOMICAL CONSTANTS,
C                    ASTRON. ASTROPHYS. 58, 1-16, 1977.
C
C                    3) SEIDELMANN, P. K., 1980 IAU THEORY OF NUTATION:
C                    THE FINAL REPORT OF THE IAU WORKING GROUP ON
C                    NUTATION, CELEST. MECH. 27, PP. 79-106 (1982).
C
C                    4) WAHR, J. M., THE FORCED NUTATIONS OF ... EARTH,
C                    GEOPHYS. J. ROY. ASTR. SOC. 64, PP. 705-727 (1981).
C
C 7.2   NUTBD PROGRAM INTERFACE
C
C 7.2.1 CALLING SEQUENCE - NONE
C
C 7.2.2 COMMON BLOCK -
C
      DOUBLE PRECISION X(9,120)
      COMMON / XWAHR / X
C
      DOUBLE PRECISION CENTJ, DJ2000, EC(4), ARGP(2,6)
      INTEGER   NOT, NOP, IDP(6)
      COMMON / NUTCM / CENTJ, DJ2000, EC, ARGP, NOT, NOP, IDP
C           VARIABLES 'TO':
C              1. CENTJ   - THE NUMBER OF COORDINATE TIME DAYS PER JULIAN
C                           CENTURY. (DAYS/CENTURY) (CENTJ = 36525.D0)
C              2. DJ2000  - THE JULIAN DATE OF THE EPOCH JANUARY 1.5, 2000.
C                           (DAYS) (DJ2000 = 2451545.D0)
C              3. EC(4)   - THE CONSTANTS APPEARING IN TERMS 1-4 IN THE
C                           CALCULATION OF THE MEAN OBLIQUITY OF THE ECLIPTIC.
C                           (ARCSEC) (SEE REFERENCES)
C                           (EC(1) = +8.4381448D4, EC(2) = -46.815D0,
C                             EC(3) = -5.9D-4, EC(4) = +1.813D-3 )
C              4. NOT     - THE NUMBER OF TERMS IN THE NUTATION SERIES.
C                           (NOT = 106)
C              5. X(9,120)- THE ARRAY CONTAINING THE NUTATION SERIES.
C                           (X = 1980 IAU THEORY OF NUTATION)
C              6. NOP     - THE NUMBER OF NUTATION TERMS DESIGNATED FOR WHICH
C                           PARTIALS ARE TO BE COMPUTED. (NOP = 6)
C                                  (Obsolete?)
C              7. IDP(6)  - IDENTIFICATION NUMBERS (TERM NUMBERS) OF DESIGNATED
C                           NUTATION TERMS FOR WHICH PARTIALS ARE TO BE COMPUTED
C                           (IDP(1) =  1, IDP(2) =  2, IDP(3) =  3,
C                             IDP(4) =  4, IDP(5) =  5, IDP(6) =  7 )
C              8. ARGP(2,6)-ARGUMENTS (COMBINATIONS OF FUNDAMENTAL ARGUMENTS)
C                           AND THEIR DERIVATIVES OF DESIGNATED NUTATION TERMS
C                           FOR WHICH PARTIALS ARE TO BE COMPUTED.
C                           (COMPUTED IN NUTW. SET TO 0.0D0 HERE)
C                                  (Obsolete?)
C
C 7.2.3 PROGRAM SPECIFICATIONS -
      DOUBLE PRECISION X1(180), X2(180), X3(180), X4(180), X5(180),
     *   X6(180)
      EQUIVALENCE (X(1,  1),X1(1))
      EQUIVALENCE (X(1, 21),X2(1))
      EQUIVALENCE (X(1, 41),X3(1))
      EQUIVALENCE (X(1, 61),X4(1))
      EQUIVALENCE (X(1, 81),X5(1))
      EQUIVALENCE (X(1,101),X6(1))
C
      DATA  CENTJ  / 36525.D0 /,
     1      DJ2000 / 2451545.D0 /,
     2      EC     / 8.4381448D4, -46.8150D0, -5.9D-4, 1.813D-3 /,
     3      NOT    / 106 /,
     4      NOP    / 6 /,
     5      IDP    / 1, 2, 3, 4, 5, 7 /,
     6      ARGP   / 12 * 0.0D0 /
C***********************************************************************
C
C               1980 IAU THEORY OF NUTATION (WAHR THEORY)
C           TABLE OF MULTIPLES OF ARGUMENTS AND COEFFICIENTS
C
C                   MULTIPLE OF            LONGITUDE        OBLIQUITY
C              L    L'   F    D  OMEGA   COEFF. OF SIN    COEFF. OF COS
      DATA X1/ 0.,  0.,  0.,  0.,  1., -171996., -174.2,  92025.,  8.9,
     /         0.,  0.,  2., -2.,  2.,  -13187.,   -1.6,   5736., -3.1,
     /         0.,  0.,  2.,  0.,  2.,   -2274.,   -0.2,    977., -0.5,
     /         0.,  0.,  0.,  0.,  2.,    2062.,    0.2,   -895.,  0.5,
     /         0.,  1.,  0.,  0.,  0.,    1426.,   -3.4,     54., -0.1,
     /         1.,  0.,  0.,  0.,  0.,     712.,    0.1,     -7.,  0.0,
     /         0.,  1.,  2., -2.,  2.,    -517.,    1.2,    224., -0.6,
     /         0.,  0.,  2.,  0.,  1.,    -386.,   -0.4,    200.,  0.0,
     /         1.,  0.,  2.,  0.,  2.,    -301.,    0.0,    129., -0.1,
     /         0., -1.,  2., -2.,  2.,     217.,   -0.5,    -95.,  0.3,
     /         1.,  0.,  0., -2.,  0.,    -158.,    0.0,     -1.,  0.0,
     /         0.,  0.,  2., -2.,  1.,     129.,    0.1,    -70.,  0.0,
     /        -1.,  0.,  2.,  0.,  2.,     123.,    0.0,    -53.,  0.0,
     /         1.,  0.,  0.,  0.,  1.,      63.,    0.1,    -33.,  0.0,
     /         0.,  0.,  0.,  2.,  0.,      63.,    0.0,     -2.,  0.0,
     /        -1.,  0.,  2.,  2.,  2.,     -59.,    0.0,     26.,  0.0,
     /        -1.,  0.,  0.,  0.,  1.,     -58.,   -0.1,     32.,  0.0,
     /         1.,  0.,  2.,  0.,  1.,     -51.,    0.0,     27.,  0.0,
     /         2.,  0.,  0., -2.,  0.,      48.,    0.0,      1.,  0.0,
     /        -2.,  0.,  2.,  0.,  1.,      46.,    0.0,    -24.,  0.0/
      DATA X2/ 0.,  0.,  2.,  2.,  2.,     -38.,    0.0,     16.,  0.0,
     /         2.,  0.,  2.,  0.,  2.,     -31.,    0.0,     13.,  0.0,
     /         2.,  0.,  0.,  0.,  0.,      29.,    0.0,     -1.,  0.0,
     /         1.,  0.,  2., -2.,  2.,      29.,    0.0,    -12.,  0.0,
     /         0.,  0.,  2.,  0.,  0.,      26.,    0.0,     -1.,  0.0,
     /         0.,  0.,  2., -2.,  0.,     -22.,    0.0,      0.,  0.0,
     /        -1.,  0.,  2.,  0.,  1.,      21.,    0.0,    -10.,  0.0,
     /         0.,  2.,  0.,  0.,  0.,      17.,   -0.1,      0.,  0.0,
     /         0.,  2.,  2., -2.,  2.,     -16.,    0.1,      7.,  0.0,
     /        -1.,  0.,  0.,  2.,  1.,      16.,    0.0,     -8.,  0.0,
     /         0.,  1.,  0.,  0.,  1.,     -15.,    0.0,      9.,  0.0,
     /         1.,  0.,  0., -2.,  1.,     -13.,    0.0,      7.,  0.0,
     /         0., -1.,  0.,  0.,  1.,     -12.,    0.0,      6.,  0.0,
     /         2.,  0., -2.,  0.,  0.,      11.,    0.0,      0.,  0.0,
     /        -1.,  0.,  2.,  2.,  1.,     -10.,    0.0,      5.,  0.0,
     /         1.,  0.,  2.,  2.,  2.,      -8.,    0.0,      3.,  0.0,
     /         0., -1.,  2.,  0.,  2.,      -7.,    0.0,      3.,  0.0,
     /         0.,  0.,  2.,  2.,  1.,      -7.,    0.0,      3.,  0.0,
     /         1.,  1.,  0., -2.,  0.,      -7.,    0.0,      0.,  0.0,
     /         0.,  1.,  2.,  0.,  2.,       7.,    0.0,     -3.,  0.0/
      DATA X3/-2.,  0.,  0.,  2.,  1.,      -6.,    0.0,      3.,  0.0,
     /         0.,  0.,  0.,  2.,  1.,      -6.,    0.0,      3.,  0.0,
     /         2.,  0.,  2., -2.,  2.,       6.,    0.0,     -3.,  0.0,
     /         1.,  0.,  0.,  2.,  0.,       6.,    0.0,      0.,  0.0,
     /         1.,  0.,  2., -2.,  1.,       6.,    0.0,     -3.,  0.0,
     /         0.,  0.,  0., -2.,  1.,      -5.,    0.0,      3.,  0.0,
     /         0., -1.,  2., -2.,  1.,      -5.,    0.0,      3.,  0.0,
     /         2.,  0.,  2.,  0.,  1.,      -5.,    0.0,      3.,  0.0,
     /         1., -1.,  0.,  0.,  0.,       5.,    0.0,      0.,  0.0,
     /         1.,  0.,  0., -1.,  0.,      -4.,    0.0,      0.,  0.0,
     /         0.,  0.,  0.,  1.,  0.,      -4.,    0.0,      0.,  0.0,
     /         0.,  1.,  0., -2.,  0.,      -4.,    0.0,      0.,  0.0,
     /         1.,  0., -2.,  0.,  0.,       4.,    0.0,      0.,  0.0,
     /         2.,  0.,  0., -2.,  1.,       4.,    0.0,     -2.,  0.0,
     /         0.,  1.,  2., -2.,  1.,       4.,    0.0,     -2.,  0.0,
     /         1.,  1.,  0.,  0.,  0.,      -3.,    0.0,      0.,  0.0,
     /         1., -1.,  0., -1.,  0.,      -3.,    0.0,      0.,  0.0,
     /        -1., -1.,  2.,  2.,  2.,      -3.,    0.0,      1.,  0.0,
     /         0., -1.,  2.,  2.,  2.,      -3.,    0.0,      1.,  0.0,
     /         1., -1.,  2.,  0.,  2.,      -3.,    0.0,      1.,  0.0/
      DATA X4/ 3.,  0.,  2.,  0.,  2.,      -3.,    0.0,      1.,  0.0,
     /        -2.,  0.,  2.,  0.,  2.,      -3.,    0.0,      1.,  0.0,
     /         1.,  0.,  2.,  0.,  0.,       3.,    0.0,      0.,  0.0,
     /        -1.,  0.,  2.,  4.,  2.,      -2.,    0.0,      1.,  0.0,
     /         1.,  0.,  0.,  0.,  2.,      -2.,    0.0,      1.,  0.0,
     /        -1.,  0.,  2., -2.,  1.,      -2.,    0.0,      1.,  0.0,
     /         0., -2.,  2., -2.,  1.,      -2.,    0.0,      1.,  0.0,
     /        -2.,  0.,  0.,  0.,  1.,      -2.,    0.0,      1.,  0.0,
     /         2.,  0.,  0.,  0.,  1.,       2.,    0.0,     -1.,  0.0,
     /         3.,  0.,  0.,  0.,  0.,       2.,    0.0,      0.,  0.0,
     /         1.,  1.,  2.,  0.,  2.,       2.,    0.0,     -1.,  0.0,
     /         0.,  0.,  2.,  1.,  2.,       2.,    0.0,     -1.,  0.0,
     /         1.,  0.,  0.,  2.,  1.,      -1.,    0.0,      0.,  0.0,
     /         1.,  0.,  2.,  2.,  1.,      -1.,    0.0,      1.,  0.0,
     /         1.,  1.,  0., -2.,  1.,      -1.,    0.0,      0.,  0.0,
     /         0.,  1.,  0.,  2.,  0.,      -1.,    0.0,      0.,  0.0,
     /         0.,  1.,  2., -2.,  0.,      -1.,    0.0,      0.,  0.0,
     /         0.,  1., -2.,  2.,  0.,      -1.,    0.0,      0.,  0.0,
     /         1.,  0., -2.,  2.,  0.,      -1.,    0.0,      0.,  0.0,
     /         1.,  0., -2., -2.,  0.,      -1.,    0.0,      0.,  0.0/
      DATA X5/ 1.,  0.,  2., -2.,  0.,      -1.,    0.0,      0.,  0.0,
     /         1.,  0.,  0., -4.,  0.,      -1.,    0.0,      0.,  0.0,
     /         2.,  0.,  0., -4.,  0.,      -1.,    0.0,      0.,  0.0,
     /         0.,  0.,  2.,  4.,  2.,      -1.,    0.0,      0.,  0.0,
     /         0.,  0.,  2., -1.,  2.,      -1.,    0.0,      0.,  0.0,
     /        -2.,  0.,  2.,  4.,  2.,      -1.,    0.0,      1.,  0.0,
     /         2.,  0.,  2.,  2.,  2.,      -1.,    0.0,      0.,  0.0,
     /         0., -1.,  2.,  0.,  1.,      -1.,    0.0,      0.,  0.0,
     /         0.,  0., -2.,  0.,  1.,      -1.,    0.0,      0.,  0.0,
     /         0.,  0.,  4., -2.,  2.,       1.,    0.0,      0.,  0.0,
     /         0.,  1.,  0.,  0.,  2.,       1.,    0.0,      0.,  0.0,
     /         1.,  1.,  2., -2.,  2.,       1.,    0.0,     -1.,  0.0,
     /         3.,  0.,  2., -2.,  2.,       1.,    0.0,      0.,  0.0,
     /        -2.,  0.,  2.,  2.,  2.,       1.,    0.0,     -1.,  0.0,
     /        -1.,  0.,  0.,  0.,  2.,       1.,    0.0,     -1.,  0.0,
     /         0.,  0., -2.,  2.,  1.,       1.,    0.0,      0.,  0.0,
     /         0.,  1.,  2.,  0.,  1.,       1.,    0.0,      0.,  0.0,
     /        -1.,  0.,  4.,  0.,  2.,       1.,    0.0,      0.,  0.0,
     /         2.,  1.,  0., -2.,  0.,       1.,    0.0,      0.,  0.0,
     /         2.,  0.,  0.,  2.,  0.,       1.,    0.0,      0.,  0.0/
      DATA X6/ 2.,  0.,  2., -2.,  1.,       1.,    0.0,     -1.,  0.0,
     /         2.,  0., -2.,  0.,  1.,       1.,    0.0,      0.,  0.0,
     /         1., -1.,  0., -2.,  0.,       1.,    0.0,      0.,  0.0,
     /        -1.,  0.,  0.,  1.,  1.,       1.,    0.0,      0.,  0.0,
     /        -1., -1.,  0.,  2.,  1.,       1.,    0.0,      0.,  0.0,
     /         0.,  1.,  0.,  1.,  0.,       1.,    0.0,      0.,  0.0,
     /                      126 *  0./
C
C***********************************************************************
C
C 7.2.4 CONSTANTS USED - CENTJ, DJ2000, EC(4), NOT, X(9,120),
C                    NOP, IDP(6), ARGP(2,6)
C
C 7.2.5 PROGRAMMER - DALE MARKHAM   01/13/77
C                    PETER DENATALE 07/12/77
C                    BRUCE SCHUPLER 12/22/77
C                    CHOPO MA       08/04/81
C                    GEORGE KAPLAN  04/24/84
C                    David Gordon   94.04.15 Converted to Implicit None.
C                    David Gordon   95.09.27 X(9,120) table changed from Real*4
C                                   to Real*8
C                    David Gordon   98.02.03 Removed X(9,120) from COMMON
C                                   /NUTCM/ and put it into COMMON /XWAHR/,
C                                   and removed it from most subroutines.
C
C 7.3   NUTBD PROGRAM STRUCTURE - NONE
C
      END
C
      SUBROUTINE CTTAB (VOL, CNO, VER, IERR)
C-----------------------------------------------------------------------
C! Pick up the values of the given column from the CT table
C# Calibration EXT-appl EXT-util
C-----------------------------------------------------------------------
C   Usually used by CLCOR at the optype='EOPS' to restore the VLBA
C   correlator treatment of the Earth rotation
C
C   Inputs:
C      VOL      I    The file disk number
C      CNO      I    The file catalog slot number.
C      VER      I    CT table version
C   Output in common:
C      INDAY    D(*)       Day numbers
C      UT1C     D(*)       UT1-UTC values, in sec
C      WOBX     D(*)       Polar wobble at X, in milliarcsec
C      WOBY     D(*)       Polar wobble at Y, in milliarcsec
C      LEAPS    D(*)       IAT-UTC, in seconds
C      TBEG     D(*)       Begin time of each group (CT table)
C      TEND     D(*)       End time of each group (CT table)
C      TBEG     D(*)       Begin time of each group (CT table)
C      TEND     D(*)       End time of each group
C      NATGRO   I(*)       Number of rows at the group
C      NACUMU   I(*)       Number of rows accumulated
C                          before the group
C      NGROUP   I          Number of groups at the CT table
C      ICASE    I          1,2,3 depending on the CT table content
C-----------------------------------------------------------------------
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:DCTV.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'CLCOR.INC'
C-----------------------------------------------------------------------
      INTEGER   VOL, CNO, VER, IERR
      INTEGER   NTR
      DOUBLE PRECISION  TR(2,200)
C                                       CTINI, TABCT
      INTEGER   CTKOLS(12), CTNUMV(12), ICTRNO, ICT, I5, IATGRO,
     *   KATGRO
      DOUBLE PRECISION    TIME, UT1UTC, IATUTC, A1IAT, WOBXY(2), DPSI,
     *   DDPSI, DEPS, DDEPS, TRANGE(2)
C
      CHARACTER    UT1TYP*1, WOBTYP*1, CHSIGN*1
      INTEGER   BUFF(512), HMS(3)
      INTEGER   IGROUP, NUMREC, TABLUN, ICURRE, IPREVI, INDEX
      LOGICAL   TZERO,  IDENTI
      REAL      TBREAL, TEREAL, SEC, TEPS
      DATA TABLUN /27/
      DATA TEPS /1.157E-5/
C-----------------------------------------------------------------------
C                                       Open table file
      CALL CTINI ('READ', BUFF, VOL, CNO, VER, CATBLK, TABLUN,
     *   ICTRNO, CTKOLS, CTNUMV, IERR)

      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1100) IERR, VER
         GO TO 990
         END IF
      NUMREC = BUFF(5)
      NCTROW = NUMREC
C                                       initiate number of different
C                                       rows in each group
      DO 10 IGROUP = 1, MAXGRO
C                                       Number of rows at the
C                                       group equaled IGROUP
         NATGRO(IGROUP) = 0
C                                       Number of rows accumulated
C                                       before group equaled IGROUP
         NACUMU(IGROUP) = 0
   10    CONTINUE
      IPREVI = -1000
      IGROUP = 1
      IDENTI = .TRUE.
      TZERO = .TRUE.
C
      DO 20 ICTRNO = 1, NUMREC
         ICT = ICTRNO
         CALL TABCT ('READ', BUFF, ICT, CTKOLS, CTNUMV, TIME,
     *      UT1UTC, IATUTC, A1IAT, UT1TYP, WOBXY, WOBTYP, DPSI,
     *      DDPSI, DEPS, DDEPS, TRANGE, IERR)
C                                       Identity of the groups based
C                                       on current TIME < the previous
         ICURRE = TIME
         IF (ICURRE.EQ.IPREVI+1) THEN
            NATGRO(IGROUP) = NATGRO(IGROUP) + 1
            INDEX = NACUMU(IGROUP) + NATGRO(IGROUP)
            INDAY(INDEX) = TIME
            UT1C(INDEX) = UT1UTC
            WOBX(INDEX) = WOBXY(1)*1000
            WOBY(INDEX) = WOBXY(2)*1000
            LEAPS(INDEX) = IATUTC
C
            IF (NATGRO(IGROUP).EQ.1) THEN
               TBEG(IGROUP) = TRANGE(1)
               TEND(IGROUP) = TRANGE(2)
               TZERO = TZERO .AND. (TBEG(IGROUP).EQ.0 .AND.
     *            TEND(IGROUP).EQ.0)
            ELSE
               TBEG(IGROUP) = MIN (TBEG(IGROUP), TRANGE(1))
               TEND(IGROUP) = MAX (TEND(IGROUP), TRANGE(2))
               END IF

            IPREVI = ICURRE
         ELSE
            IPREVI = ICURRE
            IGROUP = IGROUP + 1
            NACUMU(IGROUP) = NACUMU(IGROUP-1) + NATGRO(IGROUP-1)
            NATGRO(IGROUP) = NATGRO(IGROUP) + 1
            INDEX = NACUMU(IGROUP) + NATGRO(IGROUP)
            INDAY(INDEX) = TIME
            UT1C(INDEX) = UT1UTC
            WOBX(INDEX) = WOBXY(1)*1000
            WOBY(INDEX) = WOBXY(2)*1000
            LEAPS(INDEX) = IATUTC
C            IF (NATGRO(IGROUP).EQ.1) THEN
            TBEG(IGROUP) = TRANGE(1)
            TEND(IGROUP) = TRANGE(2)
            TZERO = TZERO .AND. (TBEG(IGROUP).EQ.0 .AND.
     *         TEND(IGROUP).EQ.0)
            IF (IGROUP.GE.2) IDENTI = IDENTI .AND.
     *         (UT1C(NACUMU(IGROUP) +1).EQ.
     *         UT1C(NACUMU(IGROUP-1) +1))
     *         .AND. (WOBX(NACUMU(IGROUP) +1).EQ.
     *         WOBX(NACUMU(IGROUP-1) +1))
     *         .AND. (WOBY(NACUMU(IGROUP) +1).EQ.
     *         WOBY(NACUMU(IGROUP-1) +1))
C               END IF
            END IF
   20    CONTINUE
      NGROUP = IGROUP
C                                       determine the cases
      IF(IDENTI) THEN
         ICASE = 0
         NGROUP = 2
         NCTROW = NATGRO(2)
      ELSE
         ICASE = 1
         IF (TZERO) ICASE = 2
         END IF
C                                       Close table.
      CALL TABIO ('CLOS', 0, ICTRNO, BUFF, BUFF, IERR)
C                                       print out EOP data for
C                                       the first 5 CT rows
      IF (ICASE.EQ.0) THEN
         MSGTXT = 'UT1-UTC(sec), POLX, POLY(milliasec) ' //
     *      'used by correlator'
         CALL MSGWRT (4)
         DO 30 I5 = 1, NCTROW
            WRITE (MSGTXT, 1200) I5, INDAY(I5), UT1C(I5),
     *         WOBX(I5), WOBY(I5)
            CALL MSGWRT (8)
   30       CONTINUE
      ELSE
C                                       read the history  file to get
C                                       TBEG/TEND
         IF (ICASE.EQ.2) THEN
            CALL HIGETT (VOL, CNO, NTR, TR)
            DO 40 IGROUP = 1, NTR
               TBEG(IGROUP) = TR(1, IGROUP)
               TEND(IGROUP) = TR(2, IGROUP)
   40          CONTINUE
            END IF

         DO 60 IGROUP = 1, NGROUP
            MSGTXT = 'UT1-UTC(sec), POLX, POLY(milliasec) ' //
     *         'used by correlator, TRANG'
            CALL MSGWRT (4)
            KATGRO = NATGRO(IGROUP)
            INDEX = NACUMU(IGROUP)
            DO 50 IATGRO = 1, KATGRO
               INDEX = INDEX + 1
               IF (IATGRO.EQ.1) THEN
                  TBREAL = TBEG(IGROUP)
                  CALL TFDHMS (TBREAL, 1, CHSIGN, HMS, SEC)
                  WRITE (MSGTXT, 1220) INDEX, INDAY(INDEX), UT1C(INDEX),
     *               WOBX(INDEX), WOBY(INDEX), CHSIGN, HMS, SEC
                  CALL MSGWRT (8)
               ELSE
                  IF (IATGRO.EQ.2) THEN
                     TEREAL = TEND(IGROUP)
                     CALL TFDHMS (TEREAL, 1, CHSIGN, HMS, SEC)
                     WRITE (MSGTXT, 1220) INDEX, INDAY(INDEX),
     *                  UT1C(INDEX),WOBX(INDEX), WOBY(INDEX), CHSIGN,
     *                  HMS, SEC
                     CALL MSGWRT (8)
                  ELSE
                     WRITE (MSGTXT, 1200) INDEX, INDAY(INDEX),
     *                  UT1C(INDEX), WOBX(INDEX), WOBY(INDEX)
                     CALL MSGWRT (8)
                     END IF
                  END IF
   50          CONTINUE
   60       CONTINUE

         END IF

C                                       use intervals between the group
C                                       ends to exclude the gaps between
C                                       previous end and current begin
         DO 70 IGROUP = 1, NGROUP
            IF (IGROUP.EQ.1) THEN
               TBEG(IGROUP) = -100
            ELSE
               TBEG(IGROUP) = TEND(IGROUP-1)
               END IF
C
            IF (IGROUP.EQ.NGROUP) TEND(IGROUP) = 100
            TBEG(IGROUP) = TBEG(IGROUP) - TEPS
            TEND(IGROUP) = TEND(IGROUP) + TEPS
   70       CONTINUE


      GO TO 999

C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1100 FORMAT ('ERROR',I5,' OPENING ','CT',' TABLE VERS=',I6)
 1200 FORMAT (I5, F5.0, F10.6, 2F10.3)
 1220 FORMAT (I5, F5.0, F10.6, 2F10.3,
     *   2X, A1,I2,'/',I2.2,':',I2.2,':',F4.1)
      END
      SUBROUTINE HIGETT (DISK, CNO, NTR, TR)
C-----------------------------------------------------------------------
C   HIGETT gets the JOBSTART to JOBSTOP time ranges from the specified
C   HIstory file from the FITLD entries
C   Inputs:
C      DISK     I        Disk number
C      CNO      I        Catalog number
C   Input in common
C      CATBLK   I(256)   Catalog header
C   Outputs:
C      NTR      I        Number time ranges found
C      TR       D(2,*)   Time ranges
C-----------------------------------------------------------------------
      INTEGER   DISK, CNO, NTR
      DOUBLE PRECISION TR(2,*)
C
      INTEGER   IHLUN, HIBUFF(256), IERR, IHPTR, NREC, IBLK, ICARD, II,
     *   NTE, LTY, IY, IM, ID, LH, LM, I, ICUR, IHIND
      REAL      LS
      CHARACTER LINE*72, CM*3, CMS(12)*3, DTEMP*8
      DOUBLE PRECISION JD0, JD, T
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHIS.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      DATA CMS /'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP',
     *   'OCT','NOV','DEC'/
C-----------------------------------------------------------------------
      NTR = 0
      NTE = 0
      CALL H2CHR (8, 1, CATH(KHDOB), DTEMP)
      CALL JULDAY (DTEMP, JD0)
C                                       open HI file
      IHLUN = 89
      CALL HIINIT (3)
      CALL HIOPEN (IHLUN, DISK, CNO, HIBUFF, IERR)
      IF (IERR.NE.0) GO TO 999
      CALL HILOCT ('SRCH', IHLUN, IHPTR, IERR)
      IF (IERR.NE.0) GO TO 999
C                                       Determine no. of hist. recs.
      NREC = HITAB(IHPTR+2)
      IHIND = HITAB(IHPTR+1)
      IBLK = 0
      ICARD = NHILPR
      DO 20 ICUR = 1,NREC
C                                       Read next buffer.
         ICARD = ICARD + 1
         IF (ICARD.GT.NHILPR) THEN
            IBLK = IBLK + 1
            ICARD = 1
            CALL ZFIO ('READ', IHLUN, IHIND, IBLK, HIBUFF, IERR)
            IF (IERR.NE.0) GO TO 100
            END IF
C                                       desired task card?
         II = (ICARD-1) * NHIWPL + 5
         CALL H2CHR (72, 1, HIBUFF(II), LINE)
         LTY = 0
         IF (LINE(:14).EQ.'FITLD JOBSTART') LTY = 1
         IF (LINE(:14).EQ.'FITLD JOBSTOP ') LTY = 2
         IF (LTY.GT.0) THEN
            READ (LINE(18:),1000) IY, CM, ID, LH, LM, LS
            DO 10 I = 1,12
               IF (CM.EQ.CMS(I)) IM = I
 10            CONTINUE
            WRITE (DTEMP,1010) IY, IM, ID
            CALL JULDAY (DTEMP, JD)
            T = JD - JD0 + ((LS / 60.0D0 + LM) / 60.0D0 + LH) / 24.0D0
            IF (LTY.EQ.1) THEN
               NTR = NTR + 1
               TR(1,NTR) = T
            ELSE
               NTE = NTE + 1
               IF (NTE.EQ.NTR) THEN
                  TR(2,NTR) = T
               ELSE
                  MSGTXT = 'HIGETT: SYNCHRONIZATION PROBLEM IN HI' //
     *               ' OF FITLD'
                  CALL MSGWRT (7)
                  END IF
               END IF
            END IF
 20      CONTINUE
C
 100  CALL HICLOS (IHLUN, .FALSE., HIBUFF, IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT (I4,A3,I2,I3,1X,I2,1X,F5.2)
 1010 FORMAT (I4.4,I2.2,I2.2)
      END
