LOCAL INCLUDE 'FGPRT.INC'
C                                       Local include for FGPRT
      INCLUDE 'INCS:DSEL.INC'
      HOLLERITH XNAMEI(3), XCLAIN(2), XXSOUR(4,30), XPRINT(12)
      REAL      XSIN, XDISIN, XFLAG, XTIME(8), XFQID, XSUBA, XBIF, XEIF,
     *   XBCHAN, XECHAN, DOCRT,
     *   SCRBUF(512), BUFF2(UVBFSS)
      INTEGER   SEQIN, DISKIN, JBUFSZ, CNO, NUMIFS, NUMCHN,
     *   FGCNT(MAXANT,MAXANT), NUMA
      CHARACTER NAMEIN*12, CLAIN*6, XSOUR(30)*16, LPNAME*48
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XFLAG, XXSOUR,
     *   XTIME, XFQID, XSUBA, XBIF, XEIF, XBCHAN, XECHAN, DOCRT, XPRINT
      COMMON /FGPRTP/ SEQIN, DISKIN, CNO, NUMIFS, NUMCHN, FGCNT, NUMA
      COMMON /CHARPM/ NAMEIN, CLAIN, XSOUR, LPNAME
      COMMON /BUFRS/ SCRBUF, BUFF2, JBUFSZ
      INCLUDE 'INCS:DMSG.INC'
C                                       End local include for FGPRT
LOCAL END
      PROGRAM FGPRT
C-----------------------------------------------------------------------
C! counts samples within limits in an FG table
C# Utility UV editing hardcopy
C-----------------------------------------------------------------------
C;  Copyright (C) 2019
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-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET
      INCLUDE 'FGPRT.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      DATA PRGM /'FGPRT'/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL FGPRTI (PRGM, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Call routine to count
      CALL FGPRTC (IRET)
      IF (IRET.NE.0) GO TO 990
C                                       now display the result
      CALL FGPRTT (IRET)
C                                       Close down files, etc.
 990  CALL DIE (IRET, SCRBUF)
C
 999  STOP
      END
      SUBROUTINE FGPRTI (PRGN, JERR)
C-----------------------------------------------------------------------
C   FGPRTI gets input parameters for FGPRT
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-----------------------------------------------------------------------
      INTEGER   JERR
      CHARACTER PRGN*6
C
      CHARACTER STAT*4, PTYPE*2
      INTEGER   IROUND, NPARM, IERR, I
      REAL      CATR(256)
      HOLLERITH CATH(256)
      DOUBLE PRECISION CATD(128)
      INCLUDE 'FGPRT.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DANT.INC'
      EQUIVALENCE (CATBLK, CATR, CATH, CATD)
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 = 155
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, SCRBUF, IERR)
      IF ((IERR.NE.0) .OR. (NPOPS.GT.NINTRN) .OR. (ISBTCH.EQ.32000))
     *   DOCRT = MIN (-1.0, DOCRT)
      IF (DOCRT.GT.0.0) RQUICK = .FALSE.
      CALL H2CHR (48, 1, XPRINT, LPNAME)
      IF (RQUICK) RQUICK = LPNAME.NE.' '
      IF (RQUICK) CALL RELPOP (IERR, SCRBUF, JERR)
      IF (IERR.NE.0) GO TO 999
C                                       Crunch input parameters.
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      DO 10 I = 1,30
         CALL H2CHR (16, 1, XXSOUR(1,I), SOURCS(I))
 10      CONTINUE
      DISKIN = IROUND (XDISIN)
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.)
      SUBARR = IROUND (XSUBA)
      IF (SUBARR.EQ.0) SUBARR = 1
      IF (SUBARR.LT.0) SUBARR = 0
      FGVER = IROUND (XFLAG)
C                                       Get CATBLK from old file.
      CNO = 1
      PTYPE = 'UV'
      CALL CATDIR ('SRCH', DISKIN, CNO, NAMEIN, CLAIN, SEQIN,
     *   PTYPE, NLUSER, STAT, SCRBUF, JERR)
      IF (JERR.NE.0) THEN
         WRITE (MSGTXT,1030) JERR, NAMEIN, CLAIN, SEQIN, DISKIN,
     *      NLUSER
         GO TO 990
         END IF
      CALL CATIO ('READ', DISKIN, CNO, CATBLK, 'REST', SCRBUF, JERR)
      IF (JERR.NE.0) THEN
         WRITE (MSGTXT,1000) JERR, 'READING HEADR'
         GO TO 990
         END IF
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
         NUMIFS = 1
      ELSE
         BIF = IROUND (XBIF)
         EIF = IROUND (XEIF)
         NUMIFS = CATBLK(KINAX+JLOCIF)
         BIF = MIN (MAX (1, BIF), NUMIFS)
         IF (EIF.LT.BIF) EIF = NUMIFS
         END IF
      NUMCHN = CATBLK(KINAX+JLOCF)
      BCHAN = IROUND (XBCHAN)
      ECHAN = IROUND (XECHAN)
      IF ((BCHAN.LE.0) .OR. (BCHAN.GT.NUMCHN)) BCHAN = 1
      IF ((ECHAN.LE.0) .OR. (ECHAN.GT.NUMCHN)) ECHAN = NUMCHN
      IF (BCHAN.GT.ECHAN) THEN
         MSGTXT = 'INVALID BCHAN AND ECHAN'
         CALL MSGWRT (6)
         JERR = 1
         GO TO 990
         END IF
C                                       Freq id
      FRQSEL = IROUND (XFQID)
      IF (FRQSEL.EQ.0) FRQSEL = -1
C                                       antenna info
      CALL GETANT (DISKIN, CNO, SUBARR, CATBLK, SCRBUF, JERR)
      IF (JERR.NE.0) THEN
         WRITE (MSGTXT,1000) JERR, 'GETTING ANTENNA INFO'
         GO TO 990
         END IF
      NUMA = NSTNS
C                                        Put input file in READ
      PTYPE = 'UV'
      CALL CATDIR ('CSTA', DISKIN, CNO, NAMEIN, CLAIN, SEQIN,
     *   PTYPE, NLUSER, 'READ', SCRBUF, JERR)
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = CNO
      FRW(NCFILE) = 0
C                                       list of source numbers
      CALL FNDEXT ('SU', CATBLK, I)
      IF (I.LE.0) THEN
         NSOUWD = 0
      ELSE
         CALL FNDSOU (DISKIN, CNO, SOURCS, SCRBUF, NSOUWD, DOSWNT,
     *      SOUWAN, JERR)
         IF (JERR.NE.0) THEN
            WRITE (MSGTXT,1000) JERR, 'FINDING SOURCE LIST'
            GO TO 990
            END IF
         END IF
      I = MAXANT * MAXANT
      CALL FILL (I, 0, FGCNT)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('FGPRTI: ERROR',I3,1X,A)
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
     *   I3,' USID=',I5)
      END
      SUBROUTINE FGPRTC (IRET)
C-----------------------------------------------------------------------
C   FGPRTC counts in a baseline based way the flags
C   Outprt:
C      IRET   I   Error code
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'FGPRT.INC'
      INTEGER   FGLUN, FGBUF(512), IVER, I, J, IFGRNO, FGKOLS(MAXFGC),
     *   FGNUMV(MAXFGC), IROW, NROWS, SOURID, SUBA, FREQID, ANTS(2),
     *   IFS(2), CHANS(2), II, JJ
      REAL      TIMER(2)
      CHARACTER REASON*24
      LOGICAL   PFLAGS(4)
      DATA FGLUN /29/
C-----------------------------------------------------------------------
      CALL FNDEXT ('FG', CATBLK, I)
      IVER = XFLAG
      IF (IVER.LE.0) IVER = I
      IF (IVER.LE.0) THEN
         MSGTXT = 'NO FLAG TABLE FOUND'
         IRET = 10
         GO TO 990
         END IF
C                                       open flag table
      CALL FLGINI ('READ', FGBUF, DISKIN, CNO, IVER, CATBLK, FGLUN,
     *   IFGRNO, FGKOLS, FGNUMV, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING THE FG TABLE'
         GO TO 990
         END IF
      NROWS = FGBUF(5)
      DO 100 IROW = 1,NROWS
         IFGRNO = IROW
         CALL TABFLG ('READ', FGBUF, IFGRNO, FGKOLS, FGNUMV, SOURID,
     *      SUBA, FREQID, ANTS, TIMER, IFS, CHANS, PFLAGS, REASON,
     *      IRET)
         IF ((FRQSEL.GT.0) .AND. (FREQID.GT.0) .AND. (FREQID.NE.FRQSEL))
     *      GO TO 100
         IF ((SUBARR.GT.0) .AND. (SUBA.GT.0) .AND. (SUBARR.NE.SUBA))
     *      GO TO 100
         IF ((TSTART.GT.TIMER(2)) .OR. (TEND.LT.TIMER(1))) GO TO 100
         IF (IFS(2).EQ.0) IFS(2) = NUMIFS
         IF (CHANS(2).EQ.0) CHANS(2) = NUMCHN
         IF ((BIF.GT.IFS(2)) .OR. (EIF.LT.IFS(1))) GO TO 100
         IF ((BCHAN.GT.CHANS(2)) .OR. (ECHAN.LT.CHANS(1))) GO TO 100
         IF ((NSOUWD.GT.0) .AND. (SOURID.GT.0)) THEN
            DO 20 I = 1,NSOUWD
               IF ((SOURID.EQ.SOUWAN(I)) .AND. DOSWNT) GO TO 30
               IF ((SOURID.EQ.SOUWAN(I)) .AND. (.NOT.DOSWNT)) GO TO 100
 20            CONTINUE
            IF (DOSWNT) GO TO 100
            END IF
C                                       we want this one
C                                       single baseline
 30      IF ((ANTS(1).GT.0) .AND. (ANTS(2).GT.0)) THEN
            I = MIN (ANTS(1), ANTS(2))
            J = MAX (ANTS(1), ANTS(2))
            IF (PFLAGS(1)) FGCNT(J,I) = FGCNT(J,I) + 1
            IF (PFLAGS(2)) FGCNT(I,J) = FGCNT(I,J) + 1
C                                       single antenna
         ELSE IF (ANTS(1).GT.0) THEN
            II = ANTS(1)
            DO 40 JJ = 1,NUMA
               I = MIN (II, JJ)
               J = MAX (II, JJ)
               IF (PFLAGS(1)) FGCNT(J,I) = FGCNT(J,I) + 1
               IF (PFLAGS(2)) FGCNT(I,J) = FGCNT(I,J) + 1
 40            CONTINUE
C                                       all baselines
         ELSE
            DO 60 I = 1,NUMA-1
               DO 50 J = I+1,NUMA
                  IF (PFLAGS(1)) FGCNT(J,I) = FGCNT(J,I) + 1
                  IF (PFLAGS(2)) FGCNT(I,J) = FGCNT(I,J) + 1
 50               CONTINUE
 60            CONTINUE
            END IF
 100     CONTINUE
      CALL TABFLG ('CLOS', FGBUF, IFGRNO, FGKOLS, FGNUMV, SOURID,
     *   SUBA, FREQID, ANTS, TIMER, IFS, CHANS, PFLAGS, REASON, I)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('FGPRTC: ERROR',I4,' ON ',A)
      END
      SUBROUTINE FGPRTT (IRET)
C-----------------------------------------------------------------------
C   FGPRTT does the actual printing of the counts
C   Outputs:
C      IRET   I   Error code
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'FGPRT.INC'
      INTEGER   I, J, MAXCNT, NCOLPV, PAGE, IPCNT, NUMPRT, NPASS, IPASS,
     *   IOFF, ITEMP, COLPNT, LUNP, FINDP, ICOL, IROW, NACROS
      REAL      TEMP
      CHARACTER TITL1*132, TITL2*132, LINE*132, SCRTCH*132, ENTRY*10
      INCLUDE 'INCS:DDCH.INC'
C-----------------------------------------------------------------------
      MAXCNT = 0
      DO 20 I = 1,NUMA
         DO 10 J = 1,NUMA
            MAXCNT = MAX (MAXCNT, FGCNT(I,J))
 10         CONTINUE
 20      CONTINUE
      IF (MAXCNT.LE.0) THEN
         MSGTXT = 'NO FLAGS COUNTED'
         GO TO 990
         END IF
      TEMP = MAXCNT
      TEMP = LOG10 (TEMP)
      NCOLPV = TEMP + 2.0
      NCOLPV = MAX (NCOLPV, 3)
C                                       Init printer
      PAGE = 0
      IPCNT = 980
      TITL1 = ' '
      TITL2 = ' '
      LINE = ' '
C                                       Open output device
      IF (LPNAME.EQ.' ') DOCRT = MAX (-1.0, DOCRT)
      CALL LPOPEN (LPNAME, DOCRT, LUNP, FINDP, NACROS, SCRBUF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING THE PRINTER'
         GO TO 990
         END IF
      NUMPRT = (NACROS-5) / NCOLPV
      NUMPRT = MIN (NUMPRT, NUMA)
      NPASS = ((NUMA+0.0) / NUMPRT) + 0.999

      DO 100 IPASS = 1,NPASS
         IOFF = (IPASS-1) * NUMPRT
         IF (IOFF+NUMPRT.GT.NUMA) NUMPRT = NUMA - IOFF
C                                          first page titles
         IF ((IPASS.EQ.1) .OR. (DOCRT.GT.-2.5)) THEN
            WRITE (LINE,1020) NAMEIN, CLAIN, SEQIN, DISKIN, NLUSER, BIF
            CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, LINE,
     *         IPCNT, PAGE, SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 950
            END IF
         IF (DOCRT.GT.-2.5) THEN
            WRITE (LINE,1021) BIF, EIF, BCHAN, ECHAN
            CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, LINE,
     *         IPCNT, PAGE, SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 950
            WRITE (LINE,1023) 'FG', FGVER
            CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, LINE,
     *         IPCNT, PAGE, SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 950
            END IF
         TITL1 = 'Number of flags by baseline'
         IF (DOCRT.GT.-2.5) THEN
            LINE = ' '
            CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, LINE,
     *         IPCNT, PAGE, SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 950
            LINE = TITL1
            CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, LINE,
     *         IPCNT, PAGE, SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 950
            LINE = ' '
            CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, LINE,
     *         IPCNT, PAGE, SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 950
            END IF
         ITEMP = 11 - NCOLPV
         COLPNT = 6
         DO 30 ICOL = 1,NUMPRT
            WRITE (ENTRY,1120) ICOL+IOFF
            TITL2(COLPNT:) = ENTRY(ITEMP:10)
            COLPNT = COLPNT + NCOLPV
 30         CONTINUE
         LINE = TITL2
         CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, LINE,
     *      IPCNT, PAGE, SCRTCH, IRET)
         IF (IRET.NE.0) GO TO 950
         DO 50 IROW = 1,NUMA
            WRITE (LINE,1030) IROW
            COLPNT = 6
            DO 40 ICOL = 1,NUMPRT
               I = ICOL+IOFF
               WRITE (ENTRY,1120) FGCNT(I,IROW)
               LINE(COLPNT:) = ENTRY(ITEMP:10)
               COLPNT = COLPNT + NCOLPV
 40            CONTINUE
            CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, LINE,
     *         IPCNT, PAGE, SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 950
 50         CONTINUE
C                                       new page?
         IF (IPCNT.GT.(PRTMAX+1)/2) THEN
            LINE = ' '
            TITL1 = ' '
            TITL2 = ' '
            IPCNT = 998
            END IF
 100     CONTINUE
      GO TO 999
C                                       CRT error
 950  IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1950) IRET
         CALL MSGWRT (8)
         IRET = 1
      ELSE
         IRET = -1
         END IF
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('FGPRTT ERROR',I4,' ON ',A)
 1020 FORMAT ('File = ',A12,'.',A6,'.',I4,' Vol =',I2,'  Userid =',I5,
     *   3X,' IF =',I3)
 1021 FORMAT ('Flags include IFs',I3,' -',I3,'  channels',I6,' -',I6)
 1023 FORMAT ('Listing ',A2,' table, version ',I3)
 1030 FORMAT (I4)
 1120 FORMAT (I10)
 1950 FORMAT ('ERROR',I5,' DOING I/O TO PRINT DEVICE')
      END
