LOCAL INCLUDE 'FGCNT.INC'
C                                       Local include for FGCNT
      INCLUDE 'INCS:ZPBUFSZ.INC'
      HOLLERITH XNAMEI(3), XCLAIN(2), XSOUR(4,30), XCALC(1), XXSTOK(1),
     *   XOPTYP(1), XOUTFI(12)
      REAL      XSIN, XDISIN, XQUAL, XTIME(8), XBAND, XFREQ, XFQID,
     *   XANT(50), XBASE(50), XSUBA, XBIF, XEIF, XBCHAN, XECHAN,
     *   XDOCAL, XGUSE, XDOPOL, XPDVER, XBLVER, XFLAG, XFLAG2, XDOBND,
     *   XBPVER, XSMOTH(3), XDOAC, PRTLEV, XIF, XCHAN, XREF, BADD(10),
     *   SCRBUF(256), BUFF2(UVBFSS)
      INTEGER   SEQIN, DISKIN, JBUFSZ, CATOLD(256), INCSI, INCFI,
     *   INCIFI, INCSO, INCFO, INCIFO, LRECO, OLDCNO, IXANT(50),
     *   IXBAS(50), NXANT, NXBAS, INSNUM, POLTYP, SPIF, SPCHAN, SPANT
      LOGICAL   DESEL, ONLY1, NOCAL, DOSPEC
      CHARACTER NAMEIN*12, CLAIN*6, OPTYPE*4, OUTFIL*48
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XSOUR, XQUAL, XCALC,
     *   XXSTOK, XTIME, XBAND, XFREQ, XFQID, XANT, XBASE, XSUBA, XBIF,
     *   XEIF, XBCHAN, XECHAN, XDOCAL, XGUSE, XDOPOL, XPDVER, XBLVER,
     *   XFLAG, XFLAG2, XDOBND, XBPVER, XSMOTH, XDOAC, XOPTYP, PRTLEV,
     *   XIF, XCHAN, XREF, XOUTFI, BADD
      COMMON /FGCNTP/ CATOLD, SEQIN, DISKIN, INCSI, INCFI, INCIFI,
     *   INCSO, INCFO, INCIFO, LRECO, OLDCNO, IXANT, IXBAS, NXANT,
     *   NXBAS, DESEL, INSNUM, POLTYP, ONLY1, NOCAL, DOSPEC, SPIF,
     *   SPCHAN, SPANT
      COMMON /CHARPM/ NAMEIN, CLAIN, OPTYPE, OUTFIL
      COMMON /BUFRS/ SCRBUF, BUFF2, JBUFSZ
C                                       End local include for FGCNT
LOCAL END
LOCAL INCLUDE 'FGCNTSOU.INC'
      INCLUDE 'INCS:PUVD.INC'
      INTEGER NUMSOU, SUNUMS(1000), SUMAX(1000,2), LP1, LP2, LF1, LF2,
     *   WANT(MAXANT), NUMCH, NUMIFS, PRTL
      CHARACTER SUNAMS(1000)*16
      COMMON /SUCOMM/ NUMSOU, SUNUMS, SUMAX, WANT, LP1, LP2, LF1, LF2,
     *   NUMCH, NUMIFS, PRTL
      COMMON /SUCOMC/ SUNAMS
LOCAL END
      PROGRAM FGCNT
C-----------------------------------------------------------------------
C! counts samples with different sampling
C# Utility UV editing
C-----------------------------------------------------------------------
C;  Copyright (C) 2016, 2018, 2020, 2022, 2024
C;  Associated Universities, Inc. Washington DC, USA.
C;
C;  This program is free software; you can redistribute it and/or
C;  modify it under the terms of the GNU General Public License as
C;  published by the Free Software Foundation; either version 2 of
C;  the License, or (at your option) any later version.
C;
C;  This program is distributed in the hope that it will be useful,
C;  but WITHOUT ANY WARRANTY; without even the implied warranty of
C;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C;  GNU General Public License for more details.
C;
C;  You should have received a copy of the GNU General Public
C;  License along with this program; if not, write to the Free
C;  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge,
C;  MA 02139, USA.
C;
C;  Correspondence concerning AIPS should be addressed as follows:
C;         Internet email: aipsmail@nrao.edu.
C;         Postal address: AIPS Project Office
C;                         National Radio Astronomy Observatory
C;                         520 Edgemont Road
C;                         Charlottesville, VA 22903-2475 USA
C-----------------------------------------------------------------------
C   FGCNT counts sampling with flag versions FLAGVER and optionally
C   IN2VERS
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET, VISCNT(2), ANTCNT(2), NWORDS, NC
      LONGINT   VISPTR, ANTPTR
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'FGCNT.INC'
      INCLUDE 'FGCNTSOU.INC'
      DATA PRGM /'FGCNT'/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL FGCNTI (PRGM, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       counting memories
      NC = NUMIFS
      IF (ONLY1) NC = NC * NUMCH
      NWORDS = (4 * NC * NUMSOU * 2 - 1) / 1024 + 4
      CALL ZMEMRY ('GET ', TSKNAM, NWORDS, VISCNT, VISPTR, IRET)
      IF ((IRET.EQ.0) .AND. (OPTYPE(:2).EQ.'AN')) THEN
         NWORDS = (4 * NC * MAXANT * NUMSOU * 2 - 1) / 1024 + 4
         CALL ZMEMRY ('GET ', TSKNAM, NWORDS, ANTCNT, ANTPTR, IRET)
         END IF
      IF (IRET.NE.0) THEN
         MSGTXT = 'FAILED TO GET DYNAMIC MEMORY NEEDED'
         CALL MSGWRT (8)
         GO TO 990
         END IF
      SPIF = SPIF - BIF + 1
      SPCHAN = SPCHAN - BCHAN + 1
C                                       Count the flagged data
      IF (NOCAL) THEN
         CALL FGCNTN (NC, MAXANT, NUMSOU, VISCNT(1+VISPTR),
     *      ANTCNT(1+ANTPTR), IRET)
      ELSE
         CALL FGCNTU (NC, MAXANT, NUMSOU, VISCNT(1+VISPTR),
     *      ANTCNT(1+ANTPTR), IRET)
         END IF
         IF (IRET.NE.0) GO TO 990

      IF (DOSPEC) CALL PRTSPC (0, 0, 0, 10000.0, BUFF2)
C                                       print the results
      CALL FGCNTH (OPTYPE, ONLY1, NC, MAXANT, NUMSOU, VISCNT(1+VISPTR),
     *   ANTCNT(1+ANTPTR), POLTYP)
C                                       Close down files, etc.
 990  CALL DIE (IRET, SCRBUF)
C
 999  STOP
      END
      SUBROUTINE FGCNTI (PRGN, JERR)
C-----------------------------------------------------------------------
C   FGCNTI gets input parameters for FGCNT and creates an output file
C   if necessary.
C   Inputs:
C      PRGN    C*6  Program name
C   Output:
C      JERR    I    Error code: 0 => ok
C                                5 => catalog troubles
C                                8 => can't start
C   Output in common:
C      NRPRMI  I  Input number of random parameters.
C      INCSI   I  Input Stokes' increment in vis.
C      INCFI   I  Input frequency increment in vis.
C      INCIFI  I  Input IF increment in vis.
C-----------------------------------------------------------------------
      INTEGER   JERR
      CHARACTER PRGN*6
C
      CHARACTER STAT*4, BLANK*6, PTYPE*2
      INTEGER   IROUND, NPARM, IERR, INCX, I, NFREQ, LUN, J
      LOGICAL   MATCH
      REAL      CATR(256), RPARM(20)
      HOLLERITH CATH(256)
      DOUBLE PRECISION CATD(128)
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'FGCNT.INC'
      INCLUDE 'FGCNTSOU.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DUVH.INC'
      EQUIVALENCE (CATBLK, CATR, CATH, CATD)
      DATA BLANK  /' '/
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      CALL SELINI
      JBUFSZ = UVBFSS * 2
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      JERR = 0
C                                       Get input parameters.
      NPARM = 286
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, SCRBUF, IERR)
      IF (IERR.NE.0) THEN
         RQUICK = .TRUE.
         JERR = 8
         IF (IERR.EQ.1) GO TO 999
            WRITE (MSGTXT,1000) IERR, 'OBTAINING INPUT PARAMETERS'
            CALL MSGWRT (8)
         END IF
C                                       Restart AIPS
      IF (RQUICK) CALL RELPOP (JERR, SCRBUF, IERR)
      IF (JERR.NE.0) GO TO 999
      JERR = 5
C                                       Crunch input parameters.
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      CALL H2CHR (4, 1, XCALC, SELCOD)
      CALL H2CHR (4, 1, XXSTOK, STOKES)
      CALL H2CHR (4, 1, XOPTYP, OPTYPE)
      CALL H2CHR (48, 1, XOUTFI, OUTFIL)
      DO 5 I = 1,10
         IBAD(I) = IROUND(BADD(I))
 5       CONTINUE
      DO 10 I = 1,30
         CALL H2CHR (16, 1, XSOUR(1,I), SOURCS(I))
 10      CONTINUE
      SELQUA = IROUND (XQUAL)
      SEQIN = IROUND (XSIN)
      DISKIN = IROUND (XDISIN)
      PRTL = IROUND (PRTLEV)
      SPIF = XIF + 0.1
      SPCHAN = XCHAN + 0.1
      SPANT = XREF + 0.1
      DOSPEC = (SPIF.GT.0) .AND. (SPCHAN.GT.0) .AND. (OUTFIL.NE.' ')
C                                       Info for UVGET:
C                                       Put selection criteria into
C                                       correct common.
      UNAME = NAMEIN
      UCLAS = CLAIN
      UDISK = DISKIN
      USEQ = SEQIN
      DOCAL = XDOCAL.GT.0.0
      DOWTCL = DOCAL .AND. (XDOCAL.LE.99.0)
      DOACOR = XDOAC.GT.0.0
C                                       Set time range.
      CALL RCOPY (8, XTIME, TIMRNG)
      IF ((TIMRNG(1)+TIMRNG(2)+TIMRNG(3)+TIMRNG(4)) .EQ.0.0)
     *   TIMRNG(1)=-1.0E6
      IF ((TIMRNG(5)+TIMRNG(6)+TIMRNG(7)+TIMRNG(8)) .EQ.0.0)
     *   TIMRNG(5)=1.0E6
      TSTART = TIMRNG(1) + TIMRNG(2) / 24. + TIMRNG(3) / (24. * 60.) +
     *   TIMRNG(4) / (24. * 60. * 60.)
      TEND = TIMRNG(5) + TIMRNG(6) / 24. + TIMRNG(7) / (24. * 60.) +
     *   TIMRNG(8) / (24. * 60. * 60.)
      DOPOL = IROUND(XDOPOL)
      IF (XDOPOL.GT.0.0) DOPOL = MAX (1, DOPOL)
      PDVER = IROUND (XPDVER)
      DOAPPL = .FALSE.
      SUBARR = IROUND (XSUBA)
      IF (SUBARR.LT.0) SUBARR = 0
      FGVER = IROUND (XFLAG)
      IF (FGVER.LE.0) FGVER = -1
      IF (OPTYPE.EQ.'ANCH') XFLAG2 = 0.0
      ONLY1 = XFLAG2.LT.0.5
      NOCAL = ONLY1 .AND. (XFLAG.LT.0.) .AND. (XDOBND.LT.0.) .AND.
     *   (XDOCAL.LT.0.)
      IF (ONLY1) STOKES = ' '
      DOBAND = IROUND (XDOBND)
      BPVER = IROUND (XBPVER)
      CALL RCOPY (3, XSMOTH, SMOOTH)
      CLVER = IROUND (XGUSE)
      CLUSE = IROUND (XGUSE)
      BLVER = IROUND (XBLVER)
C                                       Get CATBLK from old file.
      OLDCNO = 1
      PTYPE = 'UV'
      CALL CATDIR ('SRCH', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN,
     *   PTYPE, NLUSER, STAT, SCRBUF, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1030) IERR, NAMEIN, CLAIN, SEQIN, DISKIN,
     *      NLUSER
         GO TO 990
         END IF
      CALL CATIO ('READ', DISKIN, OLDCNO, CATBLK, 'REST', SCRBUF, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READING HEADR'
         GO TO 990
         END IF
C                                       Save input CATBLK
      CALL COPY (256, CATBLK, CATOLD)
C                                       Get uv header info.
      CALL UVPGET (JERR)
      IF (JERR.NE.0) GO TO 999
C                                       Channel selection?
      IF (JLOCIF.LT.0) THEN
         BIF = 1
         EIF = 1
      ELSE
         BIF = IROUND (XBIF)
         EIF = IROUND (XEIF)
         BIF = MIN (MAX (1, BIF), CATBLK(KINAX+JLOCIF))
         IF (EIF.LT.BIF) EIF = CATBLK(KINAX+JLOCIF)
         END IF
      NUMIFS = EIF - BIF + 1
      NFREQ = CATBLK(KINAX+JLOCF)
      LF1 = IROUND (XBCHAN)
      LF2 = IROUND (XECHAN)
      IF ((LF1.LE.0) .OR. (LF1.GT.NFREQ)) LF1 = 1
      IF ((LF2.LE.0) .OR. (LF2.GT.NFREQ)) LF2 = NFREQ
      IF (LF1.GT.LF2) THEN
         MSGTXT = 'INVALID BCHAN AND ECHAN'
         CALL MSGWRT (6)
         JERR = 1
         GO TO 990
         END IF
      IF (NOCAL) THEN
         BCHAN = 1
         ECHAN = NFREQ
      ELSE
         BCHAN = LF1
         ECHAN = LF2
         END IF
      NUMCH = ECHAN - BCHAN + 1
C                                       Freq id
      IF (XBAND.GT.0.0) SELBAN = XBAND
      IF (XFREQ.GT.0.0) SELFRQ = XFREQ
      FRQSEL = IROUND (XFQID)
      IF (FRQSEL.EQ.0) FRQSEL = -1
      LUN = 28
      CALL FQMATC (DISKIN, OLDCNO, CATBLK, LUN, SELBAN, SELFRQ, MATCH,
     *   FRQSEL, JERR)
      IF (.NOT.MATCH) THEN
         MSGTXT = 'NO MATCH TO SELBAND/SELFREQ ADVERBS - CHECK INPUTS'
         JERR = 1
         GO TO 990
         END IF
      IF (JERR.GT.0) GO TO 999
C                                       Find baselines to copy
      CALL SETANT (50, XANT, XBASE, NXANT, NXBAS, IXANT, IXBAS, DESEL)
C                                       print desires
      IF (ONLY1) THEN
         IF (DESEL) THEN
            J = 0
            CALL FILL (MAXANT, 1, WANT)
         ELSE
            J = 1
            CALL FILL (MAXANT, 0, WANT)
            END IF
         DO 20 I = 1,NXANT
            WANT(IXANT(I)) = J
 20         CONTINUE
         CALL H2CHR (4, 1, XXSTOK, STAT)
         LP1 = 1
         LP2 = 4
         IF ((STAT.EQ.'HALF') .OR. (STAT.EQ.'RRLL') .OR.
     *      (STAT.EQ.'VVHH')) THEN
            LP2 = 2
         ELSE IF ((STAT.EQ.'CROS') .OR. (STAT.EQ.'RLLR') .OR.
     *      (STAT.EQ.'VHHV')) THEN
            LP1 = 3
            LP2 = 4
         ELSE IF ((STAT.EQ.'RR') .OR. (STAT.EQ.'VV')) THEN
            LP2 = 1
         ELSE IF ((STAT.EQ.'LL') .OR. (STAT.EQ.'HH')) THEN
            LP1 = 2
            LP2 = 2
         ELSE IF ((STAT.EQ.'RL') .OR. (STAT.EQ.'VH')) THEN
            LP1 = 3
            LP2 = 3
         ELSE IF ((STAT.EQ.'LR') .OR. (STAT.EQ.'HV')) THEN
            LP1 = 4
            LP2 = 4
            END IF
         END IF
C                                       now using cal system -
C                                       UVGET makes header
      IF (.NOT.NOCAL) THEN
         CALL UVGET ('INIT', RPARM, SCRBUF, JERR)
         IF (JERR.NE.0) THEN
            WRITE (MSGTXT,1035) JERR
            GO TO 990
            END IF
         CALL UVGET ('CLOS', RPARM, SCRBUF, IERR)
         END IF
      INSNUM = 1
      IF ((NSOUWD.EQ.1) .AND. (DOSWNT)) INSNUM = SOUWAN(1)
      POLTYP = 4
      IF (ICOR0.EQ.-1) THEN
         IF (CATR(KRCIC+JLOCS).EQ.-1.0) POLTYP = 1
      ELSE IF (ICOR0.EQ.-5) THEN
         IF (CATR(KRCIC+JLOCS).EQ.-1.0) POLTYP = 2
      ELSE IF (ICOR0.EQ.1) THEN
         IF (CATR(KRCIC+JLOCS).EQ.1.0) POLTYP = 3
         END IF
C                                       Save input file info
      INCX = CATBLK(KINAX)
      INCSI = INCS / INCX
      INCFI = INCF / INCX
      INCIFI = INCIF / INCX
C                                        Put input file in READ
      PTYPE = 'UV'
      CALL CATDIR ('CSTA', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN,
     *   PTYPE, NLUSER, 'READ', SCRBUF, IERR)
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = OLDCNO
      FRW(NCFILE) = 0
C                                       set up source and count common
      CALL SOUSET (DISKIN, OLDCNO, CATOLD, JERR)
      IF (JERR.NE.0) THEN
         WRITE (MSGTXT,1000) JERR, 'READING SOURCE TABLE'
         GO TO 990
         END IF
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('FGCNTI: ERROR',I3,1X,A)
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
     *   I3,' USID=',I5)
 1035 FORMAT ('UVGET INIT ERROR',I3,' CHECK ADVERBS')
      END
      SUBROUTINE SOUSET (DISK, CNO, CATBLK, IRET)
C-----------------------------------------------------------------------
C   reads source numbers and names from source file
C   Inputs:
C      DISK     I      Disk number
C      CNO      I      Catalog number
C      CATBLK   I(*)   input header
C   Output:
C      IRET     I      error code
C-----------------------------------------------------------------------
      INTEGER   DISK, CNO, CATBLK(256), IRET
C
      INTEGER   NREC, IREC, VER, LUN, NKEY, NCOL, DATP(128,2), I,
     *   BUFFER(512), KOLS(2), SUNUM, LRNO, SCRTCH(1024), ITYPE,
     *   INAME(4)
      CHARACTER KOLTYP(2)*24
      HOLLERITH HNAME(4)
      EQUIVALENCE (INAME, HNAME)
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'FGCNTSOU.INC'
      DATA KOLTYP /'ID. NO.', 'SOURCE'/
C-----------------------------------------------------------------------
C                                       single source?
      CALL FNDEXT ('SU', CATBLK, I)
      IF (I.LE.0) THEN
         NUMSOU = 1
         SUNAMS(1) = ' '
         CALL COPY (2, CATBLK(KHOBJ), INAME)
         CALL H2CHR (8, 1, HNAME, SUNAMS(1))
         GO TO 999
         END IF
C                                       open source table
      VER = 1
      LUN = 86
      CALL TABINI ('READ', 'SU', DISK, CNO, VER, CATBLK, LUN, NKEY,
     *   NREC, NCOL, DATP, BUFFER, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPEN SOURCE TABLE'
         GO TO 980
         END IF
C                                       locate columns
      CALL FNDCOL (2, KOLTYP, 24, .TRUE., BUFFER, KOLS, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'FIND SOURCE NAME AND NUMBER COLS'
         GO TO 980
         END IF
C                                       read it
      NREC = BUFFER(5)
      LRNO = 0
      DO 100 IREC = 1,NREC
         CALL GETCOL (IREC, KOLS(1), DATP, LRNO, BUFFER, ITYPE, HNAME,
     *      SCRTCH, IRET)
         SUNUM = INAME(1)
         IF (IRET.EQ.0) CALL GETCOL (IREC, KOLS(2), DATP, LRNO, BUFFER,
     *      ITYPE, HNAME, SCRTCH, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READ SU TABLE ROW'
            GO TO 980
            END IF
         CALL H2CHR (16, 1, HNAME, SUNAMS(IREC))
         SUNUMS(IREC) = SUNUM
 100     CONTINUE
      NUMSOU = NREC
      CALL TABIO ('CLOS', 0, IREC, BUFFER, BUFFER, IRET)
      GO TO 999
C
 980  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SOUSET ERROR',I4,' ON ',A)
      END
      SUBROUTINE FGCNTU (NI, NA, NS, VISCNT, ANTCNT, IRET)
C-----------------------------------------------------------------------
C   FGCNTU reads with flag table 1 calling counter subroutine, then
C   if desired reads with flag table 2 calling counter routine
C   Inputs:
C      NI       I      Number channels
C      NA       I      Number antennas
C      NS       I      Number sources
C   Outputs:
C      VISCNT   I(*)   Counts (pol,chan,source,2)
C      ANTCNT   I(*)   Counts (pol,chan,antenna,source,2)
C   Output:
C      IRET    I  Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   NI, NA, NS, VISCNT(4,NI,NS,2), ANTCNT(4,NI,NA,NS,2),
     *   IRET
C
      INCLUDE 'FGCNT.INC'
      INTEGER   IA1, IA2, NUMVS1, NUMVS2, CATMP(256), I, ITYP
      LOGICAL   REQBAS
      REAL      BASEN, VIS(UVBFSS), RPARM(20)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DSEL.INC'
C-----------------------------------------------------------------------
C                                       defend cat header from UVGET
      CALL COPY (256, CATBLK, CATMP)
      WRITE (MSGTXT,1010) FGVER
      CALL MSGWRT (2)
C                                       Open and init for read
      CALL UVGET ('INIT', RPARM, VIS, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET
         GO TO 990
         END IF
      CALL COPY (256, CATMP, CATBLK)
      CALL UVPGET (IRET)
      NUMVS1 = 0
      NUMVS2 = 0
      I = 4 * NI * NS * 2
      CALL FILL (I, 0, VISCNT)
      I = I * NA
      IF (OPTYPE(:2).EQ.'AN') CALL FILL (I, 0, ANTCNT)
      ITYP = 1
      IF (ONLY1) ITYP = 0
C                                       Loop for before
C                                       Read vis. record.
 100  CALL UVGET ('READ', RPARM, VIS, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1100) IRET
         GO TO 990
C                                       Loop over buffer
      ELSE IF (IRET.EQ.0) THEN
         IF (ILOCB.GE.0) THEN
            BASEN = RPARM(1+ILOCB)
            IA1 = BASEN / 256. + 0.1
            IA2 = BASEN - IA1*256. + 0.1
         ELSE
            IA1 = RPARM(1+ILOCA1) + 0.1
            IA2 = RPARM(1+ILOCA2) + 0.1
         END IF
         IF (.NOT.ONLY1) THEN
            IF (.NOT.REQBAS (IA1, IA2, DESEL, IXANT, NXANT, IXBAS,
     *         NXBAS)) GO TO 100
            END IF
         NUMVS1 = NUMVS1 + 1
C                                       call counting routine
         CALL FGCNTC (ITYP, VIS, RPARM, IA1, IA2, NI, NA, NS, VISCNT,
     *      ANTCNT)
C                                       read next
         GO TO 100
         END IF
      CALL UVGET ('CLOS', RPARM, VIS, IRET)
      IF (ONLY1) GO TO 999
C                                       now after
      FGVER = XFLAG2 + 0.1
      WRITE (MSGTXT,1010) FGVER
      CALL MSGWRT (2)
C                                       Open and init for read
      CALL UVGET ('INIT', RPARM, VIS, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET
         GO TO 990
         END IF
      CALL COPY (256, CATMP, CATBLK)
      CALL UVPGET (IRET)
C                                       Loop for after
C                                       Read vis. record.
 200  CALL UVGET ('READ', RPARM, VIS, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1100) IRET
         GO TO 990
C                                       Loop over buffer
      ELSE IF (IRET.EQ.0) THEN
         IF (ILOCB.GE.0) THEN
            BASEN = RPARM(1+ILOCB)
            IA1 = BASEN / 256. + 0.1
            IA2 = BASEN - IA1*256. + 0.1
         ELSE
            IA1 = RPARM(1+ILOCA1) + 0.1
            IA2 = RPARM(1+ILOCA2) + 0.1
            END IF
         IF (.NOT.REQBAS (IA1, IA2, DESEL, IXANT, NXANT, IXBAS, NXBAS))
     *      GO TO 200
         NUMVS2 = NUMVS2 + 1
C                                       call counting routine
         CALL FGCNTC (2, VIS, RPARM, IA1, IA2, NI, NA, NS, VISCNT,
     *      ANTCNT)
C                                       read next
         GO TO 200
         END IF
      CALL UVGET ('CLOS', RPARM, VIS, IRET)
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('FGCNTU: ERROR',I3,' OPEN/INIT INPUT VIS FILE')
 1010 FORMAT ('Start reading with flag table version',I5)
 1100 FORMAT ('FGCNTU: ERROR',I3,' READING VIS FILE')
      END
      SUBROUTINE FGCNTN (NI, NA, NS, VISCNT, ANTCNT, IRET)
C-----------------------------------------------------------------------
C   FGCNTN reads with no flagging or other calibration
C   Inputs:
C      NI       I      Number channels
C      NA       I      Number antennas
C      NS       I      Number sources
C   Outputs:
C      VISCNT   I(*)   Counts (pol,chan,source,2)
C      ANTCNT   I(*)   Counts (pol,chan,antenna,source,2)
C   Output:
C      IRET    I  Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   NI, NA, NS, VISCNT(4,NI,NS,2), ANTCNT(4,NI,NA,NS,2),
     *   IRET
C
      INCLUDE 'FGCNT.INC'
      CHARACTER IFILE*48
      INTEGER   IA1, IA2, NCORI, LUNI, INDI, VO, ILENBU, I, BO, IBIND,
     *   IPTRI, NUMVIS, INIO, ILOCWT
      REAL      BASEN, CBUFF(UVBFSS)
      LOGICAL   T, F, ISCOMP
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA LUNI /16/
      DATA VO, BO /0, 1/
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
      ISCOMP = CATBLK(KINAX).EQ.1
      IF (ISCOMP) THEN
C                                       Find weight and scale.
         CALL AXEFND (8, 'WEIGHT  ', CATBLK(KIPCN), CATH(KHPTP), ILOCWT,
     *      IRET)
         IF (IRET.NE.0) THEN
            MSGTXT = 'ERROR FINDING WEIGHT FOR COMPRESSED DATA'
            IRET = 9
            GO TO 990
            END IF
         END IF
C                                       Number of visibilities in input
C                                       and output files.
      NCORI = (LREC - NRPARM) / CATBLK(KINAX)
C                                       Open and init for read
C                                       visibility file
      CALL ZPHFIL ('UV', DISKIN, OLDCNO, 1, IFILE, IRET)
      CALL ZOPEN (LUNI, INDI, DISKIN, IFILE, T, F, F, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1000) IRET
         GO TO 990
         END IF
C                                       Init vis file for read.
      ILENBU = 0
      CALL UVINIT ('READ', LUNI, INDI, NVIS, VO, LREC, ILENBU, JBUFSZ,
     *   BUFF2, BO, IBIND, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1030) IRET
         GO TO 990
         END IF
      NUMVIS = 0
      I = 4 * NI * NS * 2
      CALL FILL (I, 0, VISCNT)
      I = I * NA
      IF (OPTYPE(:2).EQ.'AN') CALL FILL (I, 0, ANTCNT)
C                                       Loop
 100  CONTINUE
C                                       Read vis. record.
         CALL UVDISK ('READ', LUNI, INDI, BUFF2, INIO, IBIND, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1100) IRET
            GO TO 990
            END IF
         IPTRI = IBIND
C                                       Out of data?
         IF (INIO.LE.0) GO TO 200
C                                       Loop over buffer
         DO 190 I = 1,INIO
            IF (ILOCB.GE.0) THEN
               BASEN = BUFF2(IPTRI+ILOCB)
               IA1 = BASEN / 256. + 0.1
               IA2 = BASEN - IA1*256. + 0.1
            ELSE
               IA1 = BUFF2(IPTRI+ILOCA1) + 0.1
               IA2 = BUFF2(IPTRI+ILOCA2) + 0.1
               END IF
            NUMVIS = NUMVIS + 1
C                                      Call user routine.
            IF (ISCOMP) THEN
C                                       Compressed data.
               CALL ZUVXPN (NCORI, BUFF2(IPTRI+NRPARM),
     *            BUFF2(IPTRI+ILOCWT), CBUFF)
C                                       call counting routine
               CALL FGCNTC (0, CBUFF, BUFF2(IPTRI), IA1, IA2, NI, NA,
     *            NS, VISCNT, ANTCNT)
            ELSE
C                                       Un compressed data
C                                       call counting routine
               CALL FGCNTC (0, BUFF2(IPTRI+NRPARM), BUFF2(IPTRI), IA1,
     *            IA2, NI, NA, NS, VISCNT, ANTCNT)
               END IF
C                                       OK, but no output please
            IPTRI = IPTRI + LREC
 190        CONTINUE
C                                       Read next buffer.
         GO TO 100
C                                       Close files
 200  CALL ZCLOSE (LUNI, INDI, IRET)
      IRET = 0
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('FGCNTN: ERROR',I3,' OPEN-FOR-READ VIS FILE')
 1030 FORMAT ('FGCNTN: ERROR',I3,' INIT-FOR-READ VIS FILE')
 1100 FORMAT ('FGCNTN: ERROR',I3,' READING VIS FILE')
      END
      SUBROUTINE FGCNTH (OPTYPE, ONLY1, NI, NA, NS, VISCNT, ANTCNT,
     *   POLTYP)
C-----------------------------------------------------------------------
C   FGCNTH prints the results
C-----------------------------------------------------------------------
      CHARACTER OPTYPE*4
      LOGICAL   ONLY1
      INTEGER   NI, NA, NS, VISCNT(4,NI,NS,2), ANTCNT(4,NI,NA,NS,2),
     *   POLTYP
C
      INTEGER   LP, LS, LI, JI, LA, N1, N2, N3, J, JTRIM, LF, JJ, JF
      REAL      FRAC
      LOGICAL   FIRST
      CHARACTER POLLAB(4,4)*2
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'FGCNTSOU.INC'
      DATA POLLAB /'RR','LL','RL','LR', 'HH','VV','VH','HV',
     *   'I','Q','U','V', '1','2','3','4'/
C-----------------------------------------------------------------------
C                                       Find maximum
      DO 840 LS = 1,NUMSOU
         SUMAX(LS,1) = 0
         SUMAX(LS,2) = 0
         DO 830 LP = 1,4
            DO 820 LI = 1,NI
               SUMAX(LS,1) = MAX (SUMAX(LS,1), VISCNT(LP,LI,LS,1))
               IF (OPTYPE(:2).EQ.'AN') THEN
                  DO 810 LA = 1,NA
                     SUMAX(LS,2) = MAX (SUMAX(LS,2),
     *                  ANTCNT(LP,LI,LA,LS,1))
 810                 CONTINUE
                  END IF
 820           CONTINUE
 830        CONTINUE
 840     CONTINUE
C                                       sum over antennas
      IF (.NOT.ONLY1) THEN
         IF (OPTYPE(:2).NE.'AN') THEN
            WRITE (MSGTXT,1000)
            CALL MSGWRT (5)
            DO 40 LS = 1,NUMSOU
               J = JTRIM (SUNAMS(LS))
               DO 30 LP = 1,4
                  FIRST = .TRUE.
                  DO 20 LI = BIF,EIF
                     JI = LI - BIF + 1
                     IF ((VISCNT(LP,JI,LS,1).GT.0) .OR.
     *                  (VISCNT(LP,JI,LS,2).GT.0)) THEN
                        FRAC = (VISCNT(LP,JI,LS,1) - VISCNT(LP,JI,LS,2))
                        FRAC = (100.0 * FRAC) / VISCNT(LP,JI,LS,1)
                        IF (FIRST) THEN
                           WRITE (MSGTXT,1010) SUNUMS(LS),
     *                        SUNAMS(LS)(:J),POLLAB(LP,POLTYP)
                           CALL MSGWRT (5)
                           FIRST = .FALSE.
                           END IF
                        WRITE (MSGTXT,1020) LI, VISCNT(LP,JI,LS,1),
     *                     VISCNT(LP,JI,LS,2), FRAC
                        CALL MSGWRT (5)
                        END IF
 20                  CONTINUE
 30               CONTINUE
 40           CONTINUE
C                                       sum over IFS
         ELSE IF (OPTYPE.EQ.'ANTE') THEN
            WRITE (MSGTXT,1100)
            CALL MSGWRT (5)
            DO 140 LS = 1,NUMSOU
               J = JTRIM (SUNAMS(LS))
               DO 130 LA = 1,NA
                  FIRST = .TRUE.
                  DO 120 LP = 1,4
                     N1 = 0
                     N2 = 0
                     DO 110 JI = 1,NI
                        N1 = N1 + ANTCNT(LP,JI,LA,LS,1)
                        N2 = N2 + ANTCNT(LP,JI,LA,LS,2)
 110                    CONTINUE
                     IF (N1.GT.0) THEN
                        FRAC = (100.0 * (N1 - N2)) / N1
                        IF (FIRST) THEN
                           WRITE (MSGTXT,1110) SUNUMS(LS),
     *                        SUNAMS(LS)(:J), LA, BIF, EIF
                           CALL MSGWRT (5)
                           FIRST = .FALSE.
                           END IF
                        WRITE (MSGTXT,1120) POLLAB(LP,POLTYP), N1, N2,
     *                     FRAC
                        CALL MSGWRT (5)
                        END IF
 120                 CONTINUE
 130              CONTINUE
 140          CONTINUE
         ELSE IF (OPTYPE.EQ.'ANIF') THEN
            WRITE (MSGTXT,1000)
            CALL MSGWRT (5)
            DO 250 LS = 1,NUMSOU
               J = JTRIM (SUNAMS(LS))
               DO 240 LA = 1,NA
                  DO 230 LP = 1,4
                     FIRST = .TRUE.
                     DO 220 LI = BIF,EIF
                        JI = LI - BIF + 1
                        IF (ANTCNT(LP,JI,LA,LS,1).GT.0) THEN
                           FRAC = ANTCNT(LP,JI,LA,LS,1) -
     *                        ANTCNT(LP,JI,LA,LS,2)
                           FRAC = (100.0 * FRAC) / ANTCNT(LP,JI,LA,LS,1)
                           IF (FIRST) THEN
                              WRITE (MSGTXT,1210) SUNUMS(LS),
     *                           SUNAMS(LS)(:J), LA, POLLAB(LP,POLTYP)
                              CALL MSGWRT (5)
                              FIRST = .FALSE.
                              END IF
                           WRITE (MSGTXT,1020) LI,
     *                        ANTCNT(LP,JI,LA,LS,1),
     *                        ANTCNT(LP,JI,LA,LS,2), FRAC
                           CALL MSGWRT (5)
                           END IF
 220                    CONTINUE
 230                 CONTINUE
 240              CONTINUE
 250           CONTINUE
            END IF
C                                       Have by spectral channel
      ELSE
C                                       sum over antennas
         IF (OPTYPE(:2).NE.'AN') THEN
            WRITE (MSGTXT,1300)
            CALL MSGWRT (5)
            DO 340 LS = 1,NUMSOU
               J = JTRIM (SUNAMS(LS))
               DO 330 LP = LP1,LP2
                  FIRST = .TRUE.
                  JJ = 0
                  DO 320 LI = BIF,EIF
                     JI = LI - BIF + 1
                     DO 310 LF = BCHAN,ECHAN
                        JF = LF - BCHAN + 1
                        JJ = JJ + 1
                        IF ((LF.LT.LF1) .OR. (LF.GT.LF2)) GO TO 310
                        N1 = VISCNT(LP,JJ,LS,1)
                        N2 = SUMAX(LS,1)-VISCNT(LP,JJ,LS,1)
                        N3 = VISCNT(LP,JJ,LS,2)
                        IF (N1.GT.0) THEN
                           IF (FIRST) THEN
                              WRITE (MSGTXT,1310) SUNUMS(LS),
     *                           SUNAMS(LS)(:J)
                              CALL MSGWRT (5)
                              FIRST = .FALSE.
                              END IF
                           WRITE (MSGTXT,1320) POLLAB(LP,POLTYP), LI,
     *                           LF, N1, N2, N3
                           IF ((PRTL.GT.0) .OR. (N2.GT.0) .OR.
     *                        (N3.GT.0)) CALL MSGWRT (5)
                           END IF
 310                    CONTINUE
 320                 CONTINUE
 330              CONTINUE
 340           CONTINUE
C                                       sum over IFS
         ELSE IF (OPTYPE.EQ.'ANTE') THEN
            WRITE (MSGTXT,1400)
            CALL MSGWRT (5)
            DO 440 LS = 1,NUMSOU
               J = JTRIM (SUNAMS(LS))
               DO 430 LA = 1,NA
                  FIRST = .TRUE.
                  IF (WANT(LA).EQ.0) GO TO 430
                  DO 420 LP = LP1,LP2
                     N1 = 0
                     N2 = 0
                     N3 = 0
                     JI = 0
                     DO 410 LI = BIF,EIF
                        DO 409 JF = BCHAN,ECHAN
                           JI = JI + 1
                           IF ((JF.LT.LF1) .OR. (JF.GT.LF2)) GO TO 409
                           N1 = N1 + ANTCNT(LP,JI,LA,LS,1)
                           N2 = N2 + SUMAX(ls,2)-ANTCNT(LP,JI,LA,LS,1)
                           N3 = N3 + ANTCNT(LP,JI,LA,LS,2)
 409                       CONTINUE
 410                    CONTINUE
                     IF (N1.GT.0) THEN
                        IF (FIRST) THEN
                           WRITE (MSGTXT,1410) SUNUMS(LS),
     *                        SUNAMS(LS)(:J), BIF, EIF, BCHAN, ECHAN
                           CALL MSGWRT (5)
                           FIRST = .FALSE.
                           END IF
                        WRITE (MSGTXT,1420) LA, POLLAB(LP,POLTYP),
     *                     N1, N2, N3
                        CALL MSGWRT (5)
                        END IF
 420                 CONTINUE
 430              CONTINUE
 440          CONTINUE
         ELSE IF (OPTYPE.EQ.'ANIF') THEN
            WRITE (MSGTXT,1500)
            CALL MSGWRT (5)
            DO 550 LS = 1,NUMSOU
               J = JTRIM (SUNAMS(LS))
               DO 540 LA = 1,NA
                  IF (WANT(LA).EQ.0) GO TO 540
                  DO 530 LP = LP1,LP2
                     FIRST = .TRUE.
                     JJ = 0
                     DO 520 LI = BIF,EIF
                        JI = LI - BIF + 1
                        N1 = 0
                        N2 = 0
                        N3 = 0
                        DO 510 LF = BCHAN,ECHAN
                           JJ = JJ + 1
                           IF ((LF.LT.LF1) .OR. (LF.GT.LF2)) GO TO 510
                           N1 = N1 + ANTCNT(LP,JJ,LA,LS,1)
                           N2 = N2 + SUMAX(LS,2)-ANTCNT(LP,JJ,LA,LS,1)
                           N3 = N3 + ANTCNT(LP,JJ,LA,LS,2)
 510                       CONTINUE
                        IF (N1.GT.0) THEN
                           IF (FIRST) THEN
                              WRITE (MSGTXT,1510) SUNUMS(LS),
     *                           SUNAMS(LS)(:J),
     *                           BCHAN, ECHAN
                              CALL MSGWRT (5)
                              FIRST = .FALSE.
                              END IF
                           WRITE (MSGTXT,1520) LA, POLLAB(LP,POLTYP),
     *                        JI, N1, N2, N3
                           CALL MSGWRT (5)
                           END IF
 520                    CONTINUE
 530                 CONTINUE
 540              CONTINUE
 550           CONTINUE
         ELSE IF (OPTYPE.EQ.'ANCH') THEN
            WRITE (MSGTXT,1300)
            CALL MSGWRT (5)
            DO 650 LS = 1,NUMSOU
               J = JTRIM (SUNAMS(LS))
               DO 640 LA = 1,NA
                  IF (WANT(LA).EQ.0) GO TO 640
                  DO 630 LP = LP1,LP2
                     FIRST = .TRUE.
                     JJ = 0
                     DO 620 LI = BIF,EIF
                        JI = LI - BIF + 1
                        DO 610 LF = BCHAN,ECHAN
                           JF = LF - BCHAN + 1
                           JJ = JJ + 1
                           IF ((LF.LT.LF1) .OR. (LF.GT.LF2)) GO TO 610
                           N1 = ANTCNT(LP,JJ,LA,LS,1)
                           N2 = SUMAX(LS,2)-ANTCNT(LP,JJ,LA,LS,1)
                           N3 = ANTCNT(LP,JJ,LA,LS,2)
                           IF (N1.GT.0) THEN
                              IF (FIRST) THEN
                                 WRITE (MSGTXT,1305) SUNUMS(LS),
     *                              SUNAMS(LS)(:J), LA
                                 CALL MSGWRT (5)
                                 FIRST = .FALSE.
                                 END IF
                              WRITE (MSGTXT,1320) POLLAB(LP,POLTYP), LI,
     *                           LF, N1, N2, N3
                              IF ((PRTL.GT.0) .OR. (N2.GT.0) .OR.
     *                           (N3.GT.0)) CALL MSGWRT (5)
                              END IF
 610                       CONTINUE
 620                    CONTINUE
 630                 CONTINUE
 640              CONTINUE
 650           CONTINUE
            END IF
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT (11X,'IF   Samp before    Samp after  Percent')
 1010 FORMAT ('Source',I4,'  ''',A,'''  polarization ',A2)
 1020 FORMAT (10X,I3,2I14,F9.2)
 1100 FORMAT (11X,'Pol   Samp before    Samp after  Percent')
 1110 FORMAT ('Source',I4,'  ''',A,'''  antenna',I3,'  IFs',I3,' -',I3)
 1120 FORMAT (11X,A2,2I14,F9.2)
 1210 FORMAT ('Source',I4,'  ''',A,'''  antenna',I3,'  polarization ',
     *   A2)
 1300 FORMAT (6X,'Pol  IF Channel     # samples     # flagged',
     *  '     # flagged')
 1305 FORMAT ('Source',I4,'  ''',A,'''  antenna',I3)
 1310 FORMAT ('Source',I4,'  ''',A)
 1320 FORMAT (7X,A2,I4,I8,3I14)
 1400 FORMAT (6X,'Ant  Pol     # samples     # flagged     # flagged')
 1410 FORMAT ('Source',I4,'  ''',A,'''  IFs',I3,' -',I3,'  Chans',I4,
     *   ' -',I6)
 1420 FORMAT (6X,I3,3X,A2,3I14)
 1500 FORMAT (6X,'Ant  Pol   IF   # samples       # flagged    ',
     *   ' # flagged')
 1510 FORMAT ('Source',I4,'  ''',A,'''  Chans',I4,' -',I6)
 1520 FORMAT (6X,I3,3X,A2,3X,I2,3I14)
      END
      SUBROUTINE FGCNTC (ITYP, VIS, RPARM, IA1, IA2, NI, NA, NS, VISCNT,
     *   ANTCNT)
C-----------------------------------------------------------------------
C   counts visibilities by source, IF, polarization
C     Inputs:
C      ITYPE   I       1 -> first FG, 2 -> 2nd FG, 0 -> one only
C      RPARM   R(*) Random parameter array which includes U,V,W etc
C                   but also any other random parameters.
C      VIS     R(3,*)  Visibilities in order real, imaginary, weight
C                      (Jy, Jy, unitless).  Weight <= 0 => flagged.
C      NI      I       Number IFs or Number IFs * Number channels
C   Inputs from COMMON:
C      CATBLK     I(256)  Catalog header record. See Going Aips for
C                         details.
C      INCSI      I    Input Stokes' increment in vis.
C      INCFI      I    Input frequency increment in vis.
C      INCIFI     I    Input IF increment in vis.
C   Output:
C      counting common update
C-----------------------------------------------------------------------
      INTEGER   ITYP, IA1, IA2, NI, NA, NS, VISCNT(4,NI,NS,2),
     *   ANTCNT(4,NI,NA,NS,2)
      REAL      VIS(3,*), RPARM(*)
C
      INTEGER   JIF, JF, JS, NIF, NF, NST, I, JSRC, INDEXI, JJ, LTYP
      LOGICAL   DOTWO
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'FGCNT.INC'
      INCLUDE 'FGCNTSOU.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
C-----------------------------------------------------------------------
      LTYP = MAX (1, ITYP)
      DOTWO = ITYP.LE.0
C                                       which source
      JSRC = INSNUM
      IF (ILOCSU.GE.0) THEN
         JS = RPARM(1+ILOCSU) + 0.01
         DO 10 I = 1,NUMSOU
            IF (JS.EQ.SUNUMS(I)) JSRC = I
 10         CONTINUE
         END IF
C                                       pointers to traverse the data
      NST = 1
      NIF = 1
      NF = 1
      IF (JLOCS.GE.0) NST = CATBLK(KINAX+JLOCS)
      IF (JLOCIF.GE.0) NIF = CATBLK(KINAX+JLOCIF)
      IF (JLOCF.GE.0) NF = CATBLK(KINAX+JLOCF)
      JJ = 0
      DO 40 JIF = 1,NIF
         IF (.NOT.ONLY1) JJ = JJ + 1
         DO 30 JF = 1,NF
            IF (ONLY1) JJ = JJ + 1
            IF ((DOSPEC) .AND. (JIF.EQ.SPIF) .AND. (JF.EQ.SPCHAN)) THEN
               IF ((IA1.EQ.SPANT) .OR. (IA2.EQ.SPANT) .OR. (SPANT.LE.0))
     *            THEN
                  INDEXI = (JIF-1) * INCIFI + (JF-1) * INCFI + 1
                  CALL PRTSPC (NST, IA1, IA2, RPARM(1+ILOCT),
     *               VIS(1,INDEXI))
                  END IF
               END IF
            DO 20 JS = 1,NST
               INDEXI = (JIF-1) * INCIFI + (JF-1) * INCFI +
     *            (JS-1) * INCSI + 1
               IF (VIS(3,INDEXI).GT.0.0) THEN
                  VISCNT(JS,JJ,JSRC,LTYP) = VISCNT(JS,JJ,JSRC,LTYP)+1
                  IF (OPTYPE(:2).EQ.'AN') THEN
                     ANTCNT(JS,JJ,IA1,JSRC,LTYP) =
     *                  ANTCNT(JS,JJ,IA1,JSRC,LTYP) + 1
                     IF (IA1.NE.IA2) ANTCNT(JS,JJ,IA2,JSRC,LTYP) =
     *                  ANTCNT(JS,JJ,IA2,JSRC,LTYP) + 1
                     END IF
               ELSE IF (DOTWO) THEN
                  VISCNT(JS,JJ,JSRC,2) = VISCNT(JS,JJ,JSRC,2)+1
                  IF (OPTYPE(:2).EQ.'AN') THEN
                     ANTCNT(JS,JJ,IA1,JSRC,2) =
     *                  ANTCNT(JS,JJ,IA1,JSRC,2) + 1
                     IF (IA1.NE.IA2) ANTCNT(JS,JJ,IA2,JSRC,2) =
     *                  ANTCNT(JS,JJ,IA2,JSRC,2) + 1
                     END IF
                  END IF
 20            CONTINUE
 30         CONTINUE
 40      CONTINUE
C
 999  RETURN
      END
      SUBROUTINE PRTSPC (NS, IA1, IA2, TIME, VIS)
C-----------------------------------------------------------------------
C   special text output
C   Inputs
C      NS     I        Number Stokes
C      TIME   R        time, > 1000 => close the file
C      VIS    R(3,*)   desired single channel
C   Output
C      IRET   I        error
C-----------------------------------------------------------------------
      INTEGER   NS, IA1, IA2
      REAL      TIME, VIS(3,4)
C
      INCLUDE 'INCS:FGCNT.INC'
      INTEGER   TXLUN, TXIND, NUMVIS, LUNTMP, I, J, JTRIM, ITIM(3), IRET
      CHARACTER OUTLIN*256, TSIGN*1
      REAL      AMP(4), PHASE(4), WT(4) , TSEC
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:PSTD.INC'
      INCLUDE 'INCS:DSEL.INC'
      SAVE TXLUN, TXIND, NUMVIS
      DATA NUMVIS /0/
C-----------------------------------------------------------------------
      IF (TIME.GT.1000.) THEN
         CALL ZTXCLS (TXLUN, TXIND, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'CLOSING SPECIAL TEXT FILE'
            GO TO 990
            END IF
      ELSE
C                                       open text file
         IF (NUMVIS.EQ.0) THEN
            TXLUN = LUNTMP (2)
            CALL ZTXOPN ('WRIT', TXLUN, TXIND, OUTFIL, .TRUE., IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'OPENING SPECIAL TEXT FILE'
               GO TO 990
               END IF
            WRITE (OUTLIN,2000) NAMEIN, CLAIN, SEQIN, DISKIN,
     *         SPIF+BIF-1, SPCHAN+BCHAN-1
            J = JTRIM (OUTLIN)
            CALL ZTXIO ('WRIT', TXLUN, TXIND, OUTLIN(:J), IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'WRITING SPECIAL TEXT FILE'
               GO TO 990
               END IF
            END IF
         NUMVIS = NUMVIS + 1
         CALL TFDHMS (TIME, 2, TSIGN, ITIM, TSEC)
         DO 20 I = 1,NS
            AMP(I) = SQRT (VIS(1,I)**2 + VIS(2,I)**2)
            PHASE(I) = 0.0
            IF (AMP(I).GT.0.) PHASE(I) = ATAN2 (VIS(2,I), VIS(1,I)) *
     *         RAD2DG
            WT(I) = VIS(3,I)
 20         CONTINUE
         WRITE (OUTLIN,2010) NUMVIS, IA1, IA2, ITIM, TSEC, (AMP(I),
     *      PHASE(I), WT(I), I = 1,NS)
         J = JTRIM (OUTLIN)
         CALL ZTXIO ('WRIT', TXLUN, TXIND, OUTLIN(:J), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING SPECIAL TEXT FILE'
            GO TO 990
            END IF
         END IF
      GO TO 999
C
 990  CALL MSGWRT (8)
      CALL ZTXCLS (TXLUN, TXIND, IRET)
      DOSPEC = .FALSE.
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('PRTSPC ERROR',I4,' ON ',A)
 2000 FORMAT (A12,'.',A6,'.',I4,'.',I3,'   IF',I3,' CHANNEL',I6)
 2010 FORMAT (I8,3I4,'/',2(I2.2,':'),F5.2,4(2X,F8.4,F8.2,F8.4))
      END
