LOCAL INCLUDE 'UVADD.INC'
C                                       Local include for UVADD
      INCLUDE 'INCS:ZPBUFSZ.INC'
      CHARACTER NAME*12, CLASS*6, NAME2*12, CLASS2*6, OUTNAM*12,
     *   OUTCLS*6, OPCODE*4
      HOLLERITH XNAME(3), XCLASS(2), XNAME2(3), XCLAS2(2), XONAME(3),
     *   XOCLAS(2), XOPCOD(1), CAT2H(256)
      REAL      XSEQ, XDISK, XSEQ2, XDISK2, XOSEQ, XODISK
      REAL      BUFF1(UVBFSS), BUFF2(UVBFSS), BUFFO(UVBFSS), CAT2R(256),
     *   XMAX
      DOUBLE PRECISION CAT2D(128), NSUM, SUM, SUMS
      LOGICAL   ISCMP1, ISCMP2, SINGLE
      INTEGER   LUN, FIND, CNO, SEQ, DISK, USERID, LUN2, FIND2,
     *   CNO2, SEQ2, DISK2, CAT2I(256), KLOCWT, LLOCWT, NRP1, NRP2,
     *   LREC2, LUNO, FINDO, CNOO, SEQO, DISKO, CATOLD(256),
     *   I1LOCB, I1LOCT, I1LOSA, I1LOA1, I1LOA2, I2LOCB, I2LOCT,
     *   I2LOSA, I2LOA1, I2LOA2, VISINC, VISMSG
C                                       Local include for UVADD
      COMMON /INPARM/ XNAME, XCLASS, XSEQ, XDISK, XNAME2, XCLAS2, XSEQ2,
     *   XDISK2, XONAME, XOCLAS, XOSEQ, XODISK, XOPCOD
      COMMON /CHPARM/ NAME, CLASS, NAME2, CLASS2, OUTNAM, OUTCLS, OPCODE
      COMMON /FNDUVC/ BUFF1, BUFF2, CATOLD, BUFFO, NSUM, SUM, SUMS,
     *   ISCMP1, ISCMP2, LUN, FIND, LUN2,FIND2, CNO, CNO2, SEQ, DISK,
     *   SEQ2, DISK2, USERID, KLOCWT, LLOCWT, NRP1, NRP2, LREC2, XMAX,
     *   I1LOCB, I1LOCT, I1LOSA, I1LOA1, I1LOA2, I2LOCB, I2LOCT, I2LOSA,
     *   I2LOA1, I2LOA2, SEQO, DISKO, CNOO, LUNO, FINDO, VISINC, VISMSG,
     *   SINGLE
      COMMON /MAP2HD/ CAT2I
      EQUIVALENCE (CAT2I, CAT2R, CAT2H, CAT2D)
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DFIL.INC'
LOCAL END
LOCAL INCLUDE 'BUFFS.INC'
      INCLUDE 'ZPBUFSZ.INC'
      REAL      LBUFF(UVBFSS), KBUFF(UVBFSS), KBUFF2(UVBFSS),
     *   LBUFF2(UVBFSS)
      COMMON /UVDUFS/ LBUFF, KBUFF, LBUFF2, KBUFF2
LOCAL END
      PROGRAM UVADD
C-----------------------------------------------------------------------
C! UVADD combines 2 data matching sets
C# UV UV-util
C-----------------------------------------------------------------------
C;  Copyright (C) 2019, 2021-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   UVADD is an AIPS system task to locate questionable data in a
C   catalogd UV data base and to print them.  Compares 2 data sets.
C   Inputs:
C     USERID    R         User number
C     INNAME    R(3)      File name: 12 chars
C     INCLASS   R(2)      File class: 6 chars
C     INSEQ     R         File seq #
C     INDISK    R         Disk volume on which file resides
C     IN2NAME   R(3)      File name: 12 chars
C     IN2CLASS  R(2)      File class: 6 chars
C     IN2SEQ    R         File seq #
C     IN2DISK   R         Disk volume on which file resides
C     CHANNEL   R         Spectral channel number
C     BIF       R         IF to test.
C     NITER     R         Limit on number of lines to print
C     UVRANGE   R(2)      Range of wavelengths to check in 1000s
C     OPCODE    R         Opcode: 4 chars ADD, SUBT, MULT, DIV
C-----------------------------------------------------------------------
      INTEGER   IRET
      INCLUDE 'UVADD.INC'
C-----------------------------------------------------------------------
C                                       Init, open file
      CALL UVADIN (IRET)
C                                       Do it
      IF (IRET.EQ.0) THEN
         IF (OPCODE.EQ.'DIV') THEN
            CALL UVADIV (IRET)
         ELSE IF (OPCODE.EQ.'MULT') THEN
            CALL UVADMU (IRET)
         ELSE IF (OPCODE.EQ.'ADD') THEN
            CALL UVADDD (IRET)
         ELSE
            CALL UVADSU (IRET)
            END IF
         END IF
C                                       history
      CALL UVADHI
C                                       Close up shop
      IRET = MAX (0, IRET)
      CALL DIE (IRET, BUFF1)
C
 999  STOP
      END
      SUBROUTINE UVADIN (IRET)
C-----------------------------------------------------------------------
C   UVADIN inits the task UVADV and opens the UV file and printer.
C   Outputs:
C      RQUICK   L    T => AIPS has been restarted
C      IRET     I    error code: 0 => keep going, else quit
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      CHARACTER PRGM*6, ITYPE*2, CTEMP1*8, CTEMP2*8, UTYPE*2, BLANK*6
      LOGICAL   F, EQUAL
      INTEGER   NPARM,I, J, IERR, INC, NT, IROUND
      DOUBLE PRECISION   DEPS
      INCLUDE 'UVADD.INC'
      DATA F /.FALSE./
      DATA PRGM /'UVADD '/
      DATA BLANK /' '/
C-----------------------------------------------------------------------
C                                       Init I/O
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      NSCR = 0
      NCFILE = 0
C                                       Get input parameters.
      NPARM = 22
      CALL GTPARM (PRGM, NPARM, RQUICK, XNAME, BUFF1, IRET)
      IF (IRET.EQ.0) GO TO 10
         RQUICK = .TRUE.
         IF (IRET.EQ.1) GO TO 999
C                                       Restart AIPS.
 10   IF (RQUICK) CALL RELPOP (IRET, BUFF1, IERR)
      IF (IRET.NE.0) GO TO 999
      IRET = 8
C                                       Hollerith -> char
      CALL H2CHR (12, 1, XNAME, NAME)
      CALL H2CHR (6, 1, XCLASS, CLASS)
      CALL H2CHR (12, 1, XNAME2, NAME2)
      CALL H2CHR (6, 1, XCLAS2, CLASS2)
      CALL H2CHR (12, 1, XONAME, OUTNAM)
      CALL H2CHR (6, 1, XOCLAS, OUTCLS)
      CALL H2CHR (4, 1, XOPCOD, OPCODE)
C                                       Decode input.
      USERID = NLUSER
      SEQ = IROUND (XSEQ)
      DISK = IROUND (XDISK)
      SEQ2 = IROUND (XSEQ2)
      DISK2 = IROUND (XDISK2)
      SEQO = IROUND (XOSEQ)
      DISKO = IROUND (XODISK)
C                                       Open file 2 and get CAT2.
      LUN2 = 17
      ITYPE = ' '
      CALL MAPOPN ('READ', DISK2, NAME2, CLASS2, SEQ2, ITYPE, USERID,
     *   LUN2, FIND2, CNO2, CAT2I, BUFF2, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING 2ND INPUT UV FILE'
         CALL MSGWRT (8)
         GO TO 940
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISK2
      FCNO(NCFILE) = CNO2
      FRW(NCFILE) = 0
      ISCMP2 = CAT2I(KINAX).EQ.1
      NRP2 = CAT2I(KIPCN)
      CALL COPY (256, CAT2I, CATBLK)
      CALL UVPGET (IERR)
      IF (IERR.NE.0) GO TO 950
      LREC2 = LREC
      I2LOCB = ILOCB
      I2LOCT = ILOCT
      I2LOSA = ILOCSA
      I2LOA1 = ILOCA1
      I2LOA2 = ILOCA2
C                                       Open file and get CATBLK.
      LUN = 16
      UTYPE = 'UV'
      CALL MAPOPN ('READ', DISK, NAME, CLASS, SEQ, UTYPE, USERID, LUN,
     *   FIND, CNO, CATBLK, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING 1ST INPUT UV FILE'
         CALL MSGWRT (8)
         GO TO 999
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISK
      FCNO(NCFILE) = CNO
      FRW(NCFILE) = 0
C                                       Get info from CATBLK.
      CALL UVPGET (IERR)
      IF (IERR.NE.0) GO TO 950
      I1LOCB = ILOCB
      I1LOCT = ILOCT
      I1LOSA = ILOCSA
      I1LOA1 = ILOCA1
      I1LOA2 = ILOCA2
      CALL COPY (256, CATBLK, CATOLD)
      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                                       Compressed?
      ISCMP1 = CATBLK(KINAX).EQ.1
      NRP1 = CATBLK(KIPCN)
C                                       Compare headers
      EQUAL = ITYPE.EQ.'SC'
      SINGLE = .FALSE.
      IF (ITYPE.NE.'SC') THEN
         IF (ABS(CATBLK(KIGCN)-CAT2I(KIGCN)).NE.0) GO TO 49
         IF (CATBLK(KIDIM).NE.CAT2I(KIDIM)) GO TO 49
         INC = 2
         NT = CATBLK(KIDIM)
         IF (NT.GT.4) NT = 4
         DO 45 I = 2,NT
            J = KHCTP + (I-1) * INC
            CALL H2CHR (8, 1, CATH(J), CTEMP1)
            CALL H2CHR (8, 1, CAT2H(J), CTEMP2)
            IF (CTEMP1.NE.CTEMP2) GO TO 49
            J = I - 1
            DEPS = 0.01 * ABS(CATR(KRCIC+J))
            IF (DEPS.LE.0.0D0) DEPS = 1.0D-4
            IF (CATBLK(KINAX+J).NE.CAT2I(KINAX+J)) THEN
               IF ((CAT2I(KINAX+J).NE.1) .OR. (CTEMP1.NE.'FREQ'))
     *            GO TO 49
               SINGLE= .TRUE.
               END IF
            IF (ABS(CATR(KRCRP+J)-CAT2R(KRCRP+J)).GT.DEPS) GO TO 49
            IF (ABS(CATD(KDCRV+J)-CAT2D(KDCRV+J)).GT.DEPS) GO TO 49
            IF (ABS(CATR(KRCIC+J)-CAT2R(KRCIC+J)).GT.DEPS) GO TO 49
 45         CONTINUE
         GO TO 50
C                                       no match
 49      CONTINUE
            WRITE (MSGTXT,1049)
            CALL MSGWRT (8)
            GO TO 940
         END IF
C                                       now create output file
 50   CALL MAKOUT (NAME, CLASS, SEQ, BLANK,  OUTNAM, OUTCLS, SEQO)
      CALL CHR2H (12, OUTNAM, KHIMNO, CATH(KHIMN))
      CALL CHR2H (6, OUTCLS, KHIMCO, CATH(KHIMC))
      CATBLK(KIIMS) = SEQO
      CALL UVCREA (DISKO, CNOO, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         MSGTXT = 'FAILS TO CREATE UV OUTPUT FILE'
         CALL MSGWRT (8)
         GO TO 940
         END IF
      LUNO = 18
      CALL MAPOPN ('INIT', DISKO, OUTNAM, OUTCLS, SEQO, ITYPE, USERID,
     *   LUNO, FINDO, CNOO, CATBLK, BUFFO, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING OUTPUT UV FILE'
         CALL MSGWRT (8)
         GO TO 940
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKO
      FCNO(NCFILE) = CNOO
      FRW(NCFILE) = 2
      IRET = 0
      GO TO 999
C                                       Close map on error
 940  CALL MAPCLS ('READ', DISK2, CNO2, LUN2, FIND2, CAT2I, F, BUFF2,
     *    IERR)
      IF (IERR.EQ.0) GO TO 950
         WRITE (MSGTXT,1000) IERR, 'CLOSING 2ND INPUT UV FILE'
         CALL MSGWRT (6)
 950  CALL MAPCLS ('READ', DISK, CNO, LUN, FIND, CATBLK, F, BUFF1, IERR)
      IF (IERR.EQ.0) GO TO 999
         WRITE (MSGTXT,1000) IERR, 'CLOSING 1ST INPUT UV FILE'
         CALL MSGWRT (6)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('UVADIN ERROR',I4,' ON ',A)
 1049 FORMAT ('HEADERS DO NOT MATCH')
      END
      SUBROUTINE UVADSU (IRET)
C-----------------------------------------------------------------------
C   UVADPR reads the UV files and subtracts the vis
C   Output:
C      IRET   I   Return code: 0 success or user requests end, else bad
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'UVADD.INC'
      LOGICAL   F, T
      INTEGER   DPTR, BINDO, CMAX, JIF, JF, JS, JIMAX, JFMAX, JSMAX,
     *   NIOLIM, NUMST, NUMCH, NUMIF, OPINT, BO, BIND, BIND2, VO, COUNT,
     *   BUFSZ, INDEX, NIOUT, IERR, IPINT, IPIN2, J, LRECA, LRECF,
     *   NCORR, NIO, NIO2, XCOUNT, LENBU, JERR, RNXRET, INDEX2
      REAL      XR, XI, XA
      INCLUDE 'BUFFS.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:PUVD.INC'
      DATA T, F /.TRUE.,.FALSE./
      DATA LENBU, BO, VO /0, 1, 0/
C-----------------------------------------------------------------------
      IRET = 8
      XMAX = -1.0
      NSUM = 0.0D0
      SUM = 0.0D0
      SUMS = 0.0D0
C                                       Set up for compressed data.
      NCORR = (LREC - NRPARM) / CATBLK(KINAX)
      LRECF = 3 * NCORR
      DPTR = 1 + MAX (NRP1, NRP2)
      LRECA = LRECF + DPTR - 1
      CALL AXEFND (8, 'WEIGHT  ', CATBLK(KIPCN), CATH(KHPTP), KLOCWT,
     *   JERR)
      IF (ISCMP1 .AND. ((JERR.NE.0) .OR. (KLOCWT.LT.0))) THEN
         IRET = 5
         MSGTXT = 'CANNOT FIND WEIGHT AND SCALE FOR COMPRESSED DATA'
         CALL MSGWRT (8)
         GO TO 999
         END IF
      CALL AXEFND (8, 'WEIGHT  ', CAT2I(KIPCN), CAT2H(KHPTP), LLOCWT,
     *   JERR)
      IF (ISCMP2 .AND. ((JERR.NE.0) .OR. (LLOCWT.LT.0))) THEN
         IRET = 5
         MSGTXT = 'CANNOT FIND WEIGHT AND SCALE FOR COMPRESSED DATA'
         CALL MSGWRT (8)
         GO TO 999
         END IF
C                                       Initialize difference statistics
      NUMCH = CATBLK(KINAX+JLOCF)
      NUMIF = CATBLK(KINAX+JLOCIF)
      NUMST = CATBLK(KINAX+JLOCS)
C                                       Initialize reading VIS. file.
      LENBU = 0
      BUFSZ = UVBFSS * 2
      CALL UVINIT ('READ', LUN, FIND, NVIS, VO, LREC, LENBU, BUFSZ,
     *   BUFF1, BO, BIND, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING 1ST INPUT UV FILE'
         GO TO 900
         END IF
      CALL UVINIT ('READ', LUN2, FIND2, NVIS, VO, LREC2, LENBU, BUFSZ,
     *   BUFF2, BO, BIND2, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING 2ND INPUT UV FILE'
         GO TO 900
         END IF
      CALL UVINIT ('WRIT', LUNO, FINDO, NVIS, VO, LREC, LENBU, BUFSZ,
     *   BUFFO, BO, BINDO, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING 1ST INPUT UV FILE'
         GO TO 900
         END IF
      NIOLIM = LENBU
      COUNT = 0
      NIOUT = 0
C                                       make an index table
      CALL RNXGET (DISK, CNO, CATOLD)
      CALL RNXINI (DISKO, CNOO, CATBLK, RNXRET)
C                                       Start looping thru data.
 100  CONTINUE
C                                       Read buffer.
         COUNT = COUNT + 1
         CALL UVDISK ('READ', LUN, FIND, BUFF1, NIO, BIND, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1001) IERR, COUNT, 'READING 1ST UV FILE'
            GO TO 900
            END IF
         CALL UVDISK ('READ', LUN2, FIND2, BUFF2, NIO2, BIND2, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1001) IERR, COUNT, 'READING 2ND UV FILE'
            GO TO 900
            END IF
         IPINT = BIND - LREC
         IPIN2 = BIND2 - LREC2
         OPINT = BINDO
         NIO = MIN (NIO2, NIO)
         IF (NIO.LE.0) GO TO 200
C                                       Loop thru buffer.
         DO 175 J = 1,NIO
C                                       Update counters
            XCOUNT = XCOUNT + 1
            IPINT = IPINT + LREC
            IPIN2 = IPIN2 + LREC2
            IF (MOD(XCOUNT-1,VISMSG).EQ.0) THEN
               WRITE (MSGTXT,1105) XCOUNT
               CALL MSGWRT (2)
            ELSE IF (MOD(XCOUNT-1,VISINC).EQ.0) THEN
               WRITE (MSGTXT,1105) XCOUNT
               CALL MSGWRT (1)
               END IF
C                                       matching?
            IF (I1LOCB.GE.0) THEN
               IF (BUFF1(IPINT+I1LOCB).NE.BUFF2(IPIN2+I2LOCB)) GO TO 890
            ELSE
               IF (BUFF1(IPINT+I1LOSA).NE.BUFF2(IPIN2+I2LOSA)) GO TO 890
               IF (BUFF1(IPINT+I1LOA1).NE.BUFF2(IPIN2+I2LOA1)) GO TO 890
               IF (BUFF1(IPINT+I1LOA2).NE.BUFF2(IPIN2+I2LOA2)) GO TO 890
               END IF
            IF (ABS(BUFF1(IPINT+I1LOCT)-BUFF2(IPIN2+I2LOCT)).GT.1.E-7)
     *         GO TO 890
C                                       Compressed?
            CALL RCOPY (NRP1, BUFF1(IPINT), KBUFF)
            IF (ISCMP1) THEN
               CALL ZUVXPN (NCORR, BUFF1(IPINT+NRP1),
     *            BUFF1(IPINT+KLOCWT), KBUFF(DPTR))
            ELSE
               CALL RCOPY (LRECF, BUFF1(IPINT+NRP1), KBUFF(DPTR))
               END IF
            CALL RCOPY (NRP2, BUFF2(IPIN2), KBUFF2)
            IF (ISCMP2) THEN
               CALL ZUVXPN (NCORR, BUFF2(IPIN2+NRP2),
     *            BUFF2(IPIN2+LLOCWT), KBUFF2(DPTR))
            ELSE
               CALL RCOPY (LRECF, BUFF2(IPIN2+NRP2), KBUFF2(DPTR))
               END IF
C                                       prepare output
            CALL RCOPY (NRP1, BUFF1(IPINT),  BUFFO(OPINT))
C                                       update NX table
            CALL RNXUPD (BUFF1(IPINT), RNXRET)
            DO 130 JIF = 1,NUMIF
               DO 120 JS = 1,NUMST
                  INDEX2 = (JIF-1) * INCIF/NUMCH + (JS-1) * INCS
                  DO 110 JF = 1,NUMCH
                     INDEX = (JIF-1) * INCIF + (JF-1) * INCF +
     *                  (JS-1) * INCS
                     IF (.NOT.SINGLE) INDEX2 = INDEX
                     XR = KBUFF(DPTR+INDEX) - KBUFF2(DPTR+INDEX2)
                     XI = KBUFF(DPTR+INDEX+1) - KBUFF2(DPTR+INDEX2+1)
                     KBUFF(DPTR+INDEX) = XR
                     KBUFF(DPTR+INDEX+1) = XI
                     XA = SQRT (XR*XR + XI*XI)
                     IF (XA.GT.XMAX) THEN
                        XMAX = XA
                        JIMAX = JIF
                        JFMAX = JF
                        JSMAX = JS
                        CMAX = XCOUNT
                        END IF
                     NSUM = NSUM + 1.0D0
                     SUM = SUM + XA
                     SUMS = SUMS + XA * XA
 110                 CONTINUE
 120              CONTINUE
 130           CONTINUE
            IF (ISCMP1) THEN
               CALL ZUVPAK (NCORR, KBUFF(DPTR), BUFFO(OPINT+KLOCWT),
     *            BUFFO(OPINT+NRP1))
            ELSE
               CALL RCOPY (LRECF, KBUFF(DPTR), BUFFO(OPINT+NRP1))
               END IF
            OPINT = OPINT + LREC
            NIOUT = NIOUT + 1
            IF (NIOUT.GE.NIOLIM) THEN
               CALL UVDISK ('WRIT', LUNO, FINDO, BUFFO, NIOLIM, BINDO,
     *            IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITING OUTPUT UV DATA'
                  GO TO 900
                  END IF
               OPINT = BINDO
               NIOUT = 0
               END IF
 175        CONTINUE
         GO TO 100
C                                       Finish write
 200  NIOUT = - NIOUT
      CALL UVDISK ('FLSH', LUNO, FINDO, BUFFO, NIOUT, BINDO, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'FLUSHING OUTPUT UV DATA'
         GO TO 900
         END IF
      IRET = 0
      GO TO 900
C                                       mismatch
 890  WRITE (MSGTXT,1890) COUNT
      IERR = 10
C                                       first input file
 900  IF (IERR.NE.0) CALL MSGWRT (8)
C
      WRITE (MSGTXT,1900) XMAX, CMAX, JSMAX, JFMAX, JIMAX
      CALL MSGWRT (5)
      IF (NSUM.GE.1.0D0) THEN
         SUM = SUM / NSUM
         SUMS = SUMS/NSUM - SUM * SUM
         SUMS = SQRT (MAX (0.0D0, SUMS))
         WRITE (MSGTXT,1901) SUM, SUMS, NSUM
         CALL MSGWRT (5)
         END IF
      CALL MAPCLS ('READ', DISK, CNO, LUN, FIND, CATOLD, F, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'CLOSING INPUT FILE 1'
         CALL MSGWRT (6)
         END IF
      CALL MAPCLS ('READ', DISK2, CNO2, LUN2, FIND2, CAT2I, F, BUFF1,
     *   IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'CLOSING INPUT FILE 2'
         CALL MSGWRT (6)
         END IF
      CALL MAPCLS ('WRIT', DISKO, CNOO, LUNO, FINDO, CATBLK, T, BUFF1,
     *   IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'CLOSING OUTPUT FILE'
         CALL MSGWRT (6)
         END IF
      CALL RNXCLS (RNXRET)
      IF (RNXRET.NE.0) THEN
         MSGTXT = 'OUTPUT NX TABLE, IF ANY, IS INCOMPLETE'
         CALL MSGWRT (7)
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('UVADSU ERROR',I4,' ON ',A)
 1001 FORMAT ('UVADSU ERROR',I4,' COUNT',I10,' ON ',A)
 1105 FORMAT ('UVADSU: at visibility record',I10)
 1890 FORMAT ('UVADSU MISMATCH AT COUNT',I10)
 1900 FORMAT ('UVADSU Max',1PE11.3,'  Count,st,fr,if',I10,I2,I7,I3)
 1901 FORMAT ('UVADSU Mean, rms',2(1PE11.3),' from',F13.0,' samples')
      END
      SUBROUTINE UVADDD (IRET)
C-----------------------------------------------------------------------
C   UVADPR reads the UV files and adds the vis
C   Output:
C      IRET   I   Return code: 0 success or user requests end, else bad
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'UVADD.INC'
      LOGICAL   F, T
      INTEGER   DPTR, BINDO, CMAX, JIF, JF, JS, JIMAX, JFMAX, JSMAX,
     *   NIOLIM, NUMST, NUMCH, NUMIF, OPINT, BO, BIND, BIND2, VO, COUNT,
     *   BUFSZ, INDEX, NIOUT, IERR, IPINT, IPIN2, J, LRECA, LRECF,
     *   NCORR, NIO, NIO2, XCOUNT, LENBU, JERR, RNXRET, INDEX2
      REAL      XR, XI, XA
      INCLUDE 'BUFFS.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:PUVD.INC'
      DATA T, F /.TRUE.,.FALSE./
      DATA LENBU, BO, VO /0, 1, 0/
C-----------------------------------------------------------------------
      IRET = 8
      XMAX = -1.0
      NSUM = 0.0D0
      SUM = 0.0D0
      SUMS = 0.0D0
C                                       Set up for compressed data.
      NCORR = (LREC - NRPARM) / CATBLK(KINAX)
      LRECF = 3 * NCORR
      DPTR = 1 + MAX (NRP1, NRP2)
      LRECA = LRECF + DPTR - 1
      CALL AXEFND (8, 'WEIGHT  ', CATBLK(KIPCN), CATH(KHPTP), KLOCWT,
     *   JERR)
      IF (ISCMP1 .AND. ((JERR.NE.0) .OR. (KLOCWT.LT.0))) THEN
         IRET = 5
         MSGTXT = 'CANNOT FIND WEIGHT AND SCALE FOR COMPRESSED DATA'
         CALL MSGWRT (8)
         GO TO 999
         END IF
      CALL AXEFND (8, 'WEIGHT  ', CAT2I(KIPCN), CAT2H(KHPTP), LLOCWT,
     *   JERR)
      IF (ISCMP2 .AND. ((JERR.NE.0) .OR. (LLOCWT.LT.0))) THEN
         IRET = 5
         MSGTXT = 'CANNOT FIND WEIGHT AND SCALE FOR COMPRESSED DATA'
         CALL MSGWRT (8)
         GO TO 999
         END IF
C                                       Initialize difference statistics
      NUMCH = CATBLK(KINAX+JLOCF)
      NUMIF = CATBLK(KINAX+JLOCIF)
      NUMST = CATBLK(KINAX+JLOCS)
C                                       Initialize reading VIS. file.
      LENBU = 0
      BUFSZ = UVBFSS * 2
      CALL UVINIT ('READ', LUN, FIND, NVIS, VO, LREC, LENBU, BUFSZ,
     *   BUFF1, BO, BIND, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING 1ST INPUT UV FILE'
         GO TO 900
         END IF
      CALL UVINIT ('READ', LUN2, FIND2, NVIS, VO, LREC2, LENBU, BUFSZ,
     *   BUFF2, BO, BIND2, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING 2ND INPUT UV FILE'
         GO TO 900
         END IF
      CALL UVINIT ('WRIT', LUNO, FINDO, NVIS, VO, LREC, LENBU, BUFSZ,
     *   BUFFO, BO, BINDO, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING 1ST INPUT UV FILE'
         GO TO 900
         END IF
      NIOLIM = LENBU
      COUNT = 0
      NIOUT = 0
C                                       make an index table
      CALL RNXGET (DISK, CNO, CATOLD)
      CALL RNXINI (DISKO, CNOO, CATBLK, RNXRET)
C                                       Start looping thru data.
 100  CONTINUE
C                                       Read buffer.
         COUNT = COUNT + 1
         CALL UVDISK ('READ', LUN, FIND, BUFF1, NIO, BIND, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1001) IERR, COUNT, 'READING 1ST UV FILE'
            GO TO 900
            END IF
         CALL UVDISK ('READ', LUN2, FIND2, BUFF2, NIO2, BIND2, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1001) IERR, COUNT, 'READING 2ND UV FILE'
            GO TO 900
            END IF
         IPINT = BIND - LREC
         IPIN2 = BIND2 - LREC2
         OPINT = BINDO
         NIO = MIN (NIO2, NIO)
         IF (NIO.LE.0) GO TO 200
C                                       Loop thru buffer.
         DO 175 J = 1,NIO
C                                       Update counters
            XCOUNT = XCOUNT + 1
            IPINT = IPINT + LREC
            IPIN2 = IPIN2 + LREC2
            IF (MOD(XCOUNT-1,VISMSG).EQ.0) THEN
               WRITE (MSGTXT,1105) XCOUNT
               CALL MSGWRT (2)
            ELSE IF (MOD(XCOUNT-1,VISINC).EQ.0) THEN
               WRITE (MSGTXT,1105) XCOUNT
               CALL MSGWRT (1)
               END IF
C                                       matching?
            IF (I1LOCB.GE.0) THEN
               IF (BUFF1(IPINT+I1LOCB).NE.BUFF2(IPIN2+I2LOCB)) GO TO 890
            ELSE
               IF (BUFF1(IPINT+I1LOSA).NE.BUFF2(IPIN2+I2LOSA)) GO TO 890
               IF (BUFF1(IPINT+I1LOA1).NE.BUFF2(IPIN2+I2LOA1)) GO TO 890
               IF (BUFF1(IPINT+I1LOA2).NE.BUFF2(IPIN2+I2LOA2)) GO TO 890
               END IF
            IF (ABS(BUFF1(IPINT+I1LOCT)-BUFF2(IPIN2+I2LOCT)).GT.1.E-7)
     *         GO TO 890
C                                       Compressed?
            CALL RCOPY (NRP1, BUFF1(IPINT), KBUFF)
            IF (ISCMP1) THEN
               CALL ZUVXPN (NCORR, BUFF1(IPINT+NRP1),
     *            BUFF1(IPINT+KLOCWT), KBUFF(DPTR))
            ELSE
               CALL RCOPY (LRECF, BUFF1(IPINT+NRP1), KBUFF(DPTR))
               END IF
            CALL RCOPY (NRP2, BUFF2(IPIN2), KBUFF2)
            IF (ISCMP2) THEN
               CALL ZUVXPN (NCORR, BUFF2(IPIN2+NRP2),
     *            BUFF2(IPIN2+LLOCWT), KBUFF2(DPTR))
            ELSE
               CALL RCOPY (LRECF, BUFF2(IPIN2+NRP2), KBUFF2(DPTR))
               END IF
C                                       prepare output
            CALL RCOPY (NRP1, BUFF1(IPINT),  BUFFO(OPINT))
C                                       update NX table
            CALL RNXUPD (BUFF1(IPINT), RNXRET)
            DO 130 JIF = 1,NUMIF
               DO 120 JS = 1,NUMST
                  INDEX2 = (JIF-1) * INCIF/NUMCH + (JS-1) * INCS
                  DO 110 JF = 1,NUMCH
                     INDEX = (JIF-1) * INCIF + (JF-1) * INCF +
     *                  (JS-1) * INCS
                     IF (.NOT.SINGLE) INDEX2 = INDEX
                     XR = KBUFF(DPTR+INDEX) + KBUFF2(DPTR+INDEX2)
                     XI = KBUFF(DPTR+INDEX+1) + KBUFF2(DPTR+INDEX2+1)
                     KBUFF(DPTR+INDEX) = XR
                     KBUFF(DPTR+INDEX+1) = XI
                     XA = SQRT (XR*XR + XI*XI)
                     IF (XA.GT.XMAX) THEN
                        XMAX = XA
                        JIMAX = JIF
                        JFMAX = JF
                        JSMAX = JS
                        CMAX = XCOUNT
                        END IF
                     NSUM = NSUM + 1.0D0
                     SUM = SUM + XA
                     SUMS = SUMS + XA * XA
 110                 CONTINUE
 120              CONTINUE
 130           CONTINUE
            IF (ISCMP1) THEN
               CALL ZUVPAK (NCORR, KBUFF(DPTR), BUFFO(OPINT+KLOCWT),
     *            BUFFO(OPINT+NRP1))
            ELSE
               CALL RCOPY (LRECF, KBUFF(DPTR), BUFFO(OPINT+NRP1))
               END IF
            OPINT = OPINT + LREC
            NIOUT = NIOUT + 1
            IF (NIOUT.GE.NIOLIM) THEN
               CALL UVDISK ('WRIT', LUNO, FINDO, BUFFO, NIOLIM, BINDO,
     *            IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITING OUTPUT UV DATA'
                  GO TO 900
                  END IF
               OPINT = BINDO
               NIOUT = 0
               END IF
 175        CONTINUE
         GO TO 100
C                                       Finish write
 200  NIOUT = - NIOUT
      CALL UVDISK ('FLSH', LUNO, FINDO, BUFFO, NIOUT, BINDO, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'FLUSHING OUTPUT UV DATA'
         GO TO 900
         END IF
      IRET = 0
      GO TO 900
C                                       mismatch
 890  WRITE (MSGTXT,1890) COUNT
      IERR = 10
C                                       first input file
 900  IF (IERR.NE.0) CALL MSGWRT (8)
C
      WRITE (MSGTXT,1900) XMAX, CMAX, JSMAX, JFMAX, JIMAX
      CALL MSGWRT (5)
      IF (NSUM.GE.1.0D0) THEN
         SUM = SUM / NSUM
         SUMS = SUMS/NSUM - SUM * SUM
         SUMS = SQRT (MAX (0.0D0, SUMS))
         WRITE (MSGTXT,1901) SUM, SUMS, NSUM
         CALL MSGWRT (5)
         END IF
      CALL MAPCLS ('READ', DISK, CNO, LUN, FIND, CATOLD, F, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'CLOSING INPUT FILE 1'
         CALL MSGWRT (6)
         END IF
      CALL MAPCLS ('READ', DISK2, CNO2, LUN2, FIND2, CAT2I, F, BUFF1,
     *   IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'CLOSING INPUT FILE 2'
         CALL MSGWRT (6)
         END IF
      CALL MAPCLS ('WRIT', DISKO, CNOO, LUNO, FINDO, CATBLK, T, BUFF1,
     *   IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'CLOSING OUTPUT FILE'
         CALL MSGWRT (6)
         END IF
      CALL RNXCLS (RNXRET)
      IF (RNXRET.NE.0) THEN
         MSGTXT = 'OUTPUT NX TABLE, IF ANY, IS INCOMPLETE'
         CALL MSGWRT (7)
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('UVADDD ERROR',I4,' ON ',A)
 1001 FORMAT ('UVADDD ERROR',I4,' COUNT',I10,' ON ',A)
 1105 FORMAT ('UVADDD: at visibility record',I10)
 1890 FORMAT ('UVADDD MISMATCH AT COUNT',I10)
 1900 FORMAT ('UVADDD Max',1PE11.3,'  Count,st,fr,if',I10,I2,I7,I3)
 1901 FORMAT ('UVADDD Mean, rms',2(1PE11.3),' from',F13.0,' samples')
      END
      SUBROUTINE UVADMU (IRET)
C-----------------------------------------------------------------------
C   UVADPR reads the UV files and multiplies the vis
C   Output:
C      IRET   I   Return code: 0 success or user requests end, else bad
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'UVADD.INC'
      LOGICAL   F, T
      INTEGER   DPTR, BINDO, CMAX, JIF, JF, JS, JIMAX, JFMAX, JSMAX,
     *   NIOLIM, NUMST, NUMCH, NUMIF, OPINT, BO, BIND, BIND2, VO, COUNT,
     *   BUFSZ, INDEX, NIOUT, IERR, IPINT, IPIN2, J, LRECA, LRECF,
     *   NCORR, NIO, NIO2, XCOUNT, LENBU, JERR, RNXRET, INDEX2
      REAL      XR, XI, XA
      INCLUDE 'BUFFS.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:PUVD.INC'
      DATA T, F /.TRUE.,.FALSE./
      DATA LENBU, BO, VO /0, 1, 0/
C-----------------------------------------------------------------------
      IRET = 8
      XMAX = -1.0
      NSUM = 0.0D0
      SUM = 0.0D0
      SUMS = 0.0D0
C                                       Set up for compressed data.
      NCORR = (LREC - NRPARM) / CATBLK(KINAX)
      LRECF = 3 * NCORR
      DPTR = 1 + MAX (NRP1, NRP2)
      LRECA = LRECF + DPTR - 1
      CALL AXEFND (8, 'WEIGHT  ', CATBLK(KIPCN), CATH(KHPTP), KLOCWT,
     *   JERR)
      IF (ISCMP1 .AND. ((JERR.NE.0) .OR. (KLOCWT.LT.0))) THEN
         IRET = 5
         MSGTXT = 'CANNOT FIND WEIGHT AND SCALE FOR COMPRESSED DATA'
         CALL MSGWRT (8)
         GO TO 999
         END IF
      CALL AXEFND (8, 'WEIGHT  ', CAT2I(KIPCN), CAT2H(KHPTP), LLOCWT,
     *   JERR)
      IF (ISCMP2 .AND. ((JERR.NE.0) .OR. (LLOCWT.LT.0))) THEN
         IRET = 5
         MSGTXT = 'CANNOT FIND WEIGHT AND SCALE FOR COMPRESSED DATA'
         CALL MSGWRT (8)
         GO TO 999
         END IF
C                                       Initialize difference statistics
      NUMCH = CATBLK(KINAX+JLOCF)
      NUMIF = CATBLK(KINAX+JLOCIF)
      NUMST = CATBLK(KINAX+JLOCS)
C                                       Initialize reading VIS. file.
      LENBU = 0
      BUFSZ = UVBFSS * 2
      CALL UVINIT ('READ', LUN, FIND, NVIS, VO, LREC, LENBU, BUFSZ,
     *   BUFF1, BO, BIND, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING 1ST INPUT UV FILE'
         GO TO 900
         END IF
      CALL UVINIT ('READ', LUN2, FIND2, NVIS, VO, LREC2, LENBU, BUFSZ,
     *   BUFF2, BO, BIND2, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING 2ND INPUT UV FILE'
         GO TO 900
         END IF
      CALL UVINIT ('WRIT', LUNO, FINDO, NVIS, VO, LREC, LENBU, BUFSZ,
     *   BUFFO, BO, BINDO, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING 1ST INPUT UV FILE'
         GO TO 900
         END IF
      NIOLIM = LENBU
      COUNT = 0
      NIOUT = 0
C                                       make an index table
      CALL RNXGET (DISK, CNO, CATOLD)
      CALL RNXINI (DISKO, CNOO, CATBLK, RNXRET)
C                                       Start looping thru data.
 100  CONTINUE
C                                       Read buffer.
         COUNT = COUNT + 1
         CALL UVDISK ('READ', LUN, FIND, BUFF1, NIO, BIND, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1001) IERR, COUNT, 'READING 1ST UV FILE'
            GO TO 900
            END IF
         CALL UVDISK ('READ', LUN2, FIND2, BUFF2, NIO2, BIND2, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1001) IERR, COUNT, 'READING 2ND UV FILE'
            GO TO 900
            END IF
         IPINT = BIND - LREC
         IPIN2 = BIND2 - LREC2
         OPINT = BINDO
         NIO = MIN (NIO2, NIO)
         IF (NIO.LE.0) GO TO 200
C                                       Loop thru buffer.
         DO 175 J = 1,NIO
C                                       Update counters
            XCOUNT = XCOUNT + 1
            IPINT = IPINT + LREC
            IPIN2 = IPIN2 + LREC2
            IF (MOD(XCOUNT-1,VISMSG).EQ.0) THEN
               WRITE (MSGTXT,1105) XCOUNT
               CALL MSGWRT (2)
            ELSE IF (MOD(XCOUNT-1,VISINC).EQ.0) THEN
               WRITE (MSGTXT,1105) XCOUNT
               CALL MSGWRT (1)
               END IF
C                                       matching?
            IF (I1LOCB.GE.0) THEN
               IF (BUFF1(IPINT+I1LOCB).NE.BUFF2(IPIN2+I2LOCB)) GO TO 890
            ELSE
               IF (BUFF1(IPINT+I1LOSA).NE.BUFF2(IPIN2+I2LOSA)) GO TO 890
               IF (BUFF1(IPINT+I1LOA1).NE.BUFF2(IPIN2+I2LOA1)) GO TO 890
               IF (BUFF1(IPINT+I1LOA2).NE.BUFF2(IPIN2+I2LOA2)) GO TO 890
               END IF
            IF (ABS(BUFF1(IPINT+I1LOCT)-BUFF2(IPIN2+I2LOCT)).GT.1.E-7)
     *         GO TO 890
C                                       Compressed?
            CALL RCOPY (NRP1, BUFF1(IPINT), KBUFF)
            IF (ISCMP1) THEN
               CALL ZUVXPN (NCORR, BUFF1(IPINT+NRP1),
     *            BUFF1(IPINT+KLOCWT), KBUFF(DPTR))
            ELSE
               CALL RCOPY (LRECF, BUFF1(IPINT+NRP1), KBUFF(DPTR))
               END IF
            CALL RCOPY (NRP2, BUFF2(IPIN2), KBUFF2)
            IF (ISCMP2) THEN
               CALL ZUVXPN (NCORR, BUFF2(IPIN2+NRP2),
     *            BUFF2(IPIN2+LLOCWT), KBUFF2(DPTR))
            ELSE
               CALL RCOPY (LRECF, BUFF2(IPIN2+NRP2), KBUFF2(DPTR))
               END IF
C                                       prepare output
            CALL RCOPY (NRP1, BUFF1(IPINT),  BUFFO(OPINT))
C                                       update NX table
            CALL RNXUPD (BUFF1(IPINT), RNXRET)
            DO 130 JIF = 1,NUMIF
               DO 120 JS = 1,NUMST
                  INDEX2 = (JIF-1) * INCIF/NUMCH + (JS-1) * INCS
                  DO 110 JF = 1,NUMCH
                     INDEX = (JIF-1) * INCIF + (JF-1) * INCF +
     *                  (JS-1) * INCS
                     XR = KBUFF(DPTR+INDEX) * KBUFF2(DPTR+INDEX2) -
     *                  KBUFF(DPTR+INDEX+1) * KBUFF2(DPTR+INDEX2+1)
                     XI = KBUFF(DPTR+INDEX) * KBUFF2(DPTR+INDEX2+1) +
     *                  KBUFF(DPTR+INDEX+1) + KBUFF2(DPTR+INDEX2)
                     KBUFF(DPTR+INDEX) = XR
                     KBUFF(DPTR+INDEX+1) = XI
                     XA = SQRT (XR*XR + XI*XI)
                     IF (XA.GT.XMAX) THEN
                        XMAX = XA
                        JIMAX = JIF
                        JFMAX = JF
                        JSMAX = JS
                        CMAX = XCOUNT
                        END IF
                     NSUM = NSUM + 1.0D0
                     SUM = SUM + XA
                     SUMS = SUMS + XA * XA
 110                 CONTINUE
 120              CONTINUE
 130           CONTINUE
            IF (ISCMP1) THEN
               CALL ZUVPAK (NCORR, KBUFF(DPTR), BUFFO(OPINT+KLOCWT),
     *            BUFFO(OPINT+NRP1))
            ELSE
               CALL RCOPY (LRECF, KBUFF(DPTR), BUFFO(OPINT+NRP1))
               END IF
            OPINT = OPINT + LREC
            NIOUT = NIOUT + 1
            IF (NIOUT.GE.NIOLIM) THEN
               CALL UVDISK ('WRIT', LUNO, FINDO, BUFFO, NIOLIM, BINDO,
     *            IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITING OUTPUT UV DATA'
                  GO TO 900
                  END IF
               OPINT = BINDO
               NIOUT = 0
               END IF
 175        CONTINUE
         GO TO 100
C                                       Finish write
 200  NIOUT = - NIOUT
      CALL UVDISK ('FLSH', LUNO, FINDO, BUFFO, NIOUT, BINDO, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'FLUSHING OUTPUT UV DATA'
         GO TO 900
         END IF
      IRET = 0
      GO TO 900
C                                       mismatch
 890  WRITE (MSGTXT,1890) COUNT
      IERR = 10
C                                       first input file
 900  IF (IERR.NE.0) CALL MSGWRT (8)
C
      WRITE (MSGTXT,1900) XMAX, CMAX, JSMAX, JFMAX, JIMAX
      CALL MSGWRT (5)
      IF (NSUM.GE.1.0D0) THEN
         SUM = SUM / NSUM
         SUMS = SUMS/NSUM - SUM * SUM
         SUMS = SQRT (MAX (0.0D0, SUMS))
         WRITE (MSGTXT,1901) SUM, SUMS, NSUM
         CALL MSGWRT (5)
         END IF
      CALL MAPCLS ('READ', DISK, CNO, LUN, FIND, CATOLD, F, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'CLOSING INPUT FILE 1'
         CALL MSGWRT (6)
         END IF
      CALL MAPCLS ('READ', DISK2, CNO2, LUN2, FIND2, CAT2I, F, BUFF1,
     *   IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'CLOSING INPUT FILE 2'
         CALL MSGWRT (6)
         END IF
      CALL MAPCLS ('WRIT', DISKO, CNOO, LUNO, FINDO, CATBLK, T, BUFF1,
     *   IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'CLOSING OUTPUT FILE'
         CALL MSGWRT (6)
         END IF
      CALL RNXCLS (RNXRET)
      IF (RNXRET.NE.0) THEN
         MSGTXT = 'OUTPUT NX TABLE, IF ANY, IS INCOMPLETE'
         CALL MSGWRT (7)
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('UVADMU ERROR',I4,' ON ',A)
 1001 FORMAT ('UVADMU ERROR',I4,' COUNT',I10,' ON ',A)
 1105 FORMAT ('UVADMU: at visibility record',I10)
 1890 FORMAT ('UVADMU MISMATCH AT COUNT',I10)
 1900 FORMAT ('UVADMU Max',1PE11.3,'  Count,st,fr,if',I10,I2,I7,I3)
 1901 FORMAT ('UVADMU Mean, rms',2(1PE11.3),' from',F13.0,' samples')
      END
      SUBROUTINE UVADIV (IRET)
C-----------------------------------------------------------------------
C   UVADPR reads the UV files and divides the vis
C   Output:
C      IRET   I   Return code: 0 success or user requests end, else bad
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'UVADD.INC'
      LOGICAL   F, T
      INTEGER   DPTR, BINDO, CMAX, JIF, JF, JS, JIMAX, JFMAX, JSMAX,
     *   NIOLIM, NUMST, NUMCH, NUMIF, OPINT, BO, BIND, BIND2, VO, COUNT,
     *   BUFSZ, INDEX, NIOUT, IERR, IPINT, IPIN2, J, LRECA, LRECF,
     *   NCORR, NIO, NIO2, XCOUNT, LENBU, JERR, RNXRET, INDEX2
      REAL      XR, XI, XA
      INCLUDE 'BUFFS.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:PUVD.INC'
      DATA T, F /.TRUE.,.FALSE./
      DATA LENBU, BO, VO /0, 1, 0/
C-----------------------------------------------------------------------
      IRET = 8
      XMAX = -1.0
      NSUM = 0.0D0
      SUM = 0.0D0
      SUMS = 0.0D0
C                                       Set up for compressed data.
      NCORR = (LREC - NRPARM) / CATBLK(KINAX)
      LRECF = 3 * NCORR
      DPTR = 1 + MAX (NRP1, NRP2)
      LRECA = LRECF + DPTR - 1
      CALL AXEFND (8, 'WEIGHT  ', CATBLK(KIPCN), CATH(KHPTP), KLOCWT,
     *   JERR)
      IF (ISCMP1 .AND. ((JERR.NE.0) .OR. (KLOCWT.LT.0))) THEN
         IRET = 5
         MSGTXT = 'CANNOT FIND WEIGHT AND SCALE FOR COMPRESSED DATA'
         CALL MSGWRT (8)
         GO TO 999
         END IF
      CALL AXEFND (8, 'WEIGHT  ', CAT2I(KIPCN), CAT2H(KHPTP), LLOCWT,
     *   JERR)
      IF (ISCMP2 .AND. ((JERR.NE.0) .OR. (LLOCWT.LT.0))) THEN
         IRET = 5
         MSGTXT = 'CANNOT FIND WEIGHT AND SCALE FOR COMPRESSED DATA'
         CALL MSGWRT (8)
         GO TO 999
         END IF
C                                       Initialize difference statistics
      NUMCH = CATBLK(KINAX+JLOCF)
      NUMIF = CATBLK(KINAX+JLOCIF)
      NUMST = CATBLK(KINAX+JLOCS)
C                                       Initialize reading VIS. file.
      LENBU = 0
      BUFSZ = UVBFSS * 2
      CALL UVINIT ('READ', LUN, FIND, NVIS, VO, LREC, LENBU, BUFSZ,
     *   BUFF1, BO, BIND, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING 1ST INPUT UV FILE'
         GO TO 900
         END IF
      CALL UVINIT ('READ', LUN2, FIND2, NVIS, VO, LREC2, LENBU, BUFSZ,
     *   BUFF2, BO, BIND2, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING 2ND INPUT UV FILE'
         GO TO 900
         END IF
      CALL UVINIT ('WRIT', LUNO, FINDO, NVIS, VO, LREC, LENBU, BUFSZ,
     *   BUFFO, BO, BINDO, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING 1ST INPUT UV FILE'
         GO TO 900
         END IF
      NIOLIM = LENBU
      COUNT = 0
      NIOUT = 0
C                                       make an index table
      CALL RNXGET (DISK, CNO, CATOLD)
      CALL RNXINI (DISKO, CNOO, CATBLK, RNXRET)
C                                       Start looping thru data.
 100  CONTINUE
C                                       Read buffer.
         COUNT = COUNT + 1
         CALL UVDISK ('READ', LUN, FIND, BUFF1, NIO, BIND, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1001) IERR, COUNT, 'READING 1ST UV FILE'
            GO TO 900
            END IF
         CALL UVDISK ('READ', LUN2, FIND2, BUFF2, NIO2, BIND2, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1001) IERR, COUNT, 'READING 2ND UV FILE'
            GO TO 900
            END IF
         IPINT = BIND - LREC
         IPIN2 = BIND2 - LREC2
         OPINT = BINDO
         NIO = MIN (NIO2, NIO)
         IF (NIO.LE.0) GO TO 200
C                                       Loop thru buffer.
         DO 175 J = 1,NIO
C                                       Update counters
            XCOUNT = XCOUNT + 1
            IPINT = IPINT + LREC
            IPIN2 = IPIN2 + LREC2
            IF (MOD(XCOUNT-1,VISMSG).EQ.0) THEN
               WRITE (MSGTXT,1105) XCOUNT
               CALL MSGWRT (2)
            ELSE IF (MOD(XCOUNT-1,VISINC).EQ.0) THEN
               WRITE (MSGTXT,1105) XCOUNT
               CALL MSGWRT (1)
               END IF
C                                       matching?
            IF (I1LOCB.GE.0) THEN
               IF (BUFF1(IPINT+I1LOCB).NE.BUFF2(IPIN2+I2LOCB)) GO TO 890
            ELSE
               IF (BUFF1(IPINT+I1LOSA).NE.BUFF2(IPIN2+I2LOSA)) GO TO 890
               IF (BUFF1(IPINT+I1LOA1).NE.BUFF2(IPIN2+I2LOA1)) GO TO 890
               IF (BUFF1(IPINT+I1LOA2).NE.BUFF2(IPIN2+I2LOA2)) GO TO 890
               END IF
            IF (ABS(BUFF1(IPINT+I1LOCT)-BUFF2(IPIN2+I2LOCT)).GT.1.E-7)
     *         GO TO 890
C                                       Compressed?
            CALL RCOPY (NRP1, BUFF1(IPINT), KBUFF)
            IF (ISCMP1) THEN
               CALL ZUVXPN (NCORR, BUFF1(IPINT+NRP1),
     *            BUFF1(IPINT+KLOCWT), KBUFF(DPTR))
            ELSE
               CALL RCOPY (LRECF, BUFF1(IPINT+NRP1), KBUFF(DPTR))
               END IF
            CALL RCOPY (NRP2, BUFF2(IPIN2), KBUFF2)
            IF (ISCMP2) THEN
               CALL ZUVXPN (NCORR, BUFF2(IPIN2+NRP2),
     *            BUFF2(IPIN2+LLOCWT), KBUFF2(DPTR))
            ELSE
               CALL RCOPY (LRECF, BUFF2(IPIN2+NRP2), KBUFF2(DPTR))
               END IF
C                                       prepare output
            CALL RCOPY (NRP1, BUFF1(IPINT),  BUFFO(OPINT))
C                                       update NX table
            CALL RNXUPD (BUFF1(IPINT), RNXRET)
            DO 130 JIF = 1,NUMIF
               DO 120 JS = 1,NUMST
                  INDEX2 = (JIF-1) * INCIF/NUMCH + (JS-1) * INCS
                  DO 110 JF = 1,NUMCH
                     INDEX = (JIF-1) * INCIF + (JF-1) * INCF +
     *                  (JS-1) * INCS
                     XA = KBUFF2(DPTR+INDEX)**2+KBUFF2(DPTR+INDEX2+1)**2
                     XR = (KBUFF(DPTR+INDEX) * KBUFF2(DPTR+INDEX2) +
     *                  KBUFF(DPTR+INDEX+1) * KBUFF2(DPTR+INDEX2+1))/ XA
                     XI = (KBUFF(DPTR+INDEX+1) * KBUFF2(DPTR+INDEX2) -
     *                  KBUFF(DPTR+INDEX) * KBUFF2(DPTR+INDEX2+1)) / XA
                     KBUFF(DPTR+INDEX) = XR
                     KBUFF(DPTR+INDEX+1) = XI
                     XA = SQRT (XR*XR + XI*XI)
                     IF (XA.GT.XMAX) THEN
                        XMAX = XA
                        JIMAX = JIF
                        JFMAX = JF
                        JSMAX = JS
                        CMAX = XCOUNT
                        END IF
                     NSUM = NSUM + 1.0D0
                     SUM = SUM + XA
                     SUMS = SUMS + XA * XA
 110                 CONTINUE
 120              CONTINUE
 130           CONTINUE
            IF (ISCMP1) THEN
               CALL ZUVPAK (NCORR, KBUFF(DPTR), BUFFO(OPINT+KLOCWT),
     *            BUFFO(OPINT+NRP1))
            ELSE
               CALL RCOPY (LRECF, KBUFF(DPTR), BUFFO(OPINT+NRP1))
               END IF
            OPINT = OPINT + LREC
            NIOUT = NIOUT + 1
            IF (NIOUT.GE.NIOLIM) THEN
               CALL UVDISK ('WRIT', LUNO, FINDO, BUFFO, NIOLIM, BINDO,
     *            IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1000) IERR, 'WRITING OUTPUT UV DATA'
                  GO TO 900
                  END IF
               OPINT = BINDO
               NIOUT = 0
               END IF
 175        CONTINUE
         GO TO 100
C                                       Finish write
 200  NIOUT = - NIOUT
      CALL UVDISK ('FLSH', LUNO, FINDO, BUFFO, NIOUT, BINDO, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'FLUSHING OUTPUT UV DATA'
         GO TO 900
         END IF
      IRET = 0
      GO TO 900
C                                       mismatch
 890  WRITE (MSGTXT,1890) COUNT
      IERR = 10
C                                       first input file
 900  IF (IERR.NE.0) CALL MSGWRT (8)
C
      WRITE (MSGTXT,1900) XMAX, CMAX, JSMAX, JFMAX, JIMAX
      CALL MSGWRT (5)
      IF (NSUM.GE.1.0D0) THEN
         SUM = SUM / NSUM
         SUMS = SUMS/NSUM - SUM * SUM
         SUMS = SQRT (MAX (0.0D0, SUMS))
         WRITE (MSGTXT,1901) SUM, SUMS, NSUM
         CALL MSGWRT (5)
         END IF
      CALL MAPCLS ('READ', DISK, CNO, LUN, FIND, CATOLD, F, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'CLOSING INPUT FILE 1'
         CALL MSGWRT (6)
         END IF
      CALL MAPCLS ('READ', DISK2, CNO2, LUN2, FIND2, CAT2I, F, BUFF1,
     *   IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'CLOSING INPUT FILE 2'
         CALL MSGWRT (6)
         END IF
      CALL MAPCLS ('WRIT', DISKO, CNOO, LUNO, FINDO, CATBLK, T, BUFF1,
     *   IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'CLOSING OUTPUT FILE'
         CALL MSGWRT (6)
         END IF
      CALL RNXCLS (RNXRET)
      IF (RNXRET.NE.0) THEN
         MSGTXT = 'OUTPUT NX TABLE, IF ANY, IS INCOMPLETE'
         CALL MSGWRT (7)
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('UVADIV ERROR',I4,' ON ',A)
 1001 FORMAT ('UVADIV ERROR',I4,' COUNT',I10,' ON ',A)
 1105 FORMAT ('UVADIV: at visibility record',I10)
 1890 FORMAT ('UVADIV MISMATCH AT COUNT',I10)
 1900 FORMAT ('UVADIV Max',1PE11.3,'  Count,st,fr,if',I10,I2,I7,I3)
 1901 FORMAT ('UVADIV Mean, rms',2(1PE11.3),' from',F13.0,' samples')
      END
      SUBROUTINE UVADHI
C-----------------------------------------------------------------------
C   Copies old HI to new file and adds
C-----------------------------------------------------------------------
      INTEGER   HLUN1, HLUN2, IERR, NONOT
      CHARACTER HILINE*72, NOTTYP(25)*2
      INCLUDE 'UVADD.INC'
      INCLUDE 'INCS:DHIS.INC'
      DATA HLUN1, HLUN2 /27,28/
C                                       allow SU, AN, FQ, PO
      DATA NONOT, NOTTYP /25, 'BP', 'CL', 'CD', 'CP', 'CQ', 'FG', 'GC',
     *   'IM', 'MC', 'PC', 'PD', 'SN', 'SY', 'TY', 'WX', 'BL', 'PP',
     *   'BD', 'NX', 'CC', 'CH', 'AT', 'VT', 'HF', 'TE'/
C-----------------------------------------------------------------------
      CALL HIINIT (3)
C                                       Copy/open history file.
      CALL HISCOP (HLUN1, HLUN2, DISK, DISKO, CNO, CNOO, CATBLK,
     *   BUFF1, BUFF2, IERR)
      IF (IERR.GT.2) THEN
         WRITE (MSGTXT,1000) IERR
         CALL MSGWRT (6)
         GO TO 100
         END IF
C                                       New history
      CALL HENCO1 (TSKNAM, NAME, CLASS, SEQ, DISK, HLUN2, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 100
      CALL HENCO2 (TSKNAM, NAME2, CLASS2, SEQ2, DISK2, HLUN2, BUFF2,
     *   IERR)
      IF (IERR.NE.0) GO TO 100
      CALL HENCOO (TSKNAM, OUTNAM, OUTCLS, SEQO, DISKO, HLUN2, BUFF2,
     *   IERR)
      IF (IERR.NE.0) GO TO 100
      WRITE (HILINE,2000) TSKNAM, OPCODE
      CALL HIADD (HLUN2, HILINE, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 100
      IF (SINGLE) THEN
         HILINE = TSKNAM // '/ 2nd data set single spectral channel'
         CALL HIADD (HLUN2, HILINE, BUFF2, IERR)
         IF (IERR.NE.0) GO TO 100
         END IF
      WRITE (HILINE,2001) TSKNAM, XMAX
      CALL HIADD (HLUN2, HILINE, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 100
      WRITE (HILINE,2002) TSKNAM, SUM
      CALL HIADD (HLUN2, HILINE, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 100
      WRITE (HILINE,2003) TSKNAM, SUMS
      CALL HIADD (HLUN2, HILINE, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       Close HI file
 100  CALL HICLOS (HLUN2, .TRUE., BUFF2, IERR)
C                                       Copy a few tables
      CALL ALLTAB (NONOT, NOTTYP, HLUN1, HLUN2, DISK, DISKO, CNO, CNOO,
     *   CATBLK, BUFF1, BUFF2, IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('UVADHI: ERROR',I3,' COPY/OPEN HISTORY FILE')
 2000 FORMAT (A6,'OPCODE = ''',A,'''   / operation performed')
 2001 FORMAT (A6,'/ peak amplitude out',1PE11.3)
 2002 FORMAT (A6,'/ mean amplitude out',1PE11.3)
 2003 FORMAT (A6,'/ rms amplitude out',1PE11.3)
      END
