LOCAL INCLUDE 'VLBSY.INC'
C                                                          Include VLBSY
C                                       Local include for VLBSY
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   MXFQID, MAXNX
C                                       Max. # of FQ-IDs allowed
      PARAMETER (MXFQID = 28)
C                                       Max. # of NX entries allowed
      PARAMETER (MAXNX = 1024)
C                                       Inputs and general info
      INTEGER   SEQIN, DISKIN, ISUBA, LUNK, FINDK, OLDCNO, DROPED,
     *   ADDED, NPOL, NIFS, MISSED
      LOGICAL   DOCONC
      REAL      XSIN, XDISIN, XSUBA, XSYVER, DOKEEP, BADD(10)
      HOLLERITH XNAMEI(3), XCLAIN(2), XNAME2(12)
      CHARACTER NAMEIN*12, CLAIN*6, NAME2*48
C                                       Buffers and file info
      INTEGER   SCBUFF(512), SYVER, SYTOT
C                                       Inputs and general info
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XNAME2, XSUBA,
     *   XSYVER, DOKEEP, BADD
      COMMON /TASKPM/ SEQIN, DISKIN, ISUBA, LUNK, FINDK, OLDCNO,
     *   SYTOT, DROPED, ADDED, DOCONC, NPOL, NIFS, MISSED
C                                       CHARACTER info
      COMMON /CHRCOM/ NAMEIN, CLAIN, NAME2
C                                       Buffers and file info
      COMMON /SCFILE/ SCBUFF, SYVER
C                                       NX, FQ table information
      DOUBLE PRECISION DFRQ(MAXIF)
      REAL      TIMENX(2,MAXNX)
      INTEGER   INXSOU(MAXNX), INXFQ(MAXNX), IFQUV(MXFQID), NXDAT,
     *   NFQUV, NIFFQ, FREQID
      COMMON /NXFQIN/ DFRQ, TIMENX, INXSOU, INXFQ, IFQUV, NFQUV,
     *   NXDAT, NIFFQ, FREQID
C                                                          End VLBSY
LOCAL END
      PROGRAM VLBSY
C-----------------------------------------------------------------------
C! Read in VLBA tot data from ascii file.
C# UV Calibration EXT-util VLB
C-----------------------------------------------------------------------
C;  Copyright (C) 2021
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 VLBSY reads an ascii file containing the pulse-cal, cable cal
C   and state count information generated by the VLBA monitoring system.
C   Inputs:
C      AIPS adverb  Prg. name.          Description.
C      INNAME         NAMEIN        Name of input UV data.
C      INCLASS        CLAIN         Class of input UV data.
C      INSEQ          SEQIN         Seq. of input UV data.
C      INDISK         DISKIN        Disk number of input UV data.
C      INFILE         INFIL         Name of aux. file.
C      SUBARRAY       ISUBA         Subarray number
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET
      INCLUDE 'VLBSY.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      DATA PRGM /'VLBSY '/
C-----------------------------------------------------------------------
C                                       Get input parameters
      CALL VLBSYI (PRGM, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Read total power ascii file
      CALL READSY (IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Copy and update HI file.
      CALL VLBSYH
C                                       Close down files, etc.
 990  CALL DIE (IRET, SCBUFF)
 999  STOP
      END
      SUBROUTINE VLBSYI (PRGN, JERR)
C-----------------------------------------------------------------------
C   VLBSYI gets input parameters for VLBSY.
C   Inputs:  PRGN    C*6       Program name
C   Output:  JERR    I         Error code: 0 => ok
C                                5 => catalog troubles
C                                8 => cannot 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, ANTNAM(10)*2, UTYPE*2, LINE*80
      LOGICAL   T, F
      INTEGER   NPARM, IERR, LC, JTRIM, IROUND, I, VER, LUNTMP, LUNSC
      INCLUDE 'VLBSY.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DCHND.INC'
      DATA T, F /.TRUE.,.FALSE./
      DATA ANTNAM /'BR','FD','HN','KP','LA','MK','NL','OV','PT','SC'/
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (T)
      CALL VHDRIN
      LUNK = 10
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      JERR = 0
      MISSED = 0
C                                       Get input parameters.
      NPARM = 32
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, SCBUFF, IERR)
      IF (IERR.NE.0) THEN
         RQUICK = .TRUE.
         JERR = 8
         IF (IERR.EQ.1) GO TO 999
            WRITE (MSGTXT,1000) IERR, 'OBTAINING INPUT PARAMETERS'
            CALL MSGWRT (8)
            END IF
C                                       Restart AIPS
      IF (RQUICK) CALL RELPOP (JERR, SCBUFF, IERR)
      IF (JERR.NE.0) GO TO 999
      JERR = 5
C                                       Crunch input parameters.
C                                       Convert characters
      DO 5 I = 1,10
         IBAD(I) = IROUND (BADD(I))
 5       CONTINUE
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      CALL H2CHR (48, 1, XNAME2, NAME2)
      SEQIN = IROUND (XSIN)
      DISKIN = IROUND (XDISIN)
      ISUBA = IROUND (XSUBA)
      ISUBA = MAX (ISUBA, 1)
      DROPED = 0
      ADDED = 0
C                                       Find file, read CATBLK
      OLDCNO = 1
      STAT = 'SRCH'
      UTYPE = 'UV'
      CALL CATDIR ('SRCH', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN, UTYPE,
     *   NLUSER, STAT, SCBUFF, IERR)
      IF (IERR.GT.0) THEN
         WRITE (MSGTXT,1030) IERR, NAMEIN, CLAIN, SEQIN, DISKIN,
     *      NLUSER
         GO TO 990
         END IF
      CALL CATIO ('READ', DISKIN, OLDCNO, CATBLK, 'WRIT', SCBUFF, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'COPYING CATBLK'
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = OLDCNO
      FRW(NCFILE) = 1
C                                       Get uv header info.
      CALL UVPGET (JERR)
      IF (JERR.NE.0) GO TO 999
      NPOL = MIN  (2, CATBLK(KINAX+JLOCS))
      NIFS = CATBLK(KINAX+JLOCIF)
C                                       Open text file
      LC = JTRIM (NAME2)
      IF (NAME2(LC:LC).NE.'_') THEN
         CALL ZTXOPN ('QRED', LUNK, FINDK, NAME2, F, IERR)
      ELSE
         DO 40 I = 1,10
            NAME2(LC+1:) = ANTNAM(I)
            MSGSUP = 32000
            CALL ZTXOPN ('QRED', LUNK, FINDK, NAME2, F, IERR)
            MSGSUP = 0
            IF (IERR.EQ.0) GO TO 50
 40         CONTINUE
         END IF
 50   IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING TEXT FILE'
         JERR = IERR
         GO TO 990
         END IF
C                                       read first line
      CALL ZTXIO ('READ', LUNK, FINDK, LINE, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READ FIRST TEXT LINE'
         JERR = IERR
         GO TO 990
         END IF
      IF (LINE(:16).NE.'# Project Code: ') THEN
         MSGTXT = 'FILE HAS FORMAT UNCERTAINTIES'
         JERR = 8
         GO TO 990
         END IF
      CALL ZTXCLS (LUNK, FINDK, IERR)
      IF (NAME2(LC:LC).EQ.'_') NAME2(LC+1:) = '  '
C                                       get frequencies
      VER = 1
      LUNSC = LUNTMP (1)
      CALL CHNDAT ('READ', SCBUFF, DISKIN, OLDCNO, VER, CATBLK, LUNSC,
     *   I, FOFF, ISBAND, FINC, BNDCOD, FREQID, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'GETTING FREQUENCY INFORMATION'
         JERR = 10
         GO TO 990
         END IF
      DO 70 I = 1,NIFS
         DFRQ(I) = (CATD(KDCRV+JLOCF) + FOFF(I)) / 1.0D6
 70      CONTINUE
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('VLBSYI: ERROR',I3,' ON ',A)
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
     *   I3,' USID=',I5)
      END
      SUBROUTINE READSY (IERR)
C-----------------------------------------------------------------------
C   READSY builds an SY table from the DiFX ascii format file
C   Can loop over VLBA named files
C   Output:
C      IRET   I   > 0 -> failure of some sort
C-----------------------------------------------------------------------
      INTEGER   IERR
C
      INCLUDE 'VLBSY.INC'
      INTEGER   LUNFQ, SUBA, LC, JTRIM, ILOOP, KBPLIM, KBP, SDAY,  IP,
     *   LIF, NOBAND, LUNSY, SYBUFF(512), ISYRNO, SYKOLS(MAXSYC),
     *   SYNUMV(MAXSYC), I, ISRC, IFQID, NOSTA, IROUND, IR, IL,
     *   NPV(2), IFREQS(MAXIF), J, NID, NOSORC, NPOLZ, CALTYP, NLINE,
     *   MISCNT
      LOGICAL   DOLOOP, FIRST
      CHARACTER ANTNAM(10)*2, TELNAM*8, LLINE*5000, NAMTEL*8,
     *   OBSDAT*8, SORC*16, PLINE*5000, PPLINE*5000
      DOUBLE PRECISION  XX, TIME, PVALS(3,MAXIF), JD, SCTIME, TIME1,
     *   TIME2, FREQOF, PTIME(2)
      REAL      DTIME, PSUM(2,MAXIF), PDIFF(2,MAXIF), PGAIN(2,MAXIF),
     *   RTIME
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DANS.INC'
      DATA ANTNAM /'BR','FD','HN','KP','LA','MK','NL','OV','PT','SC'/
      DATA FIRST /.TRUE./
C-----------------------------------------------------------------------
      CALL H2CHR (8, 1, CATH(KHDOB), OBSDAT)
      CALL JULDAY (OBSDAT, JD)
      JD = JD - 2400000.5D0
      SDAY = JD + 0.001
      TELNAM = ' '
      CALL FILL (MAXIF, 0, IFREQS)
      CALTYP = 0
      MISCNT = 0
C                                       Make these not fatal errors
C                                       Read NX table information
      LUNFQ = 40
      CALL NXREAD (DISKIN, OLDCNO, ISUBA, CATBLK, LUNFQ, SCBUFF, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READING NX TABLE'
         CALL MSGWRT (7)
         END IF
C                                       Get list of station names
      SUBA = ISUBA
      CALL GETANT (DISKIN, OLDCNO, SUBA, CATBLK, SCBUFF, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READING ANTENNA DATA'
         CALL MSGWRT (7)
         END IF
C                                       file name
      LC = JTRIM (NAME2)
      DOLOOP = NAME2(LC:LC).EQ.'_'
      ILOOP = 0
 50   ILOOP = ILOOP + 1
      IF (DOLOOP) NAME2(LC+1:) = ANTNAM(ILOOP)
      IF (MISCNT.GT.0) THEN
         WRITE (MSGTXT,1050) MISCNT
         CALL MSGWRT (7)
         END IF
      MISCNT = 0
      CALL ZTXOPN ('READ', LUNK, FINDK, NAME2, .FALSE., IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING TEXT FILE'
         IF (.NOT.DOLOOP) GO TO 990
         WRITE (MSGTXT,1000) IERR, 'OPENING TEXT FILE FOR ' //
     *      ANTNAM(ILOOP)
         CALL MSGWRT (7)
         GO TO 210
         END IF
      NOSORC = 0
      NLINE = 0
      NPV(1) = 0
      NPV(2) = 0
C                                       read a line
 100  PPLINE = PLINE
      PLINE = LLINE
      CALL ZTXIO ('READ', LUNK, FINDK, LLINE, IERR)
      IF (IERR.EQ.2) THEN
         GO TO 200
      ELSE IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READING TEXT FILE'
         IF (.NOT.DOLOOP) GO TO 990
         WRITE (MSGTXT,1000) IERR, 'READING TEXT FILE FOR' //
     *      ANTNAM(ILOOP)
         CALL MSGWRT (7)
         GO TO 200
      ELSE
         NLINE = NLINE + 1
         KBPLIM = JTRIM (LLINE)
C                                       new scan - get source
         IF (LLINE(:18).EQ.'#P  setObservation') THEN
            KBP = 19
            CALL GETNUM (LLINE, KBPLIM, KBP, XX)
            SCTIME = XX - SDAY
            NOSORC = 0
            DO 105 I = KBP,KBPLIM
               IF (LLINE(I:I).NE.' ') GO TO 110
 105           CONTINUE
            GO TO 100
 110        J = 0
            KBP = I
            SORC = ' '
            DO 115 I = KBP,KBPLIM
               IF ((LLINE(I:I).NE.' ') .AND. (J.LT.16)) THEN
                  J = J + 1
                  SORC(J:J) = LLINE(I:I)
               ELSE
                  GO TO 120
                  END IF
 115           CONTINUE
 120        NOSORC = 0
            IF (SORC.NE.'FINAL') THEN
               NID = 1
               CALL SOURNU (SORC, 0, 1, DISKIN, OLDCNO, NID, SCBUFF,
     *            NOSORC, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'READING SOURCE TABLE'
                  CALL MSGWRT (7)
                  NOSORC = 0
                  END IF
               END IF
            GO TO 100
         ELSE IF (LLINE(:13).EQ.'#P  setFreq 0') THEN
            KBP = 14
            CALL GETNUM (LLINE, KBPLIM, KBP, XX)
            FREQOF = XX
            GO TO 100
         ELSE IF ((LLINE(1:1).EQ.'#') .OR. (NOSORC.EQ.0)) THEN
            GO TO 100
            END IF
C                                       antenna data
C                                       telescope name
         NAMTEL = LLINE(:2)
         CALL CHLTOU (8, NAMTEL)
         IF (NAMTEL.NE.TELNAM) THEN
            NOSTA = 0
            DO 125 I = 1,NSTNS
               IF (NAMTEL.EQ.STNNAM(I)) NOSTA = TELNO(I)
 125           CONTINUE
            IF (NOSTA.LE.0) NOSTA = NSTNS + ILOOP
            IF (MISCNT.GT.0) THEN
               WRITE (MSGTXT,1050) MISCNT
               CALL MSGWRT (7)
               END IF
            MISCNT = 0
            MSGTXT = 'Data line changes telescope from ' //
     *         TELNAM(:JTRIM(TELNAM)) // ' to ' //
     *         NAMTEL(:JTRIM(NAMTEL))
            IF (TELNAM.NE.' ') CALL MSGWRT (6)
            TELNAM = NAMTEL
            END IF
C                                       time
         KBP = 3
         CALL GETNUM (LLINE, KBPLIM, KBP, XX)
         TIME1 = XX - SDAY
         CALL GETNUM (LLINE, KBPLIM, KBP, XX)
         TIME2 = XX - SDAY
         TIME = (TIME2 + TIME1) / 2.0D0
         DTIME = (TIME2 - TIME1)
         LIF = INDEX (LLINE, 'flagged')
         IF (LIF.GT.0) GO TO 100
         IR = INDEX (LLINE, ' R ')
         IL = INDEX (LLINE, ' L ')
         IP = 1
         IF (IL.GT.0) IP = 2
C                                       look for mismatches
         IF ((NPV(IP).GT.0) .OR. ((NPV(3-IP).GT.0) .AND.
     *      (TIME-PTIME(3-IP).GT.0.000001))) THEN
            MSGTXT = 'MISSING SOMETHING'
            IF (MISCNT.LE.0) CALL MSGWRT (7)
            MISCNT = MISCNT + 1
            MISSED = MISSED + 1
            IF (ISRC.LE.0) DROPED = DROPED + 1
            IF ((ISRC.GT.0) .OR. (DOKEEP.GT.0.0)) THEN
               CALL TABSY ('WRIT', SYBUFF, ISYRNO, SYKOLS, SYNUMV,
     *            NPOLZ, NIFS, TIME, DTIME, CALTYP, NOSORC, NOSTA,
     *            ISUBA, FREQID, PDIFF, PSUM, PGAIN, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITING OUTPUT SY TABLE'
                  GO TO 990
                  END IF
               ADDED = ADDED + 1
               END IF
            NPV(1) = 0
            NPV(2) = 0
            PTIME(1) = 0.0D0
            PTIME(2) = 0.0D0
            I = 2 * MAXIF
            CALL RFILL (I, FBLANK, PSUM)
            CALL RFILL (I, FBLANK, PDIFF)
            CALL RFILL (I, 1.0, PGAIN)
            END IF
         PTIME(IP) = TIME
C                                       Get source id. for this time
         RTIME = TIME
         CALL NXSRCH (RTIME, ISRC, IFQID)
         IF ((ISRC.NE.NOSORC) .AND. (ISRC.NE.0)) THEN
            WRITE (MSGTXT,1125) ISRC, NOSORC, SORC
            CALL MSGWRT (7)
            END IF
         FREQID = IFQID
C                                       FIRST: init arrays, open table
         IF (FIRST) THEN
            NOBAND = NIFS
            NPOLZ = NPOL
            I = CATBLK(KINAX+JLOCS)
            I = MIN (I, 2)
            IF ((NPOLZ.NE.I) .OR. (NOBAND.NE.CATBLK(KINAX+JLOCIF)))
     *         THEN
               WRITE (MSGTXT,1110) NPOLZ, NOBAND, I,
     *            CATBLK(KINAX+JLOCIF)
               CALL MSGWRT (6)
               END IF
            I = 2 * MAXIF
            CALL RFILL (I, FBLANK, PSUM)
            CALL RFILL (I, FBLANK, PDIFF)
            CALL RFILL (I, 1.0, PGAIN)
C                                       SY number
            SYVER = IROUND (XSYVER)
C                                       Check to see if SY table exists
            CALL FNDEXT ('SY', CATBLK, SYTOT)
            IF (SYVER.LE.0) SYVER = SYTOT + 1
            LUNSY = 30
            CALL SYINI ('WRIT', SYBUFF, DISKIN, OLDCNO, SYVER, CATBLK,
     *         LUNSY, ISYRNO, SYKOLS, SYNUMV, NSTNS, NPOLZ, NOBAND,
     *         IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPENING SY TABLE'
               GO TO 990
               END IF
C                                       warning of concatenation
            IF (SYVER.LE.SYTOT) THEN
               DOCONC = .TRUE.
               WRITE (MSGTXT,1111) SYVER
               CALL REFRMT (MSGTXT, '_', I)
               CALL MSGWRT (5)
               END IF
C                                       Update CATBLK
            CALL CATIO ('UPDT', DISKIN, OLDCNO, CATBLK, 'REST', SCBUFF,
     *         IERR)
            FIRST = .FALSE.
            END IF
C                                       parse the remainder of the line
         DO 130 LIF = 1,NIFS
C                                       frequency
            CALL GETNUM (LLINE, KBPLIM, KBP, XX)
            PVALS(1,LIF) = XX
C                                       bandwidth
            CALL GETNUM (LLINE, KBPLIM, KBP, XX)
            IF (PVALS(1,LIF).LT.0.0D0) PVALS(1,LIF) = -PVALS(1,LIF) - XX
            KBP = KBP + 2
C                                       PON
            CALL GETNUM (LLINE, KBPLIM, KBP, XX)
            PVALS(2,LIF) = XX / 1.0D9
C                                       POFF
            CALL GETNUM (LLINE, KBPLIM, KBP, XX)
            PVALS(3,LIF) = XX / 1.0D9
 130        CONTINUE
C                                       Freq order
         IF (IFREQS(1).EQ.0) THEN
            DO 150 LIF = 1,NIFS
               DO 140 I = 1,NIFS
                  IF (ABS(PVALS(1,LIF)-DFRQ(I)).LT.8.D0)
     *               IFREQS(LIF) = I
 140              CONTINUE
 150           CONTINUE
            END IF
         DO 160 LIF = 1,NIFS
            J = IFREQS(LIF)
            PSUM(IP,J) = PVALS(2,LIF) + PVALS(3,LIF)
            PDIFF(IP,J) = PVALS(2,LIF) - PVALS(3,LIF)
 160        CONTINUE
         NPV(IP) = 1
C                                       write it out
         IF (NPV(1)+NPV(2).EQ.2) THEN
            IF (ISRC.LE.0) DROPED = DROPED + 1
            IF ((ISRC.GT.0) .OR. (DOKEEP.GT.0.0)) THEN
               CALL TABSY ('WRIT', SYBUFF, ISYRNO, SYKOLS, SYNUMV,
     *            NPOLZ, NIFS, TIME, DTIME, CALTYP, NOSORC, NOSTA,
     *            ISUBA, FREQID, PDIFF, PSUM, PGAIN, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITING OUTPUT SY TABLE'
                  GO TO 990
                  END IF
               ADDED = ADDED + 1
               END IF
            NPV(1) = 0
            NPV(2) = 0
            PTIME(1) = 0.0D0
            PTIME(2) = 0.0D0
            I = 2 * MAXIF
            CALL RFILL (I, FBLANK, PSUM)
            CALL RFILL (I, FBLANK, PDIFF)
            CALL RFILL (I, 1.0, PGAIN)
            END IF
         GO TO 100
         END IF
C                                       close input text file
 200  CALL ZTXCLS (LUNK, FINDK, IERR)
 210  IF ((DOLOOP) .AND. (ILOOP.LT.10)) GO TO 50
      IF (MISCNT.GT.0) THEN
         WRITE (MSGTXT,1050) MISCNT
         CALL MSGWRT (7)
         END IF
      MISCNT = 0
      CALL TABSY ('CLOS', SYBUFF, ISYRNO, SYKOLS, SYNUMV, NPOLZ, NIFS,
     *   TIME, DTIME, CALTYP, NOSORC, NOSTA, ISUBA, FREQID, PDIFF, PSUM,
     *   PGAIN, IERR)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('READSY ERROR',I4,' ON ',A)
 1050 FORMAT ('MISSING SOMETHING',I7,' MORE TIMES')
 1110 FORMAT ('SY FILE Npol, Nif',I2,I4,' DO NOT MATCH UV DATA',I2,I4)
 1111 FORMAT ('READSY: Concatenating to SY table',I5)
 1125 FORMAT ('SOURCE NUMBER',I4,' EXPECTED',I4,' ''',A,'''')
      END
      SUBROUTINE VLBSYH
C-----------------------------------------------------------------------
C   VLBSYH copies and updates history file.
C-----------------------------------------------------------------------
      INTEGER   LUN1, IERR, ITIME(3), DATE(3), I
      CHARACTER HILINE*72, CITIME*20
      INCLUDE 'VLBSY.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      DATA LUN1 /27/
C-----------------------------------------------------------------------
C                                       Write History.
      CALL HIINIT (3)
C                                       Copy/open history file.
      CALL HIOPEN (LUN1, DISKIN, FCNO(NCFILE), SCBUFF, IERR)
      IF (IERR.GT.2) THEN
         WRITE (MSGTXT,1000) IERR
         CALL MSGWRT (6)
         GO TO 100
         END IF
C                                       Task message
      CALL ZDATE (DATE)
      CALL ZTIME (ITIME)
      CALL TIMDAT (ITIME, DATE, CITIME(13:20), CITIME(1:12))
      WRITE (HILINE,1010) TSKNAM, RLSNAM, CITIME(1:12), CITIME(13:20)
      CALL HIADD (LUN1, HILINE, SCBUFF, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       File name
      WRITE (HILINE,2000) TSKNAM, NAME2
      CALL HIADD (LUN1, HILINE, SCBUFF, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       Version #
      IF (DOCONC) THEN
         WRITE (HILINE,2001) TSKNAM, SYVER, ADDED
         CALL HIADD (LUN1, HILINE, SCBUFF, IERR)
         IF (IERR.NE.0) GO TO 100
         WRITE (MSGTXT,1020) ADDED, SYVER
         CALL REFRMT (MSGTXT, '_', I)
         CALL MSGWRT (4)
      ELSE
         WRITE (HILINE,2002) TSKNAM, SYVER, ADDED
         CALL HIADD (LUN1, HILINE, SCBUFF, IERR)
         IF (IERR.NE.0) GO TO 100
         WRITE (MSGTXT,1021) ADDED, SYVER
         CALL REFRMT (MSGTXT, '_', I)
         CALL MSGWRT (4)
         END IF
C                                       Dropped
      IF (DROPED.GT.0) THEN
         IF (DOKEEP.GT.0.0) THEN
            WRITE (HILINE,2003) TSKNAM, DROPED
         ELSE
            WRITE (HILINE,2004) TSKNAM, DROPED
            END IF
         CALL HIADD (LUN1, HILINE, SCBUFF, IERR)
         IF (IERR.NE.0) GO TO 100
         MSGTXT = HILINE(9:)
         CALL REFRMT (MSGTXT, '_', I)
         CALL MSGWRT (4)
         END IF
C                                       missing a polariz
      IF (MISSED.GT.0) THEN
         WRITE (HILINE,2010) TSKNAM, MISSED
         CALL HIADD (LUN1, HILINE, SCBUFF, IERR)
         IF (IERR.NE.0) GO TO 100
         MSGTXT = HILINE(9:)
         CALL REFRMT (MSGTXT, '_', I)
         CALL MSGWRT (4)
         END IF
C                                       Close HI file
 100  CALL HICLOS (LUN1, .TRUE., SCBUFF, IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('VLBSYH: ERROR',I3,' OPENING HISTORY FILE')
 1010 FORMAT (A6,'RELEASE =''',A,' ''  /********* Start ',
     *   A12,2X,A8)
 1020 FORMAT (I10,' records added to old SY table version',I4)
 1021 FORMAT (I10,' records written to new SY table version',I4)
 2000 FORMAT (A6,'INFILE = ''',A48,'''')
 2001 FORMAT (A6,'SYVERS =',I4,'  / Concatenated',I8,
     *   ' records to existing table')
 2002 FORMAT (A6,'SYVERS =',I4,'  / Wrote',I8,
     *   ' records to new table')
 2003 FORMAT (A6,'/ Kept',I8,' records not in scans')
 2004 FORMAT (A6,'/ Dropped',I8,' records not in scans')
 2010 FORMAT (A6,'/ ',I8,' records missing a polarization')
      END
      SUBROUTINE NXREAD (INDISK, ICNO, ISUB, CATBLK, ILUN, JBUFF, IRET)
C-----------------------------------------------------------------------
C   Subroutine to read NX table information into memory
C   Inputs:
C      INDISK  I       Disk volume number
C      ICNO    I       Catalog slot number
C      ISUB    I       Subarray number
C      CATBLK  I(256)  Catalog header block
C      ILUN    I       LUN to use for table I/O
C      JBUFF   I(*)    Buffer for table I/O
C      MAXNX   I       Maximum dimension of TIMENX, INXSOU, INXFQ
C      MXFQID  I       Maximum dimension of IFQUV
C   Outputs to common:
C      TIMENX  R(2,*)  Scan start, stop times
C      INXSOU  I(*)    Source ID's from NX table
C      INXFQ   I(*)    FQ-ID's from NX table
C      NXDAT   I       Number of NX table entries read
C      IFQUV   I(*)    Array of FQ-ID's found
C      NFQUV   I       No. of entries in IFQUV
C   Outputs:
C      IRET    I       Return code (0 => ok)
C-----------------------------------------------------------------------
      INTEGER   INDISK, ICNO, ISUB, CATBLK(256), ILUN, JBUFF(*), IRET
C
      INCLUDE 'VLBSY.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DMSG.INC'
      LOGICAL   WTABLE, WEXIST, WFITS
      REAL      TIME, TINT, TEPS
      INTEGER    NXKOLS(MAXNXC), NXNUMV(MAXNXC), IERR, I, INXRNO,
     *   IDSOUR, ISUBNX, ISTART, IEND, IFQID, NROW, NVISMX, J
C-----------------------------------------------------------------------
C                                       Initialisation
      IRET = 0
      NXDAT = 0
      TEPS = 0.1 / (24.0 * 3600.0)
C                                       Does an NX table exist ?
      CALL ISTAB ('NX', INDISK, ICNO, 1, ILUN, JBUFF, WTABLE, WEXIST,
     *   WFITS, IERR)
      IF ((IERR.NE.0).OR.(.NOT.(WEXIST.AND.WTABLE))) THEN
         IRET = 1
         WRITE (MSGTXT,1020)
         GO TO 990
         END IF
C                                       Open the NX table
      CALL NDXINI ('READ', JBUFF, INDISK, ICNO, 1, CATBLK, ILUN,
     *   INXRNO, NXKOLS, NXNUMV, IERR)
      IF (IERR.NE.0) THEN
         IRET = 2
         WRITE (MSGTXT,1040) IERR
         GO TO 990
         END IF
C                                       Read table into memory
      NROW = JBUFF(5)
      NVISMX = 0
      DO 100 I = 1, NROW
         CALL TABNDX ('READ', JBUFF, INXRNO, NXKOLS, NXNUMV, TIME,
     *      TINT, IDSOUR, ISUBNX, ISTART, IEND, IFQID, IERR)
C                                       Record de-selected ?
         IF (IERR.EQ.-1) GO TO 100
         IF (IERR.NE.0) THEN
            IRET = 3
            WRITE (MSGTXT,1100) IERR
            GO TO 990
            END IF
C                                       Update maximum vis. no.
         NVISMX = MAX (NVISMX, IEND)
C                                       Correct subarray ?
         IF (ISUBNX.NE.ISUB) GO TO 100
C                                       NX buffer too small ?
         NXDAT = NXDAT + 1
         IF (NXDAT.GT.MAXNX) THEN
            IRET = 4
            WRITE (MSGTXT,1120)
            GO TO 990
            END IF
C
         TIMENX(1,NXDAT) = TIME - TINT / 2.0 - TEPS
         TIMENX(2,NXDAT) = TIME + TINT / 2.0 + TEPS
         INXSOU(NXDAT) = IDSOUR
         INXFQ(NXDAT) = IFQID
100      CONTINUE
C                                       Close NX table
      CALL TABIO ('CLOS', 0, INXRNO, JBUFF, JBUFF, IERR)
      IF (IERR.NE.0) THEN
         IRET = 4
         WRITE (MSGTXT,1140) IERR
         GO TO 990
         END IF
C                                       Determine whether NX table is
C                                       current by matching Nvis in
C                                       catalog hdr. with NVISMX from
C                                       NX table.
      IF (NVISMX.NE.CATBLK(KIGCN)) THEN
         IRET = 5
         WRITE (MSGTXT,1160)
         GO TO 990
         END IF
C                                       Any valid scans found ?
      IF (NXDAT.EQ.0) THEN
         IRET = 6
         WRITE (MSGTXT,1180)
         GO TO 990
         END IF
C                                       Compile table of all unique
C                                       FQ_IDs in the data. Use
C                                       information read from the NX
C                                       table.
      NFQUV = 0
      DO 200 I = 1, NXDAT
         DO 150 J = 1, NFQUV
            IF (IFQUV(J).EQ.INXFQ(I)) GO TO 200
150         CONTINUE
C                                       New FQ-ID found
         NFQUV = NFQUV + 1
         IF (NFQUV.GT.MXFQID) THEN
            WRITE (MSGTXT,1150)
            IRET = 11
            GO TO 990
            END IF
         IFQUV(NFQUV) = INXFQ(I)
200      CONTINUE
C
      GO TO 999
C                                       Error
990   CALL MSGWRT (8)
C
999   RETURN
C-----------------------------------------------------------------------
1020  FORMAT ('NXREAD: NO VALID NX TABLE FOUND - RUN INDXR')
1040  FORMAT ('NXREAD: ERR',I3,' OPENING NX TABLE')
1100  FORMAT ('NXREAD: ERR',I3,' READING NX TABLE')
1120  FORMAT ('NXREAD: INCREASE PARAMETER MAXNX')
1140  FORMAT ('NXREAD: ERR',I3,' CLOSING NX TABLE')
1160  FORMAT ('NXREAD: NX TABLE OLD - RUN INDXR')
1180  FORMAT ('NXREAD: NO SCANS FOR SUBARRAY',I4)
1150  FORMAT ('NXREAD: PARAMETER MXFQID NEEDS TO BE INCREASED')
      END
      SUBROUTINE NXSRCH (RTIME, ISOUID, IFQID)
C----------------------------------------------------------------------
C   Search the NX table for the source and freq. ID. at a given time
C   Inputs:
C      RTIME   R   Input time relative to the ref. date (in days)
C   Outputs:
C      ISOUID  I   Source id. (0 if not found)
C      IFQID   I   FQ. id.
C---------------------------------------------------------------------
      REAL RTIME
      INTEGER ISOUID, IFQID
C
      INCLUDE 'VLBSY.INC'
      INTEGER I
C---------------------------------------------------------------------
      ISOUID = 0
      IFQID = 0
C                                       Search the NX table
      DO 100 I = 1, NXDAT
         IF ((RTIME.GE.TIMENX(1,I)).AND.(RTIME.LE.TIMENX(2,I))) THEN
            ISOUID = INXSOU(I)
            IFQID = INXFQ(I)
            END IF
100      CONTINUE
C                                       Exit
      RETURN
      END
