LOCAL INCLUDE 'AMKAT.INC'
C                                       Local include for AMKAT
      INCLUDE 'INCS:ZPBUFSZ.INC'
      INCLUDE 'INCS:PUVD.INC'
      HOLLERITH XNAMEI(3), XCLAIN(2), XNAMOU(3), XCLAOU(2)
      REAL      XSIN, XDISIN, XSOUT, XDISO
      REAL      BUFF1(UVBFSS), BUFF2(UVBFSS)
      INTEGER   SEQIN, SEQOUT, DISKIN, DISKO, JBUFSZ, ILOCWT,
     *   CATOLD(256), INCSI, INCFI, INCIFI, INCSO, INCFO, INCIFO, LRECI,
     *   LRECO, NRPRMI, NRPRMO, OLDCNO, NEWCNO, OUTANT(MAXANT,10), NSUB,
     *   MXANT(10), MISANT(MAXANT,10), IBUFF1(UVBFSS), IBUFF2(UVBFSS)
      LOGICAL   ISCOMP
      CHARACTER NAMEIN*12, CLAIN*6, NAMOUT*12, CLAOUT*6
      EQUIVALENCE (BUFF1, IBUFF1), (BUFF2, IBUFF2)
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XNAMOU, XCLAOU,
     *   XSOUT, XDISO
      COMMON /TPARMS/ CATOLD, SEQIN, SEQOUT, DISKIN, DISKO, ILOCWT,
     *   INCSI, INCFI, INCIFI, INCSO, INCFO, INCIFO, LRECI, LRECO,
     *   NRPRMI, NRPRMO, ISCOMP, OLDCNO, NEWCNO, OUTANT, NSUB, MXANT,
     *   MISANT
      COMMON /CHARPM/ NAMEIN, CLAIN, NAMOUT, CLAOUT
      COMMON /BUFRS/ BUFF1, BUFF2, JBUFSZ
C                                       End local include for AMKAT
LOCAL END
      PROGRAM AMKAT
C-----------------------------------------------------------------------
C! Renumbers MeerKAT antennas to match station IDs
C# Utility UV UV-util VLA VLB
C-----------------------------------------------------------------------
C;  Copyright (C) 2023
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   AMKAT renumbers MeerKAT antennas to match station IDs
C   Inputs:
C      AIPS adverb  Prg. name.          Description.
C      INNAME         NAMEIN        Name of input UV data.
C      INCLASS        CLAIN         Class of input UV data.
C      INSEQ          SEQIN         Seq. of input UV data.
C      INDISK         DISKIN        Disk number of input VU data.
C      OUTNAME        NAMOUT        Name of the output uv file.
C                                   Default output is input file.
C      OUTCLASS       CLAOUT        Class of the output uv file.
C      OUTSEQ         SEQOUT        Seq. number of output uv data.
C      OUTDISK        DISKO         Disk number of the output file.
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET
      INCLUDE 'AMKAT.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA PRGM /'AMKAT '/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL AMKATI (PRGM, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Call routine that sends data
C                                       to the user routine.
      CALL AMKATU (IRET)
      IF (IRET.NE.0) GO TO 990
      CALL AMKATH
C                                       Close down files, etc.
 990  CALL DIE (IRET, BUFF1)
C
 999  STOP
      END
      SUBROUTINE AMKATI (PRGN, JERR)
C-----------------------------------------------------------------------
C   AMKATI gets input parameters for AMKAT and creates an output file
C   if necessary.
C   Inputs:
C      PRGN    C*6  Program name
C   Output:
C      JERR    I    Error code: 0 => ok
C                                5 => catalog troubles
C                                8 => can't start
C   Output in common:
C      LRECI   I  Input file record length
C      NRPRMI  I  Input number of random parameters.
C      INCSI   I  Input Stokes' increment in vis.
C      INCFI   I  Input frequency increment in vis.
C      INCIFI  I  Input IF increment in vis.
C      LRECO   I  Output file record length
C      NRPRMO  I  Output number of random parameters.
C      INCSO   I  Output Stokes' increment in vis.
C      INCFO   I  Output frequency increment in vis.
C      INCIFO  I  Output IF increment in vis.
C      ISCOMP  L  If true data is compressed
C   Commons: /INPARM/ all input adverbs in order given by INPUTS
C                     file
C            /MAPHDR/ output file catalog header
C   See prologue comments in AMKAT for more details.
C-----------------------------------------------------------------------
      INTEGER   JERR
      CHARACTER PRGN*6
C
      CHARACTER STAT*4, BLANK*6, PTYPE*2
      INTEGER   IROUND, NPARM, IERR, INCX
      LOGICAL   T, F
      INCLUDE 'AMKAT.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DUVH.INC'
      DATA BLANK  /'      '/
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (T)
      CALL VHDRIN
      JBUFSZ = UVBFSS * 2
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      JERR = 0
C                                       Get input parameters.
      NPARM = 14
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         RQUICK = .TRUE.
         JERR = 8
         IF (IERR.EQ.1) GO TO 999
            WRITE (MSGTXT,1000) IERR, 'OBTAINING INPUT PARAMETERS'
            CALL MSGWRT (8)
         END IF
C                                       Restart AIPS
      IF (RQUICK) CALL RELPOP (JERR, BUFF1, IERR)
      IF (JERR.NE.0) GO TO 999
      JERR = 5
C                                       Crunch input parameters.
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      CALL H2CHR (12, 1, XNAMOU, NAMOUT)
      CALL H2CHR (6, 1, XCLAOU, CLAOUT)
      SEQIN = IROUND (XSIN)
      SEQOUT = IROUND (XSOUT)
      DISKIN = IROUND (XDISIN)
      DISKO = IROUND (XDISO)
C                                       Create new file.
C                                       Get CATBLK from old file.
      OLDCNO = 1
      PTYPE = 'UV'
      CALL CATDIR ('SRCH', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN,
     *   PTYPE, NLUSER, STAT, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1030) IERR, NAMEIN, CLAIN, SEQIN, DISKIN,
     *      NLUSER
         GO TO 990
         END IF
      CALL CATIO ('READ', DISKIN, OLDCNO, CATBLK, 'REST', BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READING HEADER'
         GO TO 990
         END IF
C                                       Save input CATBLK
      CALL COPY (256, CATBLK, CATOLD)
C                                       Compressed data?
      ISCOMP = CATBLK(KINAX).EQ.1
      IF (ISCOMP) THEN
C                                       Find weight and scale.
         CALL AXEFND (8, 'WEIGHT  ', CATBLK(KIPCN), CATH(KHPTP), ILOCWT,
     *      JERR)
         IF (JERR.NE.0) THEN
            MSGTXT = 'ERROR FINDING WEIGHT FOR COMPRESSED DATA'
            JERR = 9
            GO TO 990
            END IF
         END IF
C                                       Get uv header info.
      CALL UVPGET (JERR)
      IF (JERR.NE.0) GO TO 999
C                                       Save input file info
      INCX = CATBLK(KINAX)
      LRECI = LREC
      NRPRMI = NRPARM
      INCSI = INCS / INCX
      INCFI = INCF / INCX
      INCIFI = INCIF / INCX
C                                       Read AN files - do we do this?
      JERR = 1
      CALL AMKATR (IERR)
      IF (IERR.GT.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READING ANTENNA FILES'
         GO TO 990
      ELSE IF (IERR.LT.0) THEN
         MSGTXT = 'THERE IS NOTHING TO DO: QUITTING'
         GO TO 990
         END IF
C                                       Put new values in CATBLK.
      CALL MAKOUT (NAMEIN, CLAIN, SEQIN, BLANK, NAMOUT, CLAOUT, SEQOUT)
      CALL CHR2H (12, NAMOUT, KHIMNO, CATH(KHIMN))
      CALL CHR2H (6, CLAOUT, KHIMCO, CATH(KHIMC))
      CATBLK(KIIMS) = SEQOUT
C                                       Create output file.
      NEWCNO = 1
      FRW(NCFILE+1) = 3
      JERR = 4
      CALL UVCREA (DISKO, NEWCNO, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         IF (IERR.NE.2) THEN
            WRITE (MSGTXT,1000) IERR, 'CREATING OUTPUT DATA SET'
            GO TO 990
            END IF
C                                       Only overwrite Input file
C                                       no destroy existing otherwise
         IF ((NEWCNO.NE.OLDCNO) .OR. (DISKO.NE.DISKIN)) THEN
            WRITE (MSGTXT,1060)
            GO TO 990
            END IF
C                                       Recover existing CATBLK
         FRW(NCFILE+1) = 2
         CALL CATIO ('READ', DISKO, NEWCNO, CATBLK, 'WRIT', BUFF1, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'UPDATING NEW CATBLK'
            CALL MSGWRT (6)
            END IF
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKO
      FCNO(NCFILE) = NEWCNO
      FRW(NCFILE) = FRW(NCFILE) - 1
C                                       Save output file info
      CALL UVPGET (JERR)
      IF (JERR.NE.0) GO TO 999
      INCX = CATBLK(KINAX)
      LRECO = LREC
      NRPRMO = NRPARM
      INCSO = INCS / INCX
      INCFO = INCF / INCX
      INCIFO = INCIF / INCX
C                                        Put input file in READ
      PTYPE = 'UV'
      CALL CATDIR ('CSTA', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN,
     *   PTYPE, NLUSER, 'READ', BUFF1, IERR)
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = OLDCNO
      FRW(NCFILE) = 0
      JERR = 0
      SEQOUT = CATBLK(KIIMS)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('AMKATI: ERROR',I3,' ON ',A)
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
     *   I3,' USID=',I5)
 1060 FORMAT ('MAY OVERWRITE INPUT FILE ONLY.  QUITTING')
      END
      SUBROUTINE AMKATR (IRET)
C-----------------------------------------------------------------------
C   AMKATR reads the antenna files and makes a list of output antenna
C   numbers
C   Output:
C      IRET   I   Error code: 0 ok, > 0 real error, < 0 nothing to do
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'AMKAT.INC'
      INTEGER   ISUB, BUFF(512), I, J, K, KK, NDIFF
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DANT.INC'
C-----------------------------------------------------------------------
      IRET = -1
      CALL FNDEXT ('AN', CATOLD, NSUB)
      IF (NSUB.LE.0) THEN
         MSGTXT = 'NO ANTENNA FILES FOUND'
         CALL MSGWRT (8)
         GO TO 999
         END IF
      NDIFF = 0
      CALL FILL (10*MAXANT, 0, OUTANT)
      CALL FILL (10*MAXANT, 0, MISANT)
      CALL FILL (10, 0, MXANT)
C                                       loop subarrays
      DO 100 ISUB = 1,NSUB
         CALL GETANT (DISKIN, OLDCNO, ISUB, CATOLD, BUFF, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1010) IRET, ISUB
            CALL MSGWRT (8)
            GO TO 999
            END IF
C                                       loop antennas
         DO 10 I = 1,NSTNS
            J = TELNO(I)
            READ (STNNAM(I),1000,ERR=900) K
            K = K + 1
            OUTANT(J,ISUB) = K
            MXANT(ISUB) = MAX (MXANT(ISUB), K)
            IF (J.NE.K) NDIFF = NDIFF + 1
 10         CONTINUE
C                                       Missing antennas
         I = 0
         DO 30 K = 1,64
            DO 20 KK = 1,NSTNS
               IF (OUTANT(KK,ISUB).EQ.K) GO TO 30
 20            CONTINUE
            I = I + 1
            MISANT(I,ISUB) = K
 30         CONTINUE
 100     CONTINUE
      IRET = -1
      IF (NDIFF.GT.0) IRET = 0
      WRITE (MSGTXT,1100) NDIFF
      IF (NDIFF.GT.0) CALL MSGWRT (4)
      GO TO 999
C                                       format issue
 900  WRITE (MSGTXT,1900) I, ISUB, STNNAM(I)
      CALL MSGWRT (8)
      IRET = 1
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT (1X,I3)
 1010 FORMAT ('GETANT ERROR',I4,' SUBARRAY',I3)
 1100 FORMAT ('AMKATR found',I5,' antennas to correct')
 1900 FORMAT ('AMKATR FORMAT ISSUE ANT, SUB, STN',I4,I3,' ''',A,'''')
      END
      SUBROUTINE AMKATU (IRET)
C-----------------------------------------------------------------------
C   AMKATU changes the antenna numbers
C   Input in common:
C      LRECI   I  Input file record length
C      NRPRMI  I  Input number of random parameters.
C      INCSI   I  Input Stokes increment in vis.
C      INCFI   I  Input frequency increment in vis.
C      INCIFI  I  Input IF increment in vis.
C      LRECO   I  Output file record length
C      NRPRMO  I  Output number of random parameters.
C      INCSO   I  Output Stokes' increment in vis.
C      INCFO   I  Output frequency increment in vis.
C      INCIFO  I  Output IF increment in vis.
C      ISCOMP  L  If true data is compressed
C   Output:
C      IRET    I  Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      CHARACTER OFILE*48, IFILE*48
      INTEGER   INIO, IPTRI, IPTRO, LUNI, LUNO, INDI, INDO, ILENBU,
     *   KBIND, NIOUT, NIOLIM, IBIND, I, IA1, IA2, INCX, BO, VO, ISUB,
     *   NUMVIS, XCOUNT, NCORI, NCORO, NCOPY, RNXRET, VISINC, VISMSG
      LOGICAL   T, F
      INCLUDE 'AMKAT.INC'
      REAL      BASEN, CBUFF(UVBFSS), RESULT(UVBFSS)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA LUNI, LUNO /16, 17/
      DATA VO, BO /0, 1/
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
C                                       Dimension of complex axis
      INCX = CATBLK(KINAX)
      IF (ISCOMP) INCX = 3
      VISINC = CATBLK(KIGCN) / 20
      VISMSG = CATBLK(KIGCN) / 10
      VISINC = MAX (20000, MIN (200000,VISINC))
      VISMSG = (VISMSG / VISINC) * VISINC
      IF (VISMSG.LT.VISINC) VISMSG = 100 * VISINC
C                                       Number of visibilities in input
C                                       and output files.
      NCORI = (LRECI - NRPRMI) / CATOLD(KINAX)
      NCORO = (LRECO - NRPRMO) / CATBLK(KINAX)
      NCOPY = LRECO - NRPRMO
C                                       Open and init for read
C                                       visibility file
      CALL ZPHFIL ('UV', DISKIN, FCNO(NCFILE), 1, IFILE, IRET)
      CALL ZOPEN (LUNI, INDI, DISKIN, IFILE, T, F, F, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1000) IRET
         GO TO 990
         END IF
C                                       Open vis file for write
      CALL ZPHFIL ('UV', DISKO, NEWCNO, 1, OFILE, IRET)
      CALL ZOPEN (LUNO, INDO, DISKO, OFILE, T, F, F, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1010) IRET
         GO TO 990
         END IF
C                                       Init vis file for write
      ILENBU = 0
      CALL UVINIT ('WRIT', LUNO, INDO, NVIS, VO, LRECO, ILENBU, JBUFSZ,
     *   BUFF2, BO, KBIND, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1020) IRET
         GO TO 990
         END IF
      IPTRO = KBIND
      NIOUT = 0
      NIOLIM = ILENBU
C                                       Init vis file for read.
      ILENBU = 0
      CALL UVINIT ('READ', LUNI, INDI, NVIS, VO, LRECI, ILENBU, JBUFSZ,
     *   BUFF1, BO, IBIND, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1030) IRET
         GO TO 990
         END IF
      NUMVIS = 0
      XCOUNT = 0
C                                       make an index table
      CALL RNXGET (DISKIN, OLDCNO, CATOLD)
      CALL RNXINI (DISKO, NEWCNO, CATBLK, RNXRET)
C                                       Loop
 100  CONTINUE
C                                       Read vis. record.
         CALL UVDISK ('READ', LUNI, INDI, BUFF1, INIO, IBIND, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1100) IRET
            GO TO 990
            END IF
         IPTRI = IBIND
C                                       Out of data?
         IF (INIO.LE.0) GO TO 200
C                                       Loop over buffer
         DO 190 I = 1,INIO
            IF (ILOCB.GE.0) THEN
               BASEN = BUFF1(IPTRI+ILOCB)
               IA1 = BASEN / 256. + 0.1
               IA2 = BASEN - IA1*256. + 0.1
               ISUB = (BASEN - 256*IA1 - IA2) * 100.0 + 1.5
               IA1 = OUTANT(IA1,ISUB)
               IA2 = OUTANT(IA2,ISUB)
            ELSE
               IA1 = BUFF1(IPTRI+ILOCA1) + 0.1
               IA2 = BUFF1(IPTRI+ILOCA2) + 0.1
               ISUB = BUFF1(IPTRI+ILOCSA) + 0.1
               IA1 = OUTANT(IA1,ISUB)
               IA2 = OUTANT(IA2,ISUB)
               END IF
            NUMVIS = NUMVIS + 1
            IF (MOD(NUMVIS-1,VISMSG).EQ.0) THEN
               WRITE (MSGTXT,1105) NUMVIS
               CALL MSGWRT (2)
            ELSE IF (MOD(NUMVIS-1,VISINC).EQ.0) THEN
               WRITE (MSGTXT,1105) NUMVIS
               CALL MSGWRT (1)
               END IF
C                                      Call user routine.
            IF (ISCOMP) THEN
C                                       Compressed data.
               CALL ZUVXPN (NCORI, BUFF1(IPTRI+NRPRMI),
     *            BUFF1(IPTRI+ILOCWT), CBUFF)
               CALL AMKATD (NUMVIS, IA1, IA2, ISUB, CBUFF, BUFF1(IPTRI),
     *            INCX, RESULT, IRET)
            ELSE
C                                       Un compressed data
               CALL AMKATD (NUMVIS, IA1, IA2, ISUB, BUFF1(IPTRI+NRPRMI),
     *            BUFF1(IPTRI), INCX, RESULT, IRET)
               END IF
C                                       Branch on his return
C                                       Error (fatal)
            IF (IRET.GT.0) THEN
               WRITE (MSGTXT,1120) IRET
               GO TO 990
C                                       Copy to output.
            ELSE IF (IRET.EQ.0) THEN
               XCOUNT = XCOUNT + 1.0D0
               CALL RCOPY (NRPRMO, BUFF1(IPTRI), BUFF2(IPTRO))
C                                       update NX table
               CALL RNXUPD (BUFF1(IPTRI), RNXRET)
C                                       Compressed
               IF (ISCOMP) THEN
                  CALL ZUVPAK (NCORO, RESULT, BUFF2(IPTRO+ILOCWT),
     *               BUFF2(IPTRO+NRPRMO))
               ELSE
                  CALL RCOPY (NCOPY, RESULT, BUFF2(IPTRO+NRPRMO))
                  END IF
               IPTRO = IPTRO + LRECO
               NIOUT = NIOUT + 1
               END IF
C                                       OK, but no output please
            IPTRI = IPTRI + LRECI
C                                       Write vis record.
            IF (NIOUT.GE.NIOLIM) THEN
               CALL UVDISK ('WRIT', LUNO, INDO, BUFF2, NIOLIM, KBIND,
     *            IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1150) IRET
                  GO TO 990
                  END IF
               IPTRO = KBIND
               NIOUT = 0
               END IF
 190        CONTINUE
C                                       Read next buffer.
         GO TO 100
C                                       Finish write
 200  NIOUT = - NIOUT
      CALL UVDISK ('FLSH', LUNO, INDO, BUFF2, NIOUT, KBIND, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1150) IRET
         GO TO 990
         END IF
C                                       Compress output file.
      NVIS = XCOUNT
      CALL UCMPRS (NVIS, DISKO, NEWCNO, LUNO, CATBLK, IRET)
C                                       Close files
      CALL ZCLOSE (LUNI, INDI, IRET)
      CALL ZCLOSE (LUNO, INDO, IRET)
      IRET = 0
      CALL RNXCLS (RNXRET)
      IF (RNXRET.NE.0) THEN
         MSGTXT = 'OUTPUT NX TABLE, IF ANY, IS INCOMPLETE'
         GO TO 990
         END IF
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('AMKATU: ERROR',I3,' OPEN-FOR-READ VIS FILE')
 1010 FORMAT ('AMKATU: ERROR',I3,' OPEN-FOR-WRITE VIS FILE')
 1020 FORMAT ('AMKATU: ERROR',I3,' INIT-FOR-WRITE VIS FILE')
 1030 FORMAT ('AMKATU: ERROR',I3,' INIT-FOR-READ VIS FILE')
 1100 FORMAT ('AMKATU: ERROR',I3,' READING VIS FILE')
 1105 FORMAT ('AMKATU: at visibility record',I10)
 1120 FORMAT ('AMKATU: AMKATD ERROR',I3)
 1150 FORMAT ('AMKATU: ERROR',I3,' WRITING VIS FILE')
      END
      SUBROUTINE AMKATD (NUMVIS, JA1, JA2, ISUB, VIS, RPARM, INCX,
     *   RESULT, IRET)
C-----------------------------------------------------------------------
C   Copies data to RESULT with phase reversal if IA1 > IA2
C   Inputs:
C      NUMVIS  I    Visibility number, -1 => final call, no data
C                   passed but allows any operations to be completed.
C      JA1     I    First new antenna number
C      JA2     I    Second new antenna number
C      ISUB    I    subarray
C      RPARM   R(*) Random parameter array which includes U,V,W etc
C                   but also any other random parameters.
C      VIS     R(INCX,*)  Visibilities in order real, imaginary, weight
C                   (Jy, Jy, unitless).  Weight <= 0 => flagged.
C                   NOTE: INCX may be any value .GE. 2
C   Inputs from COMMON:
C      NRPARM     I       # random parameters.
C      NCOR       I       # correlators
C      LRECI      I    Input file record length
C      NRPRMI     I    Input number of random parameters.
C      INCSI      I    Input Stokes' increment in vis.
C      INCFI      I    Input frequency increment in vis.
C      INCIFI     I    Input IF increment in vis.
C      LRECO      I    Output file record length
C      NRPRMO     I    Output number of random parameters.
C      INCSO      I    Output Stokes' increment in vis.
C      INCFO      I    Output frequency increment in vis.
C      INCIFO     I    Output IF increment in vis.
C   Output:
C      RPARM      R    Modified random parameter array. (baseline or
C                      antenna changed)
C      RESULT  R(INCX,*) Output visibilities selected in frequency.
C      IRET       I    Return code  -1 => don't write
C                                    0 => OK
C                                   >0 => error, terminate.
C
C-----------------------------------------------------------------------
      INTEGER   NUMVIS, JA1, JA2, ISUB, INCX, IRET
      REAL      VIS(INCX,*), RPARM(*), RESULT(INCX,*)
C
      INTEGER   JIF, JF, JS, NIF, NF, NS, INDEXO, INDEXI, I, JJS, JJ(4)
      INCLUDE 'AMKAT.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA JJ /1,2,4,3/
C-----------------------------------------------------------------------
      IRET = 0
      IF (NUMVIS.GT.0) THEN
         NS = 1
         NIF = 1
         NF = 1
         IF (JLOCS.GE.0) NS = CATBLK(KINAX+JLOCS)
         IF (JLOCIF.GE.0) NIF = CATBLK(KINAX+JLOCIF)
         IF (JLOCF.GE.0) NF = CATBLK(KINAX+JLOCF)
C                                       copy data only
         IF (JA1.LE.JA2) THEN
            IF (ILOCB.GE.0) THEN
               RPARM(1+ILOCB) = 256 * JA1 + JA2 + (ISUB-1)/100.0
            ELSE
               RPARM(1+ILOCA1) = JA1
               RPARM(1+ILOCA2) = JA2
               RPARM(1+ILOCSA) = ISUB
               END IF
            DO 40 JIF = 1,NIF
               DO 30 JF = 1,NF
                  DO 20 JS = 1,NS
                     INDEXI = (JIF-1) * INCIFI + (JF-1) * INCFI +
     *                  (JS-1) * INCSI + 1
                     INDEXO = (JIF-1) * INCIFO + (JF-1) * INCFO +
     *                  (JS-1) * INCSO + 1
                     DO 10 I = 1,INCX
                        RESULT(I,INDEXO) = VIS(I,INDEXI)
 10                     CONTINUE
 20                  CONTINUE
 30               CONTINUE
 40            CONTINUE
C                                       reverse things
         ELSE
            RPARM(1+ILOCU) = -RPARM(1+ILOCU)
            RPARM(1+ILOCV) = -RPARM(1+ILOCV)
            RPARM(1+ILOCW) = -RPARM(1+ILOCW)
            IF (ILOCB.GE.0) THEN
               RPARM(1+ILOCB) = 256 * JA2 + JA1 + (ISUB-1)/100.0
            ELSE
               RPARM(1+ILOCA1) = JA2
               RPARM(1+ILOCA2) = JA1
               RPARM(1+ILOCSA) = ISUB
               END IF
            DO 80 JIF = 1,NIF
               DO 70 JF = 1,NF
                  DO 60 JS = 1,NS
                     JJS = JJ(JS)
                     INDEXI = (JIF-1) * INCIFI + (JF-1) * INCFI +
     *                  (JS-1) * INCSI + 1
                     INDEXO = (JIF-1) * INCIFO + (JF-1) * INCFO +
     *                  (JJS-1) * INCSO + 1
                     RESULT(1,INDEXO) = VIS(1,INDEXI)
                     RESULT(2,INDEXO) = -VIS(2,INDEXI)
                     RESULT(3,INDEXO) = VIS(3,INDEXI)
 60                  CONTINUE
 70               CONTINUE
 80            CONTINUE
            END IF
         END IF
C
 999  RETURN
      END
      SUBROUTINE AMKATH
C-----------------------------------------------------------------------
C   AMKATH copies and updates history file.  It also copies any tables.
C-----------------------------------------------------------------------
      CHARACTER NOTTYP(2)*2, HILINE*72
      INTEGER   LUN1, LUN2, IERR, I, NONOT, J
      LOGICAL   T, F
      INCLUDE 'AMKAT.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHIS.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA LUN1, LUN2 /27,28/
      DATA T, F /.TRUE.,.FALSE./
      DATA NONOT, NOTTYP /2, 'NX', 'AN'/
C-----------------------------------------------------------------------
C                                       Write History.
      CALL HIINIT (3)
C                                       Copy/open history file.
      CALL HISCOP (LUN1, LUN2, DISKIN, DISKO, FCNO(NCFILE),
     *   FCNO(NCFILE-1), CATBLK, BUFF1, BUFF2, IERR)
      IF (IERR.GT.2) THEN
         WRITE (MSGTXT,1000) IERR
         CALL MSGWRT (6)
         GO TO 200
         END IF
C                                       New history
      CALL HENCO1 (TSKNAM, NAMEIN, CLAIN, SEQIN, DISKIN, LUN2, BUFF2,
     *   IERR)
      IF (IERR.NE.0) GO TO 200
      CALL HENCOO (TSKNAM, NAMOUT, CLAOUT, SEQOUT, DISKO, LUN2, BUFF2,
     *   IERR)
      IF (IERR.NE.0) GO TO 200
      DO 100 I = 1,10
         DO 90 J = 1,MXANT(I)
            IF (OUTANT(J,I).NE.J) THEN
               WRITE (HILINE,1010) TSKNAM, I, J, OUTANT(I,J)
               CALL HIADD (LUN2, HILINE, BUFF2, IERR)
               IF (IERR.NE.0) GO TO 200
               END IF
 90         CONTINUE
 100     CONTINUE

C                                       Close HI file
 200  CALL HICLOS (LUN2, T, BUFF2, IERR)
C                                        Copy tables
      CALL ADJANT (LUN1, LUN2, IERR)
      IF (IERR.GT.0) THEN
         WRITE (MSGTXT,1200) IERR
         CALL MSGWRT (6)
         END IF
C                                        Copy tables
      CALL ADJTAB (NONOT, NOTTYP, LUN1, LUN2, DISKIN, DISKO, FCNO(2),
     *   FCNO(1), OUTANT,  CATBLK, BUFF1, IBUFF2, IERR)
      IF (IERR.GT.2) THEN
         WRITE (MSGTXT,1201)
         CALL MSGWRT (6)
         END IF
C                                        Update CATBLK.
      CALL CATIO ('UPDT', DISKO, FCNO(NCFILE-1), CATBLK, 'REST',
     *   BUFF1, IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('AMKATH: ERROR',I3,' COPY/OPEN HISTORY FILE')
 1010 FORMAT (A6,' / SUBARRAY=',I2,' ANTENNA',I4,' NOW',I4)
 1200 FORMAT ('AMKATH: ERROR',I4,' COPYING ANTENNA TABLES')
 1201 FORMAT ('AMKATH: ERROR COPYING TABLES')
      END
      SUBROUTINE ADJANT (LUNOLD, LUNNEW, IRET)
C-----------------------------------------------------------------------
C   ADJANT copies all antenna Table extension file(s).  The output
C   antenna file will have 64 antennas, some OUT.
C   Inputs:
C      LUNOLD  I       LUN for old file
C      LUNNEW  I       LUN for new file
C   Output:
C      IRET    I       Return error code  0 => ok,
C-----------------------------------------------------------------------
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   LUNOLD, LUNNEW, IRET
C
      INCLUDE 'AMKAT.INC'
      INCLUDE 'INCS:DANT.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DCAT.INC'
      INTEGER   NREC, ISUB, BUFFA(512), IER, IVERI, IVERO, I, IREC
      LOGICAL   TABLE, EXIST, FITASC
C-----------------------------------------------------------------------
C                                       loop over subarrays
      DO 100 ISUB = 1,NSUB
C                                       See if files exist and are
C                                       wanted.
         CALL ISTAB ('AN', DISKIN, OLDCNO, ISUB, LUNOLD, BUFF1, TABLE,
     *      EXIST, FITASC, IER)
         IF (TABLE .AND. EXIST .AND. (IER.EQ.0)) THEN
            IVERI = ISUB
            IVERO = ISUB
C                                       Copy
            CALL TABCOP ('AN', IVERI, IVERO, LUNOLD, LUNNEW, DISKIN,
     *         DISKO, OLDCNO, NEWCNO, CATBLK, IBUFF1, IBUFF2, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, ISUB, 'COPYING AN FILE'
               GO TO 990
               END IF
C                                       update
            CALL ANTINI ('WRIT', BUFFA, DISKO, NEWCNO, IVERO, CATBLK,
     *         LUNNEW, IANRNO, ANKOLS, ANNUMV, ARRAYC, GSTIA0, DEGPDY,
     *         SAFREQ, RDATE, POLRXY, UT1UTC, DATUTC, TIMSYS, ANAME,
     *         XYZHAN, TFRAME, NUMORB, NOPCAL, ANTNIF, ANFQID, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, ISUB, 'OPENING NEW AN FILE'
               GO TO 990
               END IF
            NREC = BUFFA(5)
            DO 20 IREC = 1,NREC
               IANRNO = IREC
               CALL TABAN ('READ', BUFFA, IANRNO, ANKOLS, ANNUMV,
     *            ANNAME, STAXYZ, ORBPRM, NOSTA, MNTSTA, STAXOF, DIAMAN,
     *            FWHMAN, POLTYA, POLAA, POLCA, POLTYB, POLAB, POLCB,
     *            IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1000) IRET, ISUB, 'READING AN FILE'
                  GO TO 990
                  END IF
               IF (OUTANT(NOSTA,ISUB).NE.NOSTA) THEN
                  NOSTA = OUTANT(NOSTA,ISUB)
                  IANRNO = IREC
                  CALL TABAN ('WRIT', BUFFA, IANRNO, ANKOLS, ANNUMV,
     *               ANNAME, STAXYZ, ORBPRM, NOSTA, MNTSTA, STAXOF,
     *               DIAMAN, FWHMAN, POLTYA, POLAA, POLCA, POLTYB,
     *               POLAB, POLCB, IRET)
                  IF (IRET.NE.0) THEN
                     WRITE (MSGTXT,1000) IRET, ISUB, 'WRITING AN FILE'
                     GO TO 990
                     END IF
                  END IF
 20            CONTINUE
            ANNAME = 'OUT'
            STAXYZ(1) = 0.0d0
            STAXYZ(2) = 0.0d0
            STAXYZ(3) = 0.0d0
            DO 30 I = 1,MAXANT
               IF (MISANT(I,ISUB).GT.0) THEN
                  IANRNO = NREC + I
                  NOSTA = MISANT(I,ISUB)
                  CALL TABAN ('WRIT', BUFFA, IANRNO, ANKOLS, ANNUMV,
     *               ANNAME, STAXYZ, ORBPRM, NOSTA, MNTSTA, STAXOF,
     *               DIAMAN, FWHMAN, POLTYA, POLAA, POLCA, POLTYB,
     *               POLAB, POLCB, IRET)
                  IF (IRET.NE.0) THEN
                     WRITE (MSGTXT,1000) IRET, ISUB,
     *                  'WRITING AN FILE OUT ANTENNAS'
                     GO TO 990
                     END IF
               ELSE
                  GO TO 40
                  END IF
 30            CONTINUE
C                                       close an file
 40         CALL TABAN ('CLOS', BUFFA, IANRNO, ANKOLS, ANNUMV,
     *         ANNAME, STAXYZ, ORBPRM, NOSTA, MNTSTA, STAXOF, DIAMAN,
     *         FWHMAN, POLTYA, POLAA, POLCA, POLTYB, POLAB, POLCB,
     *         IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, ISUB, 'CLOSING AN FILE'
               GO TO 990
               END IF
            END IF
 100     CONTINUE
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('AFJANT ERROR',I4,' SUBARRAY',I3,' ON ',A)
      END
      SUBROUTINE ADJTAB (NONOT, NOTTYP, LUNOLD, LUNNEW, VOLOLD, VOLNEW,
     *   CNOOLD, CNONEW, ANTS, CATNEW, BUFF1, BUFF2, IRET)
C-----------------------------------------------------------------------
C   ADJTAB copies all Table extension file(s).  The output files must
C   be new - old ones cannot be rewritten.  The output file must be
C   opened WRIT in the catalog and will have its CATBLK updated on disk.
C   Source, FQ, and antenna numbers are renumbered.
C   Inputs:
C      NONOT   I       Number of "Forbidden" types to copy.
C      NOTTYP  C*2(*)  Table types to ignore.
C      LUNOLD  I       LUN for old file
C      LUNNEW  I       LUN for new file
C      VOLOLD  I       Disk number for old file.
C      VOLNEW  I       Disk number for new file.
C      CNOOLD  I       Catalog slot number for old file
C      CNONEW  I       Catalog slot number for new file
C      ANTS    I(*,*)  New antenna numbers
C   In/out:
C      CATNEW  I(256)  Catalog header for new file.
C   Output:
C      BUFF1   I(1024) Work buffer
C      BUFF2   I(1024) Work buffer
C      IRET    I       Return error code  0 => ok, otherwise TABCOP
C                                             or 10*CATIO error.
C-----------------------------------------------------------------------
      INCLUDE 'INCS:PUVD.INC'
      CHARACTER NOTTYP(*)*2
      INTEGER   NONOT, LUNOLD, LUNNEW, VOLOLD, VOLNEW, CNOOLD, CNONEW,
     *   BUFF2(*), ANTS(MAXANT,*), CATNEW(256), IRET
      REAL      BUFF1(*)
C
      INCLUDE 'INCS:PHDR.INC'
      INTEGER   NKOLS
      PARAMETER (NKOLS=4)
      INTEGER   IVERI, IVERO, IER, NONON, IEXT, JEXT, OLDNUM(NIEXTN),
     *   NKEY, NCOL, DATP(128,2), NREC, KOLS(NKOLS), LKEY(NKOLS), RTYPE,
     *   VALUE(MAXIF), ISUB, LRNO, IREC, K, IANT, J, JJ,
     *   ROWB(XBPRSZ), IDUM(2), SUBKOL, IBUFF2(1024), IBUFF1(1024)
      HOLLERITH HDUM(2)
      EQUIVALENCE (IDUM, HDUM)
      LOGICAL   TABLE, EXIST, FITASC, DOPUT, DIDSOM, DIDONE
      CHARACTER OLDTYP(NIEXTN)*2, NONTAB(20)*2, KEYS(NKOLS)*8
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
C                                       Non table extension files
      DATA NONON /3/
      DATA NONTAB /'HI','PL','SL',17*'  '/
      DATA KEYS /'ANTENNA', 'REFANT 1', 'REFANT 2', 'ANTS'/
      DATA LKEY /7, 8, 8, 8/
C-----------------------------------------------------------------------
C                                       Get old CATBLK in BUFF2.
      CALL CATIO ('READ', VOLOLD, CNOOLD, BUFF2, 'REST', BUFF1, IRET)
      IF ((IRET.GE.1) .AND. (IRET.LE.4)) THEN
         WRITE (MSGTXT,1000) IRET
         CALL MSGWRT (6)
         IRET = 10 * IRET
         GO TO 999
         END IF
C                                       header ext format
      CALL FXHDEX (BUFF2)
C                                       Get extension file info
      DO 20 IEXT = 1,KIEXTN
         OLDTYP(IEXT) = ' '
         IDUM(1) = BUFF2(KHEXT+IEXT-1)
         CALL H2CHR (2, 1, HDUM, OLDTYP(IEXT))
         OLDNUM(IEXT) = BUFF2(KIVER+IEXT-1)
C                                       Check if on non table list
         DO 10 JEXT = 1,NONON
            IF (OLDTYP(IEXT).EQ.NONTAB(JEXT)) OLDNUM(IEXT) = 0
 10         CONTINUE
C                                       Check "forbidden" types
         IF (NONOT.GT.0) THEN
            DO 15 JEXT = 1,NONOT
               IF (OLDTYP(IEXT).EQ.NOTTYP(JEXT)) OLDNUM(IEXT) = 0
 15            CONTINUE
            END IF
 20      CONTINUE
C                                       Loop, copying tables.
      DO 100 IEXT = 1,KIEXTN
         IF (OLDNUM(IEXT).LE.0) GO TO 100
C                                       Copy each table independently
         DO 90 JEXT = 1,OLDNUM(IEXT)
C                                       See if files exist and are
C                                       wanted.
            CALL ISTAB (OLDTYP(IEXT), VOLOLD, CNOOLD, JEXT, LUNOLD,
     *         BUFF1, TABLE, EXIST, FITASC, IER)
            IF (TABLE .AND. EXIST .AND. (IER.EQ.0)) THEN
               IVERI = JEXT
               IVERO = JEXT
C                                       Copy
               CALL TABCOP (OLDTYP(IEXT), IVERI, IVERO, LUNOLD, LUNNEW,
     *            VOLOLD, VOLNEW, CNOOLD, CNONEW, CATNEW, IBUFF1,
     *            IBUFF2, IER)
               IRET = MAX (IER, IRET)
               IF (IER.NE.0) GO TO 90
C                                       Re-open output to update #s
               DIDSOM = .FALSE.
               NKEY = 0
               NCOL = 0
               CALL TABINI ('WRIT', OLDTYP(IEXT), VOLNEW, CNONEW, IVERO,
     *            CATNEW, LUNNEW, NKEY, NREC, NCOL, DATP, BUFF2, IER)
               IRET = MAX (IER, IRET)
               IF (IER.NE.0) GO TO 90
               NREC = BUFF2(5)
               CALL FILL (NKOLS, 0, KOLS)
               K = 0
               CALL FNDCOL (1, KEYS(1), LKEY(1), .TRUE., BUFF2, KOLS(1),
     *            IER)
               IF ((IER.GT.0) .AND. (IER.LE.10)) GO TO 85
               IF (IER.GT.10) K = K + IER - 10
               CALL FNDCOL (NKOLS-1, KEYS(2), LKEY(2), .TRUE., BUFF2,
     *            KOLS(2), IER)
               IF ((IER.GT.0) .AND. (IER.LE.10)) GO TO 85
               IER = IER + K
               IF (IER.GE.10+NKOLS) THEN
                  IER = 0
                  GO TO 85
                  END IF
C                                       subarray too
               SUBKOL = 0
               IF ((KOLS(1).GT.0) .OR. (KOLS(2).GT.0) .OR.
     *            (KOLS(3).GT.0) .OR. (KOLS(4).GT.0)) THEN
                  CALL FNDCOL (1, 'SUBARRAY', 7, .TRUE., BUFF2,
     *               SUBKOL, IER)
                  IF ((IER.GT.0) .AND. (IER.LE.10)) GO TO 85
                  END IF
               DO 80 IREC = 1,NREC
                  LRNO = 0
                  DIDONE = .FALSE.
C                                       subarray number
                  IF (SUBKOL.GT.0) THEN
                     CALL GETCOL (IREC, SUBKOL, DATP, LRNO, BUFF2,
     *                  RTYPE, IDUM, ROWB, IER)
                     ISUB = IDUM(1)
                     IF (IER.NE.0) GO TO 85
                     ISUB = MAX (1, ISUB)
                  ELSE
                     ISUB = 1
                     END IF
C                                       antenna number(s)
                  IANT = 0
                  DO 30 K = 1,4
                     IF (KOLS(K).GT.0) THEN
                        CALL GETCOL (IREC, KOLS(K), DATP, LRNO, BUFF2,
     *                     RTYPE, VALUE, ROWB, IER)
                        IF (IER.NE.0) GO TO 85
                        JJ = RTYPE / 10
                        JJ = MAX (1, JJ)
                        DOPUT = .FALSE.
                        DO 25 J = 1,JJ
                           IF ((VALUE(J).GT.0) .AND.
     *                        (ANTS(VALUE(1),ISUB).GT.0) .AND.
     *                        (ANTS(VALUE(J),ISUB).NE.VALUE(J))) THEN
                              VALUE(J) = ANTS(VALUE(J),ISUB)
                              DOPUT = .TRUE.
                              END IF
 25                        CONTINUE
                        IF (DOPUT) THEN
                           CALL PUTCOL (IREC, KOLS(K), DATP, LRNO,
     *                        BUFF2, VALUE, ROWB, IER)
                           IF (IER.NE.0) GO TO 85
                           DIDSOM = .TRUE.
                           DIDONE = .TRUE.
                           END IF
                        IF (K.EQ.2) IANT = VALUE(1)
                        END IF
 30                  CONTINUE
C                                       force write to disk
                  IF (DIDONE) THEN
                     CALL PUTCOL (0, KOLS, DATP, LRNO, BUFF2, VALUE,
     *                  ROWB, IER)
                     IF (IER.NE.0) GO TO 85
                     END IF
 80               CONTINUE
C                                       close table
 85            IRET = MAX (IRET, IER)
               CALL TABIO ('CLOS', 0, NREC, ROWB, BUFF2, IER)
               IRET = MAX (IRET, IER)
               IF (DIDSOM) THEN
                  WRITE (MSGTXT,1085) OLDTYP(IEXT), IVERO
                  CALL MSGWRT (2)
                  END IF
               END IF
 90         CONTINUE
 100     CONTINUE
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('ADJTAB: ERROR',I5,' READING OLD CATBLK')
 1085 FORMAT ('Source, FQ, and/or antenna #s adjusted in ',A,
     *   ' table version',I5)
      END
