LOCAL INCLUDE 'PCLOD.INC'
C                                                          Include PCLOD
C                                       Local include for PCLOD
C                                       Requires 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
      LOGICAL   DOCONC
      REAL      XSIN, XDISIN, XSUBA, XFQTOL, XPCVER, DOKEEP, FQTOL,
     *   BADD(10)
      HOLLERITH XNAMEI(3), XCLAIN(2), XNAME2(12)
      CHARACTER NAMEIN*12, CLAIN*6, NAME2*48
C                                       Buffers and file info
      INTEGER   DISKSC, CNOSC, LUNSC, INDSC, IBPSC, SCBUFF(256),
     *   SXBUFF(512), PCVER, JTABUF(512), PCTOT
      DOUBLE PRECISION DUMMY(2000000)
C                                       Inputs and general info
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XNAME2, XSUBA,
     *   XFQTOL, XPCVER, DOKEEP, BADD
      COMMON /TASKPM/ FQTOL, SEQIN, DISKIN, ISUBA, LUNK, FINDK, OLDCNO,
     *   PCTOT, DROPED, ADDED, DOCONC
C                                       CHARACTER info
      COMMON /CHRCOM/ NAMEIN, CLAIN, NAME2
C                                       Buffers and file info
      COMMON /SCFILE/ DUMMY, SCBUFF, SXBUFF, DISKSC, CNOSC,
     *   LUNSC, INDSC, IBPSC, PCVER, JTABUF
C                                       NX, FQ table information
      DOUBLE PRECISION DFRQTB(MXFQID,MAXIF,2)
      REAL      TIMENX(2,MAXNX)
      INTEGER   INXSOU(MAXNX), INXFQ(MAXNX), IFQUV(MXFQID), NXDAT,
     *   NFQUV, NIFFQ
      LOGICAL   NEWFMT
      COMMON /NXFQIN/ DFRQTB, TIMENX, INXSOU, INXFQ, IFQUV, NFQUV,
     *   NXDAT, NIFFQ, NEWFMT
C                                                          End PCLOD
LOCAL END
      PROGRAM PCLOD
C-----------------------------------------------------------------------
C! Read in VLBA pulse-cal data from ascii file.
C# UV Calibration EXT-util VLB
C-----------------------------------------------------------------------
C;  Copyright (C) 1995-1999, 2007, 2011-2012, 2015-2018, 2022
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 PCLOD 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 'INCS:PUVD.INC'
      INCLUDE 'PCLOD.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 /'PCLOD '/
C-----------------------------------------------------------------------
C                                       Get input parameters
      CALL PCRIN (PRGM, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Read pulse-cal ascii file
      IF (NEWFMT) THEN
         CALL NEWFPC (IRET)
      ELSE
         CALL READPC (IRET)
         END IF
      IF (IRET.NE.0) GO TO 990
C                                       Copy and update HI file.
      CALL PCRHI
C                                       Close down files, etc.
 990  CALL DIE (IRET, SCBUFF)
 999  STOP
      END
      SUBROUTINE PCRIN (PRGN, JERR)
C-----------------------------------------------------------------------
C   PCRIN gets input parameters for PCLOD.
C   Inputs:  PRGN    C*6       Program name
C   Output:  JERR    I         Error code: 0 => ok
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, ANTNAM(10)*2, UTYPE*2, LINE*80
      LOGICAL   T, F
      INTEGER   NPARM, IERR, LC, JTRIM, IROUND, I
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'PCLOD.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.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
C                                       Get input parameters.
      NPARM = 33
      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                                       Frequency tolerance in
C                                       IF match (kHz)
      FQTOL = MAX (0.0, XFQTOL) * 1000.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
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
      NEWFMT = LINE.EQ.'# DiFX-derived pulse cal data'
      CALL ZTXCLS (LUNK, FINDK, IERR)
      IF (.NOT.NEWFMT) THEN
         CALL ZTXOPN ('READ', LUNK, FINDK, NAME2, F, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'RE-OPENING TEXT FILE'
            JERR = IERR
            GO TO 990
            END IF
         END IF
      IF (NAME2(LC:LC).EQ.'_') NAME2(LC+1:) = '  '
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('PCRIN: ERROR',I3,1X,A)
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
     *   I3,' USID=',I5)
      END
      SUBROUTINE READPC (IERR)
C-----------------------------------------------------------------------
C   READPC reads the external text file containing the pulse cal and
C   associated information.
C   Output:
C      IERR       I    Error code, 0=OK, else failed.
C-----------------------------------------------------------------------
      INTEGER   IERR, IROUND
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:PSTD.INC'
      INTEGER NPRM, MAXPCT
      PARAMETER (NPRM = 33, MAXPCT = 100)
C
      CHARACTER PARS(NPRM)*8, ENDMRK*8, VALCH(NPRM)*8, STAT*8,
     *   CHVAL(2000000)*8, CDUMMY(2000000)*8, CTEMP*2,
     *   OSTAT*8, OBSDAT*8, KEYS(2)*24
      INTEGER   KMODE, NPARS, NDUM, IVERS, IDUM, IPOL, TNUM, I,
     *   ITYP, ISTN, MAXT, KKEY(2,2), JSTN, SUBA, NVALS, IJUNK, NSTAT,
     *   NBITS, TBANDN, POLNO, NVARS, FQID, LUNFQ, BANDNO, KEYSUB(2,2),
     *   TONEN, IDAY, IMON, IYEAR, DAYN, MKEY, KOLS(2), NPC, TPC, NCHAN,
     *   TRSIDE(MAXIF), TRPOL(MAXPCT), IFMAP(MAXPCT), ISTAT(MAXPCT),
     *   IFCHAN(MAXPCT), IFTONE(MAXPCT), NPCAL(MAXIF), IDDAT(3)
      REAL      FKEY(2,2), BANDBW(MAXIF), AMP, PHS, RTIME
      DOUBLE PRECISION VALS(NPRM), DEFS(NPRM), FTONE(MAXPCT), OTIME,
     *   TTIME, BANDLO(MAXIF), DDTT, EPS
      LOGICAL FIRST, STATMS, ACCEPT
C
      INCLUDE 'INCS:PPCV.INC'
C
      INTEGER   IPCRNO, NOPOLZ, NTONES
      INTEGER   NOSTA, IARRAY, IFQID, ISRC
      REAL      TINT, PCREL(2, MAXTON, MAXIF),
     *   PCIMG(2,  MAXTON,MAXIF), PCRAT(2, MAXTON, MAXIF),
     *   STATE(2, 4, MAXIF)
      DOUBLE PRECISION TIME, CABLCL, PCFRQ(2, MAXTON, MAXIF)
      INTEGER   PCKOLS(MAXPCC), PCNUMV(MAXPCC)
C                                       SKIP - skip next pulse cal grp
      LOGICAL   SKIP
C
      INCLUDE 'PCLOD.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DGLB.INC'
      DATA FKEY /1.0,0.0, 1.0,0.0/
      DATA KEYSUB /4*1/
      DATA KEYS /'TIME', 'ANTENNA_NO ' /
      DATA PARS /'FREQUENC', 'PULSE-CA', 30*'********',
     *   'NTONES  ' /
      DATA ENDMRK /'/       '/
      DATA DEFS/33*-1.0D0/
      DATA NDUM /2000000/
C-----------------------------------------------------------------------
      EPS = 1.0E-10
      NPC = 0
      TPC = 0
      SKIP = .FALSE.
      NPARS = NPRM
      FIRST = .TRUE.
      DOCONC = .FALSE.
      MAXT = -1
      OSTAT = ' '
      CALL H2CHR (8, 1, CATH(KHDOB), OBSDAT)
C
      CALL DATEST (OBSDAT, IDDAT)
      IYEAR = IDDAT(1)
      IMON = IDDAT(2)
      IDAY = IDDAT(3)
      CALL DAYNUM (IYEAR, IDAY, IMON, DAYN)
C                                       Read NX table information
      LUNFQ = 40
      CALL NXREAD (DISKIN, OLDCNO, ISUBA, CATBLK, LUNFQ, JTABUF,
     *   IERR)
      IF (IERR.NE.0) GO TO 999
C                                       Read FQ table information
      CALL FQREAD (DISKIN, OLDCNO, CATBLK, JTABUF, LUNFQ,
     *   IERR)
      IF (IERR.NE.0) GO TO 999
C                                       Prepare to read KEYIN file.
C                                       Get list of station names
      SUBA = ISUBA
      CALL GETANT (DISKIN, OLDCNO, SUBA, CATBLK, SCBUFF, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1010) IERR
         GO TO 990
         END IF
C                                       Load station names in STNNAM
C                                       from AN file into KEYIN parms
C                                       array PARS.
      DO 50 I = 1,NSTNS
         PARS(2+I) = STNNAM(I)
 50      CONTINUE
C
C                                      Read a complete text entry up to
C                                      the endmark '/'. Load defaults
C                                      into the KEYIN output buffer
C                                      first.
      ITYP = -1
 100  KMODE = 0
      DO 140 I = 1,NPARS
         VALS(I) = DEFS(I)
         VALCH(I) = '        '
 140     CONTINUE
      CALL KEYIN (PARS, VALS, VALCH, NPARS, ENDMRK, KMODE, LUNK, FINDK,
     *   IERR)
      IF (IERR.NE.0) THEN
C                                      Returns IERR=1 on EOF.
         IF (IERR.EQ.1) GO TO 700
         WRITE (MSGTXT,1020) IERR
         GO TO 990
         END IF
C
C                                      Which station name has KEYIN
C                                      just read ?
      DO 180 I = 1,NSTNS
         ISTN = TELNO(I)
         JSTN = TELNO(I)
         IF (VALS(I+2).NE.-1.0D0) THEN
            STAT = PARS(I+2)
            GO TO 190
            END IF
 180     CONTINUE
 190  STATMS = STAT.NE.OSTAT
      WRITE (MSGTXT,2000) STAT
      IF (STATMS) THEN
         CALL MSGWRT (3)
         NPC = 0
         END IF
      OSTAT = STAT
C                                      Which type of group has just been
C                                      read ?
      DO 160 I = 1,2
         ITYP  = I
         IF (VALS(I).NE.-1.D0) GO TO 170
 160     CONTINUE
C                                       If reading first frequency group
C                                       then set up the PC table
 170  IF ((ITYP.EQ.1) .AND. FIRST) THEN
         NTONES = -1
         CALL H2CHR (8, 1, CATH(KHOBS), OBSCOD)
         NOSTKD = CATBLK(KINAX+JLOCS)
         STK1 = CATD(KDCRV+JLOCS)
         NOBAND = CATBLK(KINAX+JLOCIF)
         NOCHAN = CATBLK(KINAX+JLOCF)
         REFFRQ = CATD(KDCRV+JLOCF)
         CHNBW = CATR(KRCIC+JLOCF)
         REFPIX = CATR(KRCRP+JLOCF)
         TABREV = 1
         IF (NOSTKD.EQ.4) NOPOLZ = 2
         IF (NOSTKD.EQ.2) NOPOLZ = 2
         IF (NOSTKD.LT.2) NOPOLZ = 1
         END IF
C                                       If reading FREQUENCY group then
C                                       load up the ftones array.
      IF (ITYP.EQ.1) THEN
C                                       Initialize
         ACCEPT = .TRUE.
         CALL FILL (MAXPCT, 0, TRPOL)
         CALL FILL (MAXPCT, 0, IFCHAN)
         CALL FILL (MAXPCT, 0, IFTONE)
         CALL FILL (MAXPCT, 0, ISTAT)
         CALL FILL (MAXIF, 0, NPCAL)
         CALL FILL (MAXIF, 0, TRSIDE)
         CALL RFILL (MAXIF, -1.0, BANDBW)
         CALL DFILL (MAXIF, -1.D0, BANDLO)
         CALL DFILL (MAXPCT, -1.D0, FTONE)
         OTIME = -1.D0
C
         KMODE = 3
         NVALS = NDUM
         CALL KEYIN (CDUMMY, DUMMY, CHVAL, NVALS, ENDMRK, KMODE, LUNK,
     *      FINDK, IERR)
         IF (IERR.GT.0) THEN
            WRITE (MSGTXT,1030) IERR
            GO TO 990
            END IF
C                                       Extract information required
C                                       to match the FQ-ID and IF nos.
         NCHAN = 0
         DO 182 IDUM = 1,NVALS,8
C                                       Tone number
            READ (CHVAL(IDUM),2010) CTEMP, TNUM
C                                       Channel number
            TBANDN = DUMMY(IDUM+1)
            NCHAN = MAX (NCHAN, TBANDN)
C                                       Polarization
            IPOL = 0
            IF (CHVAL(IDUM+3)(1:3).EQ.'RCP') IPOL = 1
            IF (CHVAL(IDUM+3)(1:3).EQ.'LCP') IPOL = 2
C                                       Sideband
            TRSIDE(TBANDN) = 0
            IF (CHVAL(IDUM+2)(1:1).EQ.'U') TRSIDE(TBANDN) = 1
            IF (CHVAL(IDUM+2)(1:1).EQ.'L') TRSIDE(TBANDN) = -1
C                                       Missing polzn. or sideband ?
            IF ((IPOL.EQ.0) .OR. (TRSIDE(TBANDN).EQ.0)) THEN
               MSGTXT = 'ILLEGAL ENTRY IN FREQUENCY GROUP'
               IERR = 2
               GO TO 990
               END IF
C                                       Otherwise valid ?
            IF ((NOPOLZ.EQ.1) .AND. (ABS(STK1).NE.IPOL)) THEN
               IERR = 3
               MSGTXT = 'INVALID POLARIZATION IN FREQUENCY GROUP'
               GO TO 990
               END IF
C                                       Check for case of LL only
            IF ((NOPOLZ.EQ.1) .AND. (STK1.EQ.-2) .AND. (IPOL.EQ.2))
     *         IPOL = 1
C
            TRPOL(TNUM) = IPOL
C                                       Bandwidth
            BANDBW(TBANDN) = DUMMY(IDUM+7) * 1.0D3
C                                       LO frequency
            BANDLO(TBANDN) = DUMMY(IDUM+6) * 1.0D6
C                                       Pcal tone frequency
            FTONE(TNUM) = DUMMY(IDUM+4) * 1.0D6
C                                       Map tone to channel
            IFCHAN(TNUM) = TBANDN
C                                       State count or Pcal ?
C                                       State count
            IF (DUMMY(IDUM+4).EQ.0.0D0) THEN
               ISTAT(TNUM) = 1
               NBITS = DUMMY(IDUM+5)
               NSTAT = 2 * NBITS
               WRITE (MSGTXT,2020) TNUM, NBITS, STAT
               IF (STATMS) CALL MSGWRT (3)
C                                        Pulse cal
            ELSE
               ISTAT(TNUM) = 0
               NPCAL(TBANDN) = NPCAL(TBANDN) + 1
               IFTONE(TNUM) = NPCAL(TBANDN)
C                                        Max. # tones
               MAXT = MAX (MAXT, IFTONE(TNUM))
               END IF
C
182         CONTINUE
C                                       Now match FQ-ID and IF's
         IF (FQTOL.LE.0) FQTOL = 0.1 * BANDBW(1)
         CALL MATFID (BANDLO, BANDBW, TRSIDE, NCHAN, FQID, IFMAP,
     *         FQTOL, IERR)
         IF (IERR.EQ.0) THEN
            SKIP = .FALSE.
C                                       No match - skip pulse cal
         ELSE IF (IERR.EQ.2) THEN
            IERR = 0
            SKIP = .TRUE.
            MSGTXT = 'Frequency group does not match an FQ ID'
            CALL MSGWRT (5)
            MSGTXT = 'Skipping pulse cal groups'
            CALL MSGWRT (5)
         ELSE
            IERR = 4
            WRITE (MSGTXT,1182)
            GO TO 990
            END IF
C                                       Open the table?
         IF (FIRST) THEN
            FIRST = .FALSE.
            NTONES = MAXT
            IF (NTONES.LE.0) THEN
               IERR = 5
               MSGTXT = '# TONES FROM FIRST FREQ GROUP IS ZERO'
               CALL MSGWRT (6)
               MSGTXT = 'PCLOD CANNOT OPEN THE PC TABLE - EDIT THE FILE'
               GO TO 990
               END IF
C                                       PC number
            PCVER = IROUND(XPCVER)
C                                       Check to see if PC table exists
            CALL FNDEXT ('PC', CATBLK, PCTOT)
            IF (PCVER.LE.0) PCVER = PCTOT + 1
C
            LUNSC = 30
            CALL PCINI ('WRIT', SXBUFF, DISKIN, OLDCNO, PCVER, CATBLK,
     *         LUNSC, IPCRNO, PCKOLS, PCNUMV, NOPOLZ, NOBAND, NTONES,
     *         IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR
               GO TO 990
               END IF
C                                       warning of concatenation
            IF (PCVER.LE.PCTOT) THEN
               DOCONC = .TRUE.
               WRITE (MSGTXT,1080) PCVER
               CALL REFRMT (MSGTXT, '_', I)
               CALL MSGWRT (8)
               END IF
C                                       Update CATBLK
            CALL CATIO ('UPDT', DISKIN, OLDCNO, CATBLK, 'REST',
     *         SCBUFF,IERR)
            END IF
C
         DO 210 IDUM = 1,NVALS
            CHVAL(IDUM) = ' '
            DUMMY(IDUM) = 0.D0
 210        CONTINUE
         GO TO 100
         END IF
C                                       Read the pulse-cal group
      IF (ITYP.EQ.2) THEN
         KMODE = 3
         NVALS = NDUM
         CALL KEYIN (CDUMMY, DUMMY, CHVAL, NVALS, ENDMRK, KMODE, LUNK,
     *      FINDK, IERR)
         IF (IERR.GT.0) THEN
            WRITE (MSGTXT,1040) IERR
            GO TO 990
            END IF
C
         IDUM = 1
 300     IF ((IDUM.GE.NVALS) .OR. (.NOT.ACCEPT)) THEN
C                                       Write the final row
            IF (ACCEPT) THEN
               IF (ISRC.LE.0) DROPED = DROPED + 1
               IF ((ISRC.GT.0) .OR. (DOKEEP.GT.0.0)) THEN
                  CALL TABPC ('WRIT', SXBUFF, IPCRNO, PCKOLS, PCNUMV,
     *               NOPOLZ, TIME, TINT, ISRC, NOSTA, IARRAY, IFQID,
     *               CABLCL, STATE, PCFRQ, PCREL, PCIMG, PCRAT, IERR)
                  IF (IERR.NE.0) THEN
                     CALL TABERR ('WRIT', 'TABPC ', 'READPC', IERR)
                     GO TO 999
                     END IF
                  NPC = NPC + 1
                  ADDED = ADDED + 1
C
                  IF (DOCONC) THEN
                     WRITE (MSGTXT,2050) NPC, PCVER, STAT
                  ELSE
                     WRITE (MSGTXT,2060) NPC, PCVER, STAT
                     END IF
                  CALL MSGWRT (4)
                  TPC = TPC + NPC
                  END IF
               END IF
C
            DO 310 IDUM = 1,NVALS
               CHVAL(IDUM) = ' '
               DUMMY(IDUM) = 0.D0
  310          CONTINUE
            GO TO 100
            END IF
C                                       Skip processing if this doesn't
C                                       belong to an FQ-ID
         IF (SKIP) GO TO 100
C
         NVARS = 0
         TTIME = DUMMY(IDUM) + DUMMY(IDUM+1) / 24.D0
         DDTT = TTIME - OTIME
C
         IF (((DDTT.GT.EPS) .OR. (DDTT.LT.-EPS)) .AND.
     *      (OTIME.GT.-1.D0)) THEN
C                                       Write the row
            IF (ISRC.LE.0) DROPED = DROPED + 1
            IF ((ISRC.GT.0) .OR. (DOKEEP.GT.0.0)) THEN
               CALL TABPC ('WRIT', SXBUFF, IPCRNO, PCKOLS, PCNUMV,
     *            NOPOLZ, TIME, TINT, ISRC, NOSTA, IARRAY, IFQID,
     *            CABLCL, STATE, PCFRQ, PCREL, PCIMG, PCRAT, IERR)
               IF (IERR.NE.0) THEN
                  CALL TABERR ('WRIT', 'TABPC ', 'READPC', IERR)
                  GO TO 999
                  END IF
               NPC = NPC + 1
               ADDED = ADDED + 1
               END IF
            END IF
C
         TIME = TTIME - DAYN
         OTIME = TTIME
C                                       Get source id. for this time
         RTIME = TIME
         CALL NXSRCH (RTIME, ISRC, IJUNK)
C
         IFQID = FQID
         IARRAY = ISUBA
         NOSTA = ISTN
C
         NVARS = NVARS + 5
C                                       Cable cal value
         IF (CHVAL(IDUM+2)(1:1).EQ.'C') THEN
            CABLCL = DUMMY(IDUM+3) / 1.0D12
            TINT   = DUMMY(IDUM+4) / 86400.D0
            END IF
C
         IF (CHVAL(IDUM+2)(1:1).EQ.'T') THEN
            READ (CHVAL(IDUM+2),2010) CTEMP, TNUM
C                                       Determine the AIPS IF no.
            TBANDN = IFCHAN(TNUM)
            BANDNO = IFMAP(TBANDN)
C                                       Look only nonzero IFs
            IF (BANDNO.EQ.0) GO TO 600
C                                       AIPS polzn. number
            POLNO  = TRPOL(TNUM)
C                                       AIPS tone number
            TONEN  = IFTONE(TNUM)
C                                       State count or pulse cal ?
            IF (ISTAT(TNUM).EQ.1) THEN
C                                       State count
               IF (POLNO.EQ.1) THEN
                  IF (NSTAT.EQ.2) THEN
                     STATE(1, 1, BANDNO) = DUMMY(IDUM+3)
                     STATE(1, 2, BANDNO) = DUMMY(IDUM+4)
                  ELSE IF (NSTAT.EQ.4) THEN
                     NVARS = NVARS + 2
                     STATE(1, 1, BANDNO) = DUMMY(IDUM+3)
                     STATE(1, 2, BANDNO) = DUMMY(IDUM+4)
                     STATE(1, 3, BANDNO) = DUMMY(IDUM+5)
                     STATE(1, 4, BANDNO) = DUMMY(IDUM+6)
                     END IF
               ELSE IF (POLNO.EQ.2) THEN
                  IF (NSTAT.EQ.2) THEN
                     STATE(2, 1, BANDNO) = DUMMY(IDUM+3)
                     STATE(2, 2, BANDNO) = DUMMY(IDUM+4)
                  ELSE IF (NSTAT.EQ.4) THEN
                     NVARS = NVARS + 2
                     STATE(2, 1,BANDNO) = DUMMY(IDUM+3)
                     STATE(2, 2,BANDNO) = DUMMY(IDUM+4)
                     STATE(2, 3,BANDNO) = DUMMY(IDUM+5)
                     STATE(2, 4,BANDNO) = DUMMY(IDUM+6)
                     END IF
                  END IF
C
            ELSE IF (ISTAT(TNUM).EQ.0) THEN
C                                       Pulse-cal
C                                       Amplitudes in files are
C                                       percentages - convert to
C                                       fractions.
               AMP = DUMMY(IDUM+3) / 100.0
               PHS = DUMMY(IDUM+4) * DG2RAD
               IF (POLNO.EQ.1) THEN
                  PCREL(1, TONEN, BANDNO) = AMP * COS (PHS)
                  PCIMG(1, TONEN, BANDNO) = AMP * SIN (PHS)
                  PCFRQ(1, TONEN, BANDNO) = FTONE(TNUM)
                  PCRAT(1, TONEN, BANDNO) = 0.0
               ELSE IF (POLNO.EQ.2) THEN
                  PCREL(2, TONEN, BANDNO) = AMP * COS (PHS)
                  PCIMG(2, TONEN, BANDNO) = AMP * SIN (PHS)
                  PCFRQ(2, TONEN, BANDNO) = FTONE(TNUM)
                  PCRAT(2, TONEN, BANDNO) = 0.0
                  END IF
               END IF
            END IF
 600     CONTINUE
         IDUM = IDUM + NVARS
         GO TO 300
         END IF
C                                       Close up
 700  CALL TABIO ('CLOS', 0, IPCRNO, SXBUFF, SXBUFF, IERR)
      IF (IERR.NE.0) GO TO 999
      CALL ZTXCLS (LUNK, FINDK, IERR)
      IF (TPC.EQ.0) THEN
         MSGTXT = 'NO PHASE-CAL ENTRIES WRITTEN - PROBLEM?'
         IERR = 7
         GO TO 990
         END IF
C                                       Sort PC table
      CALL PCINI ('WRIT', SXBUFF, DISKIN, OLDCNO, PCVER, CATBLK,
     *   LUNSC, IPCRNO, PCKOLS, PCNUMV, NOPOLZ, NOBAND, NTONES,
     *   IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR
         GO TO 990
         END IF
C                                       Set column pointers for sort
      MKEY = 2
      CALL FNDCOL (MKEY, KEYS, 24, .TRUE., SXBUFF, KOLS, IERR)
      IF (IERR.GT.0) THEN
         WRITE (MSGTXT,1060) IERR
         GO TO 990
         END IF
      CALL TABIO ('CLOS', 0, IPCRNO, SXBUFF, SXBUFF, IERR)
      IF (IERR.NE.0) GO TO 999
C
      IVERS = PCVER
      KKEY(1,1) = KOLS(1)
      KKEY(2,1) = KOLS(1)
      KKEY(1,2) = KOLS(2)
      KKEY(2,2) = KOLS(2)
      CALL TABSRT (DISKIN, OLDCNO, 'PC', IVERS, IVERS, KKEY, KEYSUB,
     *   FKEY, SXBUFF, CATBLK, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1070) IERR
         GO TO 990
         END IF
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('READPC: ERROR ',I3,' OPENING PC TABLE')
 1010 FORMAT ('READPC: ERROR ',I3,' READING AN TABLE')
 1020 FORMAT ('READPC: ERROR ',I3,' READING TEXT FILE WITH KEYIN')
 1030 FORMAT ('READPC: ERROR ',I3,' READING FREQUENCY GROUP')
 1040 FORMAT ('READPC: ERROR ',I3,' READING PULSE-CAL GROUP')
 1060 FORMAT ('READPC: ERROR ',I3,' RUNNING FNDCOL')
 1070 FORMAT ('READPC: ERROR ',I3,' SORTING PC TABLE')
 1080 FORMAT ('!! PC table', I3,' already exists !!')
 1182 FORMAT ('** ERROR - FQ table problem ***')
 2000 FORMAT ('Reading data for ',A2)
 2010 FORMAT (A1,I2)
 2020 FORMAT ('Tone ',I3,' carries the ',I1,' bit state count for ',A8)
 2050 FORMAT ('Added ',I5,' rows into PC table', I3, ' for ',A2)
 2060 FORMAT ('Wrote ',I5,' rows into PC table', I3, ' for ',A2)
      END
      SUBROUTINE NEWFPC (IERR)
C-----------------------------------------------------------------------
C   NEWFPC builds a PC table from the "new" 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 'INCS:PPCV.INC'
      INCLUDE 'PCLOD.INC'
      INTEGER   LUNFQ, SUBA, LC, JTRIM, ILOOP, KBPLIM, KBP, SDAY,
     *   NTONES, NIFS, LIF, LPOL, NOBAND, LUNPC, PCBUFF(512), IPCRNO,
     *   PCKOLS(MAXPCC), PCNUMV(MAXPCC), I, ITONE, ISRC, IFQID, NOPOLZ,
     *   NOSTA, IROUND, IR, IL
      LOGICAL   DOLOOP, FIRST
      CHARACTER ANTNAM(10)*2, TELNAM*8, HLINE*40, LLINE*50000, NAMTEL*8,
     *   OBSDAT*8
      DOUBLE PRECISION  XX, TIME, CABLCL, PCFREQ(2,MAXTON,MAXIF), JD
      REAL      DTIME, PCREAL(2,MAXTON,MAXIF), PCIMAG(2,MAXTON,MAXIF),
     *   PCRATE(2,MAXTON,MAXIF), STATE(2,4,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
C                                       Make these not fatal errors
C                                       Read NX table information
      LUNFQ = 40
      CALL NXREAD (DISKIN, OLDCNO, ISUBA, CATBLK, LUNFQ, JTABUF, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READING NX TABLE'
         CALL MSGWRT (7)
         END IF
C                                       Read FQ table information
      CALL FQREAD (DISKIN, OLDCNO, CATBLK, JTABUF, LUNFQ, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READING FQ DATA'
         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)
      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
C                                       read first lines, parse
      CALL ZTXIO ('READ', LUNK, FINDK, HLINE, IERR)
 55   IF (IERR.EQ.0) CALL ZTXIO ('READ', LUNK, FINDK, HLINE, IERR)
      IF (IERR.EQ.0) CALL ZTXIO ('READ', LUNK, FINDK, HLINE, IERR)
      IF (IERR.EQ.0) THEN
         KBPLIM = JTRIM (HLINE)
         KBP = 14
         CALL GETNUM (HLINE, KBPLIM, KBP, XX)
C         IF (FIRST) SDAY = XX + 0.1D0
         CALL ZTXIO ('READ', LUNK, FINDK, HLINE, IERR)
         IF (IERR.EQ.0) CALL ZTXIO ('READ', LUNK, FINDK, HLINE, IERR)
         IF (IERR.EQ.0) TELNAM = HLINE(20:)
         END IF
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READING HEADER LINES'
         IF (.NOT.DOLOOP) GO TO 990
         WRITE (MSGTXT,1000) IERR, 'READING HEADER LINES FOR' //
     *      ANTNAM(ILOOP)
         CALL MSGWRT (7)
         GO TO 200
         END IF
      NOSTA = 0
      DO 60 I = 1,NSTNS
         IF (TELNAM.EQ.STNNAM(I)) NOSTA = TELNO(I)
 60      CONTINUE
      IF (NOSTA.LE.0) NOSTA = NSTNS + ILOOP
C                                       read a line
 100  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
         KBPLIM = JTRIM (LLINE)
         IF (LLINE.EQ.'# DiFX-derived pulse cal data') GO TO 55
C                                       parse start of line
         DO 105 KBP = 1,KBPLIM
            IF (LLINE(KBP:KBP).EQ.' ') GO TO 110
 105        CONTINUE
C                                       telescope name
 110     NAMTEL = LLINE(:KBP-1)
         IF (NAMTEL.NE.TELNAM) THEN
            NOSTA = 0
            DO 115 I = 1,NSTNS
               IF (NAMTEL.EQ.STNNAM(I)) NOSTA = TELNO(I)
 115           CONTINUE
            IF (NOSTA.LE.0) NOSTA = NSTNS + ILOOP
            MSGTXT = 'Data line changes telescope from ' //
     *         TELNAM(:JTRIM(TELNAM)) // ' to ' //
     *         NAMTEL(:JTRIM(NAMTEL))
            CALL MSGWRT (6)
            TELNAM = NAMTEL
            END IF
C                                       time
         CALL GETNUM (LLINE, KBPLIM, KBP, XX)
         TIME = XX - SDAY
C                                       Get source id. for this time
         RTIME = TIME
         CALL NXSRCH (RTIME, ISRC, IFQID)
C                                       time incr
         CALL GETNUM (LLINE, KBPLIM, KBP, XX)
         DTIME = XX
C                                       ???
         CALL GETNUM (LLINE, KBPLIM, KBP, XX)
C                                       NIFS * NPOL
         CALL GETNUM (LLINE, KBPLIM, KBP, XX)
         NIFS = XX + 0.1
C                                       NVAL per IF
         CALL GETNUM (LLINE, KBPLIM, KBP, XX)
         NTONES = XX + 0.1
C                                       FIRST: init arrays, open table
         IF (FIRST) THEN
            IR = INDEX (LLINE, ' R ')
            IL = INDEX (LLINE, ' L ')
            NOPOLZ = 0
            IF (IR.GT.0) NOPOLZ = NOPOLZ + 1
            IF (IL.GT.0) NOPOLZ = NOPOLZ + 1
            NOBAND = NIFS
            IF (NOPOLZ.GT.0) NOBAND = NIFS / NOPOLZ
            I = CATBLK(KINAX+JLOCS)
            I = MIN (I, 2)
            IF ((NOPOLZ.NE.I) .OR. (NOBAND.NE.CATBLK(KINAX+JLOCIF)))
     *         THEN
               WRITE (MSGTXT,1110) NOPOLZ, NOBAND, I,
     *            CATBLK(KINAX+JLOCIF)
               CALL MSGWRT (6)
               END IF
            I = 2 * MAXTON * MAXIF
            CALL RFILL (I, FBLANK, PCREAL)
            CALL RFILL (I, FBLANK, PCIMAG)
            CALL RFILL (I, FBLANK, PCRATE)
            CALL DFILL (I, 0.0D0, PCFREQ)
            CABLCL = 0.0D0
            I = 8 * MAXIF
            CALL RFILL (I, FBLANK, STATE)
C                                       PC number
            PCVER = IROUND(XPCVER)
C                                       Check to see if PC table exists
            CALL FNDEXT ('PC', CATBLK, PCTOT)
            IF (PCVER.LE.0) PCVER = PCTOT + 1
            LUNPC = 30
            CALL PCINI ('WRIT', PCBUFF, DISKIN, OLDCNO, PCVER, CATBLK,
     *         LUNPC, IPCRNO, PCKOLS, PCNUMV, NOPOLZ, NOBAND, NTONES,
     *         IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPENING PC TABLE'
               GO TO 990
               END IF
C                                       warning of concatenation
            IF (PCVER.LE.PCTOT) THEN
               DOCONC = .TRUE.
               WRITE (MSGTXT,1111) PCVER
               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                                       sanity check
         IF (NIFS.NE.NOPOLZ*NOBAND) THEN
            WRITE (MSGTXT,1112) NIFS, NOPOLZ, NOBAND
            CALL MSGWRT (7)
         END IF
         NIFS = NIFS / NOPOLZ
         DO 140 LIF = 1,NIFS
            DO 130 LPOL = 1,NOPOLZ
               DO 120 ITONE = 1,NTONES
                  CALL GETNUM (LLINE, KBPLIM, KBP, XX)
                  PCFREQ(LPOL,ITONE,LIF) = XX * 1.D6
                  KBP = KBP + 2
                  CALL GETNUM (LLINE, KBPLIM, KBP, XX)
                  PCREAL(LPOL,ITONE,LIF) = XX
                  CALL GETNUM (LLINE, KBPLIM, KBP, XX)
                  PCIMAG(LPOL,ITONE,LIF) = XX
                  PCRATE(LPOL,ITONE,LIF) = 0.0
 120              CONTINUE
 130           CONTINUE
 140        CONTINUE
         IF (ISRC.LE.0) DROPED = DROPED + 1
         IF ((ISRC.GT.0) .OR. (DOKEEP.GT.0.0)) THEN
            CALL TABPC ('WRIT', PCBUFF, IPCRNO, PCKOLS, PCNUMV, NOPOLZ,
     *         TIME, DTIME, ISRC, NOSTA, ISUBA, IFQID, CABLCL, STATE,
     *         PCFREQ, PCREAL, PCIMAG, PCRATE, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'WRITING OUTPUT PC TABLE'
               GO TO 990
               END IF
             ADDED = ADDED + 1
             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
      CALL TABPC ('CLOS', PCBUFF, IPCRNO, PCKOLS, PCNUMV, NOPOLZ,
     *   TIME, DTIME, ISRC, NOSTA, ISUBA, IFQID, CABLCL, STATE,
     *   PCFREQ, PCREAL, PCIMAG, PCRATE, IERR)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('NEWFPC ERROR',I4,' ON ',A)
 1110 FORMAT ('PC FILE Npol, Nif',I2,I4,' DO NOT MATCH UV DATA',I2,I4)
 1111 FORMAT ('NEWFPC: Cocatenating to PC table',I5)
 1112 FORMAT ('WARNING: NIFS',I4,' NOT NPOL*NBAND',I2,I4)
      END
      SUBROUTINE PCRHI
C-----------------------------------------------------------------------
C   PCRHI copies and updates history file.
C-----------------------------------------------------------------------
      INTEGER   LUN1, IERR, ITIME(3), DATE(3), I
      CHARACTER HILINE*72, CITIME*20
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'PCLOD.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, PCVER, ADDED
         CALL HIADD (LUN1, HILINE, SCBUFF, IERR)
         IF (IERR.NE.0) GO TO 100
         WRITE (MSGTXT,1020) ADDED, PCVER
         CALL REFRMT (MSGTXT, '_', I)
         CALL MSGWRT (4)
      ELSE
         WRITE (HILINE,2002) TSKNAM, PCVER, ADDED
         CALL HIADD (LUN1, HILINE, SCBUFF, IERR)
         IF (IERR.NE.0) GO TO 100
         WRITE (MSGTXT,1021) ADDED, PCVER
         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                                       Close HI file
 100  CALL HICLOS (LUN1, .TRUE., SCBUFF, IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('PCRHI: ERROR',I3,' OPENING HISTORY FILE')
 1010 FORMAT (A6,'RELEASE =''',A,' ''  /********* Start ',
     *   A12,2X,A8)
 1020 FORMAT (I10,' records added to old PC table version',I4)
 1021 FORMAT (I10,' records written to new PC table version',I4)
 2000 FORMAT (A6,'INFILE = ''',A48,'''')
 2001 FORMAT (A6,'PCVERS =',I4,'  / Concatenated',I8,
     *   ' records to existing table')
 2002 FORMAT (A6,'PCVERS =',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')
      END
      SUBROUTINE MATFID (DLOFRQ, BANDW, ISIDE, N, IFQID, IFMAP, TOL,
     *   IRET)
C-----------------------------------------------------------------------
C   Determine FQ-ID/IF matching a given set of Pcal channel frequencies
C   Inputs:
C      DLOFRQ     D(*)   LO sum for each Pcal channel (Hz)
C      BANDW      R(*)   Bandwidth for each Pcal channel (Hz)
C      ISIDE      I(*)   Sideband for each Pcal channel
C      N          I      Number of Pcal channels
C      TOL        R      Tolerance for match (Hz)
C   Inputs from common:
C      DFRQTB     D(*,*,2) Table of freqs. for each AIPS FQ-ID/IF.
C      IFQUV      I(*)     Array of FQ-IDs in data
C      NFQUV      I        Number of entries in IFQUV
C   Outputs:
C      IFQID      I      Matching FQ-ID (zero if no match)
C      IFMAP      I(*)   AIPS IF number for each pcal. channel
C      IRET       I      Return code (0 => ok)
C-----------------------------------------------------------------------
      INTEGER N, IFQID, IRET
      DOUBLE PRECISION DLOFRQ(N)
      REAL BANDW(N), TOL
      INTEGER ISIDE(N), IFMAP(N)
C
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'PCLOD.INC'
      LOGICAL WMATCH
      DOUBLE PRECISION DFRQ1, DFRQ2, DEPS1, DEPS2
      INTEGER JFQ, ICHAN, IIF, J
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
C                                       Initialisation
      IRET = 0
      IFQID = 0
C                                       Any FQ-IDs ?
      IF (NFQUV.LE.0) THEN
         IRET = 1
         WRITE (MSGTXT,1000)
         GO TO 990
         END IF
C                                       Loop through all FQ-IDs in data
      WMATCH = .FALSE.
      JFQ = 0
C                                       Match found ?
C50    IF ((JFQ.GT.NFQUV).OR.(WMATCH)) GO TO 200
C
50    IF ((JFQ .GE. NFQUV) .OR. (WMATCH)) GO TO 200
C                                       Does this FQ-ID match Pcal
C                                       channel frequencies ?
      JFQ = JFQ + 1
C                                       Loop over all Pcal channels
      DO 100 ICHAN = 1, N
C                                       Freq. range of Pcal channel
         IF (ISIDE(ICHAN).LE.0) THEN
            DFRQ1 = DLOFRQ(ICHAN) - BANDW(ICHAN)
         ELSE
            DFRQ1 = DLOFRQ(ICHAN)
            END IF
         DFRQ2 = DFRQ1 + BANDW(ICHAN)
         IFMAP(ICHAN) = 0
C                                       Find matching AIPS IF number
         DO 75 IIF = 1, NIFFQ
            DEPS1 = ABS (DFRQ1 - DFRQTB(JFQ,IIF,1))
            DEPS2 = ABS (DFRQ2 - DFRQTB(JFQ,IIF,2))
C                                       Compare to within tolerance
            IF ((DEPS1.LE.TOL).AND.(DEPS2.LE.TOL)) THEN
              IFMAP(ICHAN) = IIF
              GO TO 100
              END IF
75          CONTINUE
100      CONTINUE
C                                       Was a match found at least
C                                       for one Pcal channel?
      WMATCH = .FALSE.
      DO 120 J = 1, N
         IF (IFMAP(J) .NE. 0) THEN
            WMATCH = .TRUE.
            GO TO 50
            END IF
120      CONTINUE
C
      GO TO 50
C                                       Endwhile
200   IF (WMATCH) THEN
         IFQID = IFQUV(JFQ)
      ELSE
         IRET = 2
         END IF
      GO TO 999
C                                       Error
990   CALL MSGWRT (8)
C                                       Exit
999   RETURN
C----------------------------------------------------------------------
1000  FORMAT ('MATFID: No FQ table information; check FQ table')
      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 'INCS:PUVD.INC'
      INCLUDE 'PCLOD.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 FQREAD (INDISK, ICNO, CATBLK, JBUFF, ILUN, IRET)
C-----------------------------------------------------------------------
C   Subroutine to read parts of the FQ table into memory
C   Inputs:
C      INDISK  I        Disk volume
C      ICNO    I        Catalog slot number
C      CATBLK  I(256)   Catalog header block
C      JBUFF   I(*)     I/O table buffer
C      ILUN    I        LUN to use for table I/O
C   Outputs to common:
C      DFRQTB  D(*,*,2) Table of freq. values for each IF/FQ-ID
C   Outputs:
C      IRET    I    Return code (0 => ok)
C-----------------------------------------------------------------------
      INCLUDE 'INCS:PUVD.INC'
      INTEGER INDISK, ICNO, CATBLK(256), ILUN, JBUFF(*), IRET
C
      INCLUDE 'PCLOD.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DMSG.INC'
      DOUBLE PRECISION DFOFF(MAXIF), DBAND, DEDGE, DREF
      REAL      CATR(256), FINC(MAXIF)
      INTEGER   ISBAND(MAXIF), NIF, I, J, IVER, IERR, NDIM
      CHARACTER BNDCOD(MAXIF)*8
C-----------------------------------------------------------------------
      IRET = 0
C                                       Initialization
      NDIM = 2 * MXFQID * MAXIF
      CALL DFILL (NDIM, 0.0D0, DFRQTB)
      CALL RCOPY (256, CATBLK, CATR)
C                                       Reference freq. at DC
      DREF = FREQ - (CATR(KRCRP+JLOCF) - 0.5) * CATR(KRCIC+JLOCF)
      NIFFQ = 0
C                                       Read FQ/CH data into memory
      DO 100 I = 1, NFQUV
         IVER = 1
         CALL CHNDAT ('READ', JBUFF, INDISK, ICNO, IVER, CATBLK,
     *      ILUN, NIF, DFOFF, ISBAND, FINC, BNDCOD, IFQUV(I), IERR)
         IF (IERR.NE.0) THEN
            IRET = 1
            WRITE (MSGTXT,1100) IERR
            GO TO 990
            END IF
C                                       Max. no. of IF's
         NIFFQ = MAX (NIF, NIFFQ)
C                                       Loop over the IFs
         DO 80 J = 1, NIF
            DBAND = FINC(J) * CATBLK(KINAX+JLOCF)
            DEDGE = DFOFF(J) + DREF
C
            DFRQTB(I,J,1) = DEDGE
            DFRQTB(I,J,2) = (DEDGE + DBAND)
80          CONTINUE
100      CONTINUE
C
      GO TO 999
C                                       Error
990   CALL MSGWRT (8)
C                                       Exit
999   RETURN
C-----------------------------------------------------------------------
1100  FORMAT ('FQREAD: ERR',I3,' READING FQ/CH TABLE')
      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 'INCS:PUVD.INC'
      INCLUDE 'PCLOD.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
