LOCAL INCLUDE 'SWPAN.INC'
C                                       Local include for SWPOL
C                                       Describes the antennas to be
C                                       swapped.
C
C   INCLUD      L      See description of NANT below
C   ANTENS      I(50)  List of antennae (all entries from 1 to NANT are
C                      positive
C   NANT        I      Number of antennae in list. If NANT = 0 then all
C                      polarizations are swapped for all antennae,
C                      otherwise only antennae in the list are swapped
C                      if INCLUD is .TRUE.; if INCLUD is .FALSE. then
C                      all antennae except those in the list are swapped
C   SUBARR      I      Subarray number to process
C
      LOGICAL   INCLUD
      INTEGER   ANTENS(50), NANT, SUBARR
C
      COMMON /SWPANT/ INCLUD, ANTENS, NANT, SUBARR
C                                       End of local include SWPAN.INC
LOCAL END
LOCAL INCLUDE 'SWPFL.INC'
C                                       Local include for SWPOL
C                                       Contains the input and output
C                                       file specifications for SWPOL
C
C     INNAME      C*12      Input file name (name)
C     INCLAS      C*6       Input file name (class)
C     INSEQ       I         Input file name (sequence number)
C     INDISK      I         Input file disk number
C     INCNO       I         Input file catalogue number
C     OUTNAM      C*12      Output file name (name)
C     OUTCLS      C*6       Output file name (class)
C     OUTSEQ      I         Output file name (sequence number)
C     OUTDSK      I         Output file disk number
C     OUTCNO      I         Output file catalogue number
C
      CHARACTER INNAME*12, INCLAS*6, OUTNAM*12, OUTCLS*6, TASWAP(50)*2
      INTEGER   INSEQ, INDISK, INCNO, OUTSEQ, OUTDSK, OUTCNO, NSWAPD
C
      COMMON /SWPFCH/ INNAME, INCLAS, OUTNAM, OUTCLS, TASWAP
      COMMON /SWPFNM/ INSEQ, INDISK, INCNO, OUTSEQ, OUTDSK, OUTCNO,
     *   NSWAPD
C                                       End of local include SWPFL
LOCAL END
LOCAL INCLUDE 'SWPIO.INC'
C                                       Local include for SWPOL.
C                                       Define variables required by
C                                       SWPOL's I/O operations.
C
C   INLUN        I         Local unit number for input file (constant)
C   OUTLUN       I         Local unit number for output file (constant)
C   IFIND        I         FTAB index for input file (initialised by
C                          INITIO)
C   OFIND        I         FTAB index for output file (initialised by
C                          INITIO)
C   LBUFF        I         Length of I/O buffers in words (constant)
C   IBUFF        R(LBUFF)  Input buffer
C   OBUFF        R(LBUFF)  Output buffer
C   NIO          I         Number of visibilities in input buffer
C                          (modified by RDVIS)
C   IBIND        I         Index of start of first visibility in input
C                          buffer (may be modified by RDVIS)
C   OBIND        I         Index of start of first visibility in ouput
C                          buffer
C   VISNO        I         Number of visibility in input buffer
C                          (1 <= VISNO <= NIO) currently being processed
C                          (modified by RDVIS)
C   ILOCWT       I         Offset of WEIGHT from beginning of random
C                          parameters if data are compressed; a negative
C                          number if data are not compressed
C                          (initialised by INITIO; ILOCWT < NRPARM)
C
      INCLUDE 'INCS:ZPBUFSZ.INC'
      INTEGER   INLUN, OUTLUN, CATOLD(256)
      PARAMETER (INLUN = 16, OUTLUN = 17)
      INTEGER   IFIND, OFIND, NIO, IBIND, OBIND, VISNO, ILOCWT
      REAL      IBUFF(UVBFSS), OBUFF(UVBFSS), XCENT, DIFPIX
      DOUBLE PRECISION UVSCAL
      COMMON    /SWPIO/ CATOLD, UVSCAL, XCENT, IFIND, OFIND, IBUFF,
     *   OBUFF, NIO, IBIND, OBIND, VISNO, ILOCWT, DIFPIX
C                                       End of local include SWPIO.INC
LOCAL END
      PROGRAM SWPOL
C-----------------------------------------------------------------------
C! Swap polarizations for designated antennae
C# UV UV-Util
C-----------------------------------------------------------------------
C;  Copyright (C) 1995-1997, 2000-2001, 2008, 2013-2015, 2017, 2022-2024
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   Swaps linear or circular polarizations for a selected subset of
C   antennae. The input data must contain one of the following
C   combinations of polarizations: (RR, LL), (RR, LL, RL, LR), (XX, YY)
C   or (XX, YY, XY, YX). In the unlikely event that the data has both
C   parallel hands but only one cross hand, the data must be mangled to
C   remove the cross hand or add the other before attempting to swap
C   polarizations.
C
C   Inputs:
C     INNAME       Input file name (name)
C     INCLASS      Input file name (class)
C     INSEQ        Input file name (sequence number)
C     INDISK       Input file disk number
C     OUTNAME      Output file name (name)
C     OUTCLASS     Output file name (class)
C     OUTSEQ       Output file name (sequence number)
C     OUTDISK      Output file disk number
C     ANTENNAS     Antenna list
C     SUBARR       Subarray number
C     DOCALIB      Swap calibration info?
C-----------------------------------------------------------------------
      INTEGER   IERR, SCRTCH(256)
      CHARACTER PRGM*6
      LOGICAL   DOCAL(2)
C
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'SWPAN.INC'
      INCLUDE 'SWPFL.INC'
      INCLUDE 'SWPIO.INC'
C
      PARAMETER (PRGM = 'SWPOL ')
C-----------------------------------------------------------------------
C                                       Get input parameters, initialize
C                                       commons and check input file:
      CALL SWINIT (PRGM, DOCAL, IERR)
C                                       Swap polarizations:
      IF (IERR.EQ.0) CALL SWMAIN (IERR)
C                                       Flush I/O buffers
      IF (IERR.EQ.0) CALL ENDUV (DOCAL, IERR)
C                                       Copy and update history and copy
C                                       tables:
      IF (IERR.EQ.0) CALL SWPHIS (DOCAL, IERR)
C                                       Close down:
      CALL DIE (IERR, SCRTCH)
C
      STOP
      END
      SUBROUTINE SWINIT (PRGM, DOCAL, IRET)
C-----------------------------------------------------------------------
C   Initialize AIPS COMMONs and COMMON blocks in local includes; get
C   inputs; open files and check input file for suitability. The
C   polarizations should correspond to one of (RR, LL), (XX, YY)
C   (RR, LL, RL, LR) or (XX, YY, XY, YX) and the fastest varying
C   visibility axis should be the complex axis.
C
C   Input:
C     PRGM    C*6     Program name
C
C   Output:
C     DOCAL   L       .TRUE. if calibration information is to be
C                     swapped, .FALSE. otherwise
C     IRET    I       Return status: 0 -> OK
C                                    1 -> error reading inputs
C                                    2 -> error opening files
C                                    3 -> bad input file
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      LOGICAL   DOCAL(2)
      INTEGER   IRET
C
C   Local variables:
C     NSUBAR   I          Number of subarrays in this data set.
C
C   Variables in /INPARM/ provide temporary storage for POPS adverbs.
C     NPARM    I          Size of adverb list (constant)
C
      INTEGER   NSUBAR, SCRTCH(256), NPARM, I, J, IERR
      LOGICAL   FOUND
      HOLLERITH XINNAM(3), XINCLS(2), XOUTNM(3), XOUTCL(2)
      REAL      XINSEQ, XINDSK, XOUTSQ, XOUTDS, XANT(50), XSUBAR,
     *   XDOCAL, XDOTAB, DOCENT
      PARAMETER (NPARM = 68)
C
      COMMON /INPARM/ XINNAM, XINCLS, XINSEQ, XINDSK, XOUTNM, XOUTCL,
     *   XOUTSQ, XOUTDS, XANT, XSUBAR, XDOCAL, XDOTAB, DOCENT
C
      INCLUDE 'SWPAN.INC'
      INCLUDE 'SWPFL.INC'
      INCLUDE 'SWPIO.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
C-----------------------------------------------------------------------
C                                       Initialize AIPS COMMONs:
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      NSCR = 0
      NCFILE = 0
C                                       Get input adverbs:
      CALL GTPARM (PRGM, NPARM, RQUICK, XINNAM, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         IF (IERR.NE.1) THEN
            WRITE (MSGTXT, 1000) IERR
            CALL MSGWRT (8)
            CALL RELPOP (1, SCRTCH, IERR)
            END IF
         IRET = 1
         GO TO 999
         END IF
C                                       Restart AIPS if requested:
      IF (RQUICK)
     *      CALL RELPOP (0, SCRTCH, IERR)
C                                       Read filenames:
      CALL H2CHR (12, 1, XINNAM, INNAME)
      CALL H2CHR (6, 1, XINCLS, INCLAS)
      INSEQ = NINT (XINSEQ)
      INDISK = NINT (XINDSK)
      CALL H2CHR (12, 1, XOUTNM, OUTNAM)
      CALL H2CHR (6, 1, XOUTCL, OUTCLS)
      OUTSEQ = NINT (XOUTSQ)
      OUTDSK = NINT (XOUTDS)
      XCENT = DOCENT
C                                       Open files and initialize I/O:
      CALL INITIO (IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1001) IERR
         CALL MSGWRT (8)
         IRET = 2
         GO TO 999
         END IF
C                                       Process antennas adverb:
      NANT = 0
      INCLUD = .TRUE.
      DO 20 I = 1, 50
         IF (ABS (NINT (XANT(I))).GT.0) THEN
            IF (NINT (XANT(I)) .LT. 0)
     *         INCLUD = .FALSE.
C                                       Check whether the current
C                                       antenna is already in the list:
            FOUND = .FALSE.
            J = 0
 10         IF ((J.NE.NANT) .AND. (.NOT.FOUND)) THEN
               J = J + 1
               IF (ABS (NINT (XANT(I))).EQ.ANTENS(J))
     *            FOUND = .TRUE.
               GO TO 10
               END IF
            IF (.NOT.FOUND) THEN
               NANT = NANT + 1
               ANTENS(NANT) = ABS (NINT (XANT(I)))
               END IF
            END IF
 20      CONTINUE
C                                       Process SUBARRAY adverb:
      CALL FNDEXT ('AN', CATBLK, NSUBAR)
      SUBARR = MAX (1, MIN (NINT (XSUBAR), NSUBAR))
C                                       Process DOCAL adverb:
      DOCAL(1) = XDOCAL.GE.0.0
      DOCAL(2) = XDOTAB.GE.0.0
C                                       Check axis number of complex
C                                       axis:
      IF (JLOCC.NE.0) THEN
         WRITE (MSGTXT, 1020)
         CALL MSGWRT (8)
         IRET = 3
         GO TO 999
         END IF
C                                       Check number of polarizations:
      IF ((CATBLK(KINAX+JLOCS).NE.2) .AND.
     *   (CATBLK(KINAX+JLOCS).NE.4)) THEN
         WRITE (MSGTXT, 1021)
         CALL MSGWRT (8)
         IRET = 3
         GO TO 999
         END IF
C                                       Check first Stokes parameter
C                                       (must be RR or XX)
      IF ((NINT(CATD(KDCRV+JLOCS)).NE.-1) .AND.
     *   (NINT(CATD(KDCRV+JLOCS)).NE.-5)) THEN
         WRITE (MSGTXT, 1022)
         CALL MSGWRT (8)
         IRET = 3
         GO TO 999
         END IF
C                                       Check Stokes axis increment:
      IF (NINT(CATR(KRCIC+JLOCS)).NE.-1) THEN
         WRITE (MSGTXT, 1022)
         CALL MSGWRT (8)
         IRET = 3
         GO TO 999
         END IF
C
      IRET = 0
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SWINIT: ERROR ', I1, ' READING INPUT PARAMETERS')
 1001 FORMAT ('SWINIT: ERROR ', I1, ' INITIALIZING I/O')
 1020 FORMAT ('COMPLEX AXIS MUST BE AXIS ONE --- ABORTING')
 1021 FORMAT ('MUST BE EITHER 2 OR 4 POLARIZATIONS PRESENT --- ',
     *   'ABORTING')
 1022 FORMAT ('POLARIZATIONS INCOMPLETE OR MIXED --- ABORTING')
      END
      SUBROUTINE INITIO (IRET)
C-----------------------------------------------------------------------
C   Open input file, create output file and initialise I/O. Uses file
C   names from SWPFL.INC and sets up I/O buffers in SWPIO.INC.
C
C   Output:
C     IRET      I         Return status: 0 -> OK
C                                        1 -> error opening input file
C                                        2 -> error creating output file
C                                        3 -> error initializing input
C                                        4 -> error initializing output
C-----------------------------------------------------------------------
      INTEGER   IRET
C
C   Local variables:
C     PTYPE      C*2      Physical type of file
C     STAT       C*4      File status
C     IFILE      C*48     Input file physical name
C     OFILE      C*48     Output file physical name
C     BO         I        Block offset to begin I/O transfer from (1)
C     VO         I        Offset of first vis. rec from BO (0)
C     NPIO       I        Number of visibilities to transfer in one I/O
C                         operation (calculated by first call to UVINIT)
C
      INTEGER   BO, VO, NPIO, IERR, I, SCRTCH(256), INCX
      CHARACTER PTYPE*2, STAT*4, IFILE*48, OFILE*48, CTEMP*8
      PARAMETER (BO = 1, VO = 0)
C
      INCLUDE 'SWPFL.INC'
      INCLUDE 'SWPIO.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
C-----------------------------------------------------------------------
C                                       Find the input file and read its
C                                       CATBLK:
      INCNO = 1
      PTYPE = 'UV'
      CALL CATDIR ('SRCH', INDISK, INCNO, INNAME, INCLAS, INSEQ, PTYPE,
     *   NLUSER, STAT, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1000) IERR, INNAME, INCLAS, INSEQ, INDISK,
     *      NLUSER
         CALL MSGWRT (8)
         IRET = 1
         GO TO 999
         END IF
      CALL CATIO ('READ', INDISK, INCNO, CATBLK, 'REST', SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1001) IERR
         CALL MSGWRT (8)
         IRET = 1
         GO TO 999
         END IF
      CALL COPY (256, CATBLK, CATOLD)
C                                       Define pointers into CATBLK:
      CALL UVPGET (IERR)
      IF (IERR.NE.0) THEN
         IRET = 1
         GO TO 999
         END IF
C                                       center frequencies
      IF (JLOCF.LT.0) XCENT = -1.
      IF (XCENT.LE.0.0) THEN
         UVSCAL = 1.0D0
         DIFPIX = 0.0
      ELSE
         INCX = CATBLK(KINAX+JLOCF) / 2 + 1
         DIFPIX = INCX - CATR(KRCRP+JLOCF)
         CATD(KDCRV+JLOCF) = CATD(KDCRV+JLOCF) + CATR(KRCIC+JLOCF) *
     *      DIFPIX
         CATR(KRCRP+JLOCF) = INCX
         UVSCAL = CATD(KDCRV+JLOCF) / FREQ
         END IF
C                                       Make output name and store it in
C                                       CATBLK for the output file:
      CALL MAKOUT (INNAME, INCLAS, INSEQ, ' ', OUTNAM, OUTCLS, OUTSEQ)
      CALL CHR2H (12, OUTNAM, KHIMNO, CATH(KHIMN))
      CALL CHR2H (6, OUTCLS, KHIMCO, CATH(KHIMC))
      CATBLK(KIIMS) = OUTSEQ
C                                       Create output file and mark it
C                                       in files common:
      OUTCNO = 1
      FRW(NCFILE) = 3
      CALL UVCREA (OUTDSK, OUTCNO, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1002) IERR
         CALL MSGWRT (8)
         IRET = 2
         GO TO 999
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = OUTDSK
      FCNO(NCFILE) = OUTCNO
      FRW(NCFILE) = 2
C                                       copy keywords
      CALL KEYCOP (INDISK, INCNO, OUTDSK, OUTCNO, IERR)
C                                       Mark input file as READ:
      PTYPE = 'UV'
      CALL CATDIR ('CSTA', INDISK, INCNO, INNAME, INCLAS, INSEQ, PTYPE,
     *   NLUSER, 'READ', SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1003) IERR
         CALL MSGWRT (8)
         IRET = 1
         GO TO 999
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = INDISK
      FCNO(NCFILE) = INCNO
      FRW(NCFILE) = 0
C                                       Open and initialize input file
C                                       for reading:
      CALL ZPHFIL ('UV', INDISK, INCNO, 1, IFILE, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1004) IERR
         CALL MSGWRT (8)
         IRET = 1
         GO TO 999
         END IF
      CALL ZOPEN (INLUN, IFIND, INDISK, IFILE, .TRUE., .FALSE., .FALSE.,
     *   IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1005) IERR
         CALL MSGWRT (8)
         IRET = 1
         GO TO 999
         END IF
      NPIO = 0
      CALL UVINIT ('READ', INLUN, IFIND, NVIS, VO, LREC, NPIO,
     *   2*UVBFSS, IBUFF, BO, IBIND, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1006) IERR
         CALL MSGWRT (8)
         IRET = 3
         GO TO 999
         END IF
C                                       Open and initialise output file
C                                       for writing:
      CALL ZPHFIL ('UV', OUTDSK, OUTCNO, 1, OFILE, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1007) IERR
         CALL MSGWRT (8)
         IRET = 2
         GO TO 999
         END IF
      CALL ZOPEN (OUTLUN, OFIND, OUTDSK, OFILE, .TRUE., .FALSE.,
     *   .FALSE., IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1008) IERR
         CALL MSGWRT (8)
         IRET = 2
         GO TO 999
         END IF
      CALL UVINIT ('WRIT', OUTLUN, OFIND, NVIS, VO, LREC, NPIO,
     *   2*UVBFSS, OBUFF, BO, OBIND, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1009) IERR
         CALL MSGWRT (8)
         IRET = 4
         GO TO 999
         END IF
C                                       Establish the definitions of
C                                       NIO, VISNO and ILOCWT in
C                                       SWPIO.INC:
      NIO = 0
      VISNO = 0
      ILOCWT = -1
C                                       If data is compressed find the
C                                       offset of the WEIGHT parameter:
      IF (CATBLK(KINAX).EQ.1) THEN
         I = 0
 10      IF ((I.NE.KIPTPN).AND.(ILOCWT.EQ.-1)) THEN
            CALL H2CHR (8, 1, CATH(KHPTP+2*I), CTEMP)
            IF (CTEMP.EQ.'WEIGHT')
     *         ILOCWT = I
            I = I + 1
            GO TO 10
            END IF
         END IF
C                                       If data is compressed then
C                                       adjust the data increments to
C                                       correspond to the expanded data:
      IF (ILOCWT.GE.0) THEN
         INCS = 3 * INCS
         INCF = 3 * INCF
         INCIF = 3 * INCIF
         END IF
C
      IRET = 0
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('ERROR ', I2, ' FINDING ', A12, '.', A6, '.', I4,
     *   ', DISK=', I2, ', USER=', I4)
 1001 FORMAT ('INITIO: ERROR ', I1, ' READING INPUT CATBLK')
 1002 FORMAT ('INITIO: ERROR ', I1, ' CREATING OUTPUT FILE')
 1003 FORMAT ('INITIO: ERROR ', I2, ' CHANGING STATUS OF INPUT FILE')
 1004 FORMAT ('INITIO: ERROR ', I1, ' OBTAINING PHYSICAL NAME OF ',
     *   'INPUT FILE')
 1005 FORMAT ('INITIO: ERROR ', I1, ' OPENING INPUT FILE')
 1006 FORMAT ('INITIO: ERROR ', I1, ' INITIALIZING INPUT FILE')
 1007 FORMAT ('INITIO: ERROR ', I1, ' OBTAINING PHYSICAL NAME OF ',
     *   'OUTPUT FILE')
 1008 FORMAT ('INITIO: ERROR ', I1, ' OPENING OUTPUT FILE')
 1009 FORMAT ('INITIO: ERROR ', I1, ' INITIALIZING OUTPUT FILE')
      END
      SUBROUTINE SWMAIN (IRET)
C-----------------------------------------------------------------------
C   Copy all visibilities from the input to the output file, swapping
C   polarizations when necessary.  The set of polarizations must be
C   (RR, LL), (RR, LL, RL, LR), (XX, YY) or (XX, YY, XY, YX). The
C   fastest varying axis in the visibility data must be the complex
C   axis.
C
C   Output:
C     IRET      I        Return status: I/O error
C-----------------------------------------------------------------------
      INTEGER IRET
C
C   Local variables:
C     NUMCH      I         Number of channels in data
C     NUMIF      I         Number of IFs in data
C     NUMPOL     I         Number of polarizations in data
C     ANT1       I         Antenna 1 in current baseline
C     ANT2       I         Antenna 2 in current baseline
C     SUBA       I         Current subarray
C     CODE       I         Which antennas are swapped on the current
C                          baseline: 0 -> none; 1 -> ant1; 2 -> ant2;
C                          3 -> both
C     POLORG     I(4,0:3)  Maps polarization streams in output to those
C                          in input for each value of CODE.
C     BASE       I         Pointer to current IF-Channel in data
C     VIS        I         Current visibility number
C     IDATA      R(?)      Input data buffer
C     ODATA      R(?)      Output data buffer
C     RPARM      R(16)     Random parameter array
C
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   NUMCH, NUMIF, NUMPOL, ANT1, ANT2, CODE, POLORG(4, 0:3),
     *   VIS, BASE, IERR, I, ICHAN, IIF, IPOL, SUBA, RNXRET, VISINC,
     *   VISMSG
      REAL      IDATA (3*MAXCIF), ODATA (3*MAXCIF), RPARM(16)
C
      LOGICAL   SWAPAN
      EXTERNAL  SWAPAN
C
      INCLUDE 'SWPAN.INC'
      INCLUDE 'SWPFL.INC'
      INCLUDE 'SWPIO.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
C
      DATA POLORG /1, 2, 3, 4,
     *             4, 3, 2, 1,
     *             3, 4, 1, 2,
     *             2, 1, 4, 3/
C-----------------------------------------------------------------------
      NUMIF = 1
      IF (JLOCIF.GE.0) NUMIF = CATBLK(KINAX+JLOCIF)
      NUMCH = CATBLK(KINAX+JLOCF)
      NUMPOL = CATBLK(KINAX+JLOCS)
      IF (NUMPOL*NUMCH*NUMIF.GT.MAXCIF) THEN
         WRITE (MSGTXT,1000) NUMPOL, NUMCH, NUMIF, MAXCIF
         CALL MSGWRT (8)
         IRET = 1
         GO TO 999
         END IF
C                                       make an index table
      CALL RNXGET (INDISK, INCNO, CATOLD)
      CALL RNXINI (OUTDSK, OUTCNO, CATBLK, RNXRET)
      VISINC = NVIS / 25
      VISINC = MAX (25000, MIN (250000, VISINC))
      VISMSG = 4 * VISINC
C
      DO 50 VIS = 1,NVIS
         IF (MOD(VIS-1,VISMSG).EQ.0) THEN
            WRITE (MSGTXT,1005) VIS
            CALL MSGWRT (2)
         ELSE IF (MOD(VIS-1,VISINC).EQ.0) THEN
            WRITE (MSGTXT,1005) VIS
            CALL MSGWRT (1)
            END IF
         CALL RDVIS (RPARM, IDATA, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT, 1010) VIS, NVIS
            CALL MSGWRT (8)
            IRET = 1
            GO TO 999
            END IF
         IF (ILOCB.GE.0) THEN
            ANT1 = NINT (RPARM(1+ILOCB)) / 256
            ANT2 = MOD (NINT (RPARM(1+ILOCB)), 256)
            SUBA = 1.5 + 100.0 * (RPARM(1+ILOCB) -
     *         (256 * ANT1 + ANT2))
         ELSE
            ANT1 = RPARM(1+ILOCA1) + 0.1
            ANT2 = RPARM(1+ILOCA2) + 0.1
            SUBA = RPARM(1+ILOCSA) + 0.1
            END IF
         CODE = 0
         IF (SWAPAN (ANT1))
     *      CODE = CODE + 1
         IF (SWAPAN (ANT2))
     *      CODE = CODE + 2
C                                       Don't swap if incorrect
C                                       subarray:
         IF (SUBA.NE.SUBARR)
     *      CODE = 0
C                                       Copy each IF, channel and
C                                       polarization:
         DO 40 IIF = 1,NUMIF
            DO 30 ICHAN = 1,NUMCH
               BASE = (IIF-1) * INCIF + (ICHAN-1) * INCF + 1
               DO 20 IPOL = 1, NUMPOL
C                                       Loop over complex axis:
                  DO 10 I = 0, 2
                     ODATA(BASE + (IPOL - 1) * INCS + I) =
     *                  IDATA(BASE + (POLORG(IPOL, CODE) - 1)
     *                  * INCS + I)
 10                  CONTINUE
 20               CONTINUE
 30            CONTINUE
 40         CONTINUE
C                                       update NX table
         CALL RNXUPD (RPARM, RNXRET)
         CALL WRVIS (RPARM, ODATA, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT, 1011) VIS, NVIS
            CALL MSGWRT (8)
            IRET = 1
            GO TO 999
            END IF
 50      CONTINUE
C                                       index table finish
      CALL RNXCLS (RNXRET)
      IF (RNXRET.NE.0) THEN
         MSGTXT = 'OUTPUT NX TABLE, IF ANY, IS INCOMPLETE'
         CALL MSGWRT (7)
         END IF
C
      IRET = 0
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SWMAIN: NUMBER POLS, CHANS, IFS',I2,I6,I4,
     *   ' EXCEEDS BUFFER',I8)
 1005 FORMAT ('At visibility record',I10)
 1010 FORMAT ('SWMAIN: ERROR READING VISIBILITY ', I6, ' OF ', I6)
 1011 FORMAT ('SWMAIN: ERROR WRITING VISIBILITY ', I6, ' OF ', I6)
      END
      SUBROUTINE RDVIS (RPARM, DATA, IRET)
C-----------------------------------------------------------------------
C   Read one visibility from the input file and return it in
C   uncompressed form. Uses variables in COMMON storage declared in
C   SWPIO.INC and DUVH.INC which must have been initialised by INITIO
C   and UVPGET respectively. There must be at least one unread
C   visibility remaining. RPARM and DATA must be large enough to hold
C   the random parameter array and data array, respectively.
C
C   Outputs:
C     RPARM       R(*)     Random parameter array
C     DATA        R(*)     Visibility data
C     IRET        I        Return status: 0 -> OK
C                                         1 -> error on input file
C
C   Uses, and modifies, variables from SWPIO.INC
C-----------------------------------------------------------------------
      REAL      RPARM(*), DATA(*)
      INTEGER   IRET
C
C   Local variables:
C     VISPTR     I        Pointer to first element in current visibility
C
      INTEGER   IERR, VISPTR
C
      INCLUDE 'SWPIO.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
C-----------------------------------------------------------------------
C                                       Read a new block of visibilities
C                                       if the current one is exhausted:
      IF (VISNO.EQ.NIO) THEN
         CALL UVDISK ('READ', INLUN, IFIND, IBUFF, NIO, IBIND, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT, 1000) IERR
            CALL MSGWRT (8)
            IRET = 1
            GO TO 999
            END IF
         VISNO = 0
         END IF
C                                       Establish the definition of
C                                       VISPTR:
      VISPTR = IBIND + VISNO * LREC
C                                       Copy random parameters to
C                                       output:
      CALL RCOPY (NRPARM, IBUFF(VISPTR), RPARM)
      RPARM(1+ILOCU) = RPARM(1+ILOCU) * UVSCAL
      RPARM(1+ILOCV) = RPARM(1+ILOCV) * UVSCAL
      RPARM(1+ILOCW) = RPARM(1+ILOCW) * UVSCAL
C                                       Copy data to output,
C                                       decompressing if necessary:
      IF (ILOCWT.GE.0) THEN
         CALL ZUVXPN (LREC-NRPARM, IBUFF(VISPTR+NRPARM),
     *      IBUFF(VISPTR+ILOCWT), DATA)
      ELSE
         CALL RCOPY (LREC-NRPARM, IBUFF(VISPTR+NRPARM), DATA)
         END IF
C                                       Re-establish the definition of
C                                       VISNO:
      VISNO = VISNO + 1
C
      IRET = 0
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('RDVIS: ERROR ', I1, ' READING INPUT UV DATA')
      END
      SUBROUTINE WRVIS (RPARM, DATA, IRET)
C-----------------------------------------------------------------------
C   Write one visibility to the output file (which must have been read
C   by RDVIS), compressing the data if necessary. The data must not have
C   been modified in any way that changes the length of the random
C   parameter array or the data array. Uses variables from SWPIO.INC and
C   DUVH.INC that must have been initialised with INITIO and UVPGET,
C   respectively.
C
C   Inputs:
C     RPARM      R(*)        Random parameter array
C     DATA       R(*)        Data array
C
C   Output:
C     IRET       I           Return status: 0 -> OK
C                                           1 -> error on output file
C-----------------------------------------------------------------------
      REAL      RPARM(*), DATA(*)
      INTEGER   IRET
C
C   Local variables:
C     VISPTR     I        Pointer to first element of current visibility
C                         in I/O buffer.
C
      INTEGER   IERR, VISPTR
C
      INCLUDE 'SWPIO.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
C-----------------------------------------------------------------------
C                                       Establish the definition of
C                                       VISPTR:
      VISPTR = OBIND + (VISNO - 1) * LREC
C                                       Copy random parameters to I/O
C                                       buffer:
      CALL RCOPY (NRPARM, RPARM, OBUFF(VISPTR))
C                                       Copy data to I/O buffer,
C                                       compressing if necessary:
      IF (ILOCWT.GE.0) THEN
         CALL ZUVPAK (LREC-NRPARM, DATA, OBUFF(VISPTR+ILOCWT),
     *      OBUFF(VISPTR+NRPARM))
      ELSE
         CALL RCOPY (LREC-NRPARM, DATA, OBUFF(VISPTR+NRPARM))
         END IF
C                                       If the current record is the
C                                       last in the buffer, flush the
C                                       contents of the buffer to disk:
      IF (VISNO.EQ.NIO) THEN
         CALL UVDISK ('WRIT', OUTLUN, OFIND, OBUFF, NIO, OBIND, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT, 1000) IERR
            CALL MSGWRT (8)
            IRET = 1
            GO TO 999
            END IF
         END IF
C
      IRET = 0
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('WRVIS: ERROR ', I1, ' WRITING TO OUTPUT FILE')
      END
      LOGICAL FUNCTION SWAPAN (ANT)
C-----------------------------------------------------------------------
C   Determine whether polarizations are to be swapped for antenna ANT.
C
C   Input:
C     ANT     I      Antenna number
C
C   Output:
C     SWAPAN  L      .TRUE. if ANT is to be swapped, otherwise .FALSE.
C
C   Uses variables in local include SWPAN.INC
C-----------------------------------------------------------------------
      INTEGER   ANT
C
      LOGICAL   FOUND, RESULT
      INTEGER   I
C
      INCLUDE 'SWPAN.INC'
C-----------------------------------------------------------------------
C                                       Check whether all antennae
C                                       wanted:
      IF (NANT.EQ.0) THEN
         RESULT = .TRUE.
      ELSE
C                                       Check if ANT is in antenna list:
         I = 0
         FOUND = .FALSE.
 10      IF ((I.NE.NANT) .AND. (.NOT.FOUND)) THEN
            I = I + 1
            IF (ANT.EQ.ANTENS(I))
     *         FOUND = .TRUE.
            GO TO 10
            END IF
C                                       Check whether antennas in list
C                                       are selected or deselected:
         IF (INCLUD) THEN
            RESULT = FOUND
         ELSE
            RESULT = .NOT. FOUND
            END IF
         END IF
      SWAPAN = RESULT
      RETURN
      END
      SUBROUTINE ENDUV (DOCAL, IRET)
C-----------------------------------------------------------------------
C   Flush the output buffer and close both the input and output UV
C   files, copy tables from the input file to the output file and swap
C   calibration information in all CL and SN tables if the user asked
C   for this. Uses variables from SWPIO.INC which must have been
C   initialised with INITIO and from SWPFL.INC which must have been
C   initialised with SWPIN.
C
C   NOTE: does not need to compress output file since number of
C   visibilities is not changed.
C
C   Input:
C     DOCAL      L        .TRUE. if polarization calibration information
C                         in SN and CL tables should be swapped; .FALSE.
C                         otherwise
C
C   Output:
C     IRET       I        Return status: 0 -> OK
C                                        1 -> error on output file
C                                        2 -> error closing file
C                                        3 -> error copying tables
C                                        4 -> error updating cal.
C-----------------------------------------------------------------------
      LOGICAL   DOCAL(2)
      INTEGER   IRET
C
C   Local variables:
C     TILUN       I        Input LUN for tables (constant)
C     TOLUN       I        Output LUN for tables (constant)
C     TIBUF       I(256)   Input buffer for tables I/O
C     TOBUF       I(256)   Output buffer for tables I/O
C
      INTEGER   TILUN, TOLUN
      PARAMETER (TILUN = 27, TOLUN = 28)
      INTEGER   TIBUF(512), TOBUF(512)
      INTEGER   IERR, NONOT
      CHARACTER NOTTYP(12)*2
C
      INCLUDE 'SWPFL.INC'
      INCLUDE 'SWPIO.INC'
      INCLUDE 'SWPAN.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DMSG.INC'
      DATA NOTTYP /'CD','SY','TY','AN','FG','GC','IM','MC','OF',
     *   'PP','BD','BL'/
C-----------------------------------------------------------------------
C                                       Flush output buffer:
      NIO = 0
      CALL UVDISK ('FLSH', OUTLUN, OFIND, OBUFF, NIO, OBIND, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1000) IERR
         CALL MSGWRT (8)
         IRET = 1
         GO TO 999
         END IF
C                                       Close files:
      CALL ZCLOSE (INLUN, IFIND, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1001) IERR
         CALL MSGWRT (8)
         IRET = 2
         GO TO 999
         END IF
      CALL ZCLOSE (OUTLUN, OFIND, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1002) IERR
         CALL MSGWRT (8)
         IRET = 2
         GO TO 999
         END IF
C                                       Copy tables:
      NONOT = 9
      IF (NANT.EQ.0) NONOT = 12
      IF (.NOT.DOCAL(2)) NONOT = 0
      CALL ALLTAB (NONOT, NOTTYP, TILUN, TOLUN, INDISK, OUTDSK, INCNO,
     *   OUTCNO, CATBLK, TIBUF, TOBUF, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1003) IERR
         CALL MSGWRT (8)
         IRET = 3
         GO TO 999
         END IF
C                                       correct for FQCENTER
      CALL CENTFQ (OUTDSK, OUTCNO, DIFPIX, TIBUF, TOBUF, IERR)
      IF (IERR.GT.0) THEN
         MSGTXT = 'ENDUV: ERROR CORRECTING FQ TABLE'
         CALL MSGWRT (6)
         END IF
C                                       Swap polarization calibration,
C                                       if requested:
      CALL SWPCAL (DOCAL(1), IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1004) IERR
         CALL MSGWRT (8)
         IRET = 4
         GO TO 999
         END IF
      IF (DOCAL(2)) THEN
         CALL FIXTAB (TILUN, TOLUN, INDISK, OUTDSK, INCNO, OUTCNO,
     *      CATOLD, CATBLK, TIBUF, TOBUF, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1210) IERR
            CALL MSGWRT (7)
            END IF
         CALL FIXFG (TILUN, TOLUN, INDISK, OUTDSK, INCNO, OUTCNO,
     *      CATOLD, CATBLK, TIBUF, TOBUF, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1211) IERR
            CALL MSGWRT (7)
            END IF
         CALL FIXBLC (TILUN, TOLUN, INDISK, OUTDSK, INCNO, OUTCNO,
     *      CATOLD, CATBLK, TIBUF, TOBUF, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1211) IERR
            CALL MSGWRT (7)
            END IF
         END IF
C
      IRET = 0
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('ENDUV: ERROR ', I1, ' WRITING TO OUTPUT FILE')
 1001 FORMAT ('ENDUV: ERROR ', I1, ' CLOSING INPUT FILE')
 1002 FORMAT ('ENDUV: ERROR ', I1, ' CLOSING OUTPUT FILE')
 1003 FORMAT ('ENDUV: ERROR ', I1, ' COPYING TABLES')
 1004 FORMAT ('ENDUV: ERROR ', I1, ' UPDATING CALIBRATION')
 1210 FORMAT ('ENDUV: ERROR',I3,' FIXING SY, TY, CD, AN TABLES')
 1211 FORMAT ('ENDUV: ERROR',I3,' FIXING FG TABLES')
      END
      SUBROUTINE SWPHIS (DOCAL, IRET)
C-----------------------------------------------------------------------
C   Copy and update history file.
C
C   Input:
C     DOCAL   L(2)   (1) .TRUE. if calibration was swapped.
C                    (2) .TRUE. is FG and other tables swapped
C   Output:
C     IRET    I      Return status: 0 -> OK
C                                   1 -> I/O error
C-----------------------------------------------------------------------
      LOGICAL   DOCAL(2)
      INTEGER   IRET
C
C   Local variables:
C     HILUN      I      LUN for input history file
C     HOLUN      I      LUN for output history file
C     HILINE     C*72   History record buffer
C     BUFER1     I(256) Extension file I/O buffer
C     BUFER2     I(256) Extension file I/O buffer
C
      INTEGER   HILUN, HOLUN, BUFER1(256), BUFER2(256), LIMIT, LIMIT2,
     *   I, IERR, J, I2
      CHARACTER HILINE*72
C
      PARAMETER (HILUN = 27, HOLUN = 28)
C
      INCLUDE 'SWPAN.INC'
      INCLUDE 'SWPFL.INC'
      INCLUDE 'SWPIO.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHIS.INC'
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
      CALL HIINIT (3)
C                                       Copy history file:
      CALL HISCOP (HILUN, HOLUN, INDISK, OUTDSK, INCNO, OUTCNO,
     *   CATBLK, BUFER1, BUFER2, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR
         CALL MSGWRT (6)
         GO TO 100
         END IF
C                                       Add input file description:
      CALL HENCO1 (TSKNAM, INNAME, INCLAS, INSEQ, INDISK, HOLUN,
     *   BUFER2, IERR)
      IF (IERR.NE.0) GO TO 90
C                                       Add output file description:
      CALL HENCOO (TSKNAM, OUTNAM, OUTCLS, OUTSEQ, OUTDSK, HOLUN,
     *   BUFER2, IERR)
      IF (IERR.NE.0) GO TO 90
C                                       Add antennas adverb:
      IF (NANT.EQ.0) THEN
         WRITE (HILINE, 1002)
      ELSE IF (INCLUD) THEN
         WRITE (HILINE, 1003)
         CALL HIADD (HOLUN, HILINE, BUFER2, IERR)
         IF (IERR.NE.0) GO TO 90
      ELSE
         WRITE (HILINE, 1004)
         CALL HIADD (HOLUN, HILINE, BUFER2, IERR)
         IF (IERR.NE.0) GO TO 90
         END IF
      LIMIT2 = MIN (12, NANT)
      WRITE (HILINE, 1005) TSKNAM, (ANTENS(I), I = 1, LIMIT2)
      CALL HIADD (HOLUN, HILINE, BUFER2, IERR)
      IF (IERR.NE.0) GO TO 90
      IF (LIMIT2.LT.NANT) THEN
         DO 10 LIMIT = 13, NANT, 12
            LIMIT2 = MIN (LIMIT+11, NANT)
            WRITE (HILINE, 1006) TSKNAM, (ANTENS(I), I=LIMIT,LIMIT2)
            CALL HIADD (HOLUN, HILINE, BUFER2, IERR)
            IF (IERR.NE.0) GO TO 90
 10         CONTINUE
         END IF
C                                       Subarray:
      WRITE (HILINE, 1007) TSKNAM, SUBARR
      CALL HIADD (HOLUN, HILINE, BUFER2, IERR)
      IF (IERR.NE.0) GO TO 90
C                                       Was calibration swapped:
      IF (DOCAL(1)) THEN
         WRITE (HILINE,1008) TSKNAM
      ELSE
         WRITE (HILINE,1009) TSKNAM
         END IF
      CALL HIADD (HOLUN, HILINE, BUFER2, IERR)
      IF (IERR.NE.0) GO TO 90
      IF (DOCAL(2)) THEN
         WRITE (HILINE,1010) TSKNAM
      ELSE
         WRITE (HILINE,1011) TSKNAM
         END IF
      CALL HIADD (HOLUN, HILINE, BUFER2, IERR)
      IF (IERR.NE.0) GO TO 90
C                                       list swapped tables
      DO 50 I = 1,NSWAPD,13
         I2 = MIN (I+12, NSWAPD)
         WRITE (HILINE,1012) TSKNAM, (TASWAP(J), J = I,I2)
         CALL HIADD (HOLUN, HILINE, BUFER2, IERR)
         IF (IERR.NE.0) GO TO 90
 50      CONTINUE
      GO TO 100
C
 90   WRITE (MSGTXT, 1001) IERR
      CALL MSGWRT (6)
C                                       Close history file:
 100  CALL HICLOS (HOLUN, .TRUE., BUFER2, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1100) IERR
         CALL MSGWRT (6)
         END IF
C                                       Update output file header:
      CALL CATIO ('UPDT', OUTDSK, OUTCNO, CATBLK, 'REST', BUFER1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT, 1101) IERR
         CALL MSGWRT (8)
         IRET = 1
         GO TO 999
         END IF
C
      IRET = 0
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SWPHIS: ERROR ', I1, ' COPYING HISTORY FILE')
 1001 FORMAT ('SWPHIS: ERROR ', I1, ' WRITING TO HISTORY FILE')
 1002 FORMAT (A6,'ANTENNAS = 0 / All antennas swapped')
 1003 FORMAT (A6,' / Polarizations swapped for listed antennas')
 1004 FORMAT (A6,' / Polarizations swapped for all but listed ',
     *   'antennas')
 1005 FORMAT (A6,'ANTENNAS = ', 12(I3, ' '))
 1006 FORMAT (A6,'           ', 12(I3, ' '))
 1007 FORMAT (A6,'SUBARRAY = ', I2)
 1008 FORMAT (A6,'DOCALIB  = TRUE  / CL,SN,BP,PD,PC tables updated')
 1009 FORMAT (A6,'DOCALIB  = FALSE / CL,SN,BP,PD,PC tables left ',
     *   'unchanged')
 1010 FORMAT (A6,'DOTABLE  = TRUE  / other tables updated')
 1011 FORMAT (A6,'DOTABLE  = FALSE / other tables left unchanged')
 1012 FORMAT (A6,' / Tables swapped ',13(A2,1X))
 1100 FORMAT ('SWPHIS: ERROR ', I1, ' CLOSING HISTORY FILE')
 1101 FORMAT ('SWPHIS: ERROR ', I1, ' UPDATING CATBLK')
      END
      SUBROUTINE SWPCAL (DOCAL, IRET)
C-----------------------------------------------------------------------
C   Swap calibration antenna for each polarization for selected
C   antennae.
C   Outputs:
C      IRET   I   Return code: 0 -> OK
C                              1 -> I/O error
C                              2 -> bad table
C-----------------------------------------------------------------------
      LOGICAL   DOCAL
      INTEGER   IRET
C
C   Local variables:
C     TABLUN      I         LUN to use for tables (constant)
C     NUMCL       I         Number of CL tables present
C     NUMSN       I         Number of SN tables present
C     TABUFF      I(512)    Tables I/O buffer
C     NUMANT      I         Number of antennae in current table (unused)
C     NUMPOL      I         Number of polarizations in current table
C                           (should be 2)
C     NUMIF       I         Number of IFs in current table
C     NUMNOD      I         Number of interpolation nodes in SN table
C     RANOD       R(32)     RA offset of each node
C     DECNOD      R(32)     Declination offset of each node
C     GMMOD       R         Mean gain modulus (unused)
C     ROWNUM      I         Current row number in current table
C     LSTROW      I         Last row in current table
C     TAKOLS      I(MAXCLC) Column pointer array
C     TANUMV      I(MAXCLC) Element count for each column
C  Most others hold calibration information from CL or SN table: see
C  headers for TABCAL and TABSN for descriptions.
C
      INTEGER   TABLUN
      PARAMETER (TABLUN = 27)
C
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:PPCV.INC'
      INTEGER   NUMCL, NUMSN, TABUFF(1024), NUMANT, NUMPOL, NUMIF,
     *   NUMNOD, ROWNUM, LSTROW, TAKOLS(MAXCLC), TANUMV(MAXCLC), I, J,
     *   IF, IERR, ITEMP, NUMBP, NUMPD, NUMSHF, K, KK, BCHAN, NUMFRQ,
     *   REFANT(2), NUMPC
      REAL      RANOD(32), DECNOD(32), GMMOD, RTEMP, LOWSHF, DELSHF,
     *   BANDW, WGT(2*MAXIF), BNDPAS(4*MAXCIF), PHDIFF(MAXCIF)
      CHARACTER LBPTYP*8, CTYP*2, POLTYP*8
C
      INTEGER   SOURID, ANTNO, SUBA, FREQID, REFA(2, MAXIF),
     *   NODENO, NTERM, NUMTON
      REAL      DOPOFF(MAXIF), ATMOS, DATMOS, MBDELY(2), CLOCK(2),
     *   DCLOCK(2), DISP(2), DDISP(2), CREAL(2,MAXIF), CIMAG(2,MAXIF),
     *   DELAY(2,MAXIF), RATE(2,MAXIF), WEIGHT(2,MAXIF)
      DOUBLE PRECISION    GEODLY(8), CHSHFT(MAXIF)
      REAL      TIMEI, IFR
      DOUBLE PRECISION TIME
      LOGICAL   ISAPPL
C
      REAL      PCREAL(2,MAXTON,MAXIF), PCIMAG(2,MAXTON,MAXIF),
     *   PCRATE(2,MAXTON,MAXIF), STATE(2,MAXTON,MAXIF)
      DOUBLE PRECISION PCFREQ(2,MAXTON,MAXIF), DTEMP, CABCAL
C
      LOGICAL   SWAPAN
      EXTERNAL  SWAPAN
C
      INCLUDE 'SWPAN.INC'
      INCLUDE 'SWPFL.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
C-----------------------------------------------------------------------
C                                       Set number of polarizations and
C                                       IFs:
      NUMPOL = 2
      NUMIF = CATBLK(KINAX+JLOCIF)
C                                       Establish the definitions of
C                                       NUMCL and NUMSN
      CALL FNDEXT ('CL', CATBLK, NUMCL)
      CALL FNDEXT ('SN', CATBLK, NUMSN)
      CALL FNDEXT ('BP', CATBLK, NUMBP)
      CALL FNDEXT ('PD', CATBLK, NUMPD)
      CALL FNDEXT ('PC', CATBLK, NUMPC)
      IRET = 0
      IF (NUMCL+NUMSN+NUMBP+NUMPD.GT.1) THEN
         IF ((DOCAL) .AND. (NANT.GT.0)) THEN
            MSGTXT = 'SWAPPING CALIBRATION OF ONLY SOME ANTENNAS NOT A'
     *         // ' GOOD IDEA!'
            CALL MSGWRT (7)
            END IF
         IF (.NOT.DOCAL) THEN
            MSGTXT = 'CALIBRATION SHOULD BE REDONE AFTER SWPOL'
            CALL MSGWRT (7)
            END IF
         END IF
      IF (.NOT.DOCAL) GO TO 999
C                                       Process all CL files:
      CTYP = 'CL'
      IF (NUMCL.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         END IF
      DO 120 I = 1, NUMCL
         CALL CLREFM (OUTDSK, OUTCNO, I, CATBLK, TABLUN, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'REFORMATING', CTYP, I
            CALL MSGWRT (7)
            GO TO 120
            END IF
         CALL CALINI ('WRIT', TABUFF, OUTDSK, OUTCNO, I, CATBLK, TABLUN,
     *      J, TAKOLS, TANUMV, NUMANT, NUMPOL, NUMIF, NTERM, GMMOD,
     *      IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'OPENING', CTYP, I
            CALL MSGWRT (7)
            GO TO 120
            END IF
C                                       Process each record:
         LSTROW = J - 1
         DO 110 J = 1, LSTROW
            ROWNUM = J
            CALL TABCAL ('READ', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMPOL,
     *         NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR,
     *         GEODLY, DOPOFF, ATMOS, DATMOS, MBDELY, CLOCK, DCLOCK,
     *         DISP, DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA,
     *         IERR)
C                                       Deselected record.
            IF (IERR.LT.0) GO TO 110
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'READING', CTYP, I
               CALL MSGWRT (8)
               IRET = 1
               GO TO 999
               END IF
            IF (SWAPAN(ANTNO) .AND. (SUBA.EQ.SUBARR)) THEN
               RTEMP = MBDELY(1)
               MBDELY(1) = MBDELY(2)
               MBDELY(2) = RTEMP
               RTEMP = CLOCK(1)
               CLOCK(1) = CLOCK(2)
               CLOCK(2) = RTEMP
               RTEMP = DCLOCK(1)
               DCLOCK(1) = DCLOCK(2)
               DCLOCK(2) = RTEMP
               RTEMP = DISP(1)
               DISP(1) = DISP(2)
               DISP(2) = RTEMP
               RTEMP = DDISP(1)
               DDISP(1) = DDISP(2)
               DDISP(2) = RTEMP
               DO 100 IF = 1, NUMIF
                  RTEMP = CREAL(1, IF)
                  CREAL(1, IF) = CREAL(2, IF)
                  CREAL(2, IF) = RTEMP
                  RTEMP = CIMAG(1, IF)
                  CIMAG(1, IF) = CIMAG(2, IF)
                  CIMAG(2, IF) = RTEMP
                  RTEMP = DELAY(1, IF)
                  DELAY(1, IF) = DELAY(2, IF)
                  DELAY(2, IF) = RTEMP
                  RTEMP = RATE(1, IF)
                  RATE(1, IF) = RATE(2, IF)
                  RATE(2, IF) = RTEMP
                  RTEMP = WEIGHT(1, IF)
                  WEIGHT(1, IF) = WEIGHT(2, IF)
                  WEIGHT(2, IF) = RTEMP
                  ITEMP = REFA(1, IF)
                  REFA(1, IF) = REFA(2, IF)
                  REFA(2, IF) = ITEMP
 100              CONTINUE
               END IF
            ROWNUM = J
            CALL TABCAL ('WRIT', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMPOL,
     *         NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR,
     *         GEODLY, DOPOFF, ATMOS, DATMOS, MBDELY, CLOCK, DCLOCK,
     *         DISP, DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA,
     *         IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'WRITING', CTYP, I
               CALL MSGWRT (8)
               IRET = 1
               GO TO 999
               END IF
 110        CONTINUE
         IERR = 0
         CALL TABCAL ('CLOS', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMPOL,
     *      NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR,
     *      GEODLY, DOPOFF, ATMOS, DATMOS, MBDELY, CLOCK, DCLOCK,
     *      DISP, DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'CLOSING', CTYP, I
            CALL MSGWRT (8)
            IRET = 1
            GO TO 999
            END IF
         WRITE (MSGTXT,1111) CTYP, I
         CALL MSGWRT (3)
 120     CONTINUE
C                                       Process each SN table:
      CTYP = 'SN'
      IF (NUMSN.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         END IF
      DO 220 I = 1, NUMSN
         CALL SNREFM (OUTDSK, OUTCNO, I, CATBLK, TABLUN, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'REFORMATING', CTYP, I
            CALL MSGWRT (7)
            GO TO 220
            END IF
         CALL SNINI ('WRIT', TABUFF, OUTDSK, OUTCNO, I, CATBLK, TABLUN,
     *      J, TAKOLS, TANUMV, NUMANT, NUMPOL, NUMIF, NUMNOD, GMMOD,
     *      RANOD, DECNOD, ISAPPL, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'OPENING', CTYP, I
            CALL MSGWRT (7)
            GO TO 220
            END IF
C                                       Process each row
         LSTROW = J - 1
         DO 210 J = 1, LSTROW
            ROWNUM = J
            CALL TABSN ('READ', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMPOL,
     *         TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR, NODENO,
     *         MBDELY, DISP, DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT,
     *         REFA, IERR)
C                                       Deselected record.
            IF (IERR.LT.0) GO TO 210
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'READING', CTYP, I
               CALL MSGWRT (8)
               IRET = 1
               GO TO 999
               END IF
C                                       Swap info this antenna?
            IF (SWAPAN(ANTNO) .AND. (SUBA.EQ.SUBARR)) THEN
C                                       Multiband delays
               RTEMP = MBDELY(1)
               MBDELY(1) = MBDELY(2)
               MBDELY(2) = RTEMP
               RTEMP = DISP(1)
               DISP(1) = DISP(2)
               DISP(2) = RTEMP
               RTEMP = DDISP(1)
               DDISP(1) = DDISP(2)
               DDISP(2) = RTEMP
C                                       Loop over IFs:
               DO 200 IF = 1, NUMIF
                  RTEMP = CREAL(1, IF)
                  CREAL(1, IF) = CREAL(2, IF)
                  CREAL(2, IF) = RTEMP
                  RTEMP = CIMAG(1, IF)
                  CIMAG(1, IF) = CIMAG(2, IF)
                  CIMAG(2, IF) = RTEMP
                  RTEMP = DELAY(1, IF)
                  DELAY(1, IF) = DELAY(2, IF)
                  DELAY(2, IF) = RTEMP
                  RTEMP = RATE(1, IF)
                  RATE(1, IF) = RATE(2, IF)
                  RATE(2, IF) = RTEMP
                  RTEMP = WEIGHT(1, IF)
                  WEIGHT(1, IF) = WEIGHT(2, IF)
                  WEIGHT(2, IF) = RTEMP
                  ITEMP = REFA(1, IF)
                  REFA(1, IF) = REFA(2, IF)
                  REFA(2, IF) = ITEMP
 200              CONTINUE
               END IF
            ROWNUM = J
            CALL TABSN ('WRIT', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMPOL,
     *         TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR, NODENO,
     *         MBDELY, DISP, DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT,
     *         REFA, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'WRITING', CTYP, I
               CALL MSGWRT (8)
               IRET = 1
               GO TO 999
               END IF
 210        CONTINUE
         IERR = 0
         CALL TABSN ('CLOS', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMPOL,
     *      TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR, NODENO,
     *      MBDELY, DISP, DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT,
     *      REFA, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'CLOSING', CTYP, I
            CALL MSGWRT (8)
            IRET = 1
            GO TO 999
            END IF
         WRITE (MSGTXT,1111) CTYP, I
         CALL MSGWRT (3)
 220     CONTINUE
C                                       BP tables
      CTYP = 'BP'
      IF (NUMBP.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         END IF
      DO 340 I = 1,NUMBP
         CALL BPREFM (OUTDSK, OUTCNO, I, CATBLK, TABLUN, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'REFORMATING', CTYP, I
            CALL MSGWRT (7)
            GO TO 340
            END IF
         CALL BPINI ('WRIT', TABUFF, OUTDSK, OUTCNO, I, CATBLK, TABLUN,
     *      J, TAKOLS, TANUMV, NUMANT, NUMPOL, NUMIF, NUMFRQ, BCHAN,
     *      NUMSHF, LOWSHF, DELSHF, LBPTYP, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'OPENING', CTYP, I
            CALL MSGWRT (7)
            GO TO 340
            END IF
C                                       Process each record:
         LSTROW = J - 1
         DO 330 J = 1,LSTROW
            ROWNUM = J
            CALL TABBP ('READ', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMIF,
     *         NUMFRQ, NUMPOL, TIME, TIMEI, SOURID, SUBA, ANTNO, BANDW,
     *         CHSHFT, FREQID, REFANT, WGT, BNDPAS, IERR)
            IF (IERR.LT.0) GO TO 330
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'READING', CTYP, I
               CALL MSGWRT (8)
               IRET = 1
               GO TO 999
               END IF
            IF (SWAPAN(ANTNO) .AND. (SUBA.EQ.SUBARR)) THEN
               KK = 2 * NUMFRQ * NUMIF
               DO 310 K = 1,KK
                  RTEMP = BNDPAS(K)
                  BNDPAS(K) = BNDPAS(K+KK)
                  BNDPAS(K+KK) = RTEMP
 310              CONTINUE
               ITEMP = REFANT(2)
               REFANT(2) = REFANT(1)
               REFANT(1) = ITEMP
               DO 320 K = 1,NUMIF
                  RTEMP = WGT(K)
                  WGT(K) = WGT(K+NUMIF)
                  WGT(K+NUMIF) = RTEMP
 320              CONTINUE
               END IF
            ROWNUM = J
            CALL TABBP ('WRIT', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMIF,
     *         NUMFRQ, NUMPOL, TIME, TIMEI, SOURID, SUBA, ANTNO, BANDW,
     *         CHSHFT, FREQID, REFANT, WGT, BNDPAS, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'WRITING', CTYP, I
               CALL MSGWRT (8)
               IRET = 1
               GO TO 999
               END IF
 330        CONTINUE
         CALL TABBP ('CLOS', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMIF,
     *      NUMFRQ, NUMPOL, TIME, TIMEI, SOURID, SUBA, ANTNO, BANDW,
     *      CHSHFT, FREQID, REFANT, WEIGHT, BNDPAS, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'CLOSING', CTYP, I
            CALL MSGWRT (8)
            IRET = 1
            GO TO 999
            END IF
         WRITE (MSGTXT,1111) CTYP, I
         CALL MSGWRT (3)
 340     CONTINUE
C                                       PD tables
      CTYP = 'PD'
      IF (NUMPD.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         END IF
      DO 440 I = 1,NUMPD
         CALL PDINI ('WRIT', TABUFF, OUTDSK, OUTCNO, I, CATBLK, TABLUN,
     *      J, TAKOLS, TANUMV, NUMANT, NUMPOL, NUMIF, NUMFRQ, POLTYP,
     *      IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'OPENING', CTYP, I
            CALL MSGWRT (7)
            GO TO 440
            END IF
C                                       Process each record:
         LSTROW = J - 1
         DO 430 J = 1,LSTROW
            ROWNUM = J
            CALL TABPD ('READ', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMIF,
     *         NUMFRQ, NUMPOL, ANTNO, SUBA, FREQID, REFANT, PHDIFF,
     *         BNDPAS, IERR)
            IF (IERR.LT.0) GO TO 430
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'READING', CTYP, I
               CALL MSGWRT (8)
               IRET = 1
               GO TO 999
               END IF
            IF (SWAPAN(ANTNO) .AND. (SUBA.EQ.SUBARR)) THEN
               KK = 2 * NUMFRQ * NUMIF
               DO 410 K = 1,KK
                  RTEMP = BNDPAS(K)
                  BNDPAS(K) = BNDPAS(K+KK)
                  BNDPAS(K+KK) = RTEMP
 410              CONTINUE
               ITEMP = REFANT(2)
               REFANT(2) = REFANT(1)
               REFANT(1) = ITEMP
               KK = NUMFRQ * NUMIF
               DO 420 K = 1,KK
                  PHDIFF(K) = -PHDIFF(K)
 420              CONTINUE
              END IF
            ROWNUM = J
            CALL TABPD ('WRIT', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMIF,
     *         NUMFRQ, NUMPOL, ANTNO, SUBA, FREQID, REFANT, PHDIFF,
     *         BNDPAS, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'WRITING', CTYP, I
               CALL MSGWRT (8)
               IRET = 1
               GO TO 999
               END IF
 430        CONTINUE
         CALL TABPD ('CLOS', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMIF,
     *      NUMFRQ, NUMPOL, ANTNO, SUBA, FREQID, REFANT, PHDIFF,
     *      BNDPAS, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'CLOSING', CTYP, I
            CALL MSGWRT (8)
            IRET = 1
            GO TO 999
            END IF
         WRITE (MSGTXT,1111) CTYP, I
         CALL MSGWRT (3)
 440     CONTINUE
C                                       PC tables
      CTYP = 'PC'
      IF (NUMPC.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         END IF
      DO 540 I = 1,NUMPC
         CALL PCINI ('WRIT', TABUFF, OUTDSK, OUTCNO, I, CATBLK, TABLUN,
     *      J, TAKOLS, TANUMV, NUMPOL, NUMIF, NUMTON, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'OPENING', CTYP, I
            CALL MSGWRT (7)
            GO TO 540
            END IF
C                                       Process each record:
         LSTROW = J - 1
         DO 530 J = 1,LSTROW
            ROWNUM = J
            CALL TABPC ('READ', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMPOL,
     *         TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, CABCAL,
     *         STATE, PCFREQ, PCREAL, PCIMAG, PCRATE, IERR)
            IF (IERR.LT.0) GO TO 530
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'READING', CTYP, I
               CALL MSGWRT (8)
               IRET = 1
               GO TO 999
               END IF
            IF (SWAPAN(ANTNO) .AND. (SUBA.EQ.SUBARR)) THEN
               DO 520 K = 1,NUMIF
                  DO 510 KK = 1,NUMTON
                     RTEMP = PCREAL(1,K,KK)
                     PCREAL(1,K,KK) = PCREAL(2,K,KK)
                     PCREAL(2,K,KK)= RTEMP
                     RTEMP = PCIMAG(1,K,KK)
                     PCIMAG(1,K,KK) = PCIMAG(2,K,KK)
                     PCIMAG(2,K,KK)= RTEMP
                     RTEMP = PCRATE(1,K,KK)
                     PCRATE(1,K,KK) = PCRATE(2,K,KK)
                     PCRATE(2,K,KK)= RTEMP
                     RTEMP = STATE(1,K,KK)
                     STATE(1,K,KK) = STATE(2,K,KK)
                     STATE(2,K,KK)= RTEMP
                     DTEMP = PCFREQ(1,K,KK)
                     PCFREQ(1,K,KK) = PCFREQ(2,K,KK)
                     PCFREQ(2,K,KK)= DTEMP
 510                 CONTINUE
 520              CONTINUE
               END IF
            ROWNUM = J
            CALL TABPC ('WRIT', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMPOL,
     *         TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, CABCAL,
     *         STATE, PCFREQ, PCREAL, PCIMAG, PCRATE, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'WRITING', CTYP, I
               CALL MSGWRT (8)
               IRET = 1
               GO TO 999
               END IF
 530        CONTINUE
         CALL TABPC ('CLOS', TABUFF, ROWNUM, TAKOLS, TANUMV, NUMPOL,
     *      TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, CABCAL,
     *      STATE, PCFREQ, PCREAL, PCIMAG, PCRATE, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'CLOSING', CTYP, I
            CALL MSGWRT (8)
            IRET = 1
            GO TO 999
            END IF
         WRITE (MSGTXT,1111) CTYP, I
         CALL MSGWRT (3)
 540     CONTINUE
C
      IRET = 0
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SWPCAL: ERROR',I3,' ON ',A,1X,A2,' VERSION',I3)
 1111 FORMAT ('Corrected ',A2,' table version ', I2)
      END
      SUBROUTINE FIXTAB (LUNI, LUNO, DISKI, DISKO, CNOI, CNOO, CATOLD,
     *   CATBLK, BUFF1, BUFF2, IERR)
C-----------------------------------------------------------------------
C   swap SY, TY, CD, AN, GC, IM, MC, OF tables, copying to output
C   Inputs:
C      NUMANT   I      Number in ANTS
C      ANTS     I(*)   Antennas to swap
C      LUNI     I      Input LUN
C      LUNO     I      Output LUN
C      DISKI    I      Input disk
C      DISKO    I      Output disk
C      CNOI     I      Input catalog number
C      CNOO     I      Input catalog number
C      CATOLD   I(*)   Input header
C   In/Out
C      CATBLK   I(*)   Output header
C      BUFF1    I(*)   buffer 1
C      BUFF2    I(*)   buffer 2
C   Output:
C      IERR     I      error code
C-----------------------------------------------------------------------
      INTEGER   LUNI, LUNO, DISKI, DISKO, CNOI, CNOO, CATOLD(256),
     *   CATBLK(256), BUFF1(*), BUFF2(*), IERR
C
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:PGCV.INC'
      INTEGER   MAXPLY
      PARAMETER (MAXPLY=20)
C
      INTEGER   NVER, NREC, IVER, RNO, KOLS(30), NUMV(30), NUMA, I, J,
     *   NUMPOL, NUMIF, IREC, ANTNO, SUBA, FREQID, SOURID, CALTYP,
     *   ITPGC(2,MAXIF), NTGC(2,MAXIF), IXTGC(2,MAXIF), IYTGC(2,MAXIF),
     *   ITEMP, NTABGC, NUMSTK, STK1, NUMCHN, NUMPLY, FFTSIZ, OVRSMP,
     *   ZEROPD, ANFLAG, TABVER, KOLO(30), NUMO(30)
      CHARACTER CTEMP*2, OBSCOD*8, TAPER*8, OBSDAT*8, CTYP*2
      REAL      TIMEI, TCAL(4,MAXIF), PDIFF(2,MAXIF), PSUM(2,MAXIF),
     *   PGAIN(2,MAXIF), TSYS(2,MAXIF), TANT(2,MAXIF), TEMP, IFR,
     *   XVALGC(2,MAXIF), YVALGC(2,MAXIF,MXTBGC), DISP(2), DDISP(2),
     *   GAINGC(2,MAXIF,MXTBGC), SENSGC(2,MAXIF), FREQVR(MAXIF),
     *   CHNBW, RFPIX, DELTAT, LOOFF(2,MAXIF), DLOOFF(2,MAXIF), RTIME
      DOUBLE PRECISION TIME, REFFRQ, CHANBW, REFPIX, CORREV, DTEMP,
     *   PDELAY(2,MAXIF,MAXPLY), GDELAY(2,MAXPLY), RFREQ, ATMOS, DATMOS,
     *   PRATE(2,MAXIF,MAXPLY), GRATE(2,MAXPLY), CLOCK(2), DCLOCK(2)
      LOGICAL   SWAP, SWAPAN
      INCLUDE 'SWPFL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:IANT.INC'
C-----------------------------------------------------------------------
C                                       CD tables
      CTYP = 'CD'
      CALL FNDEXT (CTYP, CATOLD, NVER)
      IF (NVER.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         DO 100 IVER = 1,NVER
            CALL CDINI ('READ', BUFF1, DISKI, CNOI, IVER, CATOLD, LUNI,
     *         RNO, KOLS, NUMV, NUMA, NUMPOL, NUMIF, RDATE, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 100
               END IF
            NREC = BUFF1(5)
            CALL CDINI ('WRIT', BUFF2, DISKO, CNOO, IVER, CATBLK, LUNO,
     *         RNO, KOLO, NUMO, NUMA, NUMPOL, NUMIF, RDATE, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 90
               END IF
            DO 50 IREC = 1,NREC
               RNO = IREC
               CALL TABCD ('READ', BUFF1, RNO, KOLS, NUMV, NUMPOL,
     *            NUMIF, ANTNO, SUBA, FREQID, TCAL, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'READ INPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 90
                  END IF
               SWAP = SWAPAN (ANTNO)
               IF (SWAP) THEN
                  DO 30 I = 1,NUMIF
                     TEMP = TCAL(1,I)
                     TCAL(1,I) = TCAL(2,I)
                     TCAL(2,I) = TEMP
                     TEMP = TCAL(3,I)
                     TCAL(3,I) = TCAL(4,I)
                     TCAL(4,I) = TEMP
 30                  CONTINUE
                  END IF
               RNO = IREC
               CALL TABCD ('WRIT', BUFF2, RNO, KOLO, NUMO, NUMPOL,
     *            NUMIF, ANTNO, SUBA, FREQID, TCAL, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITE OUTPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 90
                  END IF
 50            CONTINUE
            WRITE (MSGTXT,1050) 'CD', DISKI, CNOI, IVER, DISKO, CNOO,
     *         IVER
            CALL MSGWRT (3)
C                                       close
 90         RNO = NREC
            CALL TABCD ('CLOS', BUFF2, RNO, KOLO, NUMO, NUMPOL,
     *         NUMIF, ANTNO, SUBA, FREQID, TCAL, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
            RNO = NREC
            CALL TABCD ('CLOS', BUFF1, RNO, KOLS, NUMV, NUMPOL,
     *         NUMIF, ANTNO, SUBA, FREQID, TCAL, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE INPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
 100        CONTINUE
         END IF
C                                       SY tables
      CTYP = 'SY'
      CALL FNDEXT (CTYP, CATOLD, NVER)
      IF (NVER.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         DO 200 IVER = 1,NVER
            CALL SYINI ('READ', BUFF1, DISKI, CNOI, IVER, CATOLD, LUNI,
     *         RNO, KOLS, NUMV, NUMA, NUMPOL, NUMIF, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 200
               END IF
            NREC = BUFF1(5)
            CALL SYINI ('WRIT', BUFF2, DISKO, CNOO, IVER, CATBLK, LUNO,
     *         RNO, KOLO, NUMO, NUMA, NUMPOL, NUMIF, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 190
               END IF
            DO 150 IREC = 1,NREC
               RNO = IREC
               CALL TABSY ('READ', BUFF1, RNO, KOLS, NUMV, NUMPOL,
     *            NUMIF, TIME, TIMEI, CALTYP, SOURID, ANTNO, SUBA,
     *            FREQID, PDIFF, PSUM, PGAIN, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'READ INPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 190
                  END IF
               SWAP = SWAPAN (ANTNO)
               IF (SWAP) THEN
                  DO 130 I = 1,NUMIF
                     TEMP = PDIFF(1,I)
                     PDIFF(1,I) = PDIFF(2,I)
                     PDIFF(2,I) = TEMP
                     TEMP = PSUM(1,I)
                     PSUM(1,I) = PSUM(2,I)
                     PSUM(2,I) = TEMP
                     TEMP = PGAIN(1,I)
                     PGAIN(1,I) = PGAIN(2,I)
                     PGAIN(2,I) = TEMP
 130                 CONTINUE
                  END IF
               RNO = IREC
               CALL TABSY ('WRIT', BUFF2, RNO, KOLO, NUMO, NUMPOL,
     *            NUMIF, TIME, TIMEI, CALTYP, SOURID, ANTNO, SUBA,
     *            FREQID, PDIFF, PSUM, PGAIN, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITE OUTPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 190
                  END IF
 150           CONTINUE
            WRITE (MSGTXT,1050) 'SY', DISKI, CNOI, IVER, DISKO, CNOO,
     *         IVER
            CALL MSGWRT (3)
C                                       close
 190        RNO = NREC
            CALL TABSY ('CLOS', BUFF2, RNO, KOLO, NUMO, NUMPOL,
     *         NUMIF, TIME, TIMEI, CALTYP, SOURID, ANTNO, SUBA, FREQID,
     *         PDIFF, PSUM, PGAIN, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
            RNO = NREC
            CALL TABSY ('CLOS', BUFF1, RNO, KOLS, NUMV, NUMPOL,
     *         NUMIF, TIME, TIMEI, CALTYP, SOURID, ANTNO, SUBA, FREQID,
     *         PDIFF, PSUM, PGAIN, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE INPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
 200        CONTINUE
         END IF
C                                       TY tables
      CTYP = 'TY'
      CALL FNDEXT (CTYP, CATOLD, NVER)
      IF (NVER.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         DO 300 IVER = 1,NVER
            CALL TYINI ('READ', BUFF1, DISKI, CNOI, IVER, CATOLD, LUNI,
     *         RNO, KOLS, NUMV, NUMPOL, NUMIF, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 300
               END IF
            NREC = BUFF1(5)
            CALL TYINI ('WRIT', BUFF2, DISKO, CNOO, IVER, CATBLK, LUNO,
     *         RNO, KOLO, NUMO, NUMPOL, NUMIF, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 290
               END IF
            DO 250 IREC = 1,NREC
               RNO = IREC
               CALL TABTY ('READ', BUFF1, RNO, KOLS, NUMV, NUMPOL,
     *            NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID,
     *            TSYS, TANT, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'READ INPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 290
                  END IF
               SWAP = SWAPAN (ANTNO)
               IF (SWAP) THEN
                  DO 230 I = 1,NUMIF
                     TEMP = TSYS(1,I)
                     TSYS(1,I) = TSYS(2,I)
                     TSYS(2,I) = TEMP
                     TEMP = TANT(1,I)
                     TANT(1,I) = TANT(2,I)
                     TANT(2,I) = TEMP
 230                 CONTINUE
                  END IF
               RNO = IREC
               CALL TABTY ('WRIT', BUFF2, RNO, KOLO, NUMO, NUMPOL,
     *            NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID,
     *            TSYS, TANT, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITE OUTPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 290
                  END IF
 250           CONTINUE
            WRITE (MSGTXT,1050) 'TY', DISKI, CNOI, IVER, DISKO, CNOO,
     *         IVER
            CALL MSGWRT (3)
C                                       close
 290        RNO = NREC
            CALL TABTY ('CLOS', BUFF2, RNO, KOLO, NUMO, NUMPOL,
     *         NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID,
     *         TSYS, TANT, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
            RNO = NREC
            CALL TABTY ('CLOS', BUFF1, RNO, KOLS, NUMV, NUMPOL,
     *         NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID,
     *         TSYS, TANT, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE INPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
 300        CONTINUE
         END IF
C                                       AN tables
      CTYP = 'AN'
      CALL FNDEXT (CTYP, CATOLD, NVER)
      IF (NVER.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         DO 400 IVER = 1,NVER
C                                       allow reformat
            CALL ANTINI ('READ', BUFF1, DISKI, CNOI, IVER, CATOLD, LUNI,
     *         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, 'OPEN INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 400
               END IF
            NREC = BUFF1(5)
            CALL ANINI ('WRIT', BUFF2, DISKO, CNOO, IVER, CATBLK, LUNO,
     *         IANRNO, KOLO, NUMO, 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, 'OPEN INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 400
               END IF
            DO 350 IREC = 1,NREC
               IANRNO = IREC
               CALL TABAN ('READ', BUFF1, 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,1000) IERR, 'READ INPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 390
                  END IF
               SWAP = SWAPAN (NOSTA)
               IF (SWAP) THEN
                  CTEMP = POLTYA
                  POLTYA = POLTYB
                  POLTYB = CTEMP
                  TEMP = POLAA
                  POLAA = POLAB
                  POLAB = TEMP
                  DO 330 I = 1,2*NUMIF
                     TEMP = POLCA(I)
                     POLCA(I) = POLCB(I)
                     POLCB(I) = TEMP
 330                 CONTINUE
                  END IF
               IANRNO = IREC
               CALL TABAN ('WRIT', BUFF2, IANRNO, KOLO, NUMO, ANNAME,
     *            STAXYZ, ORBPRM, NOSTA, MNTSTA, STAXOF, DIAMAN, FWHMAN,
     *            POLTYA, POLAA, POLCA, POLTYB, POLAB, POLCB, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITE OUTPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 390
                  END IF
 350           CONTINUE
            WRITE (MSGTXT,1050) 'AN', DISKI, CNOI, IVER, DISKO, CNOO,
     *         IVER
            CALL MSGWRT (3)
 390        IANRNO = IREC
            CALL TABAN ('CLOS', BUFF2, IANRNO, KOLO, NUMO, ANNAME,
     *         STAXYZ, ORBPRM, NOSTA, MNTSTA, STAXOF, DIAMAN, FWHMAN,
     *         POLTYA, POLAA, POLCA, POLTYB, POLAB, POLCB, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
            IANRNO = IREC
            CALL TABAN ('CLOS', BUFF1, 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,1000) IERR, 'CLOSE INPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
 400        CONTINUE
         END IF
C                                       GC tables
      CTYP = 'GC'
      CALL FNDEXT (CTYP, CATOLD, NVER)
      IF (NVER.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         DO 500 IVER = 1,NVER
            CALL GCINI ('READ', BUFF1, DISKI, CNOI, IVER, CATOLD, LUNI,
     *         RNO, KOLS, NUMV, NUMPOL, NUMIF, NTABGC, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 500
               END IF
            NREC = BUFF1(5)
            CALL GCINI ('WRIT', BUFF2, DISKO, CNOO, IVER, CATBLK, LUNO,
     *         RNO, KOLO, NUMO, NUMPOL, NUMIF, NTABGC, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 490
               END IF
            DO 450 IREC = 1,NREC
               RNO = IREC
               CALL TABGC ('READ', BUFF1, RNO, KOLS, NUMV, NUMPOL,
     *            NTABGC, ANTNO, SUBA, FREQID, ITPGC, NTGC, IXTGC,
     *            IYTGC, XVALGC, YVALGC, GAINGC, SENSGC, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'READ INPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 490
                  END IF
               SWAP = SWAPAN (ANTNO)
               IF (SWAP) THEN
                  DO 430 I = 1,NUMIF
                     ITEMP = ITPGC(1,I)
                     ITPGC(1,I) = ITPGC(2,I)
                     ITPGC(2,I) = ITEMP
                     ITEMP = NTGC(1,I)
                     NTGC(1,I) = NTGC(2,I)
                     NTGC(2,I) = ITEMP
                     ITEMP = IXTGC(1,I)
                     IXTGC(1,I) = IXTGC(2,I)
                     IXTGC(2,I) = ITEMP
                     ITEMP = IYTGC(1,I)
                     IYTGC(1,I) = IYTGC(2,I)
                     IYTGC(2,I) = ITEMP
                     TEMP = XVALGC(1,I)
                     XVALGC(1,I) = XVALGC(2,I)
                     XVALGC(2,I) = TEMP
                     TEMP = SENSGC(1,I)
                     SENSGC(1,I) = SENSGC(2,I)
                     SENSGC(2,I) = TEMP
                     DO 420 J = 1,NTABGC
                        TEMP = YVALGC(1,I,J)
                        YVALGC(1,I,J) = YVALGC(2,I,J)
                        YVALGC(2,I,J) = TEMP
                        TEMP = GAINGC(1,I,J)
                        GAINGC(1,I,J) = GAINGC(2,I,J)
                        GAINGC(2,I,J) = TEMP
 420                    CONTINUE
 430                 CONTINUE
                  END IF
               RNO = IREC
               CALL TABGC ('WRIT', BUFF2, RNO, KOLO, NUMO, NUMPOL,
     *            NTABGC, ANTNO, SUBA, FREQID, ITPGC, NTGC, IXTGC,
     *            IYTGC, XVALGC, YVALGC, GAINGC, SENSGC, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITE OUTPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 490
                  END IF
 450           CONTINUE
            WRITE (MSGTXT,1050) 'GC', DISKI, CNOI, IVER, DISKO, CNOO,
     *         IVER
            CALL MSGWRT (3)
C                                       close
 490        RNO = NREC
            CALL TABGC ('CLOS', BUFF2, RNO, KOLO, NUMO, NUMPOL,
     *         NTABGC, ANTNO, SUBA, FREQID, ITPGC, NTGC, IXTGC,
     *         IYTGC, XVALGC, YVALGC, GAINGC, SENSGC, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
            RNO = NREC
            CALL TABGC ('CLOS', BUFF1, RNO, KOLS, NUMV, NUMPOL,
     *         NTABGC, ANTNO, SUBA, FREQID, ITPGC, NTGC, IXTGC,
     *         IYTGC, XVALGC, YVALGC, GAINGC, SENSGC, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE INPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
 500        CONTINUE
         END IF
C                                       IM tables
      CTYP = 'IM'
      CALL FNDEXT (CTYP, CATOLD, NVER)
      IF (NVER.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         DO 600 IVER = 1,NVER
            CALL IMINIT ('READ', BUFF1, DISKI, CNOI, IVER, CATOLD, LUNI,
     *         RNO, KOLS, NUMV, OBSCOD, RDATE, NUMSTK, STK1, NUMIF,
     *         NUMCHN, REFFRQ, CHANBW, REFPIX, NUMPOL, NUMPLY, CORREV,
     *         IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 600
               END IF
            NREC = BUFF1(5)
            CALL IMINIT ('WRIT', BUFF2, DISKO, CNOO, IVER, CATBLK, LUNO,
     *         RNO, KOLO, NUMO, OBSCOD, RDATE, NUMSTK, STK1, NUMIF,
     *         NUMCHN, REFFRQ, CHANBW, REFPIX, NUMPOL, NUMPLY, CORREV,
     *         IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 590
               END IF
            DO 550 IREC = 1,NREC
               RNO = IREC
               CALL TABIM ('READ', BUFF1, RNO, KOLS, NUMV, NUMPOL, TIME,
     *            TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR, FREQVR,
     *            PDELAY, GDELAY, PRATE, GRATE, DISP, DDISP, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'READ INPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 590
                  END IF
               SWAP = SWAPAN (ANTNO)
               IF (SWAP) THEN
                  DO 530 I = 1,NUMIF
                     DTEMP = GDELAY(1,I)
                     GDELAY(1,I) = GDELAY(2,I)
                     GDELAY(2,I) = DTEMP
                     DTEMP = GRATE(1,I)
                     GRATE(1,I) = GRATE(2,I)
                     GRATE(2,I) = DTEMP
                     DO 520 J =1,NUMPLY
                        DTEMP = PDELAY(1,I,J)
                        PDELAY(1,I,J) = PDELAY(2,I,J)
                        PDELAY(2,I,J) = DTEMP
                        DTEMP = PRATE(1,I,J)
                        PRATE(1,I,J) = PRATE(2,I,J)
                        PRATE(2,I,J) = DTEMP
 520                    CONTINUE
 530                 CONTINUE
                  END IF
               RNO = IREC
               CALL TABIM ('WRIT', BUFF2, RNO, KOLO, NUMO, NUMPOL, TIME,
     *            TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR, FREQVR,
     *            PDELAY, GDELAY, PRATE, GRATE, DISP, DDISP, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITE OUTPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 590
                  END IF
 550           CONTINUE
            WRITE (MSGTXT,1050) 'IM', DISKI, CNOI, IVER, DISKO, CNOO,
     *         IVER
            CALL MSGWRT (3)
C                                       close
 590        RNO = NREC
            CALL TABIM ('CLOS', BUFF2, RNO, KOLO, NUMO, NUMPOL, TIME,
     *         TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR, FREQVR,
     *         PDELAY, GDELAY, PRATE, GRATE, DISP, DDISP, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
            RNO = NREC
            CALL TABIM ('CLOS', BUFF1, RNO, KOLS, NUMV, NUMPOL, TIME,
     *         TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR, FREQVR,
     *         PDELAY, GDELAY, PRATE, GRATE, DISP, DDISP, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE INPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
 600        CONTINUE
         END IF
C                                       MC tables
      CTYP = 'MC'
      CALL FNDEXT (CTYP, CATOLD, NVER)
      IF (NVER.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         DO 700 IVER = 1,NVER
            CALL MCINI ('READ', BUFF1, DISKI, CNOI, IVER, CATOLD, LUNI,
     *         RNO, KOLS, NUMV, OBSCOD, RDATE, NUMSTK, STK1, NUMIF,
     *         NUMCHN, RFREQ, CHNBW, R FPIX, NUMPOL, FFTSIZ, OVRSMP,
     *         ZEROPD, TAPER, DELTAT, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 700
               END IF
            NREC = BUFF1(5)
            CALL MCINI ('WRIT', BUFF2, DISKO, CNOO, IVER, CATBLK, LUNO,
     *         RNO, KOLO, NUMO, OBSCOD, RDATE, NUMSTK, STK1, NUMIF,
     *         NUMCHN, RFREQ, CHNBW, RFPIX, NUMPOL, FFTSIZ, OVRSMP,
     *         ZEROPD, TAPER, DELTAT, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 690
               END IF
            DO 650 IREC = 1,NREC
               RNO = IREC
               CALL MCTAB ('READ', BUFF1, RNO, KOLS, NUMV, NUMPOL,
     *            NUMIF, TIME, SOURID, ANTNO, SUBA, FREQID, ATMOS,
     *            DATMOS,GDELAY, GRATE, CLOCK, DCLOCK, LOOFF, DLOOFF,
     *            DISP, DDISP, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'READ INPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 690
                  END IF
               SWAP = SWAPAN (ANTNO)
               IF (SWAP) THEN
                  DTEMP = CLOCK(1)
                  CLOCK(1) = CLOCK(2)
                  CLOCK(2) = DTEMP
                  DTEMP = DCLOCK(1)
                  DCLOCK(1) = DCLOCK(2)
                  DCLOCK(2) = DTEMP
                  TEMP = DISP(1)
                  DISP(1) = DISP(2)
                  DISP(2) = TEMP
                  TEMP = DDISP(1)
                  DDISP(1) = DDISP(2)
                  DDISP(2) = TEMP
                  DO 630 I = 1,NUMIF
                     TEMP = LOOFF(1,I)
                     LOOFF(1,I) = LOOFF(2,I)
                     LOOFF(2,I) = TEMP
                     TEMP = DLOOFF(1,I)
                     DLOOFF(1,I) = DLOOFF(2,I)
                     DLOOFF(2,I) = TEMP
 630                 CONTINUE
                  END IF
               RNO = IREC
               CALL MCTAB ('WRIT', BUFF2, RNO, KOLO, NUMO, NUMPOL,
     *            NUMIF, TIME, SOURID, ANTNO, SUBA, FREQID, ATMOS,
     *            DATMOS,GDELAY, GRATE, CLOCK, DCLOCK, LOOFF, DLOOFF,
     *            DISP, DDISP, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITE OUTPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 690
                  END IF
 650           CONTINUE
            WRITE (MSGTXT,1050) 'MC', DISKI, CNOI, IVER, DISKO, CNOO,
     *         IVER
            CALL MSGWRT (3)
C                                       close
 690        RNO = NREC
            CALL MCTAB ('CLOS', BUFF2, RNO, KOLO, NUMV, NUMPOL,
     *         NUMIF, TIME, SOURID, ANTNO, SUBA, FREQID, ATMOS,
     *         DATMOS,GDELAY, GRATE, CLOCK, DCLOCK, LOOFF, DLOOFF,
     *         DISP, DDISP, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
            RNO = NREC
            CALL MCTAB ('CLOS', BUFF1, RNO, KOLS, NUMV, NUMPOL,
     *         NUMIF, TIME, SOURID, ANTNO, SUBA, FREQID, ATMOS,
     *         DATMOS,GDELAY, GRATE, CLOCK, DCLOCK, LOOFF, DLOOFF,
     *         DISP, DDISP, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE INPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
 700        CONTINUE
         END IF
C                                       OF tables
      CTYP = 'OF'
      CALL FNDEXT (CTYP, CATOLD, NVER)
      IF (NVER.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         DO 800 IVER = 1,NVER
            CALL OFINI ('READ', BUFF1, DISKI, CNOI, IVER, CATOLD, LUNI,
     *         RNO, KOLS, NUMV, NUMIF, NUMPOL, ANNAME, OBSCOD, OBSDAT,
     *         TABVER, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 800
               END IF
            NREC = BUFF1(5)
            CALL OFINI ('WRIT', BUFF2, DISKO, CNOO, IVER, CATBLK, LUNO,
     *         RNO, KOLO, NUMO, NUMIF, NUMPOL, ANNAME, OBSCOD, OBSDAT,
     *         TABVER, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 790
               END IF
            DO 750 IREC = 1,NREC
               RNO = IREC
               CALL TABOF ('READ', BUFF1, RNO, KOLS, NUMV, RTIME,
     *            SOURID, ANTNO, SUBA, FREQID, ANFLAG, ITPGC, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'READ INPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 790
                  END IF
               SWAP = SWAPAN (ANTNO)
               IF (SWAP) THEN
                  DO 730 I = 1,NUMIF
                     ITEMP = ITPGC(1,I)
                     ITPGC(1,I) = ITPGC(2,I)
                     ITPGC(2,I) = ITEMP
 730                 CONTINUE
                  END IF
               RNO = IREC
               CALL TABOF ('WRIT', BUFF2, RNO, KOLO, NUMO, RTIME,
     *            SOURID, ANTNO, SUBA, FREQID, ANFLAG, ITPGC, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITE OUTPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 790
                  END IF
 750           CONTINUE
            WRITE (MSGTXT,1050) 'OF', DISKI, CNOI, IVER, DISKO, CNOO,
     *         IVER
            CALL MSGWRT (3)
C                                       close
 790        RNO = NREC
            CALL TABOF ('CLOS', BUFF2, RNO, KOLO, NUMO, RTIME,
     *         SOURID, ANTNO, SUBA, FREQID, ANFLAG, ITPGC, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
            RNO = NREC
            CALL TABOF ('READ', BUFF1, RNO, KOLS, NUMV, RTIME,
     *         SOURID, ANTNO, SUBA, FREQID, ANFLAG, ITPGC, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE INPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
 800        CONTINUE
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('FIXTAB ERROR:',I4,' ON ',A,1X,A,' TABLE VERSION',I4)
 1050 FORMAT ('Swapped ',A2,' file from vol/cno/vers',I3,I5,I4,' to',
     *   I3,I5,I4)
      END
      SUBROUTINE FIXFG (LUNI, LUNO, DISKI, DISKO, CNOI, CNOO, CATOLD,
     *   CATBLK, BUFF1, BUFF2, IERR)
C-----------------------------------------------------------------------
C   swap SY, TY, CD, AN tables, copying to output
C   Inputs:
C      NUMANT   I      Number in ANTS
C      ANTS     I(*)   Antennas to swap
C      LUNI     I      Input LUN
C      LUNO     I      Output LUN
C      DISKI    I      Input disk
C      DISKO    I      Output disk
C      CNOI     I      Input catalog number
C      CNOO     I      Input catalog number
C      CATOLD   I(*)   Input header
C   In/Out
C      CATBLK   I(*)   Output header
C      BUFF1    I(*)   buffer 1
C      BUFF2    I(*)   buffer 2
C   Output:
C      IERR     I      error code
C-----------------------------------------------------------------------
      INTEGER   LUNI, LUNO, DISKI, DISKO, CNOI, CNOO, CATOLD(256),
     *   CATBLK(256), BUFF1(*), BUFF2(*), IERR
C
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   IVER, KOLS(MAXFGC), NUMV(MAXFGC), RNO, SOURID, SUBA,
     *   FREQID, ANTS(2), IFS(2), CHANS(2), NVER, NREC, IREC,
     *   KOLO(MAXFGC), NUMO(MAXFGC)
      LOGICAL   NOGOOD, PFLAGS(4), TFLAGS(4), AFLAG, SWAP1, SWAP2
      REAL      TIMER(2)
      CHARACTER REASON*24, CTYP*2
C
      LOGICAL   SWAPAN
      EXTERNAL  SWAPAN
C
      INCLUDE 'SWPAN.INC'
      INCLUDE 'SWPFL.INC'
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
C                                       FG tables
      CTYP = 'FG'
      CALL FNDEXT (CTYP, CATOLD, NVER)
      IF (NVER.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         DO 100 IVER = 1,NVER
            CALL FGREFM (DISKI, CNOI, IVER, CATOLD, LUNI, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'REFORMAT INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 100
               END IF
            CALL FLGINI ('READ', BUFF1, DISKI, CNOI, IVER, CATOLD, LUNI,
     *         RNO, KOLS, NUMV, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 100
               END IF
            NOGOOD = .FALSE.
            NREC = BUFF1(5)
            CALL FLGINI ('WRIT', BUFF2, DISKO, CNOO, IVER, CATBLK, LUNO,
     *         RNO, KOLO, NUMO, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 90
               END IF
            DO 50 IREC = 1,NREC
               RNO = IREC
               CALL TABFLG ('READ', BUFF1, RNO, KOLS, NUMV, SOURID,
     *            SUBA, FREQID, ANTS, TIMER, IFS, CHANS, PFLAGS, REASON,
     *            IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'READ INPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 90
                  END IF
               AFLAG = PFLAGS(1) .AND. PFLAGS(2) .AND. PFLAGS(3) .AND.
     *            PFLAGS(4)
               SWAP1 = SWAPAN(ANTS(1))
               SWAP2 = SWAPAN(ANTS(1))
               IF (.NOT.AFLAG) THEN
                  CALL LCOPY (4, PFLAGS, TFLAGS)
                  IF (NANT.EQ.0) THEN
                     PFLAGS(1) = TFLAGS(2)
                     PFLAGS(2) = TFLAGS(1)
                     PFLAGS(3) = TFLAGS(4)
                     PFLAGS(4) = TFLAGS(3)
                  ELSE IF (ANTS(1).EQ.0) THEN
                     NOGOOD = .TRUE.
                  ELSE IF (ANTS(2).EQ.0) THEN
                     IF (SWAP1) THEN
                        PFLAGS(1) = TFLAGS(2)
                        PFLAGS(2) = TFLAGS(1)
                        PFLAGS(3) = TFLAGS(4)
                        PFLAGS(4) = TFLAGS(3)
                        NOGOOD = .TRUE.
                        END IF
                  ELSE IF ((SWAP1) .AND. (SWAP2)) THEN
                     PFLAGS(1) = TFLAGS(2)
                     PFLAGS(2) = TFLAGS(1)
                     PFLAGS(3) = TFLAGS(4)
                     PFLAGS(4) = TFLAGS(3)
                  ELSE IF (SWAP1) THEN
                     PFLAGS(1) = TFLAGS(4)
                     PFLAGS(2) = TFLAGS(3)
                     PFLAGS(3) = TFLAGS(2)
                     PFLAGS(4) = TFLAGS(1)
                  ELSE IF (SWAP2) THEN
                     PFLAGS(1) = TFLAGS(3)
                     PFLAGS(2) = TFLAGS(4)
                     PFLAGS(3) = TFLAGS(1)
                     PFLAGS(4) = TFLAGS(2)
                     END IF
                  END IF
               RNO = IREC
               CALL TABFLG ('WRIT', BUFF2, RNO, KOLO, NUMO, SOURID,
     *            SUBA, FREQID, ANTS, TIMER, IFS, CHANS, PFLAGS, REASON,
     *            IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITE OUTPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 90
                  END IF
 50            CONTINUE
            WRITE (MSGTXT,1050) 'FG', DISKI, CNOI, IVER, DISKO, CNOO,
     *         IVER
            CALL MSGWRT (3)
            MSGTXT = 'BUT SOME FLAGS COULD NOT BE INTERPRETED CORRECTLY'
            IF (NOGOOD) CALL MSGWRT (7)
 90         RNO = IREC
            CALL TABFLG ('CLOS', BUFF2, RNO, KOLO, NUMO, SOURID, SUBA,
     *         FREQID, ANTS, TIMER, IFS, CHANS, PFLAGS, REASON, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
            RNO = IREC
            CALL TABFLG ('CLOS', BUFF1, RNO, KOLS, NUMV, SOURID, SUBA,
     *         FREQID, ANTS, TIMER, IFS, CHANS, PFLAGS, REASON, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE INPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
 100        CONTINUE
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('FIXFG: ERROR',I4,' ON ',A,1X,A,' TABLE VERSION',I4)
 1050 FORMAT ('Swapped ',A2,' file from vol/cno/vers',I3,I5,I4,' to',
     *   I3,I5,I4)
      END
      SUBROUTINE FIXBLC (LUNI, LUNO, DISKI, DISKO, CNOI, CNOO, CATOLD,
     *   CATBLK, BUFF1, BUFF2, IERR)
C-----------------------------------------------------------------------
C   swap SY, TY, CD, AN, GC, IM, MC, OF tables, copying to output
C   Inputs:
C      NUMANT   I      Number in ANTS
C      ANTS     I(*)   Antennas to swap
C      LUNI     I      Input LUN
C      LUNO     I      Output LUN
C      DISKI    I      Input disk
C      DISKO    I      Output disk
C      CNOI     I      Input catalog number
C      CNOO     I      Input catalog number
C      CATOLD   I(*)   Input header
C   In/Out
C      CATBLK   I(*)   Output header
C      BUFF1    I(*)   buffer 1
C      BUFF2    I(*)   buffer 2
C   Output:
C      IERR     I      error code
C-----------------------------------------------------------------------
      INTEGER   LUNI, LUNO, DISKI, DISKO, CNOI, CNOO, CATOLD(256),
     *   CATBLK(256), BUFF1(*), BUFF2(*), IERR
C
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'SWPAN.INC'
      INCLUDE 'SWPFL.INC'
      INTEGER   NVER, NREC, IREC, IVER, RNO, KOLS(30), NUMV(30), I, J,
     *   BIF, BCHAN, NUMIF, NUMFRQ, SUBA, FREQID, ANT1, ANT2, IOFF,
     *   NUMANT, NUMPOL, SOURID, KOLO(30), NUMO(30), PPOL
      LOGICAL   WAS
      CHARACTER CTYP*2
      REAL      RTIME(2), FACMUL(2,2,MAXIF), FACADD(2,2,MAXIF), RTEMP
      DOUBLE PRECISION PHASES(MAXCIF), ERRORS(MAXCIF)
      COMPLEX   CTEMP, BNDPAS(4*MAXCIF)
      EQUIVALENCE (BNDPAS(1), PHASES), (BNDPAS(MAXCIF+1), ERRORS)
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
C                                       antenna specific is wrong
      IF (NANT.GT.0) THEN
         WAS = .FALSE.
         CALL FNDEXT ('PP', CATOLD, NVER)
         IF (NVER.GT.0) THEN
            WRITE (MSGTXT,1010) NVER, 'PP'
            CALL MSGWRT (7)
            WAS = .TRUE.
            END IF
         CALL FNDEXT ('BL', CATOLD, NVER)
         IF (NVER.GT.0) THEN
            WRITE (MSGTXT,1010) NVER, 'BL'
            CALL MSGWRT (7)
            WAS = .TRUE.
            END IF
         CALL FNDEXT ('BD', CATOLD, NVER)
         IF (NVER.GT.0) THEN
            WRITE (MSGTXT,1010) NVER, 'BD'
            CALL MSGWRT (7)
            WAS = .TRUE.
            END IF
         MSGTXT = 'SUCH TABLES CANNOT BE SWAPPED EXCEPT FOR ALL' //
     *      ' ANTENNAS'
         IF (WAS) CALL MSGWRT (7)
         MSGTXT = 'CALIBRATIONS APPLIED BY THEM ARE NOW INCORRECT'
         IF (WAS) CALL MSGWRT (7)
         GO TO 999
         END IF
C                                       PP tables
C                                       reverse phase
      CTYP = 'PP'
      CALL FNDEXT (CTYP, CATOLD, NVER)
      IF (NVER.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         DO 100 IVER = 1,NVER
            CALL PPINI ('READ', BUFF1, DISKI, CNOI, IVER, CATOLD, LUNI,
     *         RNO, KOLS, NUMV, NUMIF, NUMFRQ, BIF, BCHAN, PPOL, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 100
               END IF
            NREC = BUFF1(5)
            CALL PPINI ('WRIT', BUFF2, DISKO, CNOO, IVER, CATBLK, LUNO,
     *         RNO, KOLO, NUMO, NUMIF, NUMFRQ, BIF, BCHAN, PPOL, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 90
               END IF
            DO 50 IREC = 1,NREC
               RNO = IREC
               CALL TABPP ('READ', BUFF1, RNO, KOLS, NUMV, RTIME, SUBA,
     *            FREQID, PHASES, ERRORS, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'READ INPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 90
                  END IF
               J = NUMV(4)
               DO 30 I = 1,J
                  PHASES(I) = -PHASES(I)
 30               CONTINUE
               RNO = IREC
               CALL TABPP ('WRIT', BUFF2, RNO, KOLO, NUMO, RTIME, SUBA,
     *            FREQID, PHASES, ERRORS, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITE OUTPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 90
                  END IF
 50            CONTINUE
            WRITE (MSGTXT,1050) 'PP', DISKI, CNOI, IVER, DISKO, CNOO,
     *         IVER
            CALL MSGWRT (3)
C                                       close
 90         RNO = NREC
            CALL TABPP ('CLOS', BUFF2, RNO, KOLO, NUMO, RTIME, SUBA,
     *         FREQID, PHASES, ERRORS, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
            RNO = NREC
            CALL TABPP ('CLOS', BUFF1, RNO, KOLS, NUMV, RTIME, SUBA,
     *         FREQID, PHASES, ERRORS, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE INPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
 100        CONTINUE
         END IF
C                                       BL tables
      CTYP = 'BL'
      CALL FNDEXT (CTYP, CATOLD, NVER)
      IF (NVER.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         DO 200 IVER = 1,NVER
            CALL BLREFM (DISKI, CNOI, IVER, CATOLD, LUNI, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'REFORMAT INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 200
               END IF
            CALL BLINI ('READ', BUFF1, DISKI, CNOI, IVER, CATOLD, LUNI,
     *         RNO, KOLS, NUMV, NUMANT, NUMPOL, NUMIF, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 200
               END IF
            NREC = BUFF1(5)
            CALL BLINI ('WRIT', BUFF2, DISKO, CNOO, IVER, CATBLK, LUNO,
     *         RNO, KOLO, NUMO, NUMANT, NUMPOL, NUMIF, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 190
               END IF
            DO 150 IREC = 1,NREC
               RNO = IREC
               CALL TABBL ('READ', BUFF1, RNO, KOLS, NUMV, NUMPOL,
     *            RTIME, SOURID, SUBA, ANT1, ANT2, FREQID, FACMUL,
     *            FACADD, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'READ INPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 190
                  END IF
               DO 130 I = 1,NUMIF
                  RTEMP = FACMUL(1,1,I)
                  FACMUL(1,1,I) = FACMUL(1,2,I)
                  FACMUL(1,2,I) = RTEMP
                  RTEMP = FACMUL(2,1,I)
                  FACMUL(2,1,I) = FACMUL(2,2,I)
                  FACMUL(2,2,I) = RTEMP
                  RTEMP = FACADD(1,1,I)
                  FACADD(1,1,I) = FACADD(1,2,I)
                  FACADD(1,2,I) = RTEMP
                  RTEMP = FACADD(2,1,I)
                  FACADD(2,1,I) = FACADD(2,2,I)
                  FACADD(2,2,I) = RTEMP
 130              CONTINUE
               RNO = IREC
               CALL TABBL ('WRIT', BUFF2, RNO, KOLO, NUMO, NUMPOL,
     *            RTIME, SOURID, SUBA, ANT1, ANT2, FREQID, FACMUL,
     *            FACADD, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITE OUTPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 190
                  END IF
 150           CONTINUE
            WRITE (MSGTXT,1050) 'BL', DISKI, CNOI, IVER, DISKO, CNOO,
     *         IVER
            CALL MSGWRT (3)
C                                       close
 190        RNO = NREC
            CALL TABBL ('CLOS', BUFF2, RNO, KOLO, NUMO, NUMPOL,
     *         RTIME, SOURID, SUBA, ANT1, ANT2, FREQID, FACMUL,
     *         FACADD, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
            RNO = NREC
            CALL TABBL ('CLOS', BUFF1, RNO, KOLS, NUMV, NUMPOL,
     *         RTIME, SOURID, SUBA, ANT1, ANT2, FREQID, FACMUL,
     *         FACADD, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
 200        CONTINUE
         END IF
C                                       BD tables
      CTYP = 'BD'
      CALL FNDEXT (CTYP, CATOLD, NVER)
      IF (NVER.GT.0) THEN
         NSWAPD = NSWAPD + 1
         TASWAP(NSWAPD) = CTYP
         DO 300 IVER = 1,NVER
            CALL BDINI ('READ', BUFF1, DISKI, CNOI, IVER, CATOLD, LUNI,
     *         RNO, KOLS, NUMV, NUMANT, NUMPOL, NUMIF, NUMFRQ, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN INPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 300
               END IF
            NREC = BUFF1(5)
            CALL BDINI ('WRIT', BUFF2, DISKO, CNOO, IVER, CATBLK, LUNO,
     *         RNO, KOLO, NUMO, NUMANT, NUMPOL, NUMIF, NUMFRQ, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'OPEN OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               GO TO 290
               END IF
            IOFF = NUMFRQ * NUMIF
            DO 250 IREC = 1,NREC
               RNO = IREC
               CALL TABBD ('READ', BUFF1, RNO, KOLS, NUMV, NUMIF,
     *            NUMFRQ, NUMPOL, RTIME, SOURID, SUBA, ANT1, ANT2,
     *            FREQID, BNDPAS, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'READ INPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 290
                  END IF
               DO 230 I = 1,IOFF
                  CTEMP = BNDPAS(I)
                  BNDPAS(I) = BNDPAS(I+IOFF)
                  BNDPAS(I+IOFF) = CTEMP
                  IF (NUMPOL.EQ.4) THEN
                     CTEMP = BNDPAS(I+2*IOFF)
                     BNDPAS(I+2*IOFF) = BNDPAS(I+3*IOFF)
                     BNDPAS(I+3*IOFF) = CTEMP
                     END IF
 230              CONTINUE
               RNO = IREC
               CALL TABBD ('WRIT', BUFF2, RNO, KOLO, NUMO, NUMIF,
     *            NUMFRQ, NUMPOL, RTIME, SOURID, SUBA, ANT1, ANT2,
     *            FREQID, BNDPAS, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITE OUTPUT', CTYP, IVER
                  CALL MSGWRT (7)
                  GO TO 290
                  END IF
 250           CONTINUE
            WRITE (MSGTXT,1050) 'BD', DISKI, CNOI, IVER, DISKO, CNOO,
     *         IVER
            CALL MSGWRT (3)
C                                       close
 290        RNO = NREC
            CALL TABBD ('CLOS', BUFF2, RNO, KOLO, NUMO, NUMIF,
     *         NUMFRQ, NUMPOL, RTIME, SOURID, SUBA, ANT1, ANT2,
     *         FREQID, BNDPAS, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE OUTPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
            RNO = NREC
            CALL TABBD ('CLOS', BUFF1, RNO, KOLS, NUMV, NUMIF,
     *         NUMFRQ, NUMPOL, RTIME, SOURID, SUBA, ANT1, ANT2,
     *         FREQID, BNDPAS, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'CLOSE INPUT', CTYP, IVER
               CALL MSGWRT (7)
               END IF
 300        CONTINUE
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('FIXBLC ERROR:',I4,' ON ',A,1X,A,' TABLE VERSION',I4)
 1010 FORMAT ('COPIED',I3,' VERSIONS OF ',A,' BUT DID NOT CORRECT THEM')
 1050 FORMAT ('Swapped ',A2,' file from vol/cno/vers',I3,I5,I4,' to',
     *   I3,I5,I4)
      END
