LOCAL INCLUDE 'PEVACL.INC'
C                                       Parameter include for EVACL
      INTEGER   MAXQAD, MAXTRP
C                                       MAXQAD = max. no. quads
      PARAMETER (MAXQAD=100000)
C                                       MAXTRP = max. no. triples
      PARAMETER (MAXTRP=100000)
LOCAL END
LOCAL INCLUDE 'EVACL.INC'
C                                       Local include for EVACL
      INCLUDE 'PEVACL.INC'
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:ZPBUFSZ.INC'
      INCLUDE 'INCS:DMSG.INC'
      HOLLERITH XNAMEI(3), XCLAIN(2), XXSTOK(1), XOPCOD(1)
      CHARACTER NAMEIN*12, CLAIN*6, OPCODE*4, XSTOK*4
      REAL      XSIN, XDISIN, XBIF, XEIF, XBCHAN, XECHAN, XFLAGV,
     *   XANT(50), XSOLIN
      REAL      BUFF1(UVBFSS), SOLINT, ANSERS(6,MAXIF)
      INTEGER   JBUFSZ, NANT, OLDCNO, CATKEP(256), OBUFF(1024),
     *   TOTALS(2,MAXIF)
      INTEGER   SEQIN, DISKIN, LUNI, INDI, NCH, NUMQAD, NUMTRP,
     *   CPQUAD(4,MAXQAD), GOODAM(MAXQAD), GOODPH(MAXTRP),
     *   CPTRIP(3,MAXTRP), INCANT(MAXANT)
C                                       WARNING: many of these commons
C                                       are declared locally with
C                                       variables of different names!!!
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XXSTOK, XBIF, XEIF,
     *   XBCHAN, XECHAN, XFLAGV, XANT, XOPCOD, XSOLIN
      COMMON /BUFRS/ BUFF1, OBUFF, JBUFSZ
      COMMON /VBPCOM/ SEQIN, DISKIN, LUNI, INDI, OLDCNO, NCH, INCANT,
     *   CATKEP, GOODPH, GOODAM, NUMTRP, NUMQAD, CPTRIP, CPQUAD, NANT,
     *   SOLINT, ANSERS, TOTALS
      COMMON /CHRCOM/ NAMEIN, CLAIN, XSTOK, OPCODE
LOCAL END
LOCAL INCLUDE 'CLAVER.INC'
      LOGICAL   GOTPHS, GOTAMP
      INTEGER   ACOUNT(4,MAXQAD), ACOUN1(4,MAXQAD), COUNTA(MAXQAD),
     *   PCNTIM, ACNTIM, IVSCNT, PCOUNT(3,MAXTRP), PCOUN1(3,MAXTRP),
     *   VISINC, VISMSG
      REAL      ASUMT, PSUMT, AWORK(2,4,MAXQAD), AWORKC(MAXQAD),
     *   AGAMP(4,MAXQAD), AGERR(4,MAXQAD), TLAST, DTUTC,
     *   PWORK(2,3,MAXTRP), PWORKC(2,MAXTRP), PGAMP(3,MAXTRP),
     *   PGERR(3,MAXTRP)
      COMMON /CLAVG/ ACOUNT, ACOUN1, COUNTA, PCOUNT, PCOUN1,
     *   AWORK, AWORKC, AGAMP, AGERR, PWORK, PWORKC, PGAMP, PGERR,
     *   TLAST, DTUTC, IVSCNT, GOTPHS, GOTAMP, PCNTIM, PSUMT, ACNTIM,
     *   ASUMT, VISINC, VISMSG
LOCAL END
      PROGRAM EVACL
C-----------------------------------------------------------------------
C! Evaluates closure phases and amplitudes
C# UV Calibration
C-----------------------------------------------------------------------
C;  Copyright (C) 2022
C;  Associated Universities, Inc. Washington DC, USA.
C;
C;  This program is free software; you can redistribute it and/or
C;  modify it under the terms of the GNU General Public License as
C;  published by the Free Software Foundation; either version 2 of
C;  the License, or (at your option) any later version.
C;
C;  This program is distributed in the hope that it will be useful,
C;  but WITHOUT ANY WARRANTY; without even the implied warranty of
C;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C;  GNU General Public License for more details.
C;
C;  You should have received a copy of the GNU General Public
C;  License along with this program; if not, write to the Free
C;  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge,
C;  MA 02139, USA.
C;
C;  Correspondence concerning AIPS should be addressed as follows:
C;         Internet email: aipsmail@nrao.edu.
C;         Postal address: AIPS Project Office
C;                         National Radio Astronomy Observatory
C;                         520 Edgemont Road
C;                         Charlottesville, VA 22903-2475 USA
C-----------------------------------------------------------------------
C   EVACL plots uv data . A 'PL' extension file is made which can
C   be displayed in the usual ways.  It plots closure amplitudes,
C   Inputs:
C     USERID                       UV data file owner # ignored
C     INNAME         NAMEIN        Name of input UV data.
C     INCLASS        CLAIN         Class of input UV data.
C     INSEQ          SEQIN         Seq. of input UV data.
C     INDISK         DISKIN        Disk number of input UV data.
C     BCHAN          BCHAN         Start channel for averaging
C     ECHAN          ECHAN         End channel for averaging
C     BIF            BIF           Start IF number for averaging
C     EIF            EIF           End IF number for averaging
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET
      INCLUDE 'EVACL.INC'
      INCLUDE 'INCS:DLOC.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA PRGM /'EVACL '/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL EVACLI (PRGM, IRET)
C                                       Scaling
      IF (IRET.EQ.0) CALL EVACLD (IRET)
C                                       Close down
      CALL DIE (IRET, OBUFF)
C
 999  STOP
      END
      SUBROUTINE EVACLI (PRGM, IRET)
C-----------------------------------------------------------------------
C   EVACLI gets input parameters for EVACL .
C   Inputs:  PRGM   C*6       Program name
C   Output:  IRET   I         Error code: 0 => ok, else quit
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET
C
      INCLUDE 'EVACL.INC'
      CHARACTER UTYPE*2, STAT*4, ALSTOK(12)*4
      INTEGER   NPARM, IERR, IUSER, I, K, L, J, MXANT, MXQUAD, IROUND,
     *   NUMOUT, OUTANS(MAXANT)
      REAL      CATR(256), EPS
      INCLUDE 'INCS:PSTD.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DSOU.INC'
      EQUIVALENCE (CATR, CATBLK)
      DATA MXANT /MAXANT/
      DATA MXQUAD /MAXQAD/
      DATA ALSTOK /'I','Q','U','V','RR','LL','RL','LR','VV','HH','VH',
     *   'HV'/
C-----------------------------------------------------------------------
C                                       Init IO et al.
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      JBUFSZ = UVBFSS * 2
      CALL SELINI
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      IRET = 0
C                                       Get input parameters.
      NPARM = 65
      CALL GTPARM (PRGM, NPARM, RQUICK, XNAMEI, OBUFF, IERR)
      IF (IERR.NE.0) THEN
         IRET = 8
         RQUICK = .TRUE.
         IF (IERR.EQ.1) GO TO 999
         WRITE (MSGTXT,1000) IERR
         CALL MSGWRT (8)
         END IF
C                                       Restart AIPS
      IF (RQUICK) CALL RELPOP (IRET, OBUFF, IERR)
      IF (IRET.NE.0) GO TO 999
      IRET = 5
      SEQIN = XSIN + EPS
      DISKIN = XDISIN + EPS
C                                       Check SOLINT
      IF (XSOLIN.EQ.0.0) THEN
         XSOLIN = 5.0
         WRITE (MSGTXT,1020)
         CALL MSGWRT (3)
         END IF
C                                       Characters
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      CALL H2CHR (4, 1, XXSTOK, XSTOK)
      CALL H2CHR (4, 1, XOPCOD, OPCODE)
      IF (OPCODE.NE.'INDE') OPCODE = 'CLOS'
      DO 10 I = 1,12
         IF (XSTOK.EQ.ALSTOK(I)) GO TO 15
 10      CONTINUE
      XSTOK = 'I'
 15   STOKES = XSTOK
      CALL CHR2H (4, XSTOK, 1, XXSTOK)
C                                       Get CATBLK from file.
      LUNI = 16
      UTYPE = 'UV'
      OLDCNO = 1
      CALL CATDIR ('SRCH', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN, UTYPE,
     *   IUSER, STAT, OBUFF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1030) IRET, NAMEIN, CLAIN, SEQIN, DISKIN,
     *      IUSER
         GO TO 990
         END IF
      CALL CATIO ('READ', DISKIN, OLDCNO, CATBLK, 'REST', OBUFF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1035) IRET
         GO TO 990
         END IF
      XSIN = SEQIN
      XDISIN = DISKIN
      CALL CHR2H (12, NAMEIN, 1, XNAMEI)
      CALL CHR2H (6, CLAIN, 1, XCLAIN)
C                                       Get uv header info.
      CALL UVPGET (IRET)
      IF (IRET.NE.0) GO TO 999
      CALL COPY (256, CATBLK, CATKEP)
C                                       Freq id
      SUBARR = 1
      FRQSEL = 1
C                                       antenna info
      CALL EVACLA (DISKIN, OLDCNO, SUBARR, CATBLK, NANT, NUMOUT, OUTANS,
     *   IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1010) IRET, 'FINDING MAX ANTENNA NUMBER'
         GO TO 990
         END IF
C                                       Put selection criteria into
C                                       correct common.
      UNAME = NAMEIN
      UCLAS = CLAIN
      UDISK = DISKIN
      USEQ = SEQIN
      IUDISK = UDISK
      IUCNO = OLDCNO
      FGVER = IROUND (XFLAGV)
C                                       Test channel #
      BCHAN = IROUND (XBCHAN)
      BCHAN = MAX (1, MIN (BCHAN, CATBLK(KINAX+JLOCF)))
      ECHAN = IROUND (XECHAN)
      IF (ECHAN.LT.BCHAN) ECHAN = CATBLK(KINAX+JLOCF)
      ECHAN = MAX (1, MIN (ECHAN, CATBLK(KINAX+JLOCF)))
      IF (ECHAN.GT.BCHAN) THEN
         WRITE (MSGTXT,1040) BCHAN, ECHAN
         CALL MSGWRT (2)
         END IF
      XBCHAN = BCHAN
      XECHAN = ECHAN
C                                       IF number
      IF (JLOCIF.GE.0) THEN
         BIF = IROUND (XBIF)
         BIF = MAX (1, MIN (BIF, CATBLK(KINAX+JLOCIF)))
         EIF = IROUND (XEIF)
         IF (EIF.LT.BIF) EIF = CATBLK(KINAX+JLOCIF)
         EIF = MAX (1, MIN (EIF, CATBLK(KINAX+JLOCIF)))
      ELSE
         BIF = 1
         EIF = 1
         END IF
      IF (EIF.GT.BIF) THEN
         WRITE (MSGTXT,1050) BIF, EIF
         CALL MSGWRT (2)
         END IF
      XBIF = BIF
      XEIF = EIF
C                                       omit or include
      L = 0
      K = 0
      DO 20 I = 1,50
         J = IROUND (XANT(I))
         IF (J.GT.0) K = K + 1
         IF (J.LT.0) L = L + 1
 20      CONTINUE
      IF ((K.EQ.0) .AND. (L.EQ.0)) THEN
         CALL FILL (MAXANT, 1, INCANT)
      ELSE IF (L.EQ.0) THEN
         CALL FILL (MAXANT, 0, INCANT)
         DO 25 I = 1,50
            J = IROUND (XANT(I))
            IF (J.GT.0) INCANT(J) = 1
 25         CONTINUE
      ELSE
         CALL FILL (MAXANT, 1, INCANT)
         DO 30 I = 1,50
            J = IROUND (XANT(I))
            J = ABS (J)
            IF (J.GT.0) INCANT(J) = 0
 30         CONTINUE
         END IF
      DO 35 I = 1,NUMOUT
         INCANT(OUTANS(I)) = 0
 35      CONTINUE
C                                       which triples
      CALL SETTRP (IRET)
C                                       which quads
      IF (IRET.EQ.0) CALL SETQAD (IRET)
      IF (IRET.NE.0) THEN
         MSGTXT = 'ERROR SETING TRIANGLES/QUADRANGLES'
         GO TO 990
         END IF
C                                       report
      WRITE (MSGTXT,1100) NUMTRP, NUMQAD
      CALL MSGWRT (3)
      WRITE (MSGTXT,1101) NANT, NUMOUT
      CALL MSGWRT (3)
      GO TO 999
C
 990  CALL MSGWRT (6)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('EVACLI: ERROR',I3,' OBTAINING INPUT PARAMETERS')
 1010 FORMAT ('EVACLI: ERROR',I4,' ON ',A)
 1020 FORMAT ('EVACLI: SOLINT was 0, resetting to 5 minutes')
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
     *   I3,' USID=',I5)
 1035 FORMAT ('ERROR',I3,' COPYING CATBLK ')
 1040 FORMAT ('Averaging from channel ',I4,'-',I4)
 1050 FORMAT ('Displaying from IF ',I4,'-',I4)
 1100 FORMAT ('Using',I6,' triangles and',I6,' quadrangles')
 1101 FORMAT ('Using max antenna #',I4,' with',I2,' known to be out')
      END
      SUBROUTINE EVACLA (IUDISK, IUCNO, IUVER, CATBLK, MAXA, NUMOUT,
     *   OUTANS, IERR)
C-----------------------------------------------------------------------
C   finds the max antenna number in an antenna file - this may easily
C   not be the same as the number of records.  Also finds and antennas
C   listed as OUT
C   Inputs:
C      IUDISK   I        Disk number
C      IUCNO    I        Catalog number
C      IUVER    I        AN version number = subarray number
C      CATBLK   I(256)   Catalog block
C   Output:
C      MAXA     I        Max antenna number
C      NUMOUT   I        Number of OUT antennas
C      OUTANS   I(*)     Antenna numbers of OUT antennas
C      IERR     I        Error code
C   Output in Common: DANT.INC after ANTINI and several TABAN calls
C-----------------------------------------------------------------------
      INTEGER   IUDISK, IUCNO, IUVER, CATBLK(256), MAXA, NUMOUT,
     *   OUTANS(*),  IERR
C
      INTEGER   NUMSUB, IA, ANBUFF(512), ILUN, NANT
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:DANT.INC'
      INCLUDE 'INCS:DMSG.INC'
      DATA ILUN /110/
C-----------------------------------------------------------------------
      MAXA = 0
      NUMOUT = 0
      IERR = 0
      CALL FNDEXT ('AN', CATBLK, NUMSUB)
      IF ((NUMSUB.GE.IUVER) .AND. (IUVER.GE.1)) THEN
         IA = 0
         CALL ANTINI ('READ', ANBUFF, IUDISK, IUCNO, IUVER, CATBLK,
     *      ILUN, IANRNO, ANKOLS, ANNUMV, ARRAYC, GSTIA0, DEGPDY,
     *      SAFREQ, RDATE, POLRXY, UT1UTC, DATUTC, TIMSYS, ANAME,
     *      XYZHAN, TFRAME, NUMORB, NOPCAL, ANTNIF, ANFQID, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'INIT', IUVER
            GO TO 980
            END IF
         NANT = ANBUFF(5)
C                                       read the an tables
         DO 90 IA = 1,NANT
            CALL TABAN ('READ', ANBUFF, IANRNO, ANKOLS, ANNUMV, ANNAME,
     *         STAXYZ, ORBPRM, NOSTA, MNTSTA, STAXOF, DIAMAN, FWHMAN,
     *         POLTYA, POLAA,POLCA, POLTYB, POLAB, POLCB, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1000) IERR, 'READ', IUVER
               GO TO 970
               END IF
            IF (ANNAME.EQ.'OUT') THEN
               NUMOUT = NUMOUT + 1
               OUTANS(NUMOUT) = NOSTA
            ELSE IF ((STAXYZ(1).EQ.0.0D0) .AND. (STAXYZ(2).EQ.0.0D0)
     *         .AND. (STAXYZ(3).EQ.0.0D0)) THEN
               NUMOUT = NUMOUT + 1
               OUTANS(NUMOUT) = NOSTA
            ELSE
               MAXA = MAX (MAXA, NOSTA)
               END IF
 90         CONTINUE
         CALL TABIO ('CLOS', 0, IANRNO, ANBUFF, ANBUFF, IERR)
         END IF
      GO TO 999
C
 970  CALL MSGWRT (6)
      CALL TABIO ('CLOS', 0, IANRNO, ANBUFF, ANBUFF, IA)
      GO TO 999
C
 980  CALL MSGWRT (6)
      GO TO 999
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('EVACLA: ERROR',I5,1X,A,'ING AN TABLE',I4)
      END
      SUBROUTINE SETTRP (IRET)
C-----------------------------------------------------------------------
C   Sets the list of triples
C   Output:
C      IRET   I   Error occurred if > 0
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'EVACL.INC'
      INTEGER   I, J, K, A1
C-----------------------------------------------------------------------
C                                       unique
      NUMTRP = 0
      IRET = 0
      IF (OPCODE.EQ.'INDE') THEN
         DO 20 J = 3,NANT
            A1 = 1
            DO 10 I = 1,NANT
               IF ((A1.LT.J-1) .AND. (INCANT(A1).EQ.1) .AND.
     *            (INCANT(A1+1).EQ.1) .AND. (INCANT(J).EQ.1)) THEN
                  NUMTRP = NUMTRP + 1
                  CPTRIP(1,NUMTRP) = A1
                  CPTRIP(2,NUMTRP) = A1 + 1
                  CPTRIP(3,NUMTRP) = J
                  END IF
               A1 = A1 + 1
 10            CONTINUE
 20         CONTINUE
C                                       all
      ELSE
         DO 50 I = 1,NANT-2
            IF (INCANT(I).EQ.0) GO TO 50
            DO 40 J = 2,NANT-1
               IF ((I.EQ.J) .OR. (INCANT(J).EQ.0)) GO TO 40
               DO 30 K = 1,NANT
                  IF (INCANT(K).EQ.0) GO TO 30
                  IF ((K.EQ.I) .OR. (K.EQ.J)) GO TO 30
                  IF ((I.GT.J) .OR. (I.GT.K) .OR. (J.GT.K)) GO TO 30
                  NUMTRP = NUMTRP + 1
                  CPTRIP(1,NUMTRP) = I
                  CPTRIP(2,NUMTRP) = J
                  CPTRIP(3,NUMTRP) = K
 30               CONTINUE
 40            CONTINUE
 50         CONTINUE
         END IF
C                                       did we get anything
      IF (NUMTRP.LE.0) THEN
         MSGTXT = 'SETTRP DID NOT FIND ANY ALLOWED TRIPLES'
         CALL MSGWRT (8)
         IRET = 1
         END IF
C
 999  RETURN
      END
      SUBROUTINE SETQAD (IRET)
C-----------------------------------------------------------------------
C   Detrimines the quadrangles to be used
C   Output:
C      IRET   I   > 0 -> no quadrangles found
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'EVACL.INC'
      INTEGER   I, J, K, L

C-----------------------------------------------------------------------
      NUMQAD = 0
      IRET = 0
C                                       independent
      IF (OPCODE.EQ.'INDE') THEN
         DO 20 J = 3,NANT
            K = 1
            DO 10 I = 1,NANT
               IF ((K.LT.J-2) .AND. (INCANT(K).EQ.1) .AND.
     *            (INCANT(K+1).EQ.1) .AND. (INCANT(K+2).EQ.1) .AND.
     *            (INCANT(J).EQ.1))  THEN
                  NUMQAD = NUMQAD + 1
                  CPQUAD(1,NUMQAD) = K
                  CPQUAD(2,NUMQAD) = K + 1
                  CPQUAD(3,NUMQAD) = K + 2
                  CPQUAD(4,NUMQAD) = J
                  END IF
               K = K + 1
 10            CONTINUE
 20         CONTINUE
      ELSE
         DO 80 I = 1,NANT
            IF (INCANT(I).EQ.0) GO TO 80
            DO 70 J = 1,NANT
               IF (INCANT(J).EQ.0) GO TO 70
               DO 60 K = 1,NANT
                  IF (INCANT(K).EQ.0) GO TO 60
                  DO 50 L = 1,NANT
                     IF ((I.LT.J) .AND. (J.LT.K) .AND. (K.LT.L) .AND.
     *                  (INCANT(L).EQ.1)) THEN
                        NUMQAD = NUMQAD + 1
                        CPQUAD(1,NUMQAD) = I
                        CPQUAD(2,NUMQAD) = J
                        CPQUAD(3,NUMQAD) = K
                        CPQUAD(4,NUMQAD) = L
                        END IF
 50                  CONTINUE
 60               CONTINUE
 70            CONTINUE
 80         CONTINUE
         END IF
C                                       get any?
      IF (NUMQAD.LE.0) THEN
         MSGTXT = 'SETQAD DID NOT FIND ANY QUADRANGLES'
         CALL MSGWRT (8)
         IRET = 1
         END IF
C
 999  RETURN
      END
      SUBROUTINE EVACLD (IRET)
C-----------------------------------------------------------------------
C   Finds the closure phases and amplitudes, computes statistics
C   Output:
C      IRET   I   > 0 -> error
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'EVACL.INC'
      INCLUDE 'CLAVER.INC'
      INTEGER   I, J, LBIF, LEIF, NUMVIS, SCANUM, IC, NUMP, NUMA,
     *   MAXTOT
      REAL      AWT(3), PWT(3), AOFF, POFF, DT, ASCANV(MAXQAD), WT,
     *   ACLERR(MAXQAD), PSCANV(MAXTRP), PCLERR(MAXTRP), RPARM(20)
      REAL      DBGA(269), DBGP(309), DBGEA(269), DBGEP(309)
      EQUIVALENCE (DBGP, PSCANV), (DBGA, ASCANV), (DBGEA, ACLERR),
     *   (DBGEP, PCLERR)
      LOGICAL   NUSCAN, FIRST
      DOUBLE PRECISION CPRMS(3,2), CARMS(3,2)
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
C-----------------------------------------------------------------------
      LBIF = BIF
      LEIF = EIF
C                                       loop 1 IF at a time
      DO 100 BIF = LBIF,LEIF
         EIF = BIF
         CALL UVGET ('INIT', RPARM, BUFF1, IRET)
         IF (IRET.EQ.-1) THEN
            CALL UVGET ('CLOS', RPARM, BUFF1, IRET)
         ELSE IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, BIF, 'OPEN UV DATA'
            GO TO 990
         ELSE
            NUMP = 0
            NUMA = 0
            CALL DFILL (6, 0.0D0, CPRMS)
            CALL DFILL (6, 0.0D0, CARMS)
            DT = XSOLIN / 1440.0
            NUMVIS = 0
            FIRST = .TRUE.
            WT = 800.0 / (NUMTRP + NUMQAD)
            VISINC = CATBLK(KIGCN) / 20
            VISMSG = CATBLK(KIGCN) / 10
            VISINC = MAX (100000, MIN (1000000,VISINC))
            VISINC = VISINC * WT
            VISINC = ((VISINC+500)/1000) * 1000
            VISINC = MAX (40000, MIN (500000,VISINC))
            VISMSG = WT * VISMSG
            VISMSG = (VISMSG / VISINC) * VISINC
            IF (VISMSG.LT.VISINC) VISMSG = 100 * VISINC
 20         CONTINUE
               CALL CLOSAV (NUMVIS, NUMTRP, CPTRIP, NUMQAD, CPQUAD, DT,
     *            ASCANV, ACLERR, PSCANV, PCLERR, NUSCAN, SCANUM, RPARM,
     *            BUFF1, IRET)
               IF (IRET.EQ.-2) GO TO 20
               IF (IRET.GT.0) THEN
                  WRITE (MSGTXT,1000) IRET, BIF, 'READING DATA'
                  GO TO 990
                  END IF
               IF (FIRST) THEN
                  FIRST = .FALSE.
                  AOFF = 0.
                  IC = 0
                  DO 30 J = 1,NUMQAD
                     IF ((ASCANV(J).NE.FBLANK) .AND.
     *                  (ACLERR(J).NE.FBLANK)) THEN
                        AOFF = AOFF + ACLERR(J)**2
                        IC = IC + 1
                        END IF
 30                  CONTINUE
                  IF (IC.GT.0) AOFF = AOFF / IC
                  POFF = 0.0
                  IC = 0
                  DO 40 J = 1,NUMTRP
                     IF ((PSCANV(J).NE.FBLANK) .AND.
     *                  (PCLERR(J).NE.FBLANK)) THEN
                        POFF = POFF + PCLERR(J)**2
                        IC = IC + 1
                        END IF
 40                  CONTINUE
                  IF (IC.GT.0) POFF = POFF / IC
                  END IF
C                                       amplitude
               DO 60 J = 1,NUMQAD
                  IF (ASCANV(J).NE.FBLANK) THEN
                     NUMA = NUMA + 1
                     CALL RFILL (3, 1.0, AWT)
                     IF (ACLERR(J).GT.0.0) AWT(1) = 1.0 / ACLERR(J)**2
                     AWT(2) = 1.0 / (ACLERR(J)*2 + AOFF)
                     DO 50 I = 1,3
                        CARMS(I,1) = CARMS(I,1) + AWT(I)*(ASCANV(J)**2)
                        CARMS(I,2) = CARMS(I,2) + AWT(I)
 50                     CONTINUE
                     END IF
 60               CONTINUE
C                                       phase
               DO 80 J = 1,NUMTRP
                  IF (PSCANV(J).NE.FBLANK) THEN
                     NUMP = NUMP + 1
                     CALL RFILL (3, 1.0, PWT)
                     IF (PCLERR(J).GT.0.0) PWT(1) = 1.0 / PCLERR(J)**2
                     PWT(2) = 1.0 / (PCLERR(J)**2 + POFF)
                     DO 70 I = 1,3
                        CPRMS(I,1) = CPRMS(I,1) + PWT(I)*(PSCANV(J)**2)
                        CPRMS(I,2) = CPRMS(I,2) + PWT(I)
 70                     CONTINUE
                     END IF
 80               CONTINUE
               IF (IRET.EQ.0) GO TO 20
C                                       finish up
            CALL UVGET ('CLOS', RPARM, BUFF1, IRET)
            DO 90 I = 1,3
               IF (CARMS(I,2).GT.0.0) CARMS(I,1) = SQRT (CARMS(I,1) /
     *            CARMS(I,2))
               IF (CPRMS(I,2).GT.0.0) CPRMS(I,1) = SQRT (CPRMS(I,1) /
     *            CPRMS(I,2))
               ANSERS(I,BIF) = CPRMS(I,1)
               ANSERS(I+3,BIF) = CARMS(I,1)
 90            CONTINUE
            TOTALS(1,BIF) = NUMP
            TOTALS(2,BIF) = NUMA
            END IF
 100     CONTINUE
C                                       check scale
      MAXTOT = 0
      DO 110 BIF = LBIF,LEIF
         MAXTOT = MAX (MAXTOT, TOTALS(1,BIF))
         MAXTOT = MAX (MAXTOT, TOTALS(2,BIF))
 110     CONTINUE
      WT = MAXTOT
      MAXTOT = LOG10 (WT)
      IF (MAXTOT.GE.7) THEN
         WT = 10.0 ** (MAXTOT-6)
         DO 115 BIF = LBIF,LEIF
            TOTALS(1,BIF) = TOTALS(1,BIF) / WT + 0.5
            TOTALS(2,BIF) = TOTALS(2,BIF) / WT + 0.5
 115        CONTINUE
         WRITE (MSGTXT,1115) WT
         CALL MSGWRT (4)
         END IF
C                                       print answers
      MSGTXT = ' '
      CALL MSGWRT (5)
      MSGTXT = 'IF  ----------  PHASE  ----------' //
     *           '  --------  AMPLITUDE ---------'
      CALL MSGWRT (5)
      MSGTXT = '      Unwt   Robwt  Natwt   Count' //
     *           '    Unwt   Robwt  Natwt   Count'
      CALL MSGWRT (5)
      MSGTXT = ' '
      CALL MSGWRT (5)
      DO 120 BIF = LBIF,LEIF
         WRITE (MSGTXT,1100) BIF, (ANSERS(I,BIF), I = 1,3),
     *      TOTALS(1,BIF), (ANSERS(I,BIF), I=4,6), TOTALS(2,BIF)
         CALL MSGWRT (5)
 120     CONTINUE
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('EVACLD ERROR',I4,' IF',I3,' ON ',A)
 1100 FORMAT (I2,F9.2,2F7.2,I8,F9.4,2F7.4,I8)
 1115 FORMAT ('Counts reduced by a factor of',F6.0)
      END
      SUBROUTINE CLAVER (OP, NUMTRP, CPTRIP, NUMQAD, CPQUAD, T1, DT,
     *   RPARM, VIS)
C-----------------------------------------------------------------------
C   Adds a sample in to, or zeros, the summing arrays
C   DOERRB always true, DOMODL always false
C   Inputs:
C      OP       C*4      OPeration - 'ZERO', or 'AVER'
C      NUMTRP   I        Number phase triplets
C      CPTRIP   I(3,*)   Antennas in triplets
C      NUMQAD   I        Number amplitude quadrangles
C      CPQUAD   I(4,*)   Antennas in quadrangles
C      DT       R        Time interval to average
C      RPARM    R(*)     Random parameter set
C      VIS      R(3,*)   Data visibilities/weights
C   Outputs
C      T1       R        Start time this average: set if input > 10^9
C-----------------------------------------------------------------------
      CHARACTER OP*(*)
      INTEGER   NUMTRP, CPTRIP(3,*), NUMQAD, CPQUAD(4,*)
      REAL      T1, DT, RPARM(*), VIS(3,*)
C
      INTEGER   I, IVIS, KVIS, JA1, JA2, IDAY, STTRIP, ITRIP, IBASE,
     *   STQUAD
      REAL      CT, TEMP
      DOUBLE PRECISION X8
      INCLUDE 'PEVACL.INC'
      INCLUDE 'CLAVER.INC'
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DANT.INC'
C-----------------------------------------------------------------------
C                                       zero
      IF (OP.EQ.'ZERO') THEN
         TLAST = -1.0
         DTUTC = DATUTC / 86400.0
         IVSCNT = 0
         I = 3 * MAXTRP
         CALL FILL (I, 0, PCOUNT)
         CALL FILL (I, 0, PCOUN1)
         CALL RFILL (I, 0.0, PGAMP)
         CALL RFILL (I, 0.0, PGERR)
         I = 2 * 3 * MAXTRP
         CALL RFILL (I, 0.0, PWORK)
         I = 2 * MAXTRP
         CALL RFILL (I, 0.0, PWORKC)
         PCNTIM = 0
         PSUMT = 0.0
         I = 4 * MAXQAD
         CALL FILL (I, 0, ACOUNT)
         CALL FILL (I, 0, ACOUN1)
         CALL RFILL (I, 0.0, AGAMP)
         CALL RFILL (I, 0.0, AGERR)
         I = 2 * 4 * MAXQAD
         CALL RFILL (I, 0.0, AWORK)
         I = 2 * MAXQAD
         CALL RFILL (I, 0.0, AWORKC)
         ACNTIM = 0
         ASUMT = 0.0
C                                       add one vis into arrays:
      ELSE
         KVIS = (LREC-NRPARM) / 3
C                                       Set up first time boundary
         CT = RPARM(ILOCT+1) - DTUTC
         IVSCNT = IVSCNT + 1
         IF (IVSCNT.EQ.1) THEN
            IDAY = CT
            X8 = (CT - IDAY) / ABS (DT)
            TLAST = IDAY + DINT (X8) * ABS (DT) + ABS (DT)
            END IF
C                                       Antenna numbers
         IF (ILOCB.GE.0) THEN
            JA1 = RPARM(ILOCB+1) / 256. + 0.1
            JA2 = RPARM(ILOCB+1) - JA1 * 256 + 0.1
         ELSE
            JA1 = RPARM(ILOCA1+1) + 0.1
            JA2 = RPARM(ILOCA2+1) + 0.1
            END IF
         STTRIP = 1
         STQUAD = 1
C                                       Return to here to look for
C                                       further triplets involving this
C                                       baseline.
C                                       Find triplet and member
 100     DO 110 I = STTRIP,NUMTRP
            ITRIP = I
            IBASE = 1
            IF ((JA1.EQ.CPTRIP(1,I).AND.(JA2.EQ.CPTRIP(2,I)))) GO TO 120
            IBASE = 2
            IF ((JA1.EQ.CPTRIP(1,I).AND.(JA2.EQ.CPTRIP(3,I)))) GO TO 120
            IBASE = 3
            IF ((JA1.EQ.CPTRIP(2,I).AND.(JA2.EQ.CPTRIP(3,I)))) GO TO 120
 110        CONTINUE
C                                       Not wanted
         GO TO 200
C                                       wanted
 120     GOTPHS = .TRUE.
         STTRIP = ITRIP + 1
C                                       Time
         PSUMT = PSUMT + RPARM(ILOCT+1)
         IF (T1.GT.1.0E9) T1 = RPARM(ILOCT+1)
         PCNTIM = PCNTIM + 1
C                                       Vector average:
      INCLUDE 'INCS:ZVD.INC'
         DO 130 IVIS = 1,KVIS
            IF (VIS(3,IVIS).GT.0.0) THEN
               PCOUNT(IBASE,ITRIP) = PCOUNT(IBASE,ITRIP) + 1
               PCOUN1(IBASE,ITRIP) = PCOUN1(IBASE,ITRIP) + 1
               PWORK(1,IBASE,ITRIP) = PWORK(1,IBASE,ITRIP) + VIS(1,IVIS)
               PWORK(2,IBASE,ITRIP) = PWORK(2,IBASE,ITRIP) + VIS(2,IVIS)
               PGAMP(IBASE,ITRIP) = PGAMP(IBASE,ITRIP) +
     *            SQRT (VIS(1,IVIS)*VIS(1,IVIS) + VIS(2,IVIS)*
     *            VIS(2,IVIS))
               PGERR(IBASE,ITRIP) = PGERR(IBASE,ITRIP) +
     *            SQRT (1.0/VIS(3,IVIS))
               END IF
 130        CONTINUE
C                                       averaging closure phases
         IF (DT.LT.0.0) THEN
C                                       completed a triangle
            IF ((PCOUN1(1,ITRIP).GT.0) .AND. (PCOUN1(2,ITRIP).GT.0)
     *         .AND. (PCOUN1(3,ITRIP).GT.0)) THEN
               TEMP = ATAN2 (PWORK(2,1,ITRIP), PWORK(1,1,ITRIP)+1.0E-20)
     *            - ATAN2 (PWORK(2,2,ITRIP), PWORK(1,2,ITRIP)+1.0E-20)
     *            + ATAN2 (PWORK(2,3,ITRIP), PWORK(1,3,ITRIP)+1.0E-20)
               PWORKC(1,ITRIP) = PWORKC(1,ITRIP) + COS (TEMP)
               PWORKC(2,ITRIP) = PWORKC(2,ITRIP) + SIN (TEMP)
               CALL RFILL (6, 0.0, PWORK(1,1,ITRIP))
               CALL FILL (3, 0, PCOUN1(1,ITRIP))
               END IF
            END IF
C                                       This baseline may be involved in
C                                       more triplets.
         GO TO 100
C                                       NOW DO QUADRANGLES
C                                       Return to here to look for
C                                       further quadruplets involving
C                                       this baseline.
C                                       Find quadruplet and member
 200     DO 210 I = STQUAD,NUMQAD
            ITRIP = I
            IBASE = 1
            IF ((JA1.EQ.CPQUAD(1,I).AND.(JA2.EQ.CPQUAD(2,I)))) GO TO 220
            IBASE = 2
            IF ((JA1.EQ.CPQUAD(3,I).AND.(JA2.EQ.CPQUAD(4,I)))) GO TO 220
            IBASE = 3
            IF ((JA1.EQ.CPQUAD(1,I).AND.(JA2.EQ.CPQUAD(3,I)))) GO TO 220
            IBASE = 4
            IF ((JA1.EQ.CPQUAD(2,I).AND.(JA2.EQ.CPQUAD(4,I)))) GO TO 220
 210        CONTINUE
C                                       Not wanted
         GO TO 999
C                                       wanted
 220     GOTAMP = .TRUE.
         STQUAD = ITRIP + 1
C                                       Time
         ASUMT = ASUMT + RPARM(ILOCT+1)
         IF (T1.GT.1.0E9) T1 = RPARM(ILOCT+1)
         ACNTIM = ACNTIM + 1
C                                       Vector average:
      INCLUDE 'INCS:ZVD.INC'
         DO 230 IVIS = 1,KVIS
            IF (VIS(3,IVIS).GT.0.0) THEN
               ACOUNT(IBASE,ITRIP) = ACOUNT(IBASE,ITRIP) + 1
               ACOUN1(IBASE,ITRIP) = ACOUN1(IBASE,ITRIP) + 1
               AWORK(1,IBASE,ITRIP) = AWORK(1,IBASE,ITRIP) +
     *            VIS(1,IVIS)
               AWORK(2,IBASE,ITRIP) = AWORK(2,IBASE,ITRIP) +
     *            VIS(2,IVIS)
               AGAMP(IBASE,ITRIP) = AGAMP(IBASE,ITRIP) +
     *            SQRT (VIS(1,IVIS)*VIS(1,IVIS) + VIS(2,IVIS)*
     *            VIS(2,IVIS))
               AGERR(IBASE,ITRIP) = AGERR(IBASE,ITRIP) +
     *            SQRT (1.0/VIS(3,IVIS))
               END IF
 230        CONTINUE
C                                       averaging closure phases
         IF (DT.LT.0.0) THEN
C                                       completed a triangle
            IF ((ACOUN1(1,ITRIP).GT.0) .AND. (ACOUN1(2,ITRIP).GT.0)
     *         .AND. (ACOUN1(3,ITRIP).GT.0).AND. (ACOUN1(4,ITRIP).GT.0))
     *         THEN
               TEMP = SQRT (AWORK(1,3,ITRIP)**2 + AWORK(2,3,ITRIP)**2) *
     *            SQRT (AWORK(1,4,ITRIP)**2 + AWORK(2,4,ITRIP)**2) /
     *            (ACOUN1(3,ITRIP) * ACOUN1(4,ITRIP))
               IF (TEMP.NE.0.0) THEN
                  AWORKC(ITRIP) = AWORKC(ITRIP) +
     *               SQRT (AWORK(1,1,ITRIP)**2 + AWORK(2,1,ITRIP)**2) *
     *               SQRT (AWORK(1,2,ITRIP)**2 + AWORK(2,2,ITRIP)**2) /
     *               (ACOUN1(1,ITRIP) * ACOUN1(2,ITRIP)) / TEMP
                  COUNTA(ITRIP) = COUNTA(ITRIP) + 1
                  END IF
               CALL RFILL (8, 0.0, AWORK(1,1,ITRIP))
               CALL FILL (4, 0, ACOUN1(1,ITRIP))
               END IF
            END IF
C                                       This baseline may be involved in
C                                       more quadrangles
         GO TO 200
C
         END IF
C
 999  RETURN
      END
      SUBROUTINE CLOSAV (NUMVIS, NUMTRP, CPTRIP, NUMQAD, CPQUAD, DT,
     *   ASCANV, ACLERR, PSCANV, PCLERR, NUSCAN, SCANUM, RPARM, VIS,
     *   IERR)
C-----------------------------------------------------------------------
C   Reads a uv data base and returns averages of closure phases for
C   selected triplets.  The triplets are specified in array CPTRIP.
C   Needs to be initialized by a call to UVGET.
C   Inputs:
C     NUMVIS   I        Current visibility number
C     NUMTRP   I        The number of triplets selected
C     CPTRIP   I(3,*)   The antenna numbers involved in the triplets.
C     DT       R        Averaging time in days
C   Input/Output:
C     RPARM    R(*)     Random parameter array, first record of call.
C                       (1) = 'INDE' => don't use.
C     VIS      R(3,*)   Visibility array, first record of call.
C   Outputs:
C     PSCANV   R(*)     The closure phase values for the selected
C                       triplets, corresponds to CPTRIP.
C                       Undefined values will contain 'INDE'.
C     PCLERR   R(*)     The formal error associated with the closure
C                       phase, calculated as CLERR = SQRT (err(12)**2
C                       + err(13)**2 + err(23)**2)
C     NUSCAN   L        True IF the first record in a new scan.
C     IERR     I        Return code, 0 => OK, -1 => out of data,
C                          > 0 => failed.
C   Note:   If the end of data is encountered (IERR=-1) then UVGET is
C   called with OPCODE='CLOS'.
C-----------------------------------------------------------------------
      INTEGER   NUMTRP, NUMQAD, CPTRIP(3,*), CPQUAD(4,*), SCANUM,
     *    NUMVIS, IERR
      LOGICAL   NUSCAN
      REAL      RPARM(*), VIS(3,*), DT, ASCANV(*), ACLERR(*), PSCANV(*),
     *   PCLERR(*)
C
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'PEVACL.INC'
      LOGICAL   GOODP, GOODA
      INTEGER   I, KVIS, ICP, IDAY
      REAL      T1, CP, CT, TEMP
      DOUBLE PRECISION X8
      INCLUDE 'CLAVER.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DANT.INC'
      INCLUDE 'INCS:PSTD.INC'
C-----------------------------------------------------------------------
      IF (NUMVIS.EQ.0) CALL CLAVER ('ZERO', NUMTRP, CPTRIP, NUMQAD,
     *   CPQUAD, T1, DT, RPARM, VIS)
C                                       Save scan number (0= no index)
      NUSCAN = SCANUM.NE.INXRNO
      SCANUM = INXRNO
C                                       Initialize time
      T1 = 1.0E10
      KVIS = (LREC-NRPARM) / 3
C                                       Loop reading data
 100  CONTINUE
         CALL UVGET ('READ', RPARM, VIS, IERR)
         IF (IERR.GT.0) GO TO 999
         IF (IERR.EQ.-1) GO TO 200
         NUMVIS = NUMVIS + 1
         IF (MOD(NUMVIS-1,VISMSG).EQ.0) THEN
            WRITE (MSGTXT,1100) BIF, NUMVIS
            CALL MSGWRT (2)
         ELSE IF (MOD(NUMVIS-1,VISINC).EQ.0) THEN
            WRITE (MSGTXT,1100) BIF, NUMVIS
            CALL MSGWRT (1)
            END IF
         CT = RPARM(ILOCT+1) - DTUTC
C                                       Set up first time boundary
         IF (IVSCNT.EQ.0) THEN
            IDAY = CT
            X8 = (CT - IDAY) / ABS (DT)
            TLAST = IDAY + DINT (X8) * ABS (DT) + ABS (DT)
            END IF
C                                       Check if avg. or scan done
         IF ((INXRNO.LE.SCANUM) .AND. (CT.LE.TLAST)) THEN
            CALL CLAVER ('AVER', NUMTRP, CPTRIP, NUMQAD, CPQUAD, T1, DT,
     *         RPARM, VIS)
            GO TO 100
            END IF
C                                       Integration done:
C                                       Go through sums
 200  GOODP = .FALSE.
      IF (GOTPHS) THEN
C                                       Vector averaging
         CP = TWOPI
         DO 210 I = 1,NUMTRP
            IF ((PCOUNT(1,I).GT.0) .AND. (PCOUNT(2,I).GT.0) .AND.
     *         (PCOUNT(3,I).GT.0)) THEN
               IF (DT.GT.0.0) THEN
                  PSCANV(I) = ATAN2 (PWORK(2,1,I), PWORK(1,1,I)+1.0E-20)
     *               - ATAN2 (PWORK(2,2,I), PWORK(1,2,I)+1.0E-20)
     *               + ATAN2 (PWORK(2,3,I), PWORK(1,3,I)+1.0E-20)
               ELSE
                  PSCANV(I) = ATAN2 (PWORKC(2,I), PWORKC(1,I)+1.0E-20)
                  END IF
               PGERR(1,I) = PGERR(1,I) / PGAMP(1,I)
               PGERR(2,I) = PGERR(2,I) / PGAMP(2,I)
               PGERR(3,I) = PGERR(3,I) / PGAMP(3,I)
               PCLERR(I) = SQRT (
     *            PGERR(1,I)* PGERR(1,I) / MAX(PCOUNT(1,I)-1,1) +
     *            PGERR(2,I)* PGERR(2,I) / MAX(PCOUNT(2,I)-1,1) +
     *            PGERR(3,I)* PGERR(3,I) / MAX(PCOUNT(3,I)-1,1))
               GOODP = .TRUE.
            ELSE
               PSCANV(I) = FBLANK
               PCLERR(I) = FBLANK
               END IF
 210        CONTINUE
         END IF
C                                       have some results
      IF (GOODP) THEN
C                                       Force range of values= +/- pi
C                                       rad.
         DO 220 I = 1,NUMTRP
            IF (PSCANV(I).NE.FBLANK) THEN
               CP = PSCANV(I) / TWOPI
               ICP = CP
               CP = (CP - ICP) * TWOPI
               IF (CP.GT.PI) CP = CP - TWOPI
               IF (CP.LT.-PI) CP = CP + TWOPI
               PSCANV(I) = CP
               PSCANV(I) = PSCANV(I) * RAD2DG
               IF (PCLERR(I).NE.FBLANK) PCLERR(I) = PCLERR(I) * RAD2DG
               END IF
 220        CONTINUE
         END IF
C                                       now amplitudes
      GOODA = .FALSE.
      IF (GOTAMP) THEN
C                                       Vector averaging
         DO 230 I = 1,NUMQAD
            IF ((ACOUNT(1,I).GT.0) .AND. (ACOUNT(2,I).GT.0) .AND.
     *         (ACOUNT(3,I).GT.0) .AND. (ACOUNT(4,I).GT.0)) THEN
               IF (DT.GT.0.0) THEN
                  ASCANV(I) = SQRT (AWORK(1,1,I)**2 + AWORK(2,1,I)**2) *
     *               SQRT (AWORK(1,2,I)**2 + AWORK(2,2,I)**2) /
     *               (ACOUNT(1,I) * ACOUNT(2,I))
                  TEMP = SQRT (AWORK(1,3,I)**2 + AWORK(2,3,I)**2) *
     *               SQRT (AWORK(1,4,I)**2 + AWORK(2,4,I)**2) /
     *               (ACOUNT(3,I) * ACOUNT(4,I))
               ELSE
                  ASCANV(I) = AWORKC(I)
                  TEMP = COUNTA(I)
                  END IF
               IF ((TEMP.GT.0.0) .AND. (ASCANV(I).GT.0.0)) THEN
                  ASCANV(I) = ASCANV(I) / TEMP
                  AGERR(1,I) = AGERR(1,I) / ACOUNT(1,I)
                  AGERR(2,I) = AGERR(2,I) / ACOUNT(2,I)
                  AGERR(3,I) = AGERR(3,I) / ACOUNT(3,I)
                  AGERR(4,I) = AGERR(4,I) / ACOUNT(4,I)
                  ACLERR(I) = SQRT (
     *               AGERR(1,I)*AGERR(1,I)/MAX(1,ACOUNT(1,I)-1) +
     *               AGERR(2,I)*AGERR(2,I)/MAX(1,ACOUNT(2,I)-1) +
     *               AGERR(3,I)*AGERR(3,I)/MAX(1,ACOUNT(3,I)-1) +
     *               AGERR(4,I)*AGERR(4,I)/MAX(1,ACOUNT(4,I)-1))
                  IF (ASCANV(I).NE.0.0) THEN
                     ACLERR(I) = ACLERR(I) / ASCANV(I)
                     ASCANV(I) = LOG (ASCANV(I))
                     END IF
                  GOODA = .TRUE.
               ELSE
                  ASCANV(I) = FBLANK
                  ACLERR(I) = FBLANK
                  END IF
            ELSE
               ASCANV(I) = FBLANK
               ACLERR(I) = FBLANK
               END IF
 230        CONTINUE
         END IF
C                                       have some results
C                                       save current sample
      IF (IERR.EQ.0) THEN
         CALL CLAVER ('ZERO', NUMTRP, CPTRIP, NUMQAD, CPQUAD, T1, DT,
     *      RPARM, VIS)
         CALL CLAVER ('AVER', NUMTRP, CPTRIP, NUMQAD, CPQUAD, T1, DT,
     *      RPARM, VIS)
         END IF
C                                       End of data, calling routine
C                                       will close.
      IF ((.NOT.GOODP) .AND. (.NOT.GOODA)) THEN
         IF ((IERR.EQ.0) .AND. (SCANUM.GE.INXRNO)) GO TO 100
         IF (IERR.EQ.0) IERR = -2
         END IF
      GO TO 999
C
 999  RETURN
C-----------------------------------------------------------------------
 1100 FORMAT ('IF',I4,'  at visibility number',I10)
      END
