LOCAL INCLUDE 'SYPRT.INC'
      HOLLERITH XNAMIN(3), XCLSIN(2), XSOUR(4,30), XCALC(1), XLPNAM(12),
     *   XOPTYP(1)
      REAL      DSKIN, SEQIN, XINVER, XQUAL, XBAND, XFREQ, XFQID, XSUBA,
     *   XTIME(8), XANT(50), XFGVER, DOCRT, XBIF, XEIF, XNDIG, FACTOR,
     *   DOSCAL, BADD(10)
      COMMON /INPARM/ XNAMIN, XCLSIN, SEQIN, DSKIN, XINVER, XSOUR,
     *   XQUAL, XCALC, XBAND, XFREQ, XFQID, XSUBA, XTIME, XANT, XFGVER,
     *   DOCRT, XLPNAM, XBIF, XEIF, XOPTYP, XNDIG, FACTOR, DOSCAL, BADD
      INTEGER   INDISK, INCNO, INVER, INSEQ, CDVER, DTYPE, CTYPE,
     *   LFGVER, SCRTCH(256), BUFFI(512), LUNP, FINDP, IPCNT, JP0,
     *   NACROS, MXS, NDIG
      REAL      BTIME, ETIME
      CHARACTER NAMEIN*12, CLASIN*6, LPNAME*48, OPTYPE*4,
     *   SRCS(1000)*16
      COMMON /PARMS/ INDISK, INCNO, INSEQ, INVER, CDVER, DTYPE, CTYPE,
     *   BTIME, ETIME, SCRTCH, BUFFI, LFGVER, LUNP, FINDP, IPCNT, JP0,
     *   NACROS, MXS, NDIG
      COMMON /PARMC/ NAMEIN, CLASIN, LPNAME, OPTYPE, SRCS
LOCAL END
LOCAL INCLUDE 'REPSYTAB.INC'
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   NRECSY, ISYRNO, SYKOLS(MAXSYC), SYNUMV(MAXSYC), LUNSY,
     *   SSYVER
      REAL      PDIFF(2,MAXIF), PSUM(2,MAXIF), PGAIN(2,MAXIF),
     *   TCAL(4,MAXIF,MAXANT), VMIN(MAXANT), VMAX(MAXANT)
      COMMON /REPSYT/ NRECSY, ISYRNO, SYKOLS, SYNUMV, LUNSY, SSYVER,
     *   PDIFF, PSUM, PGAIN, TCAL, VMIN, VMAX
LOCAL END
      PROGRAM SYPRT
C-----------------------------------------------------------------------
C! Task to print values from SY table
C# EXT-util Utility
C-----------------------------------------------------------------------
C;  Copyright (C) 2020, 2022, 2024-2025
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   SYPRT will convert an EVLA SY (SysPower) table plus the CalDevice
C   CD table into a Tsys column in a TY table.
C   Inputs:   (from AIPS)
C      INNAME    R(3)   name of primary file.
C      INCLASS   R(2)   class of primary file.
C      INSEQ     R      sequence number of primary file.
C      INDISK    R      disk volume number. 0 means try all.
C      INVERS    R      MF file version number
C      OUTVERS   R      ST file version number
C-----------------------------------------------------------------------
      CHARACTER PRGNAM*6
      INTEGER   IRET
C
      INTEGER   I
      CHARACTER SYNAME*48
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'SYPRT.INC'
      INCLUDE 'REPSYTAB.INC'
      DATA PRGNAM /'SYPRT'/
C-----------------------------------------------------------------------
C                                       start up
      CALL SYPRTI (PRGNAM, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Read data 4 scale, print check
      CALL SYPRTA (NUMPOL, NUMIF, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Now do it
      CALL SYPRT2 (NUMPOL, NUMIF, IRET)
C                                       Clean up
      CALL FNDEXT ('SY', CATBLK, I)
      IF ((SSYVER.EQ.I) .AND. (SSYVER.NE.INVER)) THEN
         CALL ZPHFIL ('SY', INDISK, INCNO, SSYVER, SYNAME, I)
         CALL ZDESTR (INDISK, SYNAME, I)
         CALL DELEXT ('SY', INDISK, INCNO, 'WRWR', BUFFI, SCRTCH,
     *      SSYVER, I)
         END IF
C
C                                       close LP
 990  IF (LUNP.GT.0) THEN
         CALL LPCLOS (LUNP, FINDP, IPCNT, I)
         IF (I.GT.0) IRET = MAX (I, IRET)
         END IF
      IRET = MAX (0, IRET)
      CALL DIE (IRET, SCRTCH)
C
 999  STOP
      END
      SUBROUTINE SYPRTI (PRGNAM, IRET)
C-----------------------------------------------------------------------
C   Inputs
C      PRGNAM   C*6   Task name
C   Outputs:
C      IRET     I     > 0 +> die on error
C-----------------------------------------------------------------------
      CHARACTER PRGNAM*(*)
      INTEGER   IRET
C
      INTEGER   NTYPE
      PARAMETER (NTYPE=6)
C
      INTEGER   NPARMS, IERR, I, IROUND, LUN, LUNTMP, SUBA, FREQID, NIF,
     *   J, K, JTRIM
      LOGICAL   MATCH
      CHARACTER TYPIN*2, STAT*4, TYPES(NTYPE)*4
      INCLUDE 'SYPRT.INC'
      INCLUDE 'REPSYTAB.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:PFLG.INC'
      INCLUDE 'INCS:DFLG.INC'
      INCLUDE 'INCS:DHDR.INC'
      DATA TYPES /'DIFS', 'SUMS', 'TSYS', 'PDIF', 'PSUM', 'PSYS'/
C-----------------------------------------------------------------------
C                                       Initialize the IO parameters.
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      CALL SELINI
      LUNP = -1
C                                       get parameters, resume aips
      NPARMS = 222
      IRET = 0
      CALL GTPARM (PRGNAM, NPARMS, RQUICK, XNAMIN, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'GETTING ADVERBS'
         CALL MSGWRT (8)
         IRET = 8
         END IF
      IF ((IRET.NE.0) .OR. (NPOPS.GT.NINTRN) .OR. (ISBTCH.EQ.32000))
     *   DOCRT = MIN (-1.0, DOCRT)
      CALL H2CHR (48, 1, XLPNAM, LPNAME)
      IF (DOCRT.GT.0.0) RQUICK = .FALSE.
      IF (RQUICK) RQUICK = LPNAME.NE.' '
      IF (RQUICK) CALL RELPOP (IRET, SCRTCH, IERR)
      IF (IRET.NE.0) GO TO 990
      IRET = 8
C                                       interpret parameters
      CALL H2CHR (12, 1, XNAMIN, NAMEIN)
      CALL H2CHR (6, 1, XCLSIN, CLASIN)
      INSEQ = SEQIN + 0.1
      INDISK = DSKIN + 0.1
      INVER = XINVER + 0.1
      DO 5 I = 1,10
         IBAD(I) = IROUND(BADD(I))
 5       CONTINUE
      CALL H2CHR (4, 1, XCALC, SELCOD)
      DO 10 I = 1,30
         CALL H2CHR (16, 1, XSOUR(1,I), SOURCS(I))
 10      CONTINUE
      SELQUA = IROUND (XQUAL)
      SUBARR = IROUND (XSUBA)
      SUBARR = MAX (1, SUBARR)
      CALL H2CHR (4, 1, XOPTYP, OPTYPE)
      DTYPE = 0
      DO 20 I = 1,NTYPE
         IF (OPTYPE.EQ.TYPES(I)) DTYPE = I
 20      CONTINUE
      IF (DTYPE.GT.3) DTYPE = DTYPE - 3
      OPTYPE = TYPES(DTYPE)
      BTIME = ((XTIME(4)/60.+XTIME(3))/60.0 + XTIME(2))/24.0 + XTIME(1)
      ETIME = ((XTIME(8)/60.+XTIME(7))/60.0 + XTIME(6))/24.0 + XTIME(5)
      IF (BTIME.EQ.0.0) BTIME = -1000.
      IF (ETIME.EQ.0.0) ETIME = 10000.
C                                       antennas
      NANTSL = 0
      DOAWNT = .TRUE.
      DO 30 I = 1,50
         J = IROUND (XANT(I))
         IF (J.LT.0) DOAWNT = .FALSE.
         J = ABS (J)
         IF (J.NE.0) THEN
            DO 25 K = 1,NANTSL
               IF (J.EQ.ANTENS(K)) GO TO 30
 25            CONTINUE
            NANTSL = NANTSL + 1
            ANTENS(NANTSL) = J
            END IF
 30      CONTINUE
C                                       Get CATBLK from old file.
      INCNO = 1
      TYPIN = 'UV'
      CALL CATDIR ('SRCH', INDISK, INCNO, NAMEIN, CLASIN, INSEQ, TYPIN,
     *   NLUSER, STAT, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1030) IERR, NAMEIN, CLASIN, INSEQ, INDISK, NLUSER
         GO TO 990
         END IF
      STAT = 'WRIT'
      CALL CATIO ('READ', INDISK, INCNO, CATBLK, STAT, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'GETTING CATBLK'
         GO TO 990
         END IF
      NCFILE = 1
      FCNO(NCFILE) = INCNO
      FVOL(NCFILE) = INDISK
      FRW(NCFILE) = 1
      CALL UVPGET (IRET)
      CALL COPY (256, CATBLK, CATUV)
      CALL FNDEXT ('FG', CATBLK, I)
      LFGVER = IROUND (XFGVER)
      IF (I.LE.0) FGVER = 0
      LFGVER = MIN (LFGVER, I)
      JP0 = 0
      IF (ICOR0.EQ.-2) JP0 = 1
      IF (ICOR0.EQ.-5) JP0 = 2
      IF (ICOR0.EQ.-6) JP0 = 3
C                                       IF'S
      IF (JLOCIF.GE.0) THEN
         NIF = CATBLK(KINAX+JLOCIF)
         BIF = IROUND (XBIF)
         BIF = MAX (1, MIN (BIF, NIF))
         EIF = IROUND (XEIF)
         IF (EIF.LT.BIF) EIF = NIF
         IF (EIF.GT.NIF) EIF = NIF
      ELSE
         BIF = 1
         EIF = 1
         END IF
C                                       Save relevant pointers for
C                                       flagging
      KLOCFQ = ILOCFQ
      KLOCIF = JLOCIF
      KLOCFY = JLOCF
      LRECIN = LREC
      CALL FNDEXT ('AN', CATBLK, I)
      IF ((SUBARR.GT.I) .OR. (SUBARR.LT.0)) SUBARR = 0
      IUDISK = INDISK
      IUCNO = INCNO
      IFLUN = 30
      KNCOR = NCOR
      KCOR0 = ICOR0
      KNCF = INCF / CATUV(KINAX)
      KNCIF = INCIF / CATUV(KINAX)
      KNCS = INCS / CATUV(KINAX)
      UBUFSZ = UVBFSL * 2
C                                       DSEL common
      UNAME = NAMEIN
      UCLAS = CLASIN
      UDISK = INDISK
      IUDISK = INDISK
      USEQ = INSEQ
      IUSEQ = INSEQ
      IUCNO = INCNO
      IXLUN = LUNTMP (1)
      CALL SOUFIL (IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'GETTING SOURCE LIST'
         GO TO 990
         END IF
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
C                                       Find specified FQ id
      CALL FQMATC (INDISK, INCNO, CATBLK, LUN, SELBAN, SELFRQ, MATCH,
     *   FRQSEL, IERR)
      IF ((.NOT.MATCH) .OR. (IERR.NE.0)) THEN
         WRITE (MSGTXT,1000) IERR, 'GETTING DESIRED FREQID'
         GO TO 990
         END IF
C                                       version numbers
      CALL FNDEXT ('SY', CATBLK, I)
      IF ((INVER.LE.0) .OR. (INVER.GT.I)) INVER = I
      CALL FNDEXT ('CD', CATBLK, CDVER)
      IF ((INVER.LE.0) .OR. (CDVER.LE.0)) THEN
         MSGTXT = 'YOU MUST HAVE AN SY AND CD TABLE TO RUN THIS TASK'
         GO TO 990
         END IF
C                                       get Tcal values
      SUBA = SUBARR
      FREQID = 1
      CALL GETCDS (INDISK, INCNO, CDVER, SUBA, FREQID, CATBLK, TCAL,
     *   IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'READING THE TCAL VALUES'
         GO TO 990
         END IF
C                                       open SY table to read
      LUNSY = 29
      CALL SYINI ('READ', BUFFI, INDISK, INCNO, INVER, CATBLK, LUNSY,
     *   ISYRNO, SYKOLS, SYNUMV, NUMANT, NUMPOL, NUMIF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING THE SY TABLE FOR READ'
         GO TO 990
         END IF
      NRECSY = BUFFI(5)
C                                       prepare for detailed
      CALL SYPREP (IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'PREPING THE SY TABLE FOR REPORTS'
         GO TO 990
         END IF
      CALL SYSORC (IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'READING THE SOURCE TABLE'
         GO TO 990
         END IF
C                                       Open output device
      IF (LPNAME.EQ.' ') DOCRT = MAX (-1.0, DOCRT)
      CALL LPOPEN (LPNAME, DOCRT, LUNP, FINDP, NACROS, SCRTCH, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING THE PRINTER'
         GO TO 990
         END IF
C                                       length of source name
      MXS = 0
      DO 40 I = 1,1000
         J = JTRIM (SRCS(I))
         MXS = MAX (MXS, J)
 40      CONTINUE
C
 990  IF (IRET.NE.0) CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SYPRTI: ERROR',I4,1X,A)
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
     *   I3,' USID=',I5)
      END
      SUBROUTINE SYPREP (IRET)
C-----------------------------------------------------------------------
C   SYPREP makes a sorted copy of the SY table, reads it counting the
C   number of records for each antenna, and returns the count array as
C   well as its maximum.  It also reads the NX table getting scan info.
C   Outputs:
C      IRET   I   Error code: > 0 -> quit
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'SYPRT.INC'
      INCLUDE 'REPSYTAB.INC'
      INTEGER   KEY(2,2), KEYSUB(2,2),  BUFFER(512), FGKEY(2,2), K
      REAL      FKEY(2,2), TEPS
      CHARACTER ANTCOL*24
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:PFLG.INC'
      INCLUDE 'INCS:DFLG.INC'
      DATA FGKEY /5,0, 1,0/
      DATA KEY  /5,0, 1,0/
      DATA FKEY /1.0,0.0, 1.0,0.0/
      DATA KEYSUB /4*1/
      DATA ANTCOL /'ANTENNA'/
C                                       8 milliseconds
      DATA TEPS /9.E-8/
C-----------------------------------------------------------------------
C                                       find antenna col
      CALL FNDCOL (1, ANTCOL, 7, .TRUE., BUFFI, K, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'FINDING ANTENNA COLUMN'
         GO TO 990
         END IF
      FGKEY(1,1) = K
      KEY(1,1) = K
C                                       close the SY table to sort it
      CALL TABIO ('CLOS', 0, ISYRNO, BUFFI, BUFFI, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'INIT CLOSING OF INPUT SY TABLE'
         GO TO 990
         END IF
      CALL FNDEXT ('SY', CATBLK, SSYVER)
      SSYVER = SSYVER + 1
C                                       flag in copy init
      IF (LFGVER.GT.0) THEN
         FGVER = LFGVER
         IFLUN = 30
         CALL FLGINI ('READ', FGBUFF, INDISK, INCNO, FGVER, CATUV,
     *      IFLUN, IFGRNO, FGKOLS, FGNUMV, K)
         IF (K.NE.0) LFGVER = 0
C                                       Resort if necessary.
         IF ((LFGVER.GT.0) .AND. (FGBUFF(43).NE.FGKEY(1,1))) THEN
C                                       Sort to time order.
            CALL TABIO ('CLOS', 0, K, FGBUFF, FGBUFF, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'CLOSE FG TABLE TO SORT'
               GO TO 990
               END IF
            CALL TABSRT (IUDISK, IUCNO, 'FG', FGVER, FGVER, FGKEY,
     *         KEYSUB, FKEY, FGBUFF, CATUV, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'SORT FG TABLE'
               GO TO 990
               END IF
C                                       Re initialize.
            CALL FLGINI ('READ', FGBUFF, INDISK, INCNO, FGVER, CATUV,
     *         IFLUN, IFGRNO, FGKOLS, FGNUMV, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'RE-OPEN FLAG TABLE'
               GO TO 990
               END IF
            END IF
         END IF
C                                       flag in copy, sort in place
      IF (LFGVER.GT.0) THEN
         CALL SYFSEL (INDISK, INCNO, INDISK, INCNO, INVER, SSYVER,
     *      CATUV, CATBLK, BTIME, ETIME, BUFFI, BUFFER, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'COPY/FLAG SY TABLE'
            GO TO 990
            END IF
         CALL TABSRT (INDISK, INCNO, 'SY', SSYVER, SSYVER, KEY, KEYSUB,
     *      FKEY, BUFFI, CATBLK, IRET)
C                                       no flag, sort in copy
      ELSE
         CALL TABSRT (INDISK, INCNO, 'SY', INVER, SSYVER, KEY, KEYSUB,
     *      FKEY, BUFFI, CATBLK, IRET)
         END IF
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'SORTING INPUT SY TABLE'
         GO TO 990
         END IF
C                                       reopen
      CALL SYINI ('READ', BUFFI, INDISK, INCNO, SSYVER, CATBLK, LUNSY,
     *   ISYRNO, SYKOLS, SYNUMV, NUMANT, NUMPOL, NUMIF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING SORTED SY TABLE FOR READ'
         GO TO 990
         END IF
      NRECSY = BUFFI(5)
      GO TO 999
C                                       SY table error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SYPREP: ERROR',I4,' ON ',A)
      END
      SUBROUTINE SYSORC (IRET)
C-----------------------------------------------------------------------
C   SYSORC gets the list of source names (if any)
C   Outputs
C      IRET   I   Error code
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'SYPRT.INC'
      INTEGER   VERS, BUFFER(512), LUN, NUMIF, LUNTMP, FREQID, ISURNO,
     *   SUKOLS(MAXSUC), SUNUMV(MAXSUC), IREC, NREC, IDSOU, QUAL, I
      CHARACTER VELTYP*8, VELDEF*8, SOUNAM*16, CALCOD*4
      REAL      FLUX(4,MAXIF)
      DOUBLE PRECISION FREQO(MAXIF), BANDW, RAEPO, DECEPO, EPOCH, RAAPP,
     *   DECAPP, RAOBS, DECOBS, LSRVEL(MAXIF), LRESTF(MAXIF), PMRA,
     *   PMDEC
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
      IRET = 0
      DO 10 I = 1,1000
         SRCS(I) = ' '
 10      CONTINUE
C                                       single source?
      CALL FNDEXT ('SU', CATBLK, VERS)
      IF (VERS.LE.0) THEN
         CALL H2CHR (8, 1, CATH(KHOBJ), SRCS(1))
C                                       real source table
      ELSE
         LUN = LUNTMP (1)
         CALL SOUINI ('READ', BUFFER, INDISK, INCNO, VERS, CATBLK, LUN,
     *      NUMIF, VELTYP, VELDEF, FREQID, ISURNO, SUKOLS, SUNUMV, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'OPENING THE SU TABLE'
            GO TO 990
            END IF
         NREC = BUFFER(5)
         DO 20 IREC = 1,NREC
            CALL TABSOU ('READ', BUFFER, ISURNO, SUKOLS, SUNUMV, IDSOU,
     *         SOUNAM, QUAL, CALCOD, FLUX, FREQO, BANDW, RAEPO, DECEPO,
     *         EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL, LRESTF,
     *         PMRA, PMDEC, IRET)
            IF (IRET.GT.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READING THE SU TABLE'
               GO TO 999
               END IF
            IF ((IDSOU.GT.0) .AND. (IDSOU.LE.1000) .AND. (IRET.EQ.0))
     *         SRCS(IDSOU) = SOUNAM
 20         CONTINUE
         CALL TABSOU ('CLOS', BUFFER, ISURNO, SUKOLS, SUNUMV, IDSOU,
     *      SOUNAM, QUAL, CALCOD, FLUX, FREQO, BANDW, RAEPO, DECEPO,
     *      EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL, LRESTF,
     *      PMRA, PMDEC, IRET)
         END IF
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SYSORC: ERROR',I4,' ON ',A)
      END
      SUBROUTINE SYPRTA (NP, NIF, IRET)
C-----------------------------------------------------------------------
C   SYPRTA finds the max min and checks printed lines of direct to line
C   printer
C   Inputs:
C      NP       I      Number polarizations
C      NIF      I      Number IFs
C   Outputs:
C      IRET     I      Error code (-1 decided not to waste trees)
C-----------------------------------------------------------------------
      INTEGER   NP, NIF, IRET
C
      INCLUDE 'SYPRT.INC'
      INCLUDE 'REPSYTAB.INC'
      INTEGER   IREC, SOURID, ANTNO, SUBA, FREQID, J, JP, JIF, I,
     *   CALTYP, NLINES, CANT, CSOU, TTY(2), LIF, M, LI1, LI2, LP1, LP2,
     *   LDTYPE
      LOGICAL   WANT, GOOD
      REAL      TIMEI, VD, VS, TT, V, VN, VX
      DOUBLE PRECISION TIME
      CHARACTER SCRSTR*132, CTEMP*4
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DSEL.INC'
C-----------------------------------------------------------------------
      ISYRNO = 1
      CALL RFILL (MAXANT, 1.E10, VMIN)
      CALL RFILL (MAXANT, -1.E10, VMAX)
      NLINES = 0
      CSOU = 0
      CANT = 0
      NDIG = XNDIG + 0.1
      IF  ((NDIG.LT.3) .OR. (NDIG.GT.7)) NDIG = 4
      LIF = (NACROS - MXS - 10) / (NDIG + 1)
      IF (LIF.GT.EIF-BIF+1) THEN
         M = (EIF-BIF+LIF) / LIF
         M = M * NP
      ELSE
         M = NP
         IF (2*(EIF-BIF+1).LE.LIF) M = 1
         END IF
      LDTYPE = MAX (1, DTYPE)
      LI2 = BIF - 1
      LP2 = 0
C                                       multiple passes
 10   LP1 = LP2 + 1
      LI1 = LI2 + 1
      LI2 = MIN (LI1 + LIF -1, EIF)
      LP2 = MIN (LP1 + NP - 1, NP)
      IF ((LP2-LP1+1)*(LI2-lI1+1).GT.LIF) LP2 = LP1
 11   CONTINUE
C                                       read SY table
      DO 100 IREC = 1,NRECSY
         ISYRNO = IREC
         CALL TABSY ('READ', BUFFI, ISYRNO, SYKOLS, SYNUMV, NUMPOL,
     *      NUMIF, TIME, TIMEI, CALTYP, SOURID, ANTNO, SUBA, FREQID,
     *      PDIFF, PSUM, PGAIN, IRET)
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READING THE SORTED SY TABLE'
            GO TO 990
C                                       include?
         ELSE IF (IRET.EQ.0) THEN
            WANT = (TIME.GE.BTIME) .AND. (TIME.LE.ETIME)
            IF ((SOURID.GT.0) .AND. (NSOUWD.GT.0)) THEN
               WANT = .NOT.DOSWNT
               DO 12 J = 1,NSOUWD
                  IF (SOUWAN(J).EQ.SOURID) WANT = DOSWNT
 12               CONTINUE
               END IF
            IF ((TIME.LT.BTIME) .OR. (TIME.GT.ETIME)) WANT = .FALSE.
            IF ((SUBA.GT.0) .AND. (SUBARR.GT.0) .AND.
     *         (SUBA.NE.SUBARR)) WANT = .FALSE.
            IF ((FREQID.GT.0) .AND. (FRQSEL.GT.0) .AND.
     *         (FRQSEL.NE.FREQID)) WANT = .FALSE.
            IF (NANTSL.GT.0) THEN
               DO 15 I = 1,NANTSL
                  IF (ANTNO.EQ.ANTENS(I)) GO TO 20
 15               CONTINUE
               IF (DOAWNT) WANT = .FALSE.
               GO TO 25
 20            IF (.NOT.DOAWNT) WANT = .FALSE.
               END IF
 25         IF (WANT) THEN
               GOOD = .FALSE.
               DO 40 JIF = BIF,EIF
                  DO 30 JP = 1,NP
                     IF (LDTYPE.EQ.1) THEN
                        V = PDIFF(JP,JIF)
                     ELSE IF (LDTYPE.EQ.2) THEN
                        V = PSUM(JP,JIF)
                     ELSE
                        V = FBLANK
                        IF (CALTYP.EQ.1) THEN
                           TT = TCAL(JP+2,JIF,ANTNO)
                        ELSE
                           TT = TCAL(JP,JIF,ANTNO)
                           END IF
                        IF (TT.EQ.FBLANK) TT = 1.0
                        VD = PDIFF(JP,JIF)
                        VS = PSUM(JP,JIF)
                        IF ((VD.NE.FBLANK) .AND. (VS.NE.FBLANK) .AND.
     *                     (VD.GT.0.0) .AND. (VD.LT.VS)) THEN
                           V = TT * VS / (2.0 * VD)
                           END IF
                        END IF
                     IF (V.NE.FBLANK) THEN
                        GOOD = .TRUE.
                        VMAX(ANTNO) = MAX (V, VMAX(ANTNO))
                        VMIN(ANTNO) = MIN (VMIN(ANTNO), V)
                        END IF
 30                  CONTINUE
 40               CONTINUE
               IF (GOOD) THEN
                  NLINES = NLINES + M
                  IF (CANT.NE.ANTNO) THEN
                     NLINES = NLINES + 3*M
                     CANT = ANTNO
                     CSOU = SOURID
                  ELSE IF (CSOU.NE.SOURID) THEN
                     NLINES = NLINES + 2*M
                     CSOU = SOURID
                     END IF
                  END IF
               END IF
            END IF
 100     CONTINUE
      IF (DTYPE.EQ.0) THEN
         LDTYPE = LDTYPE + 1
         IF (LDTYPE.LE.3) GO TO 11
         LDTYPE = 1
         END IF
      IF ((LI2.LT.EIF) .OR. (LP2.LT.NP)) THEN
         IF (LI2.EQ.EIF) LI2 = BIF - 1
         GO TO 10
         END IF
      IF ((NLINES.GT.500) .AND. (DOCRT.LE.0.0) .AND. (LPNAME.EQ.' '))
     *   THEN
         TTY(1) = 5
         CALL ZOPEN (TTY(1), TTY(2), 1, SCRSTR, .FALSE., .FALSE.,
     *      .TRUE., IRET)
         MSGTXT = 'PROBLEM OPENING TERMINAL'
         IF (IRET.GT.0) GO TO 990
         WRITE (SCRSTR,1270) NLINES
         CALL ZTTYIO ('WRIT', TTY(1), TTY(2), 72, SCRSTR, IRET)
         MSGTXT = 'PROBLEM DOING IO TO TERMINAL'
         IF (IRET.GT.0) GO TO 990
         SCRSTR = 'Do you really want to print this much??' //
     *      ' Enter Y or y if so'
         CALL INQSTR (TTY, SCRSTR, 1, CTEMP, IRET)
         IF (IRET.GT.0) GO TO 990
         IF ((CTEMP(:1).NE.'y') .AND. (CTEMP(:1).NE.'Y')) THEN
            SCRSTR = 'Good choice - save trees'
            IRET = -1
         ELSE
            SCRSTR = 'OKAY, printing anyway'
            END IF
         CALL ZTTYIO ('WRIT', TTY(1), TTY(2), 72, SCRSTR, I)
         CALL ZCLOSE (TTY(1), TTY(2), I)
         END IF
      IF (DOSCAL.LE.0.0) THEN
         VX = -1.E10
         VN = 1.E10
         DO 110 I = 1,MAXANT
            VX = MAX (VX, VMAX(I))
            VN = MIN (VN, VMIN(I))
 110        CONTINUE
         CALL RFILL (MAXANT, VN, VMIN)
         CALL RFILL (MAXANT, VX, VMAX)
         END IF
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SYPRTA: ERROR',I4,' ON ',A)
 1270 FORMAT ('Requested print job is',I10,' lines long!')
      END
      SUBROUTINE SYPRT2 (NP, NIF, IRET)
C-----------------------------------------------------------------------
C   SYPRT2 does the display of the data: by ant, IF across, time down
C   Inputs:
C      NP       I      Number polarizations
C      NIF      I      Number IFs
C   Output:
C      IRET     I      Error code
C-----------------------------------------------------------------------
      INTEGER   NP, NIF, IRET
C
      INCLUDE 'REPSYTAB.INC'
      INCLUDE 'SYPRT.INC'
      INTEGER   JP, JIF, PAGE, K, I, J, LIF, LI1, LI2, ITT(4), PMAX,
     *   IROUND, IP, ICOUNT, LP, LP1, LP2, IREC, SOURID, ANTNO, SUBA,
     *   FREQID, CALTYP, LANT, L, LDTYPE
      CHARACTER TITL1*132, TITL2*132, LINE*132, SRC*16, CSCR*132,
     *   POLS(4)*1, TYPES(3)*4, FORM1*11, FORM2*4, DASH*10
      LOGICAL   WANT
      REAL      MAXV, T, V, SCL, X, TIMEI, TT, VD, VS
      DOUBLE PRECISION TIME
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DSEL.INC'
      DATA POLS /'R', 'L', 'X', 'Y'/
      DATA TYPES /'Pdif', 'Psum', 'Psys'/
      DATA DASH /'----------'/
C-----------------------------------------------------------------------
C                                       init printer
      PAGE = 0
      LIF = (NACROS - MXS - 10) / (NDIG + 1)
      IF (LIF.GE.2*(EIF-BIF+1)) THEN
         LP = MIN (2, NP)
      ELSE
         LP = 1
         END IF
      LI2 = BIF - 1
      LP2 = 0
      WRITE (FORM1,1010) NDIG
      WRITE (FORM2,1011) (NDIG+1)
      PMAX = 10.0**NDIG + 0.1
      ICOUNT = 0
      LDTYPE = MAX (1, DTYPE)
      IPCNT = 999
C                                       multiple passes
 10   LP1 = LP2 + 1
      LI1 = LI2 + 1
      LI2 = MIN (LI1 + LIF -1, EIF)
      LP2 = MIN (LP1 + NP - 1, NP)
      IF ((LP2-LP1+1)*(LI2-lI1+1).GT.LIF) LP2 = LP1
C                                       read SY table
 11   LANT = -1
      DO 100 IREC = 1,NRECSY
         ISYRNO = IREC
         CALL TABSY ('READ', BUFFI, ISYRNO, SYKOLS, SYNUMV, NUMPOL,
     *      NUMIF, TIME, TIMEI, CALTYP, SOURID, ANTNO, SUBA, FREQID,
     *      PDIFF, PSUM, PGAIN, IRET)
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READING THE SORTED SY TABLE'
            GO TO 990
C                                       include?
         ELSE IF (IRET.EQ.0) THEN
            WANT = (TIME.GE.BTIME) .AND. (TIME.LE.ETIME)
            IF ((SOURID.GT.0) .AND. (NSOUWD.GT.0)) THEN
               WANT = .NOT.DOSWNT
               DO 15 J = 1,NSOUWD
                  IF (SOUWAN(J).EQ.SOURID) WANT = DOSWNT
 15               CONTINUE
               END IF
            IF ((TIME.LT.BTIME) .OR. (TIME.GT.ETIME)) WANT = .FALSE.
            IF ((SUBA.GT.0) .AND. (SUBARR.GT.0) .AND.
     *         (SUBA.NE.SUBARR)) WANT = .FALSE.
            IF ((FREQID.GT.0) .AND. (FRQSEL.GT.0) .AND.
     *         (FRQSEL.NE.FREQID)) WANT = .FALSE.
            IF (NANTSL.GT.0) THEN
               DO 16 I = 1,NANTSL
                  IF (ANTNO.EQ.ANTENS(I)) GO TO 20
 16               CONTINUE
               IF (DOAWNT) WANT = .FALSE.
               GO TO 25
 20            IF (.NOT.DOAWNT) WANT = .FALSE.
               END IF
 25         IF (WANT) THEN
               IF (ANTNO.NE.LANT) THEN
C                                       find scaling
                  IF (VMIN(ANTNO).LT.0) THEN
                     X = MAX (-10.0*VMIN(ANTNO), ABS(VMAX(ANTNO)))
                  ELSE
                     X = VMAX(ANTNO)
                  END IF
                  I = LOG10 (X) + 10.0 - NDIG
                  MAXV = 10.0 ** (9-I)
                  IF (FACTOR.NE.0.0) MAXV = MAXV * FACTOR
                  SCL = PMAX / MAXV
C                                       titles
                  WRITE (TITL1,1050) TYPES(LDTYPE), ANTNO, PMAX, SCL
                  IP = 10 + MXS
                  WRITE (TITL2,1055)
                  WRITE (TITL2(IP:),FORM1) ((K, POLS(L+JP0), K=LI1,LI2),
     *               L = LP1,LP2)
                  LINE = ' '
                  CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2,
     *               LINE, IPCNT, PAGE, CSCR, IRET)
                  IF (IRET.NE.0) GO TO 960
                  IF (ICOUNT.NE.0) THEN
                     CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1,
     *                  TITL2, TITL1, IPCNT, PAGE, CSCR, IRET)
                     IF (IRET.NE.0) GO TO 960
                     CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1,
     *                  TITL2, TITL2, IPCNT, PAGE, CSCR, IRET)
                     IF (IRET.NE.0) GO TO 960
                     END IF
                  LANT = ANTNO
                  END IF
C                                       write line
               ICOUNT = ICOUNT + 1
               SRC = SRCS(SOURID)
               T = TIME
               CALL TODHMS (T, ITT)
               WRITE (LINE,1060) ITT(2), ITT(3), ITT(4), SRC(:MXS)
               IP = 10 + MXS
               DO 40 JP = LP1,LP2
                  DO 30 JIF = LI1,LI2
                     IF (LDTYPE.EQ.1) THEN
                        V = PDIFF(JP,JIF)
                     ELSE IF (LDTYPE.EQ.2) THEN
                        V = PSUM(JP,JIF)
                     ELSE
                        V = FBLANK
                        IF (CALTYP.EQ.1) THEN
                           TT = TCAL(JP+2,JIF,ANTNO)
                        ELSE
                           TT = TCAL(JP,JIF,ANTNO)
                           END IF
                        IF (TT.EQ.FBLANK) TT = 1.0
                        VD = PDIFF(JP,JIF)
                        VS = PSUM(JP,JIF)
                        IF ((VD.NE.FBLANK) .AND. (VS.NE.FBLANK) .AND.
     *                     (VD.GT.0.0) .AND. (VD.LT.VS))
     *                     V = TT * VS / (2.0 * VD)
                        END IF
                     IF (V.NE.FBLANK) THEN
                        K = IROUND (V * MAXV)
                        WRITE (LINE(IP:),FORM2) K
                     ELSE
                        LINE(IP:) = ' ' // DASH(:NDIG)
                        END IF
                     IP = IP + NDIG + 1
 30                  CONTINUE
 40               CONTINUE
               CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2,
     *            LINE,IPCNT, PAGE, CSCR, IRET)
               IF (IRET.NE.0) GO TO 960
               END IF
            END IF
 100     CONTINUE
      IF (DTYPE.EQ.0) THEN
         LDTYPE = LDTYPE + 1
         IF (LDTYPE.LE.3) GO TO 11
         LDTYPE = 1
         END IF
      IF ((LI2.LT.EIF) .OR. (LP2.LT.NP)) THEN
         IF (LI2.EQ.EIF) LI2 = BIF - 1
         GO TO 10
         END IF
C
 960  IF (IRET.LT.0) THEN
         MSGTXT = 'Stopping at your request'
         CALL MSGWRT (6)
         IRET = 0
      ELSE IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1000) IRET, 'PRINTER ERROR'
         GO TO 990
         END IF
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SYPRT2: ERROR',I4,' ON ',A)
 1010 FORMAT ('(34(I',I1,',A1))')
 1011 FORMAT ('(I',I1,')')
 1050 FORMAT ('*******  Printing ',A,' for antenna',I3,2X,I8,' =',
     *   F11.4,'  *******')
 1055 FORMAT ('  Time   Source')
C 1056 FORMAT (25(I4,A1))
 1060 FORMAT (2(I2.2,':'),I2.2,1X,A)
C 1061 FORMAT (I5)
      END
      SUBROUTINE SYFSEL (DISKI, CNOI, DISKO, CNOO, VERI, VERO, CATIN,
     *   CATOUT, TB, TE, BUFFER, OBUFF, IRET)
C-----------------------------------------------------------------------
C   Copies a subset of IFs in a SY table, can also modify the FQ ID
C   Inputs:
C      DISKI    I        Input volume number
C      CNOI     I        Input catalog number
C      DISKO    I        Output volume number
C      CNOO     I        Output catalog number
C      VER      I        Version to check/modify
C      CATIN    I(256)   Input catalog header
C      CATOUT   I(256)   Output catalog header
C      TB       R        Beginning time in days
C      TE       R        Ending time in days
C   Input/Output:
C      BUFFER   I(*)     Work buffer
C      OBUFF    I(*)     Work buffer
C   Output:
C      IRET     I        Error, 0 => OK
C-----------------------------------------------------------------------
      INTEGER   DISKI, CNOI, DISKO, CNOO, VERI, VERO, CATIN(256),
     *   CATOUT(256), BUFFER(*), OBUFF(*), IRET
      REAL      TB, TE
C
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   ISYRNO, SYKOLS(MAXSYC), SYNUMV(MAXSYC), NUMANT, NUMPOL,
     *   NUMIF, OKOLS(MAXSYC), ONUMV(MAXSYC), NSYROW, I, SOURID, ANTNO,
     *   SUBA, FREQID, OSYRNO, JIF, IPOL, OVER, NDEL, NTOT, JRET, NPART,
     *   LUNI, LUNO, LUNTMP, CALTYP
      REAL      PDIFF(2,MAXIF), PSUM(2,MAXIF), PGAIN(2,MAXIF), TIMEI
      DOUBLE PRECISION TIME
      LOGICAL   REFMT, GOTONE
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:PFLG.INC'
      INCLUDE 'INCS:DFLG.INC'
C-----------------------------------------------------------------------
C                                       open flag table
      TMFLST = -1.E20
      NUMFLG = 0
      IFGRNO = 1
      NDEL = 0
      NTOT = 0
      NPART = 0
C                                       Open SY file
      LUNI = LUNTMP (1)
      CALL SYINI ('READ', BUFFER, DISKI, CNOI, VERI, CATIN, LUNI,
     *   ISYRNO, SYKOLS, SYNUMV, NUMANT, NUMPOL, NUMIF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1010) IRET
         GO TO 990
         END IF
C                                       # rows in old table
      NSYROW = BUFFER(5)
      REFMT = .FALSE.
C                                       Open up new SY table
      OVER = VERO
      LUNO = LUNTMP (1)
      CALL SYINI ('WRIT', OBUFF, DISKO, CNOO, OVER, CATOUT, LUNO,
     *   OSYRNO, OKOLS, ONUMV, NUMANT, NUMPOL, NUMIF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1020) IRET
         GO TO 990
         END IF
C                                       Loop and copy
      DO 100 I = 1,NSYROW
         CALL TABSY ('READ', BUFFER, ISYRNO, SYKOLS, SYNUMV, NUMPOL,
     *      NUMIF, TIME, TIMEI, CALTYP, SOURID, ANTNO, SUBA, FREQID,
     *      PDIFF, PSUM, PGAIN, IRET)
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1030) IRET
            GO TO 990
            END IF
C                                       flag info
         CALL SYFLG (NUMPOL, NUMIF, TIME, SOURID, ANTNO, SUBA, FREQID,
     *      PDIFF, PSUM, PGAIN, NPART, JRET)
         IF (JRET.GT.0) THEN
            IRET = JRET
            GO TO 999
            END IF
C                                       Time selection
         IF ((TIME.LT.TB) .OR. (TIME.GT.TE)) IRET = -1
         IF ((JRET.EQ.-1) .AND. (IRET.EQ.0)) THEN
            IRET = -1
            NDEL = NDEL + 1
            END IF
C                                       Is this record selected ?
         IF (IRET.LT.0) THEN
            REFMT = .TRUE.
C                                       Re-number IF's
         ELSE
            GOTONE = .FALSE.
            DO 90 JIF = 1,NUMIF
               DO 80 IPOL = 1,NUMPOL
                  IF (PDIFF(IPOL,JIF).NE.FBLANK) GOTONE = .TRUE.
                  IF (PSUM(IPOL,JIF).NE.FBLANK) GOTONE = .TRUE.
 80               CONTINUE
 90            CONTINUE
            IF (GOTONE) THEN
               NTOT = NTOT + 1
               CALL TABSY ('WRIT', OBUFF, OSYRNO, OKOLS, ONUMV, NUMPOL,
     *            NUMIF, TIME, TIMEI, CALTYP, SOURID, ANTNO, SUBA,
     *            FREQID, PDIFF, PSUM, PGAIN, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1040) IRET
                  GO TO 990
                  END IF
            ELSE
               REFMT = .TRUE.
               END IF
            END IF
 100     CONTINUE
      IRET = 0
C                                       Close both tables
      CALL TABIO ('CLOS', 0, ISYRNO, BUFFER, BUFFER, IRET)
      CALL TABIO ('CLOS', 0, OSYRNO, OBUFF, OBUFF, IRET)
      IF ((MSGSUP.LT.31990) .OR. (MSGSUP.GE.32000)) THEN
         IF (REFMT) THEN
            WRITE (MSGTXT,1100) 'Reformatted SY', DISKI, CNOI, VERI,
     *         DISKO, CNOO, OVER
         ELSE
            WRITE (MSGTXT,1100) 'Copied SY', DISKI, CNOI, VERI, DISKO,
     *         CNOO, OVER
            END IF
         CALL MSGWRT (3)
         NTOT = NTOT + NDEL
         WRITE (MSGTXT,1101) NDEL, NTOT
         CALL REFRMT (MSGTXT, '_', I)
         CALL MSGWRT (3)
         WRITE (MSGTXT,1102) NPART
         CALL REFRMT (MSGTXT, '_', I)
         IF (NPART.GT.0) CALL MSGWRT (3)
         END IF
      GO TO 999
C                                       Error
 990  CALL MSGWRT (6)
C
 999  RETURN
C-----------------------------------------------------------------------
 1010 FORMAT ('SYFSEL: ERROR ',I3,' INITING OLD TABLE')
 1020 FORMAT ('SYFSEL: ERROR ',I3,' INITING NEW TABLE')
 1030 FORMAT ('SYFSEL: ERROR ',I3,' READING OLD TABLE')
 1040 FORMAT ('SYFSEL: ERROR ',I3,' WRITING NEW TABLE')
 1100 FORMAT (A,' file from vol/cno/vers',I3,I5,I4,' to',I3,I5,I4)
 1101 FORMAT ('__Fully deleted',I10,' of',I12,' SY records applying',
     *   ' flag table')
 1102 FORMAT ('__Partly flagged',I10,' SY records applying flag table')
      END
      SUBROUTINE SYFLG (NPOL, NIF, TIME, SOURID, ANTNO, SUBA, FREQID,
     *   PDIFF, PSUM, PGAIN, NPART, IRET)
C-----------------------------------------------------------------------
C   Flags a TY table row based on the flags in FG table loaded to Common
C   Inputs:
C      NPOL     I      Number polarizations in TY data
C      NIF      I      Number of IFs in those data
C      TIME     R      Time of table row
C      SOURID   I      Source number of row
C      ANTNO    I      Antenna number of row
C      SUBA     I      Subarray of row
C      FREQID   I      Frequency ID if row
C   In/Out:
C      PDIFF    R(*)   Pon-Poff
C      PSUM     R(*)   Pon+Poff
C      PGAIN    R(*)   Post detection gains
C      NPART    I      count of partly flagged records
C   Inputs from include DSEL.INC:
C      NUMFLG     I    Number of flagging entries.
C      TMFLST     R    Time of last visibility for which flagging
C                      was checked.
C      FLGSOU(*)  I    Source id numbers to flag, 0=all.
C      FLGANT(*)  I    Antenna numbers to flag, 0=all.
C      FLGBAS(*)  I    Baseline (A1*32768+A2) numbers to flag, 0=all.
C      FLGSUB(*)  I    Subarray numbers to flag, 0=all.
C      FLGFQD(*)  I    Freqid numbers to flag, <=0=all.
C                      Following should have defaults filled in.
C      FLGBIF(*)  I    First IF to flag.
C      FLGEIF(*)  I    Highest IF to flag.
C      FLGBCH(*)  I    First channel to flag.
C      FLGECH(*)  I    Highest channel to flag.
C      FLGPOL(4,*)L    Flags for the polarizations, should correspond
C                      to selected polarization types.
C   Output:
C      IRET     I      0 -> okay, -1 -> all flagged
C-----------------------------------------------------------------------
      INTEGER   NPOL, NIF, SOURID, ANTNO, SUBA, FREQID, NPART, IRET
      REAL      PDIFF(2,*), PSUM(2,*), PGAIN(2,*)
      DOUBLE PRECISION TIME
C
      INTEGER   IFLAG, FLGA, JPOLN, JIF, LIMF1, LIMF2, IPOLPT
      REAL      RTIME
      LOGICAL   PART
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:PFLG.INC'
      INCLUDE 'INCS:DFLG.INC'
      INCLUDE 'INCS:DDCH.INC'
C-----------------------------------------------------------------------
      IRET = 0
      RTIME = TIME
      IF (TMFLST.LT.TIME) CALL NXTFLG (RTIME, .TRUE., IRET)
      IF (IRET.NE.0) GO TO 999
      IF (NUMFLG.LE.0) GO TO 999
      PART = .FALSE.
C                                       loop over current flags
      DO 50 IFLAG = 1,NUMFLG
C                                       Check time if needed
         IF ((TIME.LT.FLGTST(IFLAG)) .OR. (TIME.GT.FLGTND(IFLAG)))
     *      GO TO 50
C                                       Check source
         IF ((FLGSOU(IFLAG).NE.SOURID) .AND. (FLGSOU(IFLAG).NE.0) .AND.
     *      (SOURID.NE.0)) GO TO 50
C                                       Check antenna
         FLGA = FLGANT(IFLAG)
         IF ((FLGA.NE.0) .AND. (FLGA.NE.ANTNO)) GO TO 50
C                                       Check subarray
         IF ((FLGSUB(IFLAG).GT.0) .AND. (FLGSUB(IFLAG).NE.SUBA))
     *      GO TO 50
C                                       Check freqid.: may be changed
C                                       from input to 1 already
         IF ((FLGFQD(IFLAG).GT.0) .AND. (FLGFQD(IFLAG).NE.FREQID) .AND.
     *      (FREQID.GT.0)) GO TO 50
C                                       Some data to be flagged
C                                       Set limits
         LIMF1 = FLGBIF(IFLAG)
         LIMF2 = FLGEIF(IFLAG)
C                                       Loop over polarizations
         IPOLPT = ABS(KCOR0) - 1
         IF (KCOR0.LT.-4) IPOLPT = IPOLPT - 4
         DO 40 JPOLN = 1,NPOL
            IF (FLGPOL(JPOLN+IPOLPT,IFLAG)) THEN
               PART = .TRUE.
C                                       Loop over IF
               DO 30 JIF = LIMF1,LIMF2
                  PDIFF(JPOLN,JIF) = FBLANK
                  PSUM(JPOLN,JIF) = FBLANK
                  PGAIN(JPOLN,JIF) = FBLANK
 30               CONTINUE
               END IF
 40         CONTINUE
 50      CONTINUE
C                                       Check if data all flagged
      IF (PART) NPART = NPART + 1
      DO 70 JPOLN = 1,NPOL
         DO 60 JIF = 1,NIF
            IF ((PDIFF(JPOLN,JIF).NE.FBLANK) .OR.
     *         (PSUM(JPOLN,JIF).NE.FBLANK)) GO TO 999
 60         CONTINUE
 70      CONTINUE
      IF (PART) NPART = NPART - 1
      IRET = -1
C
 999  RETURN
      END
