LOCAL INCLUDE 'PCFLG.BUF'
C                                        Local include for PCFLG buffers
      INTEGER   ABUF, IOBUF, MAXBUF, DIMB1, DIMB2, BIGBUF, BIGPT(6)
      COMMON /BUFSIZ/ ABUF, IOBUF, MAXBUF, DIMB1, DIMB2, BIGBUF, BIGPT
LOCAL END
LOCAL INCLUDE 'PCFLG.INC'
C                                                          Include DSPF
C                                       Local include for PCFLG
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   MXTIME
      PARAMETER (MXTIME=131073)
C
      DOUBLE PRECISION FREQIF, CATID(128), NPOINT
      HOLLERITH XNAMEI(3), XCLAIN(2), XXSOUR(4,30), XXCALC(1),
     *   CATIH(256), FCOPER(2), FCSFLG, FCREAS(6)
      CHARACTER NAMEIN*12, CLAIN*6, XSOUR(30)*16, TTIME(2)*12,
     *   STKFLG*4, USTFLG*4, SNAMES(XSTBSZ)*16
      REAL      XSIN, XDISIN, XINVER, XDOCAT, XIN2S, XIN2D, XDOHST,
     *   XTIME(8), XBIF, XEIF, XANT(50), XSUBA, DOCENT, XBADD(10),
     *   PIXRNG(2,5), START, STOP, TIMES(MXTIME), MTIMES(MXTIME),
     *   CATIR(256), FCTIME(2), FCLIPR(2), FCTVAV, FCTVSC,
     *   CSMOTH, LCSMOT, MINTS(MXTIME)
      LOGICAL   ISINGL, DESEL, LQUICK, MENUOK, DOWEDG, DOSOUR, GPH1OK,
     *   GPH3OK, GPH4OK, DOLABL
      INTEGER   NNFLAG, DISKIN, SEQIN, CNOIN, INEXT, INVER,
     *   IMSIZE(2), BUFFER(512), CATIMG(256), NXANT, LLOCSU, IXANT(50),
     *   SMODE, SEQOUT, LANT, LTYPE, LSMOO, DISKOU, CNOOUT, LANTV,
     *   LWINTV(4,4), TVFILE, LSTOKS, PLSMOO, PLSTOK, PLANT, PLTYPE,
     *   FCVERS, FCLUN, FCBUF(512), FCNUMB, FCBASL(2), FCIF(2),
     *   FCCHAN(2), FCTVTY,FCTVBL, FCTVIF, FCTVST, FCTVWI(4), MAXSOU,
     *   ILSTOK(4), MSOU(MXTIME), FCSOUR, IBL0, MBL, LSCAN, PLSCAN,
     *   SCFILE, JBUFSZ, DOANT, ITRTYP, LSNAME, FGFLAG,MAXLAB,
     *   XYCENT(2), TFORM, INSNUM, MAXMEN, DOIFS, LCIF(2), IPIECE,
     *   NPIECE, MPIECE, NSTOKS, CHNMAX, IVER, OVER, NUMVAL, RESOFF,
     *   PESOFF, DOCHAR
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XINVER, XDOCAT,
     *   XIN2S, XIN2D, XDOHST, XXSOUR, XXCALC, XTIME, XBIF, XEIF, XANT,
     *   XSUBA, DOCENT, XBADD
      COMMON /CHRCOM/ NAMEIN, CLAIN, XSOUR, TTIME, STKFLG, USTFLG,
     *   SNAMES
      COMMON /UVIMGC/ CATIMG
      COMMON /INFOLS/ FREQIF, NPOINT, PIXRNG, START, STOP, TIMES,
     *   MTIMES, MINTS, NNFLAG, ISINGL, DESEL, DOANT, DOIFS,
     *   LQUICK, MENUOK, DISKIN, SEQIN, CNOIN, INEXT, INVER, IMSIZE,
     *   BUFFER, NXANT, IXANT, SMODE, SEQOUT, LANTV,
     *   LANT, LTYPE, LSMOO, DISKOU, CNOOUT, LWINTV, TVFILE,
     *   LSTOKS, PLSMOO, PLSTOK, PLANT, PLTYPE, FCVERS, FCLUN, FCBUF,
     *   ILSTOK, MAXSOU, MSOU, DOWEDG, IBL0, MBL, LLOCSU,
     *   DOSOUR, LSCAN, PLSCAN, SCFILE, GPH1OK, GPH3OK, JBUFSZ,
     *   ITRTYP, LSNAME, FGFLAG, GPH4OK, DOLABL, MAXLAB, XYCENT,
     *   TFORM, INSNUM, MAXMEN, CSMOTH, LCSMOT, LCIF, IPIECE,
     *   NPIECE, MPIECE, NSTOKS, CHNMAX, IVER, OVER, NUMVAL, RESOFF,
     *   PESOFF, DOCHAR
      COMMON /FCTABL/ FCTIME, FCLIPR, FCTVAV, FCTVSC, FCOPER, FCSFLG,
     *   FCREAS, FCNUMB, FCBASL, FCCHAN, FCIF, FCSOUR, FCTVTY, FCTVBL,
     *   FCTVIF, FCTVST, FCTVWI
      EQUIVALENCE (CATIMG, CATIR, CATIH, CATID)
C                                                          End DSPF
LOCAL END
LOCAL INCLUDE 'PCDATA.INC'
      INCLUDE 'INCS:PPCV.INC'
      DOUBLE PRECISION TIME, CABCAL, PCFREQ(2,MAXTON,MAXIF)
      INTEGER   PCNPOL, PCNIF, NUMTON, PCBUFF(512), PCNUMV(MAXPCC),
     *   PCKOLS(MAXPCC), PCROW
      REAL STATE(2,4,MAXIF), PCREAL(2,MAXTON,MAXIF),
     *   PCIMAG(2,MAXTON,MAXIF), PCRATE(2,MAXTON,MAXIF)
      COMMON /PCDATA/ PCFREQ, TIME, CABCAL, STATE, PCREAL, PCIMAG,
     *   PCRATE, PCBUFF, PCKOLS, PCNUMV, PCNPOL, PCNIF, NUMTON, PCROW
LOCAL END
      PROGRAM PCFLG
C-----------------------------------------------------------------------
C! Interactive PC table data editor
C# UV Calibration EXT-appl TV-appl VLBI
C-----------------------------------------------------------------------
C;  Copyright (C) 2016-2017, 2021-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   Task PCFLG grids uv data in TB sort order to make an image of the
C   selected form (amp, phase, rms) of the data.  It then displays the
C   grid, suitably smoothed to fit, on the TV and offers enhancement
C   and editing options.  The resulting editing commands are applied to
C   the input data set.  This image is channel-time-bl-Stokes-IF, where
C   TVFLG has channel and bl switched.
C   Inputs:
C      AIPS Adverb   Prg. Name          Description
C      INNAME         NAMEIN        File name to be imaged
C      INCLASS        CLAIN         File class to be imaged
C      INSEQ          SEQIN         File sequence number
C      INDISK         DISKIN        Disk volume on which file resides
C      DOCAT          XDOCAT        Catalog main grid file? 2 => quick
C                                   return, grid file and exit
C      IN2SEQ         XIN2S         Sequence number of cataloged grid
C      IN2DISK        XIN2D         Disk number of catalogued disk
C      SOURCES        XSOUR(4,30)   Sources selected
C      TIMERANG       XTIME(8)      Timerange
C      BIF            XBIF          IF number: begin
C      EIF            XEIF          IF number: end
C      ANTENNAS       XANT(50)      Antenna numbers
C      BADDISK        XBADD(10)     Disks to avoid for scratch
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET
      LOGICAL   ONEIF
      INCLUDE 'PCFLG.INC'
      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 'PCFLG.BUF'
      INTEGER   PABUF, PIOBUF, PMAXB, PDIMB1, PDIMB2, PI, PJ
      PARAMETER (PABUF = 120)
      PARAMETER (PMAXB = 8)
      PARAMETER (PIOBUF = (UVBFSS))
      PARAMETER (PDIMB1 = (MAXCIF))
      PARAMETER (PDIMB2 = (MAXCIF+10))
      PARAMETER (PI = (PMAXB * (PIOBUF + 2*PDIMB1) + 3*MAXCIF + 5))
      PARAMETER (PJ = ((3*PABUF+2) * PDIMB2 + 3*PABUF + 3 * PIOBUF))
C     REAL      BIGBOY(PBIGB)
C     PARAMETER (PBIGB = (PJ))
      REAL      BIGBOY(2)
      INTEGER   IPI, IPJ, KIGBOY(2)
      LONGINT   PBIGB
      EQUIVALENCE (BIGBOY, KIGBOY)
      DATA PRGM /'PCFLG '/
C-----------------------------------------------------------------------
      ABUF = PABUF
      IOBUF = PIOBUF
      JBUFSZ = 2 * IOBUF
      MAXBUF = PMAXB
      DIMB1 = PDIMB1
      DIMB2 = PDIMB2
      IPI = PI
      IPJ = PJ
      NUMVAL = 7
      BIGBUF = MAX (IPI, IPJ)
      BIGPT(1) = 1
      BIGPT(2) = BIGPT(1) + DIMB2
      BIGPT(3) = BIGPT(2) + DIMB2
      BIGPT(4) = BIGPT(3) + 3 * ABUF * (DIMB2+1)
      BIGPT(5) = BIGPT(4) + IOBUF
      BIGPT(6) = BIGPT(5) + IOBUF
C                                       get inputs, ...
      CALL PCFLIN (PRGM, ONEIF, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Do the gridding
      CALL PCFLSC (BIGBUF, BIGBOY, KIGBOY, PBIGB, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       fill in calibration
      CALL PCALIB (BIGBOY(BIGPT(4)+PBIGB), BIGBOY(BIGPT(5)+PBIGB), IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Do the editing
      IF (.NOT.RQUICK) THEN
         CALL PCFLGR (ONEIF, BIGBUF, BIGBOY(BIGPT(1)+PBIGB),
     *      KIGBOY(BIGPT(1)+PBIGB), IRET)
         IF (IRET.NE.0) GO TO 990
C                                       Do history
         CALL PCFLHI (BIGBOY(BIGPT(4)+PBIGB), BIGBOY(BIGPT(5)+PBIGB))
         END IF
C                                       close down
 990  CALL DIE (IRET, BUFFER)
C
 999  STOP
      END
      SUBROUTINE PCFLIN (PRGM, ONEIF, IRET)
C-----------------------------------------------------------------------
C   PCFLIN gets the inputs for PCFLG.
C   Inputs:
C      PRGM   C*6   Task name
C   Output:
C      ONEIF  L     T => input has <= 1 IF
C      IRET   I     Error code: 0 ok, else quit
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      LOGICAL   ONEIF
      INTEGER   IRET
C
      CHARACTER STAT*4, CLSOUT*6, SCLASS*6, UTYPE*2, MTYPE*2, KEYS(2)*8
      INTEGER   NPARM, IERR, IROUND, I, LOCS(2), VALUES(2),
     *   KEYTYP(4), II, J
      REAL      CATUR(256), CATR(256)
      INCLUDE 'PCFLG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      EQUIVALENCE (CATUV, CATUR),  (CATBLK, CATR)
      DATA SCLASS /'PCFLGR'/
      DATA KEYS /'BIF','EIF'/
C-----------------------------------------------------------------------
      FCLUN = 27
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      CALL SELINI
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      IRET = 0
C                                       Get input parameters.
      NPARM = 204
      CALL GTPARM (PRGM, NPARM, RQUICK, XNAMEI, BUFFER, IERR)
      IF (IERR.NE.0) THEN
         RQUICK = .TRUE.
         IRET = 8
         IF (IERR.EQ.1) GO TO 999
            WRITE (MSGTXT,1000) IERR
            CALL MSGWRT (8)
         END IF
C                                       Restart AIPS
      LQUICK = RQUICK
      RQUICK = .FALSE.
      IF (IRET.NE.0) GO TO 999
      IF ((NPOPS.GT.NINTRN) .OR. (NTVDEV.LE.0)) THEN
         IRET = 4
         IF (NPOPS.GT.NINTRN) THEN
            MSGTXT = 'TV TASKS ARE RESERVED FOR INTERACTIVE USERS'
         ELSE
            MSGTXT = 'YOU HAVE NOT BEEN ASSIGNED A TV'
            END IF
         CALL MSGWRT (8)
         GO TO 999
         END IF
      IRET = 5
C                                       Crunch input parameters.
      SEQIN = IROUND (XSIN)
      DISKIN = IROUND (XDISIN)
      CALL RFILL (10, 0.0, PIXRNG)
      MAXLAB = 3
C                                       Convert characters
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      DO 20 I = 1,30
         CALL H2CHR (16, 1, XXSOUR(1,I), XSOUR(I))
 20      CONTINUE
C                                       Get CATBLK.
      CNOIN = 1
      UTYPE = 'UV'
      CALL CATDIR ('SRCH', DISKIN, CNOIN, NAMEIN, CLAIN, SEQIN, UTYPE,
     *   NLUSER, STAT, BUFFER, IERR)
      IF (IERR.NE.0) THEN
         IF (IERR.NE.5) THEN
            WRITE (MSGTXT,1015) IERR, NAMEIN, CLAIN, SEQIN, DISKIN,
     *         NLUSER
         ELSE
            WRITE (MSGTXT,1016) NAMEIN, CLAIN, SEQIN, DISKIN, NLUSER
            END IF
         GO TO 990
         END IF
      IF (STAT.NE.'REST') THEN
         MSGTXT = 'STATUS OF INPUT IS ' // STAT //
     *      '. CLRSTAT OR WAIT UNTIL FILE ISN''T IN USE'
         IERR = 7
         GO TO 990
         END IF
      CALL CATIO ('READ', DISKIN, CNOIN, CATBLK, 'WRIT', BUFFER, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1020) IERR
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = CNOIN
      FRW(NCFILE) = 1
C                                       Get uv header info.
      CALL UVPGET (IRET)
      IF (IRET.NE.0) GO TO 999
      LLOCSU = ILOCSU
      ISINGL = LLOCSU.LT.0
C                                       Info for UVGET:
C                                       Put selection criteria into
C                                       correct common.
      UNAME = NAMEIN
      UCLAS = CLAIN
      UDISK = DISKIN
      IUDISK = DISKIN
      USEQ = SEQIN
      IUSEQ = SEQIN
      DO 30 I = 1,30
         SOURCS(I) = XSOUR(I)
 30      CONTINUE
      CALL RCOPY (8, XTIME, TIMRNG)
C                                       Timerange
      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
      START = TIMRNG(1) + TIMRNG(2) / 24. + TIMRNG(3) / (24. * 60.) +
     *   TIMRNG(4) / (24. * 60. * 60.)
      STOP = TIMRNG(5) + TIMRNG(6) / 24. + TIMRNG(7) / (24. * 60.) +
     *   TIMRNG(8) / (24. * 60. * 60.)
C                                       calcode, IFs
      CALL H2CHR (4, 1, XXCALC, SELCOD)
      IF (JLOCIF.LT.0) THEN
         BIF = 1
         EIF = 1
         ONEIF = .TRUE.
      ELSE
         BIF = IROUND (XBIF)
         BIF = MAX (1, BIF)
         BIF = MIN (BIF, CATBLK(KINAX+JLOCIF))
         EIF = IROUND (XEIF)
         IF ((EIF.LT.BIF) .OR. (EIF.GT.CATBLK(KINAX+JLOCIF)))
     *      EIF = CATBLK(KINAX+JLOCIF)
         ONEIF = CATBLK(KINAX+JLOCIF).LE.1
         END IF
C                                       Antennas
      DESEL = .FALSE.
      NXANT = 0
      DO 40 I = 1,50
         II = IROUND (XANT(I))
         IF (II.NE.0) THEN
            II = ABS (II)
            DO 35 J = 1,NXANT
               IF (II.EQ.IXANT(J)) GO TO 40
 35            CONTINUE
            NXANT = NXANT + 1
            IXANT(NXANT) = II
            IF (XANT(I).LT.0.0) DESEL = .TRUE.
            END IF
 40      CONTINUE
      CALL FILL (50, 0, ANTENS)
C                                       limit to one subarray
      SUBARR = IROUND (XSUBA)
      IF (SUBARR.LE.0) THEN
         MSGTXT = 'using subarray 1'
         CALL MSGWRT (6)
         SUBARR = 1
         END IF
C
      DO 80 I = 1,10
         IBAD(I) = IROUND (XBADD(I))
 80      CONTINUE
      CALL COPY (256, CATBLK, CATUV)
      GPH4OK = .FALSE.
      DOLABL = .FALSE.
C                                       locate old grid file
      SEQOUT = IROUND (XIN2S)
      DISKOU = IROUND (XIN2D)
      CNOOUT = 1
      IF (XDOCAT.LE.0.0) SEQOUT = 0
      IF ((XDOCAT.GT.0.0) .AND. (SEQOUT.GT.0)) THEN
         CLSOUT = SCLASS
         MTYPE = 'MA'
         CALL CATDIR ('SRCH', DISKOU, CNOOUT, NAMEIN, CLSOUT, SEQOUT,
     *      MTYPE, NLUSER, STAT, BUFFER, IERR)
         IF (IERR.NE.0) THEN
            IF (IERR.NE.5) THEN
               WRITE (MSGTXT,1015) IERR, NAMEIN, CLSOUT, SEQOUT,
     *            DISKOU, NLUSER
            ELSE
               WRITE (MSGTXT,1016) NAMEIN, CLSOUT, SEQOUT, DISKOU,
     *            NLUSER
               END IF
            CALL MSGWRT (6)
            SEQOUT = -SEQOUT
         ELSE
            CALL CATIO ('READ', DISKOU, CNOOUT, CATBLK, 'WRIT', BUFFER,
     *         IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1020) IERR
               IRET = 5
               GO TO 990
               END IF
            CALL COPY (256, CATBLK, CATIMG)
            NCFILE = NCFILE + 1
            FVOL(NCFILE) = DISKOU
            FCNO(NCFILE) = CNOOUT
            FRW(NCFILE) = 1
C                                       set BIF
            CALL CATKEY ('READ', DISKOU, CNOOUT, KEYS, 2, LOCS, VALUES,
     *         KEYTYP, BUFFER, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1021) IERR
               IRET = 5
               GO TO 990
               END IF
            IF (JLOCIF.GE.0) THEN
               BIF = VALUES(1)
               EIF = VALUES(2)
            ELSE
               BIF = 1
               EIF = 1
               END IF
            END IF
         END IF
      CALL COPY (256, CATUV, CATBLK)
C                                       Quick return mode?
      IF ((XDOCAT.GT.1.5) .AND. (SEQOUT.LE.0)) THEN
         RQUICK = .TRUE.
         CALL RELPOP (IRET, BUFFER, IERR)
         END IF
      MAXMEN = 480
      CSMOTH = 0.0
      LCSMOT = 0.0
      GO TO 999
C                                       message
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('PCFLIN: ERROR',I3,' OBTAINING INPUT PARAMETERS')
 1015 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I5,' DISK=',
     *   I3,' USID=',I5)
 1016 FORMAT (A12,'.',A6,'.',I5,' DISK=',I3,' USID=',I5,' NOT FOUND')
 1020 FORMAT ('PCFLIN: ERROR',I3,' READING CATBLK ')
 1021 FORMAT ('PCFLIN: ERROR',I3,' READING WORK FILE KEYWORDS')
      END
      SUBROUTINE PCFLSC (BIGDIM, BIGBOY, KIGBOY, PBIGB, IRET)
C-----------------------------------------------------------------------
C   PCFLSC grids the PC data into a SC file by figuring out the start
C   and stop times, the image size, and calling GRIDPC.
C   Input:
C      BIGDIM   I      Total size of BIGBOY
C   Output:
C      BIGBOY   R(*)   Large IO buffers
C      KIGBOY   I(*)   Large IO buffers - equivalenced
C      IRET     I      Error code: 0 => okay, else die.
C-----------------------------------------------------------------------
      INTEGER   BIGDIM, KIGBOY(*), IRET
      REAL      BIGBOY(*)
      LONGINT   PBIGB
C
      INCLUDE 'INCS:PPCV.INC'
      CHARACTER OUTNAM*12, OUTCLS*6
      INTEGER   I, ISUB, NWORDS, PCLUN, KEY(2,2), KEYSUB(2,2), NXVER,
     *   NTANT(MAXANT), ANTNUM, FREQID, IROW, ISCAN, MXANT, NSCAN,
     *   NTIME, NUMPC, NXLUN, SOUNUM, MSCAN
      LOGICAL   FIRST
      REAL      FKEY(2,2), STIMES(2000), TIMINT, TEPS
      DOUBLE PRECISION LTIME
      LONGINT   P1
      INCLUDE 'PCFLG.INC'
      INCLUDE 'PCDATA.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'PCFLG.BUF'
      DATA FKEY /1.0,0.0,1.0,0.0/
      DATA KEYSUB, KEY /4*1, 4*0/
      DATA PCLUN, NXLUN /43,44/
C-----------------------------------------------------------------------
C                                       get time range
      FIRST = .TRUE.
      MSCAN = 0
      TEPS = 1.0 / (24.0 * 3600.0)
      IUCNO = CNOIN
      IXLUN = 28
      INSNUM = 0
      CALL SOUFIL (IRET)
      IF ((NSOUWD.EQ.1) .AND. (DOSWNT)) INSNUM = SOUWAN(1)
      IF ((XDOCAT.LE.0.0) .OR. (SEQOUT.LE.0)) THEN
         IF (IRET.NE.0) THEN
            MSGTXT = 'ERROR IN LIST OF SOURCES'
            GO TO 990
            END IF
      ELSE
         NSOUWD = 0
         DOSWNT = .TRUE.
         END IF
C                                       open PC table
      IVER = XINVER + 0.1
      CALL FNDEXT ('PC', CATBLK, I)
      IF (IVER.LE.0) IVER = I
      IF (IVER.GT.I) IVER = I
      OVER = I + 1
      CALL PCINI ('READ', PCBUFF, DISKIN, CNOIN, IVER, CATBLK, PCLUN,
     *   PCROW, PCKOLS, PCNUMV, PCNPOL, PCNIF, NUMTON, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING PC TABLE'
         GO TO 990
         END IF
      XINVER = IVER
      CHNMAX = NUMTON
C                                       sort to output PC table
      CALL TABIO ('CLOS', 0, PCROW, STIMES, PCBUFF, IRET)
      IF ((PCBUFF(43).EQ.1) .AND. (PCBUFF(44).EQ.4)) THEN
         MSGTXT = 'Copying input table'
         CALL MSGWRT (2)
         CALL TABCOP ('PC', IVER, OVER, NXLUN, PCLUN, DISKIN, DISKIN,
     *      CNOIN, CNOIN, CATBLK, PCBUFF, BUFFER, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'COPYING PC TABLE'
            GO TO 990
            END IF
      ELSE
         MSGTXT = 'Sorting input table'
         CALL MSGWRT (2)
         KEY(1,1) = 1
         KEY(1,2) = 4
         CALL TABSRT (DISKIN, CNOIN, 'PC', IVER, OVER, KEY, KEYSUB,
     *      FKEY, PCBUFF, CATBLK, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'SORTING PC TABLE'
            GO TO 990
            END IF
         END IF
      WRITE (MSGTXT,1010) OVER
      CALL MSGWRT (3)
      CALL PCINI ('READ', PCBUFF, DISKIN, CNOIN, OVER, CATBLK, PCLUN,
     *   PCROW, PCKOLS, PCNUMV, PCNPOL, PCNIF, NUMTON, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'RE-OPENING PC TABLE'
         GO TO 990
         END IF
C                                       scan list
      CALL FNDEXT ('NX', CATBLK, NXVER)
      IF (NXVER.LE.0) THEN
         NSCAN = 0
         MSGTXT = 'NO INDEX TABLE SO NO SCAN BREAKS'
         CALL MSGWRT (6)
      ELSE
         CALL GETNX (NXLUN, DISKIN, CNOIN, CATBLK, SUBARR, NXBUFF,
     *      NSCAN, STIMES)
         IF (NSCAN.LE.0) THEN
            MSGTXT = 'INDEX TABLE TROUBLES, SO NO SCAN BREAKS'
            CALL MSGWRT (6)
            END IF
         END IF
      CALL COPY (256, CATBLK, CATUV)
C                                       restore input names
      DO 5 I = 1,30
         SOURCS(I) = XSOUR(I)
 5       CONTINUE
C                                       count times
      IF ((XDOCAT.GT.0.0) .AND. (SEQOUT.GT.0)) THEN
         CALL COPY (256, CATIMG, CATBLK)
      ELSE
         ISCAN = 1
         LTIME = -1000.
         NUMPC = PCBUFF(5)
         NTIME = 0
         MXANT = 0
         CALL FILL (MAXANT, 0, NTANT)
         DO 50 IROW = 1,NUMPC
            PCROW = IROW
            CALL TABPC ('READ', PCBUFF, PCROW, PCKOLS, PCNUMV, PCNPOL,
     *         TIME, TIMINT, SOUNUM, ANTNUM, ISUB, FREQID, CABCAL,
     *         STATE, PCFREQ, PCREAL, PCIMAG, PCRATE, IRET)
            IF (IRET.GT.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READING PC TABLE FOR TIMES'
               GO TO 990
               END IF
            IF (IRET.LT.0) GO TO 50
C                                       want this record?
            IF (TIME.LT.START) THEN
               IF (TIME.GT.STIMES(ISCAN)) ISCAN = ISCAN + 1
               IF (TIME.GT.STIMES(ISCAN)) ISCAN = ISCAN + 1
               GO TO 50
               END IF
            IF (TIME.GT.STOP) GO TO 60
            IF (ISUB.NE.SUBARR) GO TO 50
C                                       antenna
            IF (NXANT.GT.0) THEN
               DO 10 I = 1,NXANT
                  IF (ANTNUM.EQ.IXANT(I)) THEN
                     IF (DESEL) GO TO 50
                     GO TO 15
                     END IF
 10               CONTINUE
               IF (.NOT.DESEL) GO TO 50
               END IF
C                                       source
 15         IF (NSOUWD.GT.0) THEN
               DO 20 I = 1,NSOUWD
                  IF (SOUNUM.EQ.SOUWAN(I)) THEN
                     IF (DOSWNT) GO TO 25
                     GO TO 50
                     END IF
 20               CONTINUE
               IF (DOSWNT) GO TO 50
               END IF
C                                       want this one - new time?
 25         IF (TIME-LTIME.GT.TEPS) THEN
C                                       scan break
               IF ((ISCAN.LT.NSCAN) .AND. (TIME.GT.STIMES(ISCAN))) THEN
                  IF (NTIME.GE.MXTIME-1) GO TO 980
                  NTIME = NTIME + 1
                  TIMES(NTIME) = STIMES(ISCAN)
                  MINTS(NTIME) = TIMINT / 10.0
                  ISCAN = ISCAN + 1
                  MSCAN = MSCAN + 1
                  MSOU(NTIME) = 0
                  END IF
               IF (NTIME.GE.MXTIME-1) GO TO 980
               NTIME = NTIME + 1
               TIMES(NTIME) = TIME
               MINTS(NTIME) = TIMINT
               LTIME = TIME
               MSOU(NTIME) = SOUNUM
               END IF
            NTANT(ANTNUM) = NTANT(ANTNUM) + 1
            MXANT = MAX (MXANT, ANTNUM)
 50         CONTINUE
C                                       last time break
 60      IF ((ISCAN.LE.NSCAN) .AND. (LTIME.LT.STIMES(ISCAN))) THEN
            IF (NTIME.GT.MXTIME-1) GO TO 980
            NTIME = NTIME + 1
            TIMES(NTIME) = STIMES(ISCAN)
            MINTS(NTIME) = TIMINT / 10.0
            MSOU(NTIME) = 0
            END IF
         IF (MXANT.LE.0) THEN
            MSGTXT = 'NO DATA FOUND'
            IRET = 10
            GO TO 990
            END IF
         WRITE (MSGTXT,1195) NTIME, MSCAN
         CALL MSGWRT (4)
C                                       image
         IMSIZE(2) = NTIME
         IMSIZE(1) = NUMVAL * NUMTON * (EIF-BIF+1) + 3
         NWORDS = (IMSIZE(1)*IMSIZE(2) - 1) / 1024 + 1
         I = KAPWRD / NWORDS
         I = MIN (I, PCNPOL*MXANT)
C         I = PCNPOL * MXANT
C                                       get multiple planes
         NWORDS = I * NWORDS
         CALL ZMEMRY ('GET ', TSKNAM, NWORDS, BIGBOY, PBIGB, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1200) IRET, 'GETTING FULL PLANES MEMORY'
            GO TO 990
            END IF
C                                       do it
         P1 = 1 + PBIGB
         CALL GRIDPC (IMSIZE, MXANT, NTANT, MSOU, TIMES, MINTS, I,
     *      IMSIZE(1), IMSIZE(2), 1.0, OUTNAM, OUTCLS, SEQOUT, DISKOU,
     *      START, STOP, CNOOUT, NPOINT, INSNUM, BIGBOY(P1), IRET)
         IF (IRET.NE.0) GO TO 999
C                                       free full planes
         CALL ZMEMRY ('FREE', TSKNAM, NWORDS, BIGBOY, PBIGB, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1200) IRET, 'FREEING FULL PLANES MEMORY'
            GO TO 990
            END IF
         END IF
C                                       get usual BIGBOY
      NWORDS = (BIGDIM - 1)/1024 + 1
      CALL ZMEMRY ('GET ', TSKNAM, NWORDS, BIGBOY, PBIGB, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1200) IRET, 'GETTING NORMAL BIG MEMORY'
         GO TO 990
         END IF
      GO TO 999
C
 980  WRITE (MSGTXT,1980) MXTIME
      IRET = 10
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('PCFLSC: ERROR',I5,' ON ',A)
 1010 FORMAT ('Created new sorted PC table version',I6)
 1195 FORMAT ('Found',I6,' time intervals to grid including',I4,
     *   ' scan breaks')
 1200 FORMAT ('ZMEMRY ERROR',I3,' ON ',A)
 1980 FORMAT ('MORE THAN',I8,' TIMES - QUITTING')
      END
      SUBROUTINE GRIDPC (IMSIZE, MAXANS, NODATA, MSOU, TIMES, MINTS,
     *   MAXBUF, DIMX, DIMY, XDOCAT, OUTNAM, OUTCLS, SEQOUT, DISKOU,
     *   START, STOP, CNOOUT, NPOINT, INSNUM, SBUFF, IRET)
C-----------------------------------------------------------------------
C   GRIDPC makes a gridded image of the PC data
C   Inputs:
C      IMSIZE   I(2)    Output image size (x,y)
C      MAXANS   I       maximum antenna number
C      NODATA   I(*)    Count of samples by antenna
C      MAXBUF   I       Number of buffers to use
C      XDOCAT   R       > 0 => mark the new image as permanent in the
C                       DFIL commons, else as temporary
C   In/out:
C      MSOU     I(*)    Source numbers that go with times - set to -1
C                          when times set to regular intervals
C      MTIMES   R(*)    (* = IMSIZE(2)) start times for each row
C                          MTIMES(2) < MTIMES(1) < 0 => set regular
C                          times from the first datum
C      OUTNAM   C*12    Output image name
C      OUTCLS   C*6     Output image class or 'SC  ',' '
C      SEQOUT   I       Output image seq number, if scratch, is DFIL
C                       number of SC file
C      DISKOU   I       Output image disk
C   Output:
C      CNOOUT   I       Output image catalog number
C      MBL      I       max number baselines with data
C      NPOINT   D       Vis included in grid note double precision
C      SBUFF    R(*)    Summing buffer (DIMX,DIMY,#baselines=MAXBUF)
C      IRET     I       Error code: 0 ok, else die
C   Expected:
C      MAXBUF = > 8     max number planes at once
C      DIMX,DIMY        X,Y dimension of each plane - row DIMY for
C                       counting
C-----------------------------------------------------------------------
      INTEGER   IMSIZE(2), MAXANS, NODATA(MAXANS), MSOU(*), MAXBUF,
     *   DIMX, DIMY, SEQOUT, DISKOU, CNOOUT, INSNUM, IRET
      DOUBLE PRECISION NPOINT
      REAL      XDOCAT, TIMES(*), MINTS(*), SBUFF(DIMX,DIMY,*), START,
     *   STOP
      CHARACTER OUTNAM*12, OUTCLS*6
C
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:ZPBUFSZ.INC'
      INCLUDE 'PCDATA.INC'
      CHARACTER PHNAME*48, CUNITS(2)*8, KEYS(2)*8
      HOLLERITH CATH(256), CATSH(256), CATIH(256)
      INTEGER   I, IERR, JERR, CATSAV(256), LUNO, LIF, IBLKOF, NBYT,
     *   IDEPTH(5), NCOL, II, LR, IROW, ITYP, OLDSOU, IV, CATIMG(256),
     *   COLMUL, LSTSOU, NCOL2, LNCFIL, COLUP, LLSUN, LLARR, LBVIS,
     *   NSTOK, IB, NUMBUF, LSTINC, MROW, NNVIS, INCBUF, JBUFF, MUMBUF,
     *   LUN, NCOLMX, FIND, IIV, LOCS(4), VALUES(2), KEYTYP(2), NCHAN,
     *   NIF, NPTS, JR, KR, IY, IX, IBIND, SOUNUM, ANTNUM, IMAX, FREQID,
     *   ISUB, LA, LIA, NA, NUMPC, IDUM(4), SCRTCH(256)
      LOGICAL   T, F, FIRST
      REAL      CATR(256), CATSR(256), CATIR(256), RMAX, RMIN, TIMLST,
     *   VBUFF(UVBFSS), DIFMAX, TIMINT, TSIGMA, RTEMP(2)
      DOUBLE PRECISION    CATD(128), CATSD(128), CATID(128), NNNV,
     *   REFREQ, REFPIX, DTEMP
      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 'INCS:DSOU.INC'
      INCLUDE 'INCS:DCHND.INC'
      COMMON /UVIMGC/ CATIMG
      EQUIVALENCE (DTEMP, RTEMP), (CATBLK, CATH, CATR, CATD),
     *   (CATSAV, CATSH, CATSR, CATSD), (CATIMG, CATIH, CATIR, CATID)
      SAVE FIRST
      DATA FIRST /.TRUE./
      DATA LUNO /26/
      DATA T, F /.TRUE.,.FALSE./
      DATA CUNITS /'DEGREES ','RATIO   '/
      DATA KEYS /'BIF','EIF'/
      DATA LOCS /1,2,3,4/
      DATA KEYTYP /2*4/
C-----------------------------------------------------------------------
      LUN = 55
      NCOLMX = DIMX
      IRET = 0
      LSTSOU = -1
      LLSUN = INSNUM
      LLARR = 0
      OLDSOU = 0
      NPOINT = 0.0D0
C                                       7 = real & imag & flag #
      ITYP = 7
      COLMUL = 7
      COLUP = 3
C                                       Build image header:
C                                       Misc.
      CALL COPY (256, CATBLK, CATSAV)
      CALL UVPGET (IRET)
      CATBLK(KIGCN) = 1
      CATBLK(KIPCN) = 0
      CATR(KRBLK) = FBLANK
      CATBLK(KIIMU) = NLUSER
      CATBLK(KITYP) = 0
      CALL CHR2H (2, 'MA', KHPTYO, CATH(KHPTY))
C                                       Coordinates
      CATBLK(KIDIM) = 7
C                                       antenna
      CATD(KDCRV+3) = 1.D0
      CATBLK(KINAX+3) = MAXANS
      NPTS = MAXANS
      CATR(KRCRT+3) = 0.0
      CATR(KRCIC+3) = 1.0
      CATR(KRCRP+3) = 1.0
      CALL CHR2H (8, 'ANTENNA', 1, CATH(KHCTP+6))
C                                       FREQ * IF
      NCHAN = NUMTON
      NIF = EIF - BIF + 1
      CATBLK(KINAX) = NCHAN * NIF
      REFREQ = CATSD(KDCRV+JLOCF)
      REFPIX = CATSR(KRCRP+JLOCF)
      CATD(KDCRV) = 1.0D0
      CATR(KRCIC) = 1.0 / 3.0
      CATR(KRCRP) = 1.0
      CATR(KRCRT) = 0.0
      NNVIS = CATBLK(KINAX)
      CALL CHR2H (8, 'TONES/IF', 1, CATH(KHCTP))
C                                       IF
      CATR(KRCRT+4) = 0.0
      IF (JLOCIF.GE.0) THEN
         CATBLK(KINAX+4) = 1
         CATD(KDCRV+4) = CATSD(KDCRV+JLOCIF)
         CATR(KRCIC+4) = CATSR(KRCIC+JLOCIF)
         CATR(KRCRP+4) = CATSR(KRCRP+JLOCIF) - BIF + 1
         I = JLOCIF * 2
         CALL CHCOPY (8, 1, CATSH(KHCTP+I), 1, CATH(KHCTP+8))
      ELSE
         CATBLK(KINAX+4) = 1
         CATD(KDCRV+4) = 1.0D0
         CATR(KRCIC+4) = 1.0
         CATR(KRCRP+4) = 1.0
         CALL CHR2H (8, 'IF      ', 1, CATH(KHCTP+8))
         CALL CHR2H (8, 'TONES   ', 1, CATH(KHCTP))
         END IF
C                                       Stokes
      CATBLK(KINAX+2) = MIN (2, CATSAV(KINAX+JLOCS))
      CATD(KDCRV+2) = CATSD(KDCRV+JLOCS)
      CATR(KRCIC+2) = CATSR(KRCIC+JLOCS)
      CATR(KRCRP+2) = CATSR(KRCRP+JLOCS)
      CATR(KRCRT+2) = 0.0
      I = JLOCS * 2
      CALL CHCOPY (8, 1, CATSH(KHCTP+I), 1, CATH(KHCTP+4))
      NSTOK = CATBLK(KINAX+2)
      NPTS = NPTS * NSTOK
      LBVIS = COLMUL * NSTOK
C                                       RA, dec
      CATBLK(KINAX+5) = 1
      CATD(KDCRV+5) = CATSD(KDCRV+JLOCR)
      CATR(KRCIC+5) = CATSR(KRCIC+JLOCR)
      CATR(KRCRP+5) = CATSR(KRCRP+JLOCR)
      CATR(KRCRT+5) = CATSR(KRCRT+JLOCR)
      I = JLOCR * 2
      CALL CHCOPY (8, 1, CATSH(KHCTP+I), 1, CATH(KHCTP+10))
      CATBLK(KINAX+6) = 1
      CATD(KDCRV+6) = CATSD(KDCRV+JLOCD)
      CATR(KRCIC+6) = CATSR(KRCIC+JLOCD)
      CATR(KRCRP+6) = CATSR(KRCRP+JLOCD)
      CATR(KRCRT+6) = CATSR(KRCRT+JLOCD)
      I = JLOCD * 2
      CALL CHCOPY (8, 1, CATSH(KHCTP+I), 1, CATH(KHCTP+12))
C                                       2nd axis: Time
      CATBLK(KINAX+1) = IMSIZE(2)
      CATR(KRCIC+1) = 1.0 / (24. * 3600.)
      TSIGMA = CATR(KRCIC+1) / 11.0D0
      CATD(KDCRV+1) = TIMES(1)
      CATR(KRCRP+1) = 1.0
      CATR(KRCRT+1) = 0.0
      CALL CHR2H (8, 'TIME    ', 1, CATH(KHCTP+2))
      CATBLK(KINAX) = CATBLK(KINAX) * COLMUL + COLUP
      IMSIZE(1) = CATBLK(KINAX)
      IMSIZE(2) = CATBLK(KINAX+1)
      NPTS = NPTS * IMSIZE(1) * IMSIZE(2)
      MROW = CATBLK(KINAX+1)
C                                       Create output map file
      LNCFIL = 0
C                                       Cataloged MA file output
      SEQOUT = ABS (SEQOUT)
      OUTCLS = 'PCFLGR'
      CALL MAKOUT (UNAME, UCLAS, IUSEQ, ' ', OUTNAM, OUTCLS, SEQOUT)
      CALL CHR2H (12, OUTNAM, KHIMNO, CATH(KHIMN))
      CALL CHR2H (6, OUTCLS, KHIMCO, CATH(KHIMC))
      CATBLK(KIIMS) = SEQOUT
C                                       support BADDISK
      IIV = 0
      IF (DISKOU.GT.0) THEN
         IV = DISKOU
         IIV = IV
         CALL MCREAT (IV, CNOOUT, SCRTCH, IRET)
      ELSE
         DO 15 IV = 1,NVOL
            DO 10 I = 1,10
               IF (IV.EQ.IBAD(I)) GO TO 15
 10            CONTINUE
            MSGSUP = 32000
            IIV = IV
            CALL MCREAT (IV, CNOOUT, SCRTCH, IRET)
            MSGSUP = 0
            IF (IRET.NE.1) GO TO 20
 15         CONTINUE
         IRET = 1
         END IF
 20   SEQOUT = CATBLK(KIIMS)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CREATE OUTPUT IMAGE'
         IF (IRET.EQ.1) THEN
            CALL MSGWRT (8)
            MSGTXT = 'NO DISK SPACE ON ALLOWED DISKS'
            IF (IIV.LE.0) MSGTXT = 'BADDISK LEAVES NO DISKS TO USE'
            END IF
         IRET = 3
         GO TO 990
         END IF
      DISKOU = IV
C                                       mark cataloged
      IF (XDOCAT.GT.0.0) THEN
         NCFILE = NCFILE + 1
         FVOL(NCFILE) = DISKOU
         FCNO(NCFILE) = CNOOUT
         FRW(NCFILE) = 2
         LNCFIL = NCFILE
         VALUES(1) = BIF
         VALUES(2) = EIF
         CALL CATKEY ('WRIT', DISKOU, CNOOUT, KEYS, 2, LOCS, VALUES,
     *      KEYTYP, SCRTCH, IERR)
C                                       mark as temporary
      ELSE
         NSCR = NSCR + 1
         SCRVOL(NSCR) = DISKOU
         SCRCNO(NSCR) = CNOOUT
         END IF
      CALL ZPHFIL ('MA', DISKOU, CNOOUT, 1, PHNAME, IERR)
C                                       Loop over IF, freq
      NBYT = 2 * UVBFSS
      NCOL = CATBLK(KINAX)
      NCOL2 = (CATBLK(KINAX) - COLUP) / COLMUL
      CALL COPY (256, CATBLK, CATIMG)
      CALL COPY (256, CATSAV, CATBLK)
      RMAX = -1.E23
      RMIN = 1.E23
      LSTINC = CATIMG(KINAX+2)
      IB = MAXBUF / LSTINC
      NNNV = 0.0D0
C                                       Use buffers for IFs.
      NUMBUF = LSTINC
      LIA = MAXBUF / NUMBUF
      LIA = MIN (MAXANS, LIA)
      DO 500 LA = 1,MAXANS,LIA
C                                       Init i/o to uv file
         IROW = 1
         NA = MIN (LA+LIA-1, MAXANS)
         INCBUF = LSTINC
         MUMBUF = MIN (LIA,MAXANS-LA+1) * INCBUF
         NUMBUF = MAX (NUMBUF, MUMBUF)
C                                       zero summing array
         LR = DIMX * DIMY
         DO 38 JR = LA,NA
            DO 37 JBUFF = 1,INCBUF
               KR = (JR - LA) * INCBUF + JBUFF
               CALL RFILL (LR, FBLANK, SBUFF(1,1,KR))
 37            CONTINUE
 38         CONTINUE
         TIMLST = -1.E10
         NUMPC = PCBUFF(5)
         DO 100 IROW = 1,NUMPC
            PCROW = IROW
            CALL TABPC ('READ', PCBUFF, PCROW, PCKOLS, PCNUMV, PCNPOL,
     *         TIME, TIMINT, SOUNUM, ANTNUM, ISUB, FREQID, CABCAL,
     *         STATE, PCFREQ, PCREAL, PCIMAG, PCRATE, IRET)
            IF (IRET.GT.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READING PC TABLE FOR DATA'
               GO TO 990
               END IF
            IF (IRET.LT.0) GO TO 100
C                                       want this record?
            IF (TIME.LT.START) GO TO 100
            IF (TIME.GT.STOP) GO TO 110
            IF (ISUB.NE.SUBARR) GO TO 100
C                                       antenna
            IF (NODATA(ANTNUM).LE.0) GO TO 100
            IF ((ANTNUM.LT.LA) .OR. (ANTNUM.GT.NA)) GO TO 100
C                                       source
            IF (NSOUWD.GT.0) THEN
               DO 60 I = 1,NSOUWD
                  IF (SOUNUM.EQ.SOUWAN(I)) THEN
                     IF (DOSWNT) GO TO 65
                     GO TO 100
                     END IF
 60               CONTINUE
               IF (DOSWNT) GO TO 100
               END IF
C                                       want it: find time
 65         DIFMAX = 1.E6
            DO 70 I = 1,IMSIZE(2)
               IF (ABS(TIME-TIMES(I)).LT.DIFMAX) THEN
                  IMAX = I
                  DIFMAX = ABS (TIME-TIMES(I))
                  END IF
 70            CONTINUE
            II = 3
            KR = (ANTNUM - LA) * INCBUF
            NPOINT = NPOINT + 1
            DO 80  LIF = BIF,EIF
               DO 75 I = 1,NUMTON
                  DTEMP = PCFREQ(1,I,LIF)
                  SBUFF(II+6,IMAX,KR+1) = RTEMP(1)
                  SBUFF(II+7,IMAX,KR+1) = RTEMP(2)
                  IF ((PCREAL(1,I,LIF).NE.FBLANK) .AND.
     *               (PCIMAG(1,I,LIF).NE.FBLANK)) THEN
                     SBUFF(II+2,IMAX,KR+1) = PCREAL(1,I,LIF)
                     SBUFF(II+3,IMAX,KR+1) = PCIMAG(1,I,LIF)
                     SBUFF(II+1,IMAX,KR+1) = 0.0
                  ELSE
                     SBUFF(II+1,IMAX,KR+1) = FBLANK
                     SBUFF(II+2,IMAX,KR+1) = FBLANK
                     SBUFF(II+3,IMAX,KR+1) = FBLANK
                     END IF
                  IF (PCNPOL.EQ.2) THEN
                     DTEMP = PCFREQ(2,I,LIF)
                     SBUFF(II+6,IMAX,KR+2) = RTEMP(1)
                     SBUFF(II+7,IMAX,KR+2) = RTEMP(2)
                     IF ((PCREAL(2,I,LIF).NE.FBLANK) .AND.
     *                  (PCIMAG(2,I,LIF).NE.FBLANK)) THEN
                        SBUFF(II+2,IMAX,KR+2) = PCREAL(2,I,LIF)
                        SBUFF(II+3,IMAX,KR+2) = PCIMAG(2,I,LIF)
                        SBUFF(II+1,IMAX,KR+2) = 0.0
                     ELSE
                        SBUFF(II+1,IMAX,KR+2) = FBLANK
                        SBUFF(II+2,IMAX,KR+2) = FBLANK
                        SBUFF(II+3,IMAX,KR+2) = FBLANK
                        END IF
                     END IF
                  II = II + COLMUL
 75               CONTINUE
 80            CONTINUE
 100        CONTINUE
C                                       ready to write out
C                                       init image I/O
C                                       Open output files on first pass
 110     IF (LA.EQ.1) THEN
            CALL ZOPEN (LUN, FIND, DISKOU, PHNAME, T, F, T, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'OPEN OUTPUT IMAGE'
               IRET = 4
               GO TO 990
               END IF
            END IF
         DO 450 KR = 1,MUMBUF
            LR = (KR-1) / LSTINC
            IDEPTH(1) = MOD (KR-1, LSTINC) + 1
            IDEPTH(2) = LA + (KR-1) / LSTINC
            IDEPTH(3) = 1
            IDEPTH(4) = 1
            IDEPTH(5) = 1
            CALL COMOFF (CATIMG(KIDIM), CATIMG(KINAX), IDEPTH, IBLKOF,
     *         IERR)
            IBLKOF = IBLKOF + 1
            CALL FILL (4, 0, IDUM)
            CALL MINIT ('WRIT', LUN, FIND, CATIMG(KINAX),
     *         CATIMG(KINAX+1), IDUM, VBUFF, NBYT, IBLKOF, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'INIT OUTPUT IMAGE'
               IRET = 4
               GO TO 990
               END IF
            DO 430 IY = 1,DIMY
               CALL MDISK ('WRIT', LUN, FIND, VBUFF, IBIND, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1000) IRET, 'WRITE OUTPUT FILE'
                  GO TO 990
                  END IF
               SBUFF(1,IY,KR) = MSOU(IY)
               SBUFF(2,IY,KR) = TIMES(IY)
               SBUFF(3,IY,KR) = MINTS(IY)
               CALL RCOPY (DIMX, SBUFF(1,IY,KR), VBUFF(IBIND))
               DO 420 IX = 5,DIMX,COLMUL
                  IF (SBUFF(IX,IY,KR).NE.FBLANK) THEN
                     RMAX = MAX (RMAX, SBUFF(IX,IY,KR))
                     RMIN = MIN (RMIN, SBUFF(IX,IY,KR))
                     END IF
                  IF (SBUFF(IX+1,IY,KR).NE.FBLANK) THEN
                     RMAX = MAX (RMAX, SBUFF(IX+1,IY,KR))
                     RMIN = MIN (RMIN, SBUFF(IX+1,IY,KR))
                     END IF
 420              CONTINUE
 430           CONTINUE
            CALL MDISK ('FINI', LUN, FIND, VBUFF, IBIND, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'FINISH OUTPUT FILE'
               GO TO 990
               END IF
 450        CONTINUE
 500     CONTINUE
C                                       Close file
      CALL ZCLOSE (LUN, FIND, JERR)
C                                       finish the header
      CALL COPY (256, CATIMG, CATBLK)
      CATR(KRDMX) = RMAX
      CATR(KRDMN) = RMIN
      CATD(KDCRV+1) = CATD(KDCRV+1) * 24.D0 * 3600.D0
      CATR(KRCIC+1) = CATR(KRCIC+1) * 24. * 3600.
      CALL CATIO ('UPDT', DISKOU, CNOOUT, CATBLK, 'REST', SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1520) IERR
         CALL MSGWRT (6)
         END IF
C                                       Summary messages
      WRITE (MSGTXT,1521) NPOINT
      CALL MSGWRT (4)
      IF ((NPOINT.GT.0.0D0) .AND. (LNCFIL.GT.0)) FRW(LNCFIL) = 1
      IF (NPOINT.LE.0.0D0) IRET = 6
      GO TO 999
C                                       Error message print
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('GRIDSP: ERROR',I4,' ON ',A)
 1520 FORMAT ('ERROR',I5,' UPDATING THE CATALOG HEADER')
 1521 FORMAT ('Included',F13.0,' spectra in the grid')
      END
      SUBROUTINE PCALIB (BUFF1, BUFF2, IRET)
C-----------------------------------------------------------------------
C   Reads grid file applies PC delay/phase calibration string in pixels
C   4 and 5 of each sample
C   Outputs:
C      BUFF1   R(*)   Input buffer
C      BUFF2   R(*)   Output buffer
C      IRET    I      Error code > 0 -> die
C-----------------------------------------------------------------------
      INTEGER   IRET
      REAL      BUFF1(*), BUFF2(*)
C
      INTEGER   LUN1, LUN2, FIND1, FIND2, IDEPTH(5), IBLKOF, NBYT,
     *   IWIN(4), N3, N4, I3, I4, IY, BIND1, BIND2, IX, IX1, IX2, NIF,
     *   LIF, IERR, J
      REAL      RTEMP(2), PCDELY, PCPHAS, ERDELY, ERPHAS, WEIGHT
      DOUBLE PRECISION DTEMP
      CHARACTER PHNAME*48
      LOGICAL   T
      EQUIVALENCE (DTEMP, RTEMP)
      INCLUDE 'PCFLG.INC'
      INCLUDE 'PCFLG.BUF'
      INCLUDE 'PCDATA.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      DATA T /.TRUE./
      DATA LUN1, LUN2 /16,17/
C-----------------------------------------------------------------------
      MSGTXT = 'Finding and applying delays/phases to PC data'
      CALL MSGWRT (3)
C                                       open
      CALL ZPHFIL ('MA', DISKOU, CNOOUT, 1, PHNAME, IRET)
      CALL ZOPEN (LUN1, FIND1, DISKOU, PHNAME, T, T, T, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1010) 'OPEN', 'INPUT MASTER', IRET
         GO TO 990
         END IF
C                                       open for output
      CALL ZPHFIL ('MA', DISKOU, CNOOUT, 1, PHNAME, IRET)
      CALL ZOPEN (LUN2, FIND2, DISKOU, PHNAME, T, T, T, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1010) 'OPEN', 'INPUT MASTER', IRET
         GO TO 990
         END IF
C                                       windows
      IX = (CATIMG(KINAX) - 3) / NUMVAL
      NIF = IX / NUMTON
      NBYT = 2 * IOBUF
      IWIN(1) = 1
      IWIN(2) = 1
      IWIN(3) = CATIMG(KINAX)
      IWIN(4) = CATIMG(KINAX+1)
      N3 = CATIMG(KINAX+2)
      N4 = CATIMG(KINAX+3)
      IDEPTH(3) = 1
      IDEPTH(4) = 1
      IDEPTH(5) = 1
C                                       loop over 4-space
      DO 100 I4 = 1,N4
         DO 90 I3 = 1,N3
            IDEPTH(1) = I3
            IDEPTH(2) = I4
C                                       init IO from input
            CALL COMOFF (CATIMG(KIDIM), CATIMG(KINAX), IDEPTH, IBLKOF,
     *         IRET)
            IBLKOF = IBLKOF + 1
            CALL MINIT ('READ', LUN1, FIND1, CATIMG(KINAX),
     *         CATIMG(KINAX+1), IWIN, BUFF1, NBYT, IBLKOF, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1010) 'INIT', 'INPUT MASTER', IRET
               GO TO 990
               END IF
            CALL MINIT ('WRIT', LUN2, FIND2, CATIMG(KINAX),
     *         CATIMG(KINAX+1), IWIN, BUFF2, NBYT, IBLKOF, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1010) 'INIT', 'OUTPUT MASTER', IRET
               GO TO 990
               END IF
            DO 50 IY = 1,IWIN(4)
C                                       "write" row
               CALL MDISK ('WRIT', LUN2, FIND2, BUFF2, BIND2, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1010) 'WRITE', 'OUTPUT MASTER', IRET, IY
                  GO TO 990
                  END IF
C                                       "write" row
               CALL MDISK ('READ', LUN1, FIND1, BUFF1, BIND1, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1010) 'READ', 'INPUT MASTER', IRET, IY
                  GO TO 990
                  END IF
               DO 40 LIF = 1,NIF
                  IX1 = 3 + (LIF - 1) * NUMVAL * NUMTON
                  IX2 = 2 + LIF * NUMVAL * NUMTON
                  J = 0
C                                       pick up freqs and input data
                  DO 20 IX = IX1,IX2,NUMVAL
                     J = J + 1
                     IF (BUFF1(BIND1+IX).EQ.0.0) THEN
                        PCREAL(1,J,1) = BUFF1(BIND1+IX+1)
                        PCIMAG(1,J,1) = BUFF1(BIND1+IX+2)
                     ELSE
                        PCREAL(1,J,1) = FBLANK
                        PCIMAG(1,J,1) = FBLANK
                        END IF
                     RTEMP(1) = BUFF1(BIND1+IX+5)
                     RTEMP(2) = BUFF1(BIND1+IX+6)
                     PCFREQ(1,J,1) = DTEMP
 20                  CONTINUE
C                                       ffit it
                  CALL PCFITR (1, 1, 1, 1, NUMTON, PCFREQ, PCREAL,
     *               PCIMAG, 0.0, PCDELY, PCPHAS, ERDELY, ERPHAS,
     *               WEIGHT, IRET)
                  IRET = 0
C                                       put it back
                  J = 0
                  DO 30 IX = IX1,IX2,NUMVAL
                     J = J + 1
                     BUFF1(BIND1+IX+3) = PCREAL(1,J,1)
                     BUFF1(BIND1+IX+4) = PCIMAG(1,J,1)
 30                  CONTINUE
                  CALL RCOPY (CATIMG(KINAX), BUFF1(BIND1), BUFF2(BIND2))
 40               CONTINUE
 50            CONTINUE
C                                       "write" last row
            CALL MDISK ('FINI', LUN2, FIND2, BUFF2, BIND2, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1010) 'FINISH', 'OUTPUT MASTER', IRET, IY
               GO TO 990
               END IF
 90         CONTINUE
 100     CONTINUE
C
      CALL ZCLOSE (LUN1, FIND1, IERR)
      CALL ZCLOSE (LUN2, FIND2, IERR)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1010 FORMAT ('PCALIB: UNABLE TO ',A,1X,A,' FILE, ERROR',2I4)
      END
      SUBROUTINE PCFLGR (ONEIF, BIGDIM, BIGBOY, KIGBOY, IRET)
C-----------------------------------------------------------------------
C   PCFLGR is the main action routine of PCFLG.  It takes the TV and
C   displays the gridded SC file (smoothed to fit), offers options to
C   enhance the display, selected and redisplay a subimage, and edit
C   (flag) the data.
C   Input:
C      ONEIF    L      T => there is only one IF
C      BIGDIM   I      Total size of BIGBOY
C   Output:
C      BIGBOY   R(*)   Large IO buffers
C      KIGBOY   I(*)   Large IO buffers
C      IRET     I   Error code: 0 => okay, else die.
C-----------------------------------------------------------------------
      LOGICAL   ONEIF
      INTEGER   BIGDIM, KIGBOY(*), IRET
      REAL      BIGBOY(BIGDIM)
C
      INCLUDE 'INCS:PMAD.INC'
      CHARACTER CHTYPE(9)*8, CHSDEF(8)*2, CTEMP*4, ROUTIN*6, MSGBUF*72,
     *   CHST(13)*2, PHNAME*48, REAZON*24
      INTEGER   TTY(2), JERR, SCRTCH(MAXIMG), ICOL, IROW, MTRY, JTRIM,
     *   LTEMP(2), NTRY, IMGWIN(4), IGR, IPL, ITEMP, NX, IX, I, ALUN,
     *   NY, DATE(3), TIME(3), SLUN, ISIZE, IROUND, PLIMG(2), IY,
     *   PWIND(4), IT2, LUN0, FIND0, IB1, SVZOOM(3), IB2, IDUM(4)
      HOLLERITH HDUM(4)
      REAL      DTIME, PRPOS(2,10), BLCORN(7), TRCORN(7), TEMP,
     *   RSCR(MAXIMG)
      LOGICAL   T, F, EQUAL, NOFLAG, OKCORN(4), DOSTOK, FIRSTV
      DOUBLE PRECISION DTEMP(2)
      EQUIVALENCE (RSCR, SCRTCH), (IDUM, HDUM)
      INCLUDE 'PCFLG.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DTVC.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'PCFLG.BUF'
      DATA ALUN, SLUN, LUN0 /28, 29, 16/
      DATA T, F /.TRUE.,.FALSE./
      DATA DTIME /3.0/
      DATA CHTYPE /'AMPLTUDE', 'PHASE   ', 'RMS AMPL', 'RMS/MEAN',
     *   'RMS VAMP', 'VRMS/AVG', 'VEC DIFF', 'AMP DIFF', 'PHS DIFF'/
      DATA CHST /'HV','VH','HH','VV', 'LR','RL','LL','RR', '??',
     *   'I','Q','U ','V '/
      DATA CHSDEF /'RR','LL','RL','LR','VV','HH','VH','HV'/
C-----------------------------------------------------------------------
      RESOFF = 0
      PESOFF = 0
      XYCENT(1) = 0
      XYCENT(2) = 0
      FIRSTV = .TRUE.
      TTY(1) = 5
      MTRY = 20
      NTRY = MTRY + 1
      CALL FILL (16, 0, LWINTV)
      CALL RFILL (20, 0.0, PRPOS)
      LTYPE = 1
      LSTOKS = 1
      PLSTOK = 0
      PLANT = 0
      LANT = 1
      LSMOO = 1
      DOANT = LANT
      IF (ONEIF) THEN
         DOIFS = 1
      ELSE
         DOIFS = -1
         END IF
      LCIF(1) = 0
      LCIF(2) = 0
      DOWEDG = .FALSE.
      DOSOUR = .FALSE.
      ITRTYP = 1
      TEMP = CATIR(KRCIC+1)
      IF (TEMP.LT.9.9) THEN
         TFORM = 1
      ELSE
         TFORM = 0
         END IF
C                                       Open terminal
      TTY(2) = 0
      CALL ZOPEN (TTY(1), TTY(2), 1, MSGBUF, F, T, T, IRET)
      IF (IRET.NE.0) THEN
         TTY(2) = 0
         WRITE (MSGTXT,1000) IRET
         GO TO 980
         END IF
C                                       open TV
 10   CALL TVOPEN (BUFFER, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1010) IRET
         IF (IRET.NE.4) GO TO 970
         IF (NTRY.GE.MTRY) THEN
            MSGBUF = 'TV is busy: do we wait? Y or N'
            CALL INQSTR (TTY, MSGBUF, 4, CTEMP, IRET)
            IF ((IRET.NE.0) .AND. (IRET.NE.10)) GO TO 950
            CALL CHLTOU (4, CTEMP)
            IF ('Y'.NE.CTEMP(1:1)) GO TO 970
            NTRY = 0
            END IF
         NTRY = NTRY + 1
         CALL ZDELAY (DTIME, JERR)
         GO TO 10
         END IF
      DOCHAR = SQRT ((MAXXTV(1)/1024.0)*(MAXXTV(2)/1024.0)) + 0.5
      IF (DOCHAR.LE.1) DOCHAR = CSIZTV(1) / 7
      IF (DOCHAR.EQ.1) DOCHAR = 0
C                                       create TV scratch file
      CALL COPY (256, CATBLK, CATIMG)
      CATBLK(KINAX) = (CATBLK(KINAX) - 3) / NUMVAL
      WRITE (MSGTXT,1020) CATBLK(KINAX), CATBLK(KINAX+1)
      CALL MSGWRT (2)
      CATBLK(KINAX) = CATBLK(KINAX) + 3
      CATBLK(KINAX+2) = 1
      CATBLK(KINAX+3) = 1
      CATBLK(KINAX+4) = 1
      CATBLK(KINAX+5) = 1
      CATBLK(KINAX+6) = 1
      CALL MAPSIZ (CATBLK(KIDIM), CATBLK(KINAX), ISIZE)
      CALL SCREAT (ISIZE, BUFFER, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1021) IRET
         CALL MSGWRT (8)
         IRET = 3
         GO TO 990
         END IF
      TVFILE = NSCR
C                                       floating buffer SC file
      CATBLK(KINAX) = (CATBLK(KINAX) - 2) * 3
      CALL MAPSIZ (CATBLK(KIDIM), CATBLK(KINAX), ISIZE)
      CALL SCREAT (ISIZE, BUFFER, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1022) IRET
         CALL MSGWRT (8)
         IRET = 3
         GO TO 990
         END IF
      SCFILE = NSCR
      CATBLK(KINAX) = CATBLK(KINAX) / 3 + 2
C                                       init the TV
      CALL YHOLD ('ONNN', IRET)
      ROUTIN = 'YHOLD'
      IF (IRET.GT.0) GO TO 940
      CALL YINIT (SCRTCH, IRET)
      ROUTIN = 'YINIT'
      IF (IRET.NE.0) GO TO 940
      CALL COPY (3, TVZOOM, SVZOOM)
C                                       turn on graphics
      ROUTIN = 'YSLECT'
      IF (NGRAPH.GT.1) THEN
         IGR = 1 + NGRAY
         CALL YSLECT ('ONNN', IGR, 0, SCRTCH, IRET)
         IF (IRET.NE.0) GO TO 940
         END IF
      IF (NGRAPH.GT.2) THEN
         IGR = 3 + NGRAY
         CALL YSLECT ('ONNN', IGR, 0, SCRTCH, IRET)
         IF (IRET.NE.0) GO TO 940
         END IF
C                                       get antenna info
      IMGWIN(1) = 1
      IMGWIN(3) = (CATIMG(KINAX) - 3) / NUMVAL
C                                       Stokes in data
      CALL FILL (4, 0, ILSTOK)
      NSTOKS = CATIMG(KINAX+2)
      DO 25 I = 1,NSTOKS
         TEMP = (I - CATIR(KRCRP+2)) * CATIR(KRCIC+2) + CATID(KDCRV+2)
         ILSTOK(I) = IROUND (TEMP)
 25      CONTINUE
      USTFLG = 'FULL'
      IB1 = -ILSTOK(1)
      IF (CATIMG(KINAX+2).EQ.1) THEN
         USTFLG = CHSDEF(IB1)
      ELSE IF ((CATIMG(KINAX+2).EQ.2) .AND. (CATUV(KINAX+1).LT.4))
     *   THEN
         USTFLG = CHSDEF(IB1)
      ELSE
         IF (IB1.EQ.1) USTFLG = 'NOLL'
         IF (IB1.EQ.2) USTFLG = 'NORR'
         IF (IB1.EQ.5) USTFLG = 'NOHH'
         IF (IB1.EQ.6) USTFLG = 'NOVV'
         END IF
C                                       get 1s and 0s flag
      CALL MKSTOK (ILSTOK, USTFLG, STKFLG, IRET)
      IRET = 0
C                                       get source names
      MAXSOU = 0
      LSNAME = 0
      IF (LLOCSU.GE.0) THEN
         DO 50 I = 1,XSTBSZ
            MSGSUP = 32000
            CALL GETSOU (I, IUDISK, IUCNO, CATUV, SLUN, JERR)
            MSGSUP = 0
            MAXSOU = MAXSOU + 1
            IF (JERR.EQ.0) THEN
               SNAMES(MAXSOU) = SNAME
            ELSE
               SNAMES(MAXSOU) = 'NOT IN SU TABLE'
               END IF
            LSNAME = MAX (LSNAME, JTRIM (SNAMES(MAXSOU)))
 50         CONTINUE
      ELSE
         CALL H2CHR (8, 1, CATIH(KHOBJ), SNAMES)
         LSNAME = JTRIM (SNAMES(1))
         END IF
C                                       set default flagging reason
      REAZON = 'PCFLG:date time'
      CALL CHR2H (24, REAZON, 1, FCREAS)
C                                       read in the master grid times
C                                       open master grid file
      CALL ZPHFIL ('MA', DISKOU, CNOOUT, 1, PHNAME, IRET)
      CALL ZOPEN (LUN0, FIND0, DISKOU, PHNAME, T, F, T, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1060) IRET
         GO TO 899
         END IF
      NY = CATIMG(KINAX+1)
      CALL FILL (4, 0, IDUM)
      CALL MINIT ('READ', LUN0, FIND0, CATIMG(KINAX), NY, IDUM, BIGBOY,
     *   JBUFSZ, 1, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1065) IRET, 'INIT'
         GO TO 899
         END IF
      DO 70 IY = 1,NY
         CALL MDISK ('READ', LUN0, FIND0, BIGBOY, IB1, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1065) IRET, 'READ'
            GO TO 899
            END IF
         TEMP = BIGBOY(IB1)
         IF (TEMP.NE.FBLANK) THEN
            MSOU(IY) = IROUND (TEMP)
            IF (MSOU(IY).LE.0) MSOU(IY) = INSNUM
         ELSE
            MSOU(IY) = -1
            END IF
         TEMP = BIGBOY(IB1+1)
         IF (TEMP.NE.FBLANK) THEN
            MTIMES(IY) = TEMP
         ELSE IF (IY.EQ.1) THEN
            MTIMES(IY) = START - CATIR(KRCIC+1) / (2. * 24. * 3600.)
         ELSE
            MTIMES(IY) = MTIMES(IY-1) + CATIR(KRCIC+1) / (24. * 3600.)
            END IF
         TEMP = BIGBOY(IB1+2)
         IF (TEMP.NE.FBLANK) THEN
            MINTS(IY) = TEMP
         ELSE
            MINTS(IY) = 1.0 / (24.0 * 3600.0)
            END IF
 70      CONTINUE
      MTIMES(NY+1) = MTIMES(NY) + CATIR(KRCIC+1) / (24. * 3600.)
      MTIMES(NY+2) = MTIMES(NY+1) + CATIR(KRCIC+1) / (24. * 3600.)
      MTIMES(NY+3) = MTIMES(NY+2) + CATIR(KRCIC+1) / (24. * 3600.)
      MSOU(NY+1) = -1
      MSOU(NY+2) = -1
      MSOU(NY+3) = -1
      START = MTIMES(1)
      STOP = MTIMES(NY+1)
      CALL ZCLOSE (LUN0, FIND0, IRET)
C                                       create/find the FC table
      FCVERS = 0
      CALL PCFCOP (FCLUN, DISKOU, CNOOUT, FCVERS, CATIMG, FCNUMB,
     *   NNFLAG, FCBUF, IRET)
      IF (IRET.NE.0) GO TO 999
      IF (NNFLAG.GT.0) THEN
         WRITE (MSGTXT,1070) FCNUMB, NNFLAG
         CALL MSGWRT (2)
         END IF
      CALL TABIO ('CLOS', 0, NNFLAG, FCTIME, FCBUF, IRET)
      IF (IRET.NE.0) GO TO 999
C                                       branch to load function to start
      IROW = 11
      LSMOO = (CATIMG(KINAX+1) - 1) / (0.75 * MAXXTV(2)) + 1
      IF (LSMOO.LT.1) LSMOO = 1
      IPIECE = 1
      NPIECE = 1
      MPIECE = CATIMG(KINAX+1)
      LSCAN = MIN (30, 3 * LSMOO)
      LSCAN = MAX (LSCAN, LSMOO+2)
      MENUOK = .FALSE.
      GPH1OK = .TRUE.
      GPH3OK = .TRUE.
      GO TO 300
C                                       Set new choice
 90   CALL PCFCHS (PRPOS(1,1), IMGWIN, PWIND, SVZOOM, SCRTCH, RSCR,
     *   ICOL, IROW, IRET)
      ROUTIN = 'PCFCHS'
      IF (IRET.NE.0) GO TO 940
      GO TO (100, 200, 300, 400, 900), ICOL
C                                       enhancement functions
 100     IF ((IROW.GE.1) .AND. (IROW.LE.6)) THEN
            CALL PCFUNS (IROW, PRPOS(1,2), SCRTCH, IRET)
            ROUTIN = 'PCFUNS'
            IF ((IROW.EQ.1) .OR. (IROW.EQ.4)) CALL COPY (3, TVZOOM,
     *         SVZOOM)
C                                       wedge
         ELSE IF (IROW.EQ.7) THEN
            DOWEDG = .NOT.DOWEDG
            IPL = 1
            CALL YHOLD ('ONNN', IRET)
            ROUTIN = 'YHOLD'
            IF (IRET.GT.0) GO TO 940
            CALL PCFWED (DOWEDG, PLTYPE, IPL, SCRTCH, BIGBOY, IRET)
            ROUTIN = 'PCFWED'
            IF (IRET.GT.0) GO TO 940
            GPH4OK = .FALSE.
            CALL PCFLAB (IPL, PWIND, SCRTCH, BIGBOY, IRET)
            ROUTIN = 'PCFLAB'
            IF (IRET.GT.0) GO TO 940
            CALL YHOLD ('OFFF', IRET)
            ROUTIN = 'YHOLD'
C                                       log/linear load
         ELSE IF (IROW.EQ.8) THEN
            ITRTYP = ITRTYP + 1
            IF (ITRTYP.GT.4) ITRTYP = 1
            MENUOK = .FALSE.
C                                       unflagging functions
         ELSE IF ((IROW.GE.9) .AND. (IROW.LE.11)) THEN
            CALL PCFUNF (IROW, TTY, PWIND, BIGBOY(BIGPT(6)), BIGBOY,
     *         KIGBOY, SCRTCH, IRET)
            ROUTIN = 'PCFUNF'
C                                       re-calibrate
         ELSE IF (IROW.EQ.12) THEN
            CALL PCALIB (BIGBOY(BIGPT(4)), BIGBOY(BIGPT(5)), IRET)
            ROUTIN = 'PCALIB'
C                                       view resid
         ELSE IF (IROW.EQ.13) THEN
            MENUOK = .FALSE.
            IF (RESOFF.EQ.0) THEN
               RESOFF = 2
            ELSE
               RESOFF = 0
               END IF
C                                       Do labeling
         ELSE IF (IROW.EQ.14) THEN
            DOLABL = .NOT.DOLABL
            IPL = 1
            CALL YHOLD ('ONNN', IRET)
            ROUTIN = 'YHOLD'
            IF (IRET.GT.0) GO TO 940
            CALL PCFLAB (IPL, PWIND, SCRTCH, BIGBOY, IRET)
            ROUTIN = 'PCFLAB'
            IF (IRET.GT.0) GO TO 940
            CALL YHOLD ('OFFF', IRET)
            ROUTIN = 'YHOLD'
C                                       Character multiply
         ELSE IF (IROW.EQ.15) THEN
            IX = CSIZTV(1) / 7
            WRITE (MSGBUF,1136) IX
            CALL INQINT (TTY, MSGBUF, 1, LTEMP, IRET)
            IF (IRET.LT.0) GO TO 190
            IF (IRET.GT.0) GO TO 950
            IF ((LTEMP(1).GE.1) .AND. (LTEMP(1).LE.5)) THEN
               CALL YCMULT (LTEMP(1), IRET)
               MENUOK = .FALSE.
               CSIZTV(1) = 7 * LTEMP(1)
               CSIZTV(2) = 9 * LTEMP(1)
               IF (DOLABL) THEN
                  IPL = 1
                  CALL YHOLD ('ONNN', IRET)
                  ROUTIN = 'YHOLD'
                  IF (IRET.GT.0) GO TO 940
                  GPH4OK = .FALSE.
                  CALL PCFLAB (IPL, PWIND, SCRTCH, BIGBOY, IRET)
                  ROUTIN = 'PCFLAB'
                  IF (IRET.GT.0) GO TO 940
                  CALL YHOLD ('OFFF', IRET)
                  ROUTIN = 'YHOLD'
                  END IF
            ELSE
               MSGTXT = 'OUT OF RANGE'
               CALL MSGWRT (6)
               END IF
            END IF
C
         IF (IRET.GT.0) GO TO 940
         IF ((IRET.EQ.0) .AND. ((IROW.EQ.10) .OR. (IROW.EQ.11) .OR.
     *      (IROW.EQ.8))) GO TO 335
         GO TO 90
C                                       Non-numeric inputs
 190     MSGTXT = 'NON-NUMERIC INPUT - return to menu'
         CALL MSGWRT (6)
         GO TO 90
C                                       window set / load
C                                       manually entered windows
 200     IF (IROW.LE.2) THEN
            NX = (CATIMG(KINAX) - 3) / NUMVAL
            IF (IROW.EQ.1) WRITE (MSGBUF,1200) 1, NX, CATIMG(KINAX+1)
            IF (IROW.EQ.2) WRITE (MSGBUF,1201) 1, NX, CATIMG(KINAX+1)
            CALL INQINT (TTY, MSGBUF, 2, LTEMP, IRET)
            IF (IRET.LT.0) GO TO 190
            IF (IRET.GT.0) GO TO 950
            IF (IROW.EQ.1) THEN
               IF (LTEMP(1).LT.1) LTEMP(1) = 1
               IF (LTEMP(1).GT.NX) GO TO 200
               IF (LTEMP(2).LT.1) LTEMP(2) = 1
               IF (LTEMP(2).GT.CATIMG(KINAX+1)) GO TO 200
               IMGWIN(1) = LTEMP(1)
               IMGWIN(2) = LTEMP(2)
            ELSE
               IF (LTEMP(1).GT.NX) LTEMP(1) = NX
               IF (LTEMP(1).LE.IMGWIN(1)) GO TO 200
               IF (LTEMP(2).GT.CATIMG(KINAX+1)) LTEMP(2) =
     *            CATIMG(KINAX+1)
               IF (LTEMP(2).LE.IMGWIN(2)) GO TO 200
               IMGWIN(3) = LTEMP(1)
               IMGWIN(4) = LTEMP(2)
               END IF
C                                       enter pixranges
         ELSE IF (IROW.LE.6) THEN
            IX = IROW - 2
            WRITE (MSGBUF,1220) CHTYPE(IX)
            CALL INQFLT (TTY, MSGBUF, 2, DTEMP, IRET)
            IF (IRET.LT.0) GO TO 190
            IF (IRET.GT.0) GO TO 950
            PIXRNG(1,IX) = DTEMP(1)
            PIXRNG(2,IX) = DTEMP(2)
C                                       time averaging select
         ELSE IF (IROW.EQ.7) THEN
 230        TEMP = CATIR(KRCIC+1)
            WRITE (MSGBUF,1230) TEMP
            CALL INQINT (TTY, MSGBUF, 1, IDUM, IRET)
            ITEMP = IDUM(1)
            IF (IRET.GT.0) GO TO 950
            IF (IRET.LT.0) GO TO 190
            IF ((ITEMP.LT.1) .OR. (ITEMP.GT.CATIMG(KINAX+1)))
     *         GO TO 230
            IF (LSMOO.NE.ITEMP) THEN
               LSMOO = ITEMP
               MPIECE = 0.75 * MAXXTV(2)
               ITEMP = (CATIMG(KINAX+1)-1) / LSMOO + 1
               IF (ITEMP.LT.MPIECE) THEN
                  NPIECE = 1
                  MPIECE = ITEMP
               ELSE
                  NPIECE = (1.125 * ITEMP) / MPIECE + 1
                  END IF
               MPIECE = MPIECE * LSMOO
               IPIECE = 1
               IMGWIN(2) = 1
               IMGWIN(4) = MIN (MPIECE, CATIMG(KINAX+1))
               MENUOK = .FALSE.
               END IF
C                                       Scan averaging select
         ELSE IF (IROW.EQ.8) THEN
 235        TEMP = CATIR(KRCIC+1)
            WRITE (MSGBUF,1235) TEMP
            CALL INQINT (TTY, MSGBUF, 1, IDUM, IRET)
            ITEMP = IDUM(1)
            IF (IRET.GT.0) GO TO 950
            IF (IRET.LT.0) GO TO 190
            IF ((ITEMP.LT.1) .OR. (ITEMP.GT.CATIMG(KINAX+1)))
     *         GO TO 235
            LSCAN = ITEMP
C                                       baseline select
         ELSE IF (IROW.EQ.9) THEN
 240        IF (CATIMG(KINAX+3).GT.2) THEN
               WRITE (MSGBUF,1240) CATIMG(KINAX+3)
               CALL INQINT (TTY, MSGBUF, 1, IDUM, IRET)
               ITEMP = IDUM(1)
               IF (IRET.GT.0) GO TO 950
               IF (IRET.LT.0) GO TO 190
               IF ((ITEMP.LT.1) .OR. (ITEMP.GT.CATIMG(KINAX+3)))
     *            GO TO 240
               LANT = ITEMP
            ELSE IF (CATIMG(KINAX+3).EQ.2) THEN
               LANT = 3 - LANT
               END IF
C                                       set Stokes mask
         ELSE IF (IROW.EQ.10) THEN
 250        IF (ILSTOK(1).LE.-5) THEN
               WRITE (MSGTXT,1250) 'VV/HH/HV/VH'
            ELSE IF (ILSTOK(1).LE.-1) THEN
               WRITE (MSGTXT,1250) 'RR/LL/RL/LR'
            ELSE
               WRITE (MSGTXT,1250) 'I/Q/U/V'
               END IF
            CALL MSGWRT (1)
            MSGBUF = 'Enter Stokes flag string or mask: 4 chars '
     *         // 'must begin in col 1'
 251        CALL INQSTR (TTY, MSGBUF, 4, USTFLG, IRET)
            IF (IRET.EQ.10) THEN
               MSGTXT = 'STRING TOO LONG, TRY AGAIN'
               CALL MSGWRT (7)
               GO TO 251
               END IF
            IF (IRET.NE.0) GO TO 950
            CALL CHLTOU (4, USTFLG)
C                                       get 1s and 0s flag
            CALL MKSTOK (ILSTOK, USTFLG, STKFLG, IRET)
            IF (IRET.NE.0) THEN
                MSGTXT = 'STOKES FLAG ''' // USTFLG //
     *             ''' NOT RECOGNIZED OR INAPROPRIATE'
                CALL MSGWRT (6)
                IRET = 0
                GO TO 250
                END IF
            IF (.NOT.DOSTOK (ILSTOK, STKFLG, PLSTOK)) THEN
               MSGTXT = '****  NEW STOKES FLAG DOES NOT INCLUDE ' //
     *            'CURRENT STOKES  ****'
               CALL MSGWRT (7)
               IF (DOSTOK (ILSTOK, STKFLG, LSTOKS)) THEN
                  MSGTXT = '****  new Stokes flag does include new ' //
     *               'Stokes - do a LOAD  ****'
                  CALL MSGWRT (3)
                  END IF
               END IF
C                                       channel smoothing
         ELSE IF (IROW.EQ.11) THEN
            MSGBUF = 'Enter channel smooth FWHM in channels'
            CALL INQFLT (TTY, MSGBUF, 1, DTEMP, IRET)
            IF (IRET.LT.0) GO TO 190
            IF (IRET.GT.0) GO TO 950
            CSMOTH = DTEMP(1)
            CSMOTH = MAX (0.0, CSMOTH)
C                                       all planes flags
         ELSE IF (IROW.EQ.12) THEN
            IF (MAXSOU.GT.0) DOSOUR = .NOT.DOSOUR
         ELSE IF (IROW.EQ.13) THEN
            IF (DOANT.GT.0) THEN
               DOANT = 0
            ELSE
               DOANT = PLANT
               END IF
         ELSE IF (IROW.EQ.14) THEN
            IF (ONEIF) THEN
               DOIFS = 1
            ELSE
               DOIFS = DOIFS + 1
               IF (DOIFS.GT.1) DOIFS = -1
               IF ((DOIFS.EQ.0) .AND. (EIF-BIF.LE.1)) DOIFS = 1
C                                       which IFs?
               IF (DOIFS.EQ.0) THEN
 260              WRITE (MSGBUF,1260) BIF, EIF
                  CALL INQINT (TTY, MSGBUF, 2, LTEMP, IRET)
                  IF (IRET.LT.0) GO TO 190
                  IF (IRET.GT.0) GO TO 950
                  IF ((LTEMP(1).LT.BIF) .OR. (LTEMP(1).GT.EIF) .OR.
     *               (LTEMP(2).LT.LTEMP(1)) .OR. (LTEMP(2).GT.EIF))
     *               GO TO 260
                  LCIF(1) = LTEMP(1)
                  LCIF(2) = LTEMP(2)
               ELSE
                  LCIF(1) = 0
                  LCIF(2) = 0
                  END IF
               END IF
            END IF
         GO TO 90
C                                       data selection
C                                       data conversion
 300     IF ((IROW.EQ.15) .AND. (NPIECE.EQ.1)) IROW = 17
         IF (IROW.LE.9) THEN
            IF ((TYPUVD.LE.0) .OR. (IROW.NE.2)) LTYPE = IROW
C                                       Stokes select (switch)
         ELSE IF (IROW.EQ.10) THEN
            NSTOKS = CATIMG(KINAX+2)
            IF (NSTOKS.GT.1) THEN
               LSTOKS = MOD (LSTOKS, NSTOKS) + 1
C                                       try to fix
               IF (.NOT.DOSTOK (ILSTOK, STKFLG, LSTOKS)) THEN
                  IB2 = ILSTOK(LSTOKS)
                  IF (IB2.EQ.-1) THEN
                     STKFLG = '1011'
                     USTFLG = 'NOLL'
                  ELSE IF (IB2.EQ.-2) THEN
                     STKFLG = '0111'
                     USTFLG = 'NORR'
                  ELSE IF (IB2.EQ.-5) THEN
                     STKFLG = '1010'
                     USTFLG = 'NOHH'
                  ELSE IF (IB2.EQ.-6) THEN
                     STKFLG = '0111'
                     USTFLG = 'NOVV'
                  ELSE
                     STKFLG = '1111'
                     USTFLG = 'FULL'
                     END IF
                  MSGTXT = 'CHANGING STOKES FLAG TO INCLUDE NEW' //
     *               ' STOKES'
                  CALL MSGWRT (2)
                  END IF
C                                       check anyway
               IF (.NOT.DOSTOK (ILSTOK, STKFLG, LSTOKS)) THEN
                  MSGTXT = '*****  CURRENT STOKES FLAG DOES NOT'  //
     *               ' INCLUDE NEW STOKES  ****'
                  CALL MSGWRT (7)
                  END IF
               END IF
C                                       clear window
         ELSE IF (IROW.EQ.11) THEN
            IMGWIN(1) = 1
            IMGWIN(2) = 1
            IMGWIN(3) = (CATIMG(KINAX) - 3) / NUMVAL
            IMGWIN(4) = CATIMG(KINAX+1)
C                                       set window
         ELSE IF (IROW.EQ.12) THEN
            IRET = 0
            IF (NGRAPH.LE.1) MENUOK = .FALSE.
            IF (NGRAPH.LT.3) THEN
               IGR = MIN (1, NGRAPH)
               IPL = IGR + NGRAY
               IF (.NOT.GPH1OK) THEN
                  CALL YZERO (IPL, IRET)
                  GPH1OK = .TRUE.
                  END IF
            ELSE
               IGR = 3
               IPL = IGR + NGRAY
               IF (.NOT.GPH3OK) THEN
                  CALL YZERO (IPL, IRET)
                  GPH3OK = .TRUE.
                  END IF
               END IF
            ROUTIN = 'YZERO'
            IF (IRET.NE.0) GO TO 940
            CALL PCFBOX (IGR, 1, BLCORN, TRCORN, XYCENT, SCRTCH, IRET)
            ROUTIN = 'PCFBOX'
            IF (IRET.NE.0) GO TO 940
            OKCORN(1) = BLCORN(1).GE.1.0
            OKCORN(2) = BLCORN(2).GE.1.0
            OKCORN(3) = TRCORN(1).GE.1.0
            OKCORN(4) = TRCORN(2).GE.1.0
            IMGWIN(1) = BLCORN(1) + 0.5 + PLIMG(1)
            IMGWIN(3) = TRCORN(1) + 0.5 + PLIMG(1)
            IF (.NOT.OKCORN(1)) IMGWIN(1) = PWIND(1)
            IF (.NOT.OKCORN(3)) IMGWIN(3) = PWIND(3)
            IMGWIN(2) = PWIND(2)
            NY = CATIMG(KINAX+1) + 1
            IF (OKCORN(2)) THEN
               IY = IROUND (BLCORN(2))
               TEMP = TIMES(IY)
               DO 310 I = 1,NY
                  IF (MTIMES(I).GT.TEMP) THEN
                     IMGWIN(2) = MAX (I-1, 1)
                     GO TO 315
                     END IF
 310              CONTINUE
               END IF
 315        IMGWIN(4) = PWIND(4)
            IF (OKCORN(4)) THEN
               IY = IROUND (TRCORN(2))
               TEMP = TIMES(IY)
               DO 320 I = 1,NY
                  IF (MTIMES(I).GT.TEMP) THEN
                     IMGWIN(4) = MAX (I-1, 1)
                     GO TO 325
                     END IF
 320              CONTINUE
               END IF
 325        IF ((IMGWIN(1).LT.1) .OR. (IMGWIN(2).LT.1) .OR.
     *         (IMGWIN(3).LT.1) .OR. (IMGWIN(4).LT.1) .OR.
     *         (IMGWIN(3).GT.(CATIMG(KINAX)-3)/NUMVAL) .OR.
     *         (IMGWIN(4).GT.CATIMG(KINAX+1)) .OR.
     *         (IMGWIN(1).GE.IMGWIN(3)) .OR. (IMGWIN(2).GE.IMGWIN(4)))
     *         THEN
                  WRITE (MSGTXT,1325) IMGWIN
                  CALL MSGWRT (1)
C                                       Does full x fit - yes
            ELSE
               I = (CATIMG(KINAX) - 3) / NUMVAL
               IF (I.LE.MAXXTV(1)) THEN
                  IF ((IMGWIN(1).LE.3) .OR. (IMGWIN(1).LE.(I/100.)))
     *               IMGWIN(1) = 1
                  IF ((IMGWIN(3).GE.I-2) .OR. (IMGWIN(1).GE.(0.99*I)))
     *               IMGWIN(3) = I
                  END IF
               I = 0
               IMGWIN(1) = IMGWIN(1) + I
               IMGWIN(3) = IMGWIN(3) + I
               WRITE (MSGTXT,1326) IMGWIN
               CALL MSGWRT (2)
               IMGWIN(1) = IMGWIN(1) - I
               IMGWIN(3) = IMGWIN(3) - I
               END IF
C                                       last piece
         ELSE IF (IROW.EQ.15) THEN
            IPIECE = IPIECE - 1
            IF (IPIECE.LE.0) IPIECE = NPIECE
            I = CATIMG(KINAX+1)
            I = (I - MPIECE) / (NPIECE-1)
            IMGWIN(2) = 1 + (IPIECE-1) * I
            IMGWIN(4) = MPIECE + (IPIECE-1) * I
            WRITE (MSGTXT,1330) IPIECE, NPIECE
            CALL MSGWRT (2)
C                                       next piece
         ELSE IF (IROW.EQ.16) THEN
            IPIECE = MOD (IPIECE, NPIECE) + 1
            I = CATIMG(KINAX+1)
            I = (I - MPIECE) / (NPIECE-1)
            IMGWIN(2) = 1 + (IPIECE-1) * I
            IMGWIN(4) = MPIECE + (IPIECE-1) * I
            WRITE (MSGTXT,1330) IPIECE, NPIECE
            CALL MSGWRT (2)
            END IF
C                                       smooth and load
         IF ((IROW.LT.11) .OR. (IROW.GT.17)) GO TO 90
            IF (IROW.EQ.14) LANT = MOD (LANT, CATIMG(KINAX+3)) + 1
            IF (IROW.EQ.13) THEN
               LANT = LANT - 1
               IF (LANT.LE.0) LANT = CATIMG(KINAX+3)
               END IF
 335        I = 0
            IMGWIN(1) = IMGWIN(1) + I
            IMGWIN(3) = IMGWIN(3) + I
            WRITE (MSGTXT,1335) CHTYPE(LTYPE), IMGWIN
            CALL MSGWRT (2)
            IMGWIN(1) = IMGWIN(1) - I
            IMGWIN(3) = IMGWIN(3) - I
            TEMP = CATID(KDCRV+2) + (LSTOKS - CATIR(KRCRP+2)) *
     *         CATIR(KRCIC+2)
            IT2 = IROUND (TEMP) + 9
            IF ((IT2.LT.1) .OR. (IT2.GT.13)) IT2 = 9
            TEMP = CATIR(KRCIC+1) * LSMOO
            WRITE (MSGTXT,1336) CHST(IT2), LANT, TEMP
            CALL MSGWRT (2)
            IPL = 1
            CALL YHOLD ('ONNN', IRET)
            ROUTIN = 'YHOLD'
            IF (IRET.GT.0) GO TO 940
            CALL PCFOAD (IPL, IMGWIN, DIMB2, ABUF, IOBUF, SCRTCH,
     *         BIGBOY(1), BIGBOY(BIGPT(2)), KIGBOY(BIGPT(3)),
     *         BIGBOY(BIGPT(4)), BIGBOY(BIGPT(5)), BIGBOY(BIGPT(6)),
     *         IRET)
            ROUTIN = 'PCFOAD'
            IF (IRET.GT.100) GO TO 990
            IF (IRET.GT.0) GO TO 940
C                                       valid data -> TV display
            IF ((IRET.EQ.0) .OR. (FIRSTV)) THEN
               FIRSTV = .FALSE.
               LANTV = LANT
               PLTYPE = LTYPE
               PESOFF = RESOFF
               PLSTOK = LSTOKS
               PLSMOO = LSMOO
               PLSCAN = LSCAN
               IF (PLANT.NE.LANT) THEN
                  IF (DOANT.GT.0) DOANT = LANT
                  PLANT = LANT
                  END IF
               PLIMG(1) = IMGWIN(1) - 1
               PLIMG(2) = IMGWIN(2) - 1
               CALL COPY (4, IMGWIN, PWIND)
C                                       FC table
               FCTVTY = LTYPE
               FCTVBL = LANT
               FCTVIF = 0
               FCTVST = IT2 - 9
               CALL COPY (4, IMGWIN, FCTVWI)
               FCTVAV = LSMOO * CATIR(KRCIC+1)
               FCTVSC = LSCAN * CATIR(KRCIC+1)
               END IF
            GPH4OK = .FALSE.
            ROUTIN = 'PCFLAB'
            CALL PCFLAB (IPL, PWIND, SCRTCH, BIGBOY, IRET)
            IF (IRET.GT.0) GO TO 940
            GO TO 90
C                                       flagging
C                                       FC table
 400     IF (DOANT.GT.0) THEN
            FCBASL(1) = DOANT
            FCBASL(2) = 0
         ELSE
            FCBASL(1) = 0
            FCBASL(2) = 0
            END IF
         FCIF(1) = 0
         FCIF(2) = 0
         CALL CHR2H (4, STKFLG, 1, HDUM)
         FCSFLG = HDUM(1)
         IF (IROW.LE.7) THEN
            CALL PCFLAG (IROW, PWIND, TTY, SCRTCH, BIGBOY(BIGPT(4)),
     *         BIGBOY(BIGPT(5)), IRET)
         ELSE
            I = IROW - 7
            CALL PCFCLP (I, PWIND, TTY, SCRTCH, BIGBOY, KIGBOY, IRET)
            END IF
         IF (IRET.GT.0) GO TO 990
         IF ((IROW.EQ.10) .AND. (IRET.EQ.0)) GO TO 335
         GO TO 90
C                                       message first
 899     CALL MSGWRT (8)
C                                       Do flagging and Exit
 900     CALL ZDATE (DATE)
         CALL ZTIME (TIME)
         DATE(1) = -DATE(1)
         CALL TIMDAT (TIME, DATE, TTIME(2), TTIME)
C                                       Mark temp file as scratch
         IF (XDOCAT.LE.0.0) THEN
            NSCR = NSCR + 1
            SCRVOL(NSCR) = DISKOU
            SCRCNO(NSCR) = CNOOUT
            END IF
         IF (NNFLAG.LE.0) THEN
            MSGTXT = 'No flagging commands were prepared'
            CALL MSGWRT (4)
            CALL DELEXT ('PC', DISKIN, CNOIN, 'WRIT', CATUV, BUFFER,
     *         OVER, JERR)
            CALL ZPHFIL ('PC', DISKIN, CNOIN, OVER, PHNAME, JERR)
            CALL ZDESTR (DISKIN, PHNAME, JERR)
            WRITE (MSGTXT,1910) OVER
            CALL MSGWRT (3)
         ELSE
            WRITE (MSGBUF,1900) NNFLAG
            CALL ZTTYIO ('WRIT', TTY(1), TTY(2), 72, MSGBUF, JERR)
            IF (JERR.NE.0) GO TO 950
            IB1 = 0
 910        MSGBUF = 'Do you wish to enter them in the data?  Y/N'
 911        CALL INQSTR (TTY, MSGBUF, 4, CTEMP, JERR)
            IF (JERR.EQ.10) THEN
               MSGTXT = 'STRING TOO LONG, TRY AGAIN'
               CALL MSGWRT (7)
               GO TO 911
               END IF
            IF (JERR.NE.0) GO TO 950
            IB1 = IB1 + 1
            CALL CHLTOU (4, CTEMP)
            EQUAL = 'Y'.EQ.CTEMP(1:1)
            NOFLAG = 'N'.EQ.CTEMP(1:1)
            IF ((.NOT.EQUAL) .AND. (.NOT.NOFLAG)) GO TO 910
            IF (NOFLAG) THEN
               IF (XDOCAT.LE.0.0) THEN
                  IF (IB1.LE.5) THEN
                     MSGBUF = 'WARNING: THESE COMMANDS ARE ABOUT TO BE'
     *                  // ' LOST, so again:'
                     CALL ZTTYIO ('WRIT', TTY(1), TTY(2), 72, MSGBUF,
     *                  JERR)
                     IF (JERR.NE.0) GO TO 950
                     IB1 = IB1 + 5
                     GO TO 910
                  ELSE
                     MSGTXT = 'SO BE IT'
                     CALL MSGWRT (6)
                     END IF
                  END IF
               CALL DELEXT ('PC', DISKIN, CNOIN, 'WRIT', CATUV, BUFFER,
     *            OVER, JERR)
               CALL ZPHFIL ('PC', DISKIN, CNOIN, OVER, PHNAME, JERR)
               CALL ZDESTR (DISKIN, PHNAME, JERR)
               WRITE (MSGTXT,1910) OVER
               CALL MSGWRT (3)
               NNFLAG = 0
            ELSE
               MSGTXT = 'Begin actually flagging the data'
               CALL MSGWRT (2)
               WRITE (MSGTXT,1911) OVER
               CALL MSGWRT (3)
               IF (LQUICK) CALL RELPOP (IRET, BUFFER, JERR)
               CALL TVCLOS (BUFFER, JERR)
               RQUICK = LQUICK
               CALL PCFMRK (BIGBOY(BIGPT(4)), BIGBOY(BIGPT(5)), JERR)
               IF (IRET.EQ.0) IRET = JERR
               GO TO 995
               END IF
            END IF
         GO TO 990
C                                       error
 940  WRITE (MSGTXT,1940) IRET, ROUTIN
      CALL MSGWRT (8)
      GO TO 990
 950  WRITE (MSGTXT,1950) JERR
      CALL MSGWRT (8)
      IF (IRET.EQ.0) IRET = JERR
      GO TO 990
 970  CALL MSGWRT (8)
      CALL ZCLOSE (TTY(1), TTY(2), JERR)
      GO TO 999
 980  CALL MSGWRT (8)
      GO TO 999
C                                       closes
 990  CALL TVCLOS (BUFFER, JERR)
 995  CALL ZCLOSE (TTY(1), TTY(2), JERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('CANNOT OPEN YOUR TERMINAL: ERROR',I5)
 1010 FORMAT ('CANNOT OPEN THE TV DEVICE: ERROR',I5)
 1020 FORMAT ('Basic UV image is',I5,I6,' pixels in X,Y (Ch,T)')
 1021 FORMAT ('CANNOT CREATE TV IMAGE SCRATCH FILE, ERROR',I5)
 1022 FORMAT ('CANNOT CREATE FLOATING AVERAGE SCRATCH FILE, ERROR',I5)
 1060 FORMAT ('ERROR',I6,' OPENING MASTER GRID FILE TO READ TIMES')
 1065 FORMAT ('ERROR',I6,1X,A4,'ING MASTER GRID FILE FOR TIMES')
 1070 FORMAT ('Existing FC table has',I5,' flag commands, with',I6,
     *   ' total flags')
 1136 FORMAT ('Enter character multiplier 1 - 5, current value',I2)
 1200 FORMAT ('Enter BLC in ranges',I3,'-',I4,' , 1-',I5,
     *   ' (2 integers)')
 1201 FORMAT ('Enter TRC in ranges',I3,'-',I4,' , 1-',I5,
     *   ' (2 integers)')
 1220 FORMAT ('Enter ',A8,' TV-load pixel intensity range (2 reals)')
 1230 FORMAT ('Enter averaging interval in units of',F7.2,
     *   ' seconds, (integer)')
 1235 FORMAT ('Enter scan length in units of',F7.2,
     *   ' seconds, (integer)')
 1240 FORMAT ('Enter antenna number between 1 and',I4,' (integer)')
 1250 FORMAT ('Current Stokes order is taken as ',A)
 1260 FORMAT ('Enter desired IF range from',I3,' to',I3)
 1325 FORMAT ('Bad window BLC',2I5,' TRC',2I6,' try again')
 1326 FORMAT ('Set window BLC',I5,I6,' TRC',I5,I6)
 1330 FORMAT ('loading piece',I3,' of',I3)
 1335 FORMAT ('Loading ',A8,' over window BLC',I5,I6,' TRC',I5,I6)
 1336 FORMAT ('with Stokes ',A2,' antenna',I4,' smoothed to',F8.2,
     *   ' seconds')
 1900 FORMAT (I8,' Flagging commands have been prepared')
 1910 FORMAT ('Deleted new sorted PC table version',I6)
 1911 FORMAT ('Keeping new sorted and now edited PC table version',I6)
 1940 FORMAT ('TELEVISION I/O ERROR',I5,' FROM ',A)
 1950 FORMAT ('TERMINAL I/O ERROR',I5)
      END
      SUBROUTINE GTREAS (TTY, REAZON)
C-----------------------------------------------------------------------
C   GTREAS maintains a user-entered list [RLIST] of reasons to attach to
C   the flag table.  RLIST(1) defaults to the string 'PCFLG:date time'
C   which is filled in with the date and time that the flagging info was
C   generated.
C   Input:
C      TTY     I(2)   variable describing the Text and Message terminals
C   Output:
C      REAZON  C*24   reason selected by user to be attached to flags
C                     ' ' user bailed out
C   Internal:
C      RLIST C(10)*24 internally maintined list of reasons entered by
C                     user,  note that the list is REINITIALIZED when
C                     the calling program calls GTREAS for the first
C                     time and hence is NOT saved/recovered
C                     between different invocations of the calling
C                     program
C-----------------------------------------------------------------------
      INTEGER MREAS
      PARAMETER (MREAS=10)
      CHARACTER REAZON*24, RLIST(MREAS)*24, MSGBUF*72
      INTEGER   IREAS, NREAS, I, J, IRET, TTY(2), IDUM(4)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'PCFLG.BUF'
      SAVE RLIST
      DATA IREAS, NREAS /1,1/
      DATA RLIST /MREAS*' '/
C-----------------------------------------------------------------------
      RLIST(1) = 'PCFLG:date time'
      REAZON = ' '
C                                        show current list of reasons
 10   WRITE (MSGTXT,1010) IREAS, NREAS
      CALL MSGWRT (1)
      DO 20 I = 1,NREAS
         WRITE (MSGTXT,1015) I, RLIST(I)
         CALL MSGWRT (1)
 20      CONTINUE
C                                           what does the user want to
C                                           do?
 30   WRITE (MSGBUF,1030) NREAS
      CALL INQINT (TTY, MSGBUF, 1, IDUM, IRET)
      I = IDUM(1)
      IF (IRET.NE.0) GO TO 30
      IF (ABS(I).GT.NREAS) GO TO 30
      IF ((I.EQ.0) .AND. (NREAS.EQ.MREAS)) THEN
         WRITE (MSGTXT,1035) MREAS
         CALL MSGWRT (6)
         GO TO 30
         END IF
      IF (I.EQ.-1) THEN
         MSGTXT = 'Sorry, string #1 cannot be replaced'
         CALL MSGWRT (6)
         GO TO 30
         END IF
C                                       I=0: add new reason,
C                                       I<0: replace old one
      IF (I.LE.0) THEN
 40      MSGBUF = 'Enter new string text'
         CALL INQSTR (TTY, MSGBUF, 24, REAZON, IRET)
         IF (IRET.EQ.10) THEN
            MSGTXT = 'STRING TOO LONG, TRY AGAIN'
            CALL MSGWRT (7)
            GO TO 40
            END IF
         IF (IRET.NE.0) GO TO 40
         WRITE (MSGTXT,1040) REAZON
         CALL MSGWRT (2)
C                                           confirm selected reason

         IF (I.EQ.0) THEN
            WRITE (MSGBUF,1045) NREAS+1
         ELSE
            WRITE (MSGBUF,1045) -I
            END IF
         CALL INQINT (TTY, MSGBUF, 1, IDUM, IRET)
         J = IDUM(1)
         IF (J.EQ.-1) GO TO 999
         IF (J.NE.1) GO TO 10
         IF (I.EQ.0) THEN
            NREAS = NREAS + 1
            I = -NREAS
            END IF
         IREAS = -I
         RLIST(IREAS) = REAZON
      ELSE
         IREAS = I
         END IF
      REAZON = RLIST(IREAS)
C
 999  RETURN
C-----------------------------------------------------------------------
 1010 FORMAT ('Currently using reason string #',I2,' of ',I2)
 1015 FORMAT ('Reason string #', I2, ' = ''',A24,'''')
 1030 FORMAT ('Choose string # to use [1:',I2,
     *  '] (<0 to replace,0 for new)')
 1035 FORMAT ('Sorry maximum of ',I2,' reasons, choose again')
 1040 FORMAT ('You entered ''',A24,'''')
 1045 FORMAT ('Confirm new text for string # ',I2,
     *   ' (1=yes,0=no,-1=cancel)')
      END
      SUBROUTINE PCFCHS (RPOS, IMGWIN, WIND, SVZOOM, SCRTCH, RSCR, ICOL,
     *   IROW, IRET)
C-----------------------------------------------------------------------
C   handles the choice of operation to perform
C   In/out:
C      RPOS     R(2)   cursor position to start and end
C   Input:
C      IMGWIN   I(4)   window of next load
C      WIND     I(4)   window of last load
C      SVZOOM   I(3)   zoom parameters
C   Output:
C      SCRTCH   I(*)   scratch buffer (>1024)
C      ICOL     I      col number of choice
C      IROW     I      row number of choice
C      IRET     I      TV I/O error (no message)
C-----------------------------------------------------------------------
      REAL      RPOS(2), RSCR(*)
      INTEGER   IMGWIN(4), WIND(4), SVZOOM(3), IROW, ICOL, SCRTCH(*),
     *   IRET
C
      INTEGER   MAXR
      PARAMETER (MAXR=17)
C
      CHARACTER PS*132, VARTYP*4, CHOIC1(MAXR)*18, CHOIC2(MAXR)*18,
     *   CHOIC3(MAXR)*18, CHOIC4(MAXR)*18, CHOIC5(MAXR)*18, CHTYPE(9)*8,
     *   FLGTYP(5)*7, CHOICE(MAXR,5)*18, ROUTIN*6, STRING*180, CT(12)*1,
     *   CHST(13)*2, SUTYP(2)*10, STRIN2*100, BLFLAG*8, PRSTR*16,
     *   TRTYP(4)*4
      REAL      PPOS(2), TEMP, CATR(256)
      INTEGER   IX, IY, NC, GR1, GR2, LCOL, LROW, NROW, NCOL, PCOL, I,
     *   NROWS(5), NCHM(5), LCH(MAXR,5), NCH(MAXR,5), IXC(5), IYC(MAXR),
     *   IXP(5), IYP(5), QUAD, IBUT, LX, LY, ITW(3), IROUND, JERR, PROW,
     *   NEDGE, MASK, IT2, IWIN(4), ISU, NACROS, IZOOM(3), ZAND, MENUCH,
     *   MENU0, NCHAR, NCHAR2, NCT, ITRIM, NC1, NC2, NC3, NC4, NCC, GR4,
     *   IPL, LROWS(5)
      LOGICAL   F, DOIT, DOZOOM(MAXR,5)
      INCLUDE 'PCFLG.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DTVC.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      EQUIVALENCE (CATBLK, CATR)
      EQUIVALENCE (CHOICE(1,1), CHOIC1),  (CHOICE(1,2), CHOIC2),
     *   (CHOICE(1,3), CHOIC3),  (CHOICE(1,4), CHOIC4),
     *   (CHOICE(1,5), CHOIC5)
      SAVE IXC, IYC
      DATA CHST /'HV','VH','HH','VV', 'LR','RL','LL','RR', '??',
     *   'I','Q','U ','V '/
      DATA F /.FALSE./
      DATA NCOL, LROWS /5, 14,14,17,10,1/
      DATA NCHM /10,18,18,15,4/
      DATA LCH /7, 8, 8, 8, 8, 8,10, 9,10,10,10,10,10,10, 9, 0, 0,
     *          9, 9,18,18,18,18,17,15,14,17,15,18,18,18, 0, 0, 0,
     *         17,13,11,16,16,17,18,17,18,17,17,17,17,17,15,15, 4,
     *         10,12, 9,15,15,11,14,14,15,12, 0, 0, 0, 0, 0, 0, 0,
     *          4,16*0/
      DATA DOZOOM /3*.FALSE., 3*.TRUE., 2*.FALSE., 2*.TRUE., 7*.FALSE.,
     *   17*.FALSE.,
     *   10*.FALSE., 2*.TRUE., 5*.FALSE.,
     *   10*.TRUE., 7*.FALSE.,
     *   17*.FALSE./
      DATA CHOIC1
     *   /'OFFZOOM           ', 'OFFTRANS          ',
     *    'OFFCOLOR          ', 'TVFIDDLE          ',
     *    'TVTRANSF          ', 'TVPSEUDO          ',
     *    'DO WEDGE ?        ', 'LOAD SQRT         ',
     *    'LIST FLAGS        ', 'UNDO FLAGS        ',
     *    'REDO FLAGS        ', 'REDO DELAY        ',
     *    'VIEW RESID        ', 'DO LABEL ?        ',
     *    'CHAR MULT         ', '                  ',
     *    '                  '/
      DATA CHOIC2
     *   /'ENTER BLC         ', 'ENTER TRC         ',
     *    'ENTER AMP PIXRANGE', 'ENTER PHS PIXRANGE',
     *    'ENTER RMS PIXRANGE', 'ENTER R/M PIXRANGE',
     *    'ENTER SMOOTH TIME ', 'ENTER SCAN TIME   ',
     *    'ENTER ANTENNA     ', 'ENTER STOKES FLAG ',
     *    'ENTER CH SMOOTH   ', 'SWITCH SOURCE FLAG',
     *    'SWITCH ALLANT FLAG', 'SWITCH ALL-IF FLAG',
     *    '                  ', '                  ',
     *    '                  '/
      DATA CHOIC3
     *   /'DISPLAY AMPLITUDE ', 'DISPLAY PHASE     ',
     *    'DISPLAY RMS       ', 'DISPLAY RMS/MEAN  ',
     *    'DISPLAY VECT RMS  ', 'DISPLAY VRMS/VAVG ',
     *    'DISPLAY AMP V DIFF', 'DISPLAY AMPL DIFF ',
     *    'DISPLAY PHASE DIFF', 'DISPLAY STOKES    ',
     *    'OFF WINDOW + LOAD ', 'SET WINDOW + LOAD ',
     *    'LOAD LAST ANTENNA ', 'LOAD NEXT ANTENNA ',
     *    'LOAD LAST PIECE   ', 'LOAD NEXT PIECE   ',
     *    'LOAD              '/
      DATA CHOIC4
     *   /'FLAG PIXEL        ', 'FLAG/CONFIRM      ',
     *    'FLAG AREA         ', 'FLAG TIME RANGE   ',
     *    'FLAG CHANNEL-DT   ', 'FLAG A TIME       ',
     *    'FLAG A CHANNEL    ', 'CLIP BY SET #S    ',
     *    'CLIP INTERACTIV   ', 'CLIP BY FORM      ',
     *    '                  ', '                  ',
     *    '                  ', '                  ',
     *    '                  ', '                  ',
     *    '                  '/
      DATA CHOIC5
     *   /'EXIT              ', 16*' '/
      DATA CHTYPE /'AMPLTUDE', 'PHASE   ', 'RMS AMPL', 'RMS/MEAN',
     *   'RMS VAMP', 'VRMS/AVG', 'VEC DIFF', 'AMP DIFF', 'PHS DIFF'/
      DATA FLGTYP /'ALL-ANT', 'ALL-IF', 'ONE-ANT', 'ONE-IF','> 1-IF'/
      DATA SUTYP /'ALL-SOURCE', 'ONE-SOURCE'/
      DATA TRTYP /'LOG ','SQRT','LOG2','LIN '/
C-----------------------------------------------------------------------
 1    IF (DOCHAR.GT.1) LROWS(1) = 15
      IROW = 0
      ICOL = 0
      CALL COPY (NCOL, LROWS, NROWS)
      NROW = MAXR
      I = NCOL * NROW
      CALL COPY (I, LCH, NCH)
      IF (NPIECE.GT.1) THEN
         CHOIC3(MAXR-2) = 'LOAD LAST PIECE'
         CHOIC3(MAXR-1) = 'LOAD NEXT PIECE'
         NCH(NROWS(3)-2,3) = 15
         NCH(NROWS(3)-1,3) = 15
      ELSE
         CHOIC3(MAXR-2) = 'LOAD'
         NCH(NROWS(3)-2,3) = 4
         NROWS(3) = NROWS(3) - 2
         END IF
      IF (RESOFF.EQ.0) THEN
         CHOIC1(13) = 'VIEW RESID'
      ELSE
         CHOIC1(13) = 'VIEW INPUT'
         END IF
C                                       set spacing
      NEDGE = (CSIZTV(1) + 1) / 2
      IF (NEDGE.LT.2) NEDGE = 2
      NC = 0
      DO 5 I = 1,NCOL
         NC = NC + NCHM(I)
 5       CONTINUE
 6    MENUCH = 2 * (2 + NEDGE + (NCOL-1) * (1+NEDGE)) + CSIZTV(1) * NC
      IF (MENUCH.GT.MAXXTV(1)) THEN
         NEDGE = NEDGE - 1
         IF (NEDGE.GT.0) GO TO 6
            I = CSIZTV(1) / 7
            IF (I.GT.1) THEN
               MSGTXT = 'TV SCREEN TOO NARROW.  LOWERING CHAR MULT'
               CALL MSGWRT (6)
               I = I - 1
               CSIZTV(1) = 7 * I
               CSIZTV(2) = 9 * I
               CALL YCMULT (I, IRET)
               IF (IRET.EQ.0) GO TO 1
               END IF
            MSGTXT = 'TV SCREEN TOO NARROW.  BUY A BIGGER ONE'
            CALL MSGWRT (9)
            IRET = 8
            GO TO 999
         END IF
      CALL ZTIME (ITW)
      PROW = 0
      PCOL = 0
      IZOOM(1) = 0
      IZOOM(2) = MAXXTV(1)/2
      IZOOM(3) = MAXXTV(2)/2
      IF ((TVZOOM(1).NE.IZOOM(1)) .OR. (TVZOOM(2).NE.IZOOM(2)) .OR.
     *   (TVZOOM(3).NE.IZOOM(3))) THEN
         CALL YZOOMC (IZOOM(1), IZOOM(2), IZOOM(3), F, IRET)
         ROUTIN = 'YZOOMC'
         IF (IRET.NE.0) GO TO 990
         END IF
C                                       check window of TV
      CALL YWINDO ('READ', WINDTV, IRET)
      ROUTIN = 'YWINDO'
      IF (IRET.NE.0) GO TO 990
      IF ((WINDTV(1).NE.LWINTV(1,1)) .OR. (WINDTV(2).NE.LWINTV(2,1))
     *   .OR. (WINDTV(3).NE.LWINTV(3,1)) .OR.
     *   (WINDTV(4).NE.LWINTV(4,1))) THEN
         MENUOK = .FALSE.
         GPH4OK = .FALSE.
         END IF
      CALL COPY (4, WINDTV, LWINTV(1,1))
C                                       init the display
      IF (NGRAPH.LT.2) THEN
         GR2 = NGRAY + 1
         GR4 = GR2
         GR1 = 0
C                                       set highlight graphics
      ELSE
         GR2 = NGRAY + 2
         GR4 = GR2
         IF (NGRAPH.GE.4) GR4 = NGRAY + 4
         GR1 = 1 + NGRAY
         IF (.NOT.GPH1OK) THEN
            CALL YZERO (GR1, IRET)
            ROUTIN = 'YZERO'
            IF (IRET.NE.0) GO TO 900
            GPH1OK = .TRUE.
            END IF
         MASK = 2 ** (GR1 - 1)
         MASK = ZAND (MASK, TVLIMG(1))
         IF (MASK.EQ.0) THEN
            CALL YSLECT ('ONNN', GR1, 0, SCRTCH, IRET)
            ROUTIN = 'YSLECT'
            IF (IRET.NE.0) GO TO 900
            END IF
         END IF
C                                       turn on cursor
      QUAD = -1
      IF ((RPOS(1).LE.WINDTV(1)) .OR. (RPOS(1).GT.WINDTV(3)))
     *   RPOS(1) = (WINDTV(1) + WINDTV(3)) / 2
      IF ((RPOS(2).LE.WINDTV(2)) .OR. (RPOS(2).GT.WINDTV(4)))
     *   RPOS(2) = WINDTV(4) - 10 - 3 * CSIZTV(2)
      CALL YCURSE ('ONNN', F, F, RPOS, QUAD, IBUT, IRET)
      ROUTIN = 'YCURSE'
      IF (IRET.NE.0) GO TO 900
C                                       turn on graphics
      CALL YHOLD ('ONNN', I)
      MASK = 2 ** (GR2 - 1)
      MASK = ZAND (MASK, TVLIMG(1))
      IF (MASK.EQ.0) THEN
         CALL YSLECT ('ONNN', GR2, 0, SCRTCH, IRET)
         ROUTIN = 'YSLECT'
         IF (IRET.NE.0) GO TO 900
         END IF
      IF ((.NOT.GPH4OK) .AND. (GR4.GT.GR2)) THEN
         CALL YZERO (GR4, IRET)
         ROUTIN = 'YZERO'
         IF (IRET.NE.0) GO TO 900
         IF (DOLABL) THEN
            IPL = 1
            CALL PCFLAB (IPL, WIND, SCRTCH, RSCR, IRET)
            ROUTIN = 'PCFLAB'
            IF (IRET.NE.0) GO TO 900
            END IF
         END IF
      MASK = 2 ** (GR4 - 1)
      MASK = ZAND (MASK, TVLIMG(1))
      IF (MASK.EQ.0) THEN
         CALL YSLECT ('ONNN', GR4, 0, SCRTCH, IRET)
         ROUTIN = 'YSLECT'
         IF (IRET.NE.0) GO TO 900
         END IF
C                                       init the graphics display
      IF (.NOT.MENUOK) THEN
         NC1 = 0
         NC2 = 0
         NC3 = 0
         NC4 = 0
         CALL YZERO (GR2, IRET)
         ROUTIN = 'YZERO'
         IF (IRET.NE.0) GO TO 900
C                                       write to planes: strings
         MENU0 = 4 + WINDTV(1)
         IF (MENU0+MENUCH.GT.MAXXTV(1)) MENU0 = MAXXTV(1) - MENUCH
         ROUTIN = 'IMCHAR'
         IX = 3 + NEDGE + MENU0
         DO 20 LCOL = 1,NCOL
            IY = WINDTV(4) - 12 - NEDGE - CSIZTV(2)
            NROW = NROWS(LCOL)
            IXC(LCOL) = IX
            DO 10 LROW = 1,NROW
               IYC(LROW) = IY
               NC = NCH(LROW,LCOL)
               PS = CHOICE(LROW,LCOL)(1:NC)
               IF ((LROW.EQ.8) .AND. (LCOL.EQ.1))
     *            PS = 'LOAD ' // TRTYP(ITRTYP)
               CALL IMCHAR (GR2, IX, IY, 0, 0, PS(1:NC), SCRTCH, IRET)
               IF (IRET.NE.0) GO TO 900
               IY = IY - 2*NEDGE - CSIZTV(2)
 10            CONTINUE
            IX = IX + 2 + 2*NEDGE + NCHM(LCOL)*CSIZTV(1)
 20         CONTINUE
C                                       write border lines
         IX = 1 + MENU0
         IY = WINDTV(4) - 11
         DO 30 LCOL = 1,NCOL
            LX = 4 + 2*NEDGE + NCHM(LCOL)*CSIZTV(1)
            LY = NROWS(LCOL) * (2*NEDGE + CSIZTV(2)) + 4
            IXP(1) = IX
            IYP(1) = IY
            IXP(2) = IX + LX - 1
            IF (LCOL.EQ.4) MAXMEN = IXP(2) + 5 - WINDTV(1)
            IYP(2) = IYP(1)
            IXP(3) = IXP(2)
            IYP(3) = IY - LY + 1
            IXP(4) = IXP(1)
            IYP(4) = IYP(3)
            IXP(5) = IXP(1)
            IYP(5) = IYP(1)
            CALL IMVECT ('ONNN', GR2, 5, IXP, IYP, SCRTCH, IRET)
            ROUTIN = 'IMVECT'
            IF (IRET.NE.0) GO TO 900
            IX = IX + 1
            IY = IY - 1
            LX = LX - 2
            LY = LY - 2
            IXP(1) = IX
            IYP(1) = IY
            IXP(2) = IX + LX - 1
            IYP(2) = IYP(1)
            IXP(3) = IXP(2)
            IYP(3) = IY - LY + 1
            IXP(4) = IXP(1)
            IYP(4) = IYP(3)
            IXP(5) = IXP(1)
            IYP(5) = IYP(1)
            CALL IMVECT ('ONNN', GR2, 5, IXP, IYP, SCRTCH, IRET)
            ROUTIN = 'IMVECT'
            IF (IRET.NE.0) GO TO 900
            IX = IX + LX - 1
            IY = IY + 1
 30         CONTINUE
         END IF
C                                       change variable part
      NSTOKS = CATIMG(KINAX+2)
      I = MOD (LSTOKS, NSTOKS) + 1
      I = ILSTOK(I) + 9
      IF ((I.LT.1) .OR. (I.GT.13)) I = 9
      IY = IYC(10)
      IX = IXC(3) + 15 * CSIZTV(1)
      CALL IMCHAR (GR2, IX, IY, 0, 0, CHST(I)(:2), SCRTCH, IRET)
      IF (IRET.NE.0) GO TO 900
C                                       status line
      IX = 5 + 2*NEDGE
      IY = CSIZTV(2) + WINDTV(2)
      IX = IX + WINDTV(1)
      WRITE (BLFLAG,1025) PLANT
      IF (DOANT.EQ.0) BLFLAG(6:8) = '***'
      LY = 4
      IF (DOIFS.EQ.1) LY = 2
      IF (DOIFS.EQ.0) THEN
         LY = 5
         WRITE (FLGTYP(LY),1029) LCIF
         END IF
      ISU = 1
      IF (DOSOUR) ISU = 2
      CT(1) = '*'
      CT(2) = '*'
      CT(3) = '*'
      CT(4) = '*'
      CT(5) = '*'
      CT(6) = '*'
      CT(7) = '*'
      CT(8) = '*'
      CT(9) = '*'
      CT(10) = '*'
      CT(11) = '*'
      CT(12) = '*'
      IF (LTYPE.EQ.PLTYPE) CT(1) = '_'
      IF (LANT.EQ.PLANT) CT(2) = '_'
      IF (LSMOO.EQ.PLSMOO) CT(4) = '_'
      IF (IMGWIN(1).EQ.WIND(1)) CT(5) = ' '
      IF (IMGWIN(2).EQ.WIND(2)) CT(6) = '_'
      IF (IMGWIN(3).EQ.WIND(3)) CT(7) = ' '
      IF (IMGWIN(4).EQ.WIND(4)) CT(8) = '_'
      IF (LSTOKS.EQ.PLSTOK) CT(10) = '_'
      IF (LSCAN.EQ.PLSCAN) CT(11) = '_'
      IF (LCSMOT.EQ.CSMOTH) CT(12) = '_'
      TEMP = CATID(KDCRV+2) + (PLSTOK-CATIR(KRCRP+2)) * CATIR(KRCIC+2)
      IT2 = IROUND (TEMP) + 9
      IF ((IT2.LT.1) .OR. (IT2.GT.13)) IT2 = 9
      IWIN(1) = WIND(1)
      IWIN(3) = WIND(3)
      IWIN(2) = WIND(2)
      IWIN(4) = WIND(4)
      IF (PESOFF.EQ.0) THEN
         VARTYP = 'INP '
      ELSE
         VARTYP = 'RES '
         END IF
      IF (RESOFF.NE.PESOFF) VARTYP(4:4)='*'
C                                       choose form that fits
      CALL PRFRMT (CATR(IRRAN), PRSTR)
      ROUTIN = 'IMCHAR'
      NACROS = (WINDTV(3) - IX) / CSIZTV(1)
      NCT = ITRIM (CHTYPE(PLTYPE))
      WRITE (STRING,1030) VARTYP, CHTYPE(PLTYPE)(:NCT), CT(1), PRSTR,
     *   PLANT, CT(2), PLSMOO, CT(4), IWIN(1), CT(5), IWIN(2), CT(6),
     *   IWIN(3), CT(7), IWIN(4), CT(8), SUTYP(ISU), BLFLAG, FLGTYP(LY),
     *   PLSCAN, CT(11), CSMOTH, CT(12), CHST(IT2), CT(10), USTFLG
      CALL REFRMT (STRING, '_', NCHAR)
      IF (NACROS.GE.NCHAR) THEN
         NCC = MAX (NC1, NCHAR)
         NC1 = NCHAR
         CALL IMCHAR (GR4, IX, IY, 0, 0, STRING(:NCC), SCRTCH, IRET)
         IF (IRET.NE.0) GO TO 900
         MAXLAB = 1
      ELSE
         WRITE (STRING,1035) IWIN(1), CT(5), IWIN(2), CT(6), IWIN(3),
     *      CT(7), IWIN(4), CT(8), PLSMOO, CT(4), PLSCAN, CT(11),
     *      CSMOTH, CT(12), CHST(IT2), CT(10), USTFLG
         CALL REFRMT (STRING, '_', NCHAR)
         WRITE (STRIN2,1036) VARTYP,CHTYPE(PLTYPE)(:NCT), CT(1), PRSTR,
     *      PLANT, CT(2), SUTYP(ISU), BLFLAG, FLGTYP(LY)
         CALL REFRMT (STRIN2, '_', NCHAR2)
         IF (NACROS.GT.MAX(NCHAR,NCHAR2)) THEN
            NCC = MAX (NC1, NCHAR)
            NC1 = NCHAR
            CALL IMCHAR (GR4, IX, IY, 0, 0, STRING(:NCC), SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 900
            IY = IY + NEDGE + CSIZTV(2)
            NCC = MAX (NC2, NCHAR2)
            NC2 = NCHAR2
            CALL IMCHAR (GR4, IX, IY, 0, 0, STRIN2(:NCC), SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 900
            MAXLAB = 2
         ELSE IF (NACROS.GE.51) THEN
            WRITE (STRING,1040) PLSCAN, CT(11), CSMOTH, CT(12),
     *         CHST(IT2), CT(10), USTFLG, BLFLAG
            CALL REFRMT (STRING, '_', NCHAR)
            NCC = MAX (NC1, NCHAR)
            NC1 = NCHAR
            CALL IMCHAR (GR4, IX, IY, 0, 0, STRING(:NCC), SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 900
            IY = IY + NEDGE + CSIZTV(2)
            WRITE (STRING,1041) IWIN(1), CT(5), IWIN(2), CT(6), IWIN(3),
     *         CT(7), IWIN(4), CT(8), SUTYP(ISU), FLGTYP(LY)
            CALL REFRMT (STRING, '_', NCHAR)
            NCC = MAX (NC2, NCHAR)
            NC2 = NCHAR
            CALL IMCHAR (GR4, IX, IY, 0, 0, STRING(:NCC), SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 900
            IY = IY + NEDGE + CSIZTV(2)
            WRITE (STRING,1042) VARTYP, CHTYPE(PLTYPE)(:NCT), CT(1),
     *         PRSTR, PLANT, CT(2), PLSMOO, CT(4)
            CALL REFRMT (STRING, '_', NCHAR)
            NCC = MAX (NC3, NCHAR)
            NC3 = NCHAR
            CALL IMCHAR (GR4, IX, IY, 0, 0, STRING(:NCC), SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 900
            MAXLAB = 3
         ELSE IF (NACROS.GE.39) THEN
            WRITE (STRING,1045) PLSMOO, CT(4), SUTYP(ISU), BLFLAG,
     *         FLGTYP(LY)
            CALL REFRMT (STRING, '_', NCHAR)
            NCC = MAX (NC1, NCHAR)
            NC1 = NCHAR
            CALL IMCHAR (GR4, IX, IY, 0, 0, STRING(:NCC), SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 900
            IY = IY + NEDGE + CSIZTV(2)
            WRITE (STRING,1046) PLSCAN, CT(11), CSMOTH, CT(12),
     *         CHST(IT2), CT(10), USTFLG
            CALL REFRMT (STRING, '_', NCHAR)
            NCC = MAX (NC2, NCHAR)
            NC2 = NCHAR
            CALL IMCHAR (GR4, IX, IY, 0, 0, STRING(:NCC), SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 900
            IY = IY + NEDGE + CSIZTV(2)
            WRITE (STRING,1047) IWIN(1), CT(5), IWIN(2), CT(6), IWIN(3),
     *         CT(7), IWIN(4), CT(8)
            CALL REFRMT (STRING, '_', NCHAR)
            NCC = MAX (NC3, NCHAR)
            NC3 = NCHAR
            CALL IMCHAR (GR4, IX, IY, 0, 0, STRING(:NCC), SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 900
            IY = IY + NEDGE + CSIZTV(2)
            WRITE (STRING,1048) VARTYP, CHTYPE(PLTYPE)(:NCT), CT(1),
     *         PLANT, CT(2)
            CALL REFRMT (STRING, '_', NCHAR)
            NCC = MAX (NC4, NCHAR)
            NC4 = NCHAR
            CALL IMCHAR (GR4, IX, IY, 0, 0, STRING(:NCC), SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 900
            MAXLAB = 4
         ELSE
            MSGTXT = 'WINDOW IS TOO NARROW FOR STATUS DISPLAYS !'
            CALL MSGWRT (7)
            END IF
         END IF
C                                       read a choice
      CALL YHOLD ('FFFF', I)
      MENUOK = .TRUE.
      PPOS(1) = 0.0
      PPOS(2) = 0.0
      MSGTXT = 'Press buttons A, B, or C to choose an operation'
      CALL MSGWRT (1)
      MSGTXT = 'Press button D for on-line help'
      CALL MSGWRT (1)
C                                        read until cursor moves
 50   CALL YCURSE ('READ', F, F, RPOS, QUAD, IBUT, IRET)
      ROUTIN = 'YCURSE'
      IF (IRET.NE.0) GO TO 800
      CALL DLINTR (RPOS, IBUT, PPOS, ITW, DOIT)
      IF (.NOT.DOIT) GO TO 50
C                                        find the choice
         IX = IROUND (RPOS(1))
         IY = IROUND (RPOS(2))
         ICOL = 0
         DO 55 LCOL = 1,NCOL
            IF (IX.GE.IXC(LCOL)-2) ICOL = LCOL
 55         CONTINUE
         IF (ICOL.LE.0) GO TO 50
         IROW = 0
         NROW = NROWS(ICOL)
         DO 60 LROW = 1,NROW
            IF (IY.GT.IYC(NROW+1-LROW)-2) IROW = NROW+1-LROW
 60         CONTINUE
         IF (IROW.EQ.0) GO TO 50
         IF (GR1.GT.0) THEN
            IF ((PCOL.NE.ICOL) .OR. (PROW.NE.IROW) .OR. ((IBUT.GT.0)
     *         .AND. (IBUT.LE.7))) THEN
C                                       restore choice
               ROUTIN = 'IMCHAR'
               IF ((PCOL.GT.0) .AND. (PROW.GT.0)) THEN
                  CALL YHOLD ('ONNN', I)
                  NC = NCH(PROW,PCOL)
                  PS(1:NC) = ' '
                  CALL IMCHAR (GR1, IXC(PCOL), IYC(PROW), 0, 0,
     *               PS(1:NC), SCRTCH, IRET)
                  IF (IRET.NE.0) GO TO 800
                  PS(1:NC) = CHOICE(PROW,PCOL)(1:NC)
                  IF ((PROW.EQ.8) .AND. (PCOL.EQ.1))
     *               PS = 'LOAD ' // TRTYP(ITRTYP)
                  IF ((PCOL.EQ.1) .AND. (PROW.EQ.13)) THEN
                     IF (RESOFF.EQ.0) THEN
                        PS = 'VIEW RESID'
                     ELSE
                        PS = 'VIEW INPUT'
                        END IF
                     END IF
                  CALL IMCHAR (GR2, IXC(PCOL), IYC(PROW), 0, 0,
     *               PS(1:NC), SCRTCH, IRET)
                  IF (IRET.NE.0) GO TO 800
C                                       change variable part
                  IF ((PCOL.EQ.3) .AND. (PROW.EQ.10)) THEN
                     NSTOKS = CATIMG(KINAX+2)
                     I = MOD (LSTOKS, NSTOKS) + 1
                     I = ILSTOK(I) + 9
                     IF ((I.LT.1) .OR. (I.GT.13)) I = 9
                     IY = IYC(10)
                     IX = IXC(3) + 15 * CSIZTV(1)
                     CALL IMCHAR (GR2, IX, IY, 0, 0, CHST(I)(:2),
     *                  SCRTCH, IRET)
                     IF (IRET.NE.0) GO TO 900
                     END IF
                  CALL YHOLD ('OFFF', I)
                  END IF
C                                       highlight choice
               IF ((IBUT.LE.0) .OR. (IBUT.GT.7)) THEN
                  NC = NCH(IROW,ICOL)
                  PS(1:NC) = CHOICE(IROW,ICOL)(1:NC)
                  IF ((IROW.EQ.8) .AND. (ICOL.EQ.1))
     *               PS = 'LOAD ' // TRTYP(ITRTYP)
                  IF ((ICOL.EQ.1) .AND. (IROW.EQ.13)) THEN
                     IF (RESOFF.EQ.0) THEN
                        PS = 'VIEW RESID'
                     ELSE
                        PS = 'VIEW INPUT'
                        END IF
                     END IF
                  CALL IMCHAR (GR1, IXC(ICOL), IYC(IROW), 0, 0,
     *               PS(1:NC), SCRTCH, IRET)
                  IF (IRET.NE.0) GO TO 800
C                                       change variable part
                  IF ((ICOL.EQ.3) .AND. (IROW.EQ.10)) THEN
                     NSTOKS = CATIMG(KINAX+2)
                     I = MOD (LSTOKS, NSTOKS) + 1
                     I = ILSTOK(I) + 9
                     IF ((I.LT.1) .OR. (I.GT.13)) I = 9
                     IY = IYC(10)
                     IX = IXC(3) + 15 * CSIZTV(1)
                     CALL IMCHAR (GR1, IX, IY, 0, 0, CHST(I)(:2),
     *                  SCRTCH, IRET)
                     IF (IRET.NE.0) GO TO 900
                     END IF
                  END IF
               PCOL = ICOL
               PROW = IROW
               END IF
            END IF
C                                       leave on button A, B, C
         IF (IBUT.GE.8) THEN
            NC = NCH(IROW,ICOL)
            IF (CHOICE(IROW,ICOL)(:15).EQ.'DISPLAY STOKES ') NC = 15
            PS = CHOICE(IROW,ICOL)(1:NC)
            IF ((IROW.EQ.8) .AND. (ICOL.EQ.1))
     *         PS = 'LOAD ' // TRTYP(ITRTYP)
            CALL TSKHLP (PS, NC, ' ', JERR)
            IBUT = 0
         ELSE IF (IBUT.GT.0) THEN
            GO TO 800
            END IF
         GO TO 50
C                                       turn off the cursor
 800  CALL YCURSE ('OFFF', F, F, RPOS, QUAD, IBUT, JERR)
C                                       turn off the choices
 900  IF (DOZOOM(IROW,ICOL)) THEN
         CALL YHOLD ('ONNN', I)
         CALL YSLECT ('OFFF', GR2, 0, SCRTCH, JERR)
         IF (IRET.EQ.0) THEN
            CALL COPY (3, SVZOOM, TVZOOM)
            CALL YZOOMC (TVZOOM(1), TVZOOM(2), TVZOOM(3), F, JERR)
            END IF
         CALL YHOLD ('OFFF', I)
         END IF
C                                       force buffer to TV
      CALL YCURSE ('READ', F, F, RPOS, QUAD, IBUT, JERR)
C
 990  IF (IRET.EQ.0) GO TO 999
         WRITE (MSGTXT,1990) IRET, ROUTIN
         CALL MSGWRT (6)
         CALL YHOLD ('OFFF', I)
C
 999  RETURN
C-----------------------------------------------------------------------
 1025 FORMAT ('ANT=',I3.2)
 1029 FORMAT ('IF',I2.2,'-',I2.2)
 1030 FORMAT (A,A,A1,1X,A,' _Ant',I3.2,A1,1X,'Avg',I5,A1,1X,'BLC',
     *   2(I5,A1),1X,'TRC',2(I5,A1),3('__',A),' _Scan',I5,A1,
     *   ' CSmooth',F5.1,A1,' Show ',A2,A1,' flag ',A4)
 1035 FORMAT ('BLC',2(I5,A1),1X,'TRC',2(I5,A1),' Avg',I5,A1,' Scan',I5,
     *  A1,' CSmooth',F5.1,A1,' Show ',A2,A1,' flag ',A4)
 1036 FORMAT (A,A,A1,1X,A,' _Ant',I3.2,A1,1X,A,2('__',A))
 1040 FORMAT ('Scan',I5,A1,' CSmooth',F5.1,A1,' Show ',A2,A1,' flag ',
     *   A4,'__',A)
 1041 FORMAT ('BLC',2(I5,A1),1X,'TRC',2(I5,A1),'__',A,'__',A)
 1042 FORMAT (A,A,A1,1X,A,' _Ant',I3.2,A1,1X,'Avg',I5,A1)
 1045 FORMAT ('Avg',I5,A1,3('__',A))
 1046 FORMAT ('Scan',I5,A1,' CSmooth',F5.1,A1,' Show ',A2,A1,' flag ',
     *   A4)
 1047 FORMAT ('BLC',2(I6,A1),3X,'TRC',2(I6,A1))
 1048 FORMAT (A,A,A1,2X,'Ant',I3.2,A1)
 1990 FORMAT ('PCFCHS: TV I/O ERROR',I7,' FROM ',A)
      END
      SUBROUTINE PCFUNS (BRANCH, PPOS, SCRTCH, IRET)
C-----------------------------------------------------------------------
C   performs TV enhancement functions for PCFLG
C   Inputs:
C      BRANCH   I         1 => off zoom
C                         2 => off black and white transfer
C                         3 => off pseudo color
C                         4 => do TVFIDDLE
C                         5 => do TVtransfer (black and white)
C                         6 => do TVpseudo (various pseudo colors)
C   In/out:
C      PPOS     I(2,9)    previous cursor positions for various modes:
C                         1 for transfer, 2-4 for pseudo's
C   Output:
C      SCRTCH   I(*)      scratch buffer: > 3072 (IENHNS)
C      IRET     I         TV error (no message)
C-----------------------------------------------------------------------
      INTEGER   BRANCH, SCRTCH(*), IRET
      REAL      PPOS(2,9)
C
      INCLUDE 'INCS:PTVC.INC'
      LOGICAL   F
      INTEGER   I, J, IC, ICOLOR, NLEVS, GR1, II, JJ
      REAL      SLOPE, RBUF(TVMOFM)
      INCLUDE 'PCFLG.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DTVC.INC'
      DATA F /.FALSE./
C-----------------------------------------------------------------------
      CALL YWINDO ('READ', WINDTV, IRET)
      IF (IRET.NE.0) THEN
         WINDTV(1) = 1
         WINDTV(2) = 1
         WINDTV(3) = MAXXTV(1)
         WINDTV(4) = MAXXTV(2)
         IRET = 0
         END IF
      IF ((BRANCH.LT.1) .OR. (BRANCH.GT.6)) GO TO 999
      GO TO (100, 200, 300, 400, 500, 600), BRANCH
C-----------------------------------------------------------------------
C                                       off zoom
 100  CONTINUE
         I = TVZOOM(1)
         TVZOOM(1) = 0
         TVZOOM(2) = MAXXTV(1) / 2
         TVZOOM(3) = MAXXTV(2) / 2
         IF (I.NE.0) THEN
            CALL YZOOMC (TVZOOM(1), TVZOOM(2), TVZOOM(3), F, IRET)
         ELSE
            IRET = 0
            END IF
         GO TO 999
C-----------------------------------------------------------------------
C                                       off transfer: channel 1
 200  CONTINUE
         IC = 2 ** NGRAY - 1
         ICOLOR = 7
         NLEVS = MAXINT + 1
         SLOPE = REAL (LUTOUT) / REAL (MAXINT)
         DO 210 I = 1,NLEVS
            SCRTCH(I) = (I-1) * SLOPE + 0.5
 210        CONTINUE
         CALL YLUT ('WRIT', IC, ICOLOR, F, SCRTCH, IRET)
         GO TO 999
C-----------------------------------------------------------------------
C                                       off pseudo (off colors)
 300  CONTINUE
         I = OFMINP + 1
         ICOLOR = 7
         CALL RFILL (I, 0.0, RBUF)
         NLEVS = LUTOUT + 1
         IF (NLEVS.GT.OFMINP) NLEVS = OFMINP + 1
         SLOPE = 1.0 / REAL(NLEVS-1)
         DO 310 I = 1,NLEVS
            RBUF(I) = (I-1) * SLOPE
 310        CONTINUE
         I = OFMINP + 1
         JJ = NLEVS
         I = I / NLEVS
         DO 311 II = 2,I
            IF (JJ+NLEVS.LE.I) CALL RCOPY (NLEVS, RBUF, RBUF(JJ+1))
            JJ = JJ + NLEVS
 311        CONTINUE
         CALL YOFM ('WRIT', ICOLOR, F, RBUF, IRET)
         GO TO 999
C-----------------------------------------------------------------------
C                                       TVFIDDLE
 400  CONTINUE
         NLEVS = LUTOUT + 1
         IF (NLEVS.GT.OFMINP) NLEVS = OFMINP + 1
         IC = 2 ** NGRAY - 1
         CALL TVFIDL (IC, NLEVS, SCRTCH, IRET)
         GO TO 999
C-----------------------------------------------------------------------
C                                       TVTRANSF
 500  CONTINUE
         IF (NGRAPH.LE.1) MENUOK = .FALSE.
         IF (.NOT.GPH1OK) THEN
            J = NGRAY + 1
            CALL YZERO (J, IRET)
            IF (IRET.NE.0) GO TO 999
            END IF
         GPH1OK = .FALSE.
         MSGTXT = 'Cursor x position controls intercept'
         CALL MSGWRT (1)
         MSGTXT = 'Cursor y position controls slope'
         CALL MSGWRT (1)
         MSGTXT = 'Hit buttons A or B to turn plot off or back on'
         CALL MSGWRT (1)
         MSGTXT = 'Hit button C to reverse sign of slope'
         CALL MSGWRT (1)
         MSGTXT = 'Hit button D to exit TV transfer and return to menu'
         CALL MSGWRT (1)
C                                        off graphics
         IF (NGRAPH.LE.2) THEN
            GPH1OK = .FALSE.
            GR1 = 1 + NGRAY
            CALL YSLECT ('OFFF', GR1, 0, SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 999
         ELSE IF (NGRAPH.EQ.3) THEN
            MENUOK = .FALSE.
            GR1 = 2 + NGRAY
            CALL YZERO (GR1, IRET)
            IF (IRET.NE.0) GO TO 999
         ELSE IF (NGRAPH.EQ.4) THEN
            GPH3OK = .FALSE.
            GR1 = 3 + NGRAY
            CALL YSLECT ('OFFF', GR1, 0, SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 999
            END IF
C                                        hide this mess in subroutine
         J = 1
         IC = 1
         ICOLOR = 7
         CALL IENHNS (IC, ICOLOR, J, PPOS(1,1), SCRTCH, IRET)
         IF (IRET.NE.0) GO TO 999
C                                        clean up again
         IF (NGRAPH.LE.4) THEN
            CALL YZERO (GR1, IRET)
            IF (IRET.NE.0) GO TO 999
            CALL YSLECT ('ONNN', GR1, 0, SCRTCH, IRET)
            IF (NGRAPH.LE.2) GPH1OK = .TRUE.
            IF (NGRAPH.EQ.4) GPH3OK = .TRUE.
            END IF
         GO TO 999
C-----------------------------------------------------------------------
C                                       TVPSEUDO
C                                       Button A: RGB triangles
C                                       Button B: Loops in hue
C                                       Button C: color contours
 600  CONTINUE
         NLEVS = LUTOUT + 1
         IF (NLEVS.GT.OFMINP) NLEVS = OFMINP + 1
         CALL TVPSUD (NLEVS, RBUF, IRET)
C
 999  RETURN
      END
      SUBROUTINE PCFLAG (BRANCH, IMGWIN, TTY, SCRTCH, BUFF, BUFF2, IRET)
C-----------------------------------------------------------------------
C   does various forms of interactive TV flagging using the currently
C   displayed file
C   Inputs:
C      BRANCH   I      1 => flag pixel
C                      2 => flag pixel and confirm
C                      3 => flag area CH-T
C                      4 => flag timerange
C                      5 => flag one channel, timerange
C                      6 => flag time
C                      7 => flag channel
C      IMGWIN   I(4)   currently loaded image window
C   Output:
C      BUFF     R(*)   IO buffer
C      BUFF2    R(*)   IO buffer
C      SCRTCH   I(*)   TV scratch buffer
C      IRET     I      error code
C-----------------------------------------------------------------------
      INTEGER   BRANCH, IMGWIN(4), TTY(2), SCRTCH(*), IRET
      REAL      BUFF(*), BUFF2(*)
C
      INCLUDE 'PCFLG.INC'
      CHARACTER FIXIT*4, CHTEMP*4, ROUTIN*6, STRING*20, MSGBUF*72,
     *   PHNAME*48, OPERS(7)*8, BLNAME*16
      INTEGER   GR1, GR3, NPIX, NROW, NEDGE, MAG, IX0, IY0, IX, IY,
     *   LUN1, LUN2, FIND1, FIND2, QUAD, IBUT, ITW(3), TVX, TVY, J, I,
     *   IWIN(4), NB, JERR, IXP(5), IERR, IYL0, KST, IYP(5), DOBLC,
     *   LUN0, FIND0, I1, I2, LBUT, LUN3, FIND3, NRPL, IYL, NCTI,
     *   IYH, IB1, IB2, IXL, IXH, ISOU, IBLKOF, IDEPTH(5), KBBASL,
     *   KEBASL, KBASL, NFLAGD, IYH0, LTVX, LTVY, LSOU, NSNUMS, SL,
     *   SNUMS(XSTBSZ), ISNUM, MASK, ZAND, NCHAN, MCHAN, LIF, I4, IXINC,
     *   LCHAN, IROUND, LDOIFS, LMGWIN(4), LMGCOR(4)
      LOGICAL   DOANOT, DOIT, T, F, BLANKD, DOBOX, DOTV, DOSTOK, FIX
      REAL      CATR(256), RPOS(2), TEMP, PPOS(2), CORN(2), PIXVAL,
     *   TIM1, TIM2
      DOUBLE PRECISION CATD(128)
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DTVC.INC'
      EQUIVALENCE (CATBLK, CATR, CATD)
      DATA FIXIT /'FXIT'/
      DATA T, F /.TRUE.,.FALSE./
      DATA LUN0, LUN1, LUN2, LUN3 /16,17,18,19/
      DATA OPERS /'PIXEL', 'PIXEL', 'AREA', 'TIMERANG', 'CHANL-DT',
     *   'TIME', 'CHANNEL'/
C-----------------------------------------------------------------------
      BLNAME = ' '
      LTVX = -1
      LTVY = -1
      LSOU = -2
      CALL YWINDO ('READ', WINDTV, IRET)
      IF (IRET.NE.0) THEN
         WINDTV(1) = 1
         WINDTV(2) = 1
         WINDTV(3) = MAXXTV(1)
         WINDTV(4) = MAXXTV(2)
         IRET = 0
         END IF
      IXINC = CATBLK(IICOR+2) - CATBLK(IICOR)
      IXINC = MAX (1, IXINC)
      IXINC = (CATBLK(IIWIN+2) - CATBLK(IIWIN)) / IXINC
      IXINC = MAX (1, IXINC)
      NCHAN = CHNMAX
      LCHAN = NCHAN / IXINC
      CALL COPY (4, CATBLK(IIWIN), LMGWIN)
      CALL COPY (4, CATBLK(IICOR), LMGCOR)
C                                       cursor on
      QUAD = -1
      RPOS(1) = (LMGCOR(1) + LMGCOR(3)) / 2
      RPOS(2) = (LMGCOR(2) + LMGCOR(4)) / 2
      CALL YCURSE ('ONNN', F, F, RPOS, QUAD, IBUT, IRET)
      ROUTIN = 'YCURSE'
      IF (IRET.NE.0) GO TO 800
C                                       init controls
      DOBOX = (BRANCH.GE.3) .AND. (BRANCH.LE.5)
      CALL FILL (5, 1, IXP)
      CALL FILL (5, 1, IYP)
      NB = 2
      DOTV = DOSTOK (ILSTOK, STKFLG, PLSTOK)
      IF (.NOT.DOTV) THEN
         MSGTXT = 'WARNING: flag command does not apply to displayed'
     *      // ' Stokes'
         CALL MSGWRT (6)
         END IF
C                                       FC table
      FCLIPR(1) = 0.0
      FCLIPR(2) = 0.0
      CALL CHR2H (8, OPERS(BRANCH), 1, FCOPER)
C                                       NO background blanking here
      GR1 = 1 + NGRAY
      GR3 = 1 + NGRAY
      IF (NGRAPH.GT.2) GR3 = 3 + NGRAY
C                                       Zero AND ON the graphics
      FIND0 = 0
      FIND1 = 0
      FIND2 = 0
      FIND3 = 0
      IF (NGRAPH.LE.1) MENUOK = .FALSE.
      CALL YHOLD ('ONNN', I)
      IF (.NOT.GPH1OK) THEN
         CALL YZERO (GR1, IRET)
         ROUTIN = 'YZERO'
         IF (IRET.NE.0) GO TO 800
         END IF
      IF ((GR3.NE.GR1) .AND. (.NOT.GPH3OK)) THEN
         CALL YZERO (GR3, IRET)
         IF (IRET.NE.0) GO TO 800
         END IF
      DOANOT = .TRUE.
      ROUTIN = 'YSLECT'
      MASK = 2 ** (GR1 - 1)
      MASK = ZAND (MASK, TVLIMG(1))
      IF (MASK.EQ.0) THEN
         CALL YSLECT ('ONNN', GR1, 0, SCRTCH, IRET)
         IF (IRET.NE.0) GO TO 800
         END IF
      MASK = 2 ** (GR3 - 1)
      MASK = ZAND (MASK, TVLIMG(1))
      IF (MASK.EQ.0) THEN
         CALL YSLECT ('ONNN', GR3, 0, SCRTCH, IRET)
         IF (IRET.NE.0) GO TO 800
         END IF
      CALL YHOLD ('OFFF', I)
C                                       CURVAL display location
      SL = MAX (11+2*TFORM, LSNAME)
      NPIX = SL * CSIZTV(1)
      NEDGE = (2 * MAXXTV(1)) / 512
      IF (NEDGE.LT.2) NEDGE = 2
      NROW = 3
      IF (MAXSOU.GT.0) NROW = NROW + 1
      NROW = NROW * (2*NEDGE + CSIZTV(2))
      MAG = 1 + TVZOOM(1)
      IF (MXZOOM.GT.0) MAG = 2 ** TVZOOM(1)
      IX0 = WINDTV(1) - (MAG-1)/2
      IY0 = WINDTV(4) - MAG*NROW + 1 - (MAG-1)/2
      IF (MAG.GT.1) IY0 = IY0 + MAG
      IX0 = (IX0 - TVZOOM(2))/MAG + TVZOOM(2)
      IY0 = (IY0 - TVZOOM(3))/MAG + TVZOOM(3)
      IX0 = MAX (1, IX0)
      IY0 = MAX (1, IY0)
      IF (IX0+NPIX-1.GT.MAXXTV(1)) IX0 = MAXXTV(1) - NPIX + 1
      IF (IY0+NROW-1.GT.MAXXTV(2)) IY0 = MAXXTV(2) - NROW + 1
C                                       set to top row of text
      IX0 = IX0 + NEDGE
      IY0 = IY0 + 5*NEDGE + 2*CSIZTV(2)
      IF (MAXSOU.GT.0) IY0 = IY0 + 2*NEDGE + CSIZTV(2)
C                                       get image header
      IX = (WINDTV(1) + WINDTV(3)) / 2
      IY = (WINDTV(2) + WINDTV(4)) / 2
      IF (XYCENT(1).GT.0) IX = XYCENT(1)
      IF (XYCENT(2).GT.0) IY = XYCENT(2)
      CALL YCREAD (1, IX, IY, CATBLK, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1005) IRET
         GO TO 990
         END IF
C                                       open TV image SC file
      CALL ZPHFIL ('SC', SCRVOL(TVFILE), SCRCNO(TVFILE), 1, PHNAME,
     *   IRET)
      CALL ZOPEN (LUN2, FIND2, SCRVOL(TVFILE), PHNAME, T, F, T, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1010) 'OPEN (R)', IRET
         GO TO 990
         END IF
      CALL ZOPEN (LUN3, FIND3, SCRVOL(TVFILE), PHNAME, T, F, T, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1010) 'OPEN (W)', IRET
         GO TO 990
         END IF
C                                       open master grid file
      CALL ZPHFIL ('MA', DISKOU, CNOOUT, 1, PHNAME, IRET)
      CALL ZOPEN (LUN1, FIND1, DISKOU, PHNAME, T, F, T, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1015) 'OPEN (W)', IRET
         GO TO 900
         END IF
      CALL ZOPEN (LUN0, FIND0, DISKOU, PHNAME, T, F, T, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1015) 'OPEN (R)', IRET
         GO TO 900
         END IF
C                                       prepare interaction
      RPOS(1) = IX
      RPOS(2) = IY
      PPOS(1) = 0.0
      PPOS(2) = 0.0
      CALL ZTIME (ITW)
C                                       instructions: Buttons
 90   IF (.NOT.DOBOX) THEN
         MSGTXT = 'Hit button A or B to mark flagged position, '
     *      // 'loop for more'
         CALL MSGWRT (1)
         MSGTXT = 'Hit button C to mark flagged position, return'
     *      // ' to menu'
      ELSE
         MSGTXT = 'Hit button A to switch between BLC and TRC'
         CALL MSGWRT (1)
         MSGTXT = 'Hit button B to mark final box, loop for more'
         CALL MSGWRT (1)
         MSGTXT = 'Hit button C to mark final box, return to menu'
         END IF
      CALL MSGWRT (1)
C                                       instructions: Button D
      MSGTXT = 'Hit button D to exit - no further flagging'
      CALL MSGWRT (1)
      NFLAGD = 0
      DOBLC = 0
C                                        read until cursor moves
 100  CALL YCURSE ('READ', F, F, RPOS, QUAD, IBUT, IRET)
      ROUTIN = 'YCURSE'
      IF (IRET.NE.0) GO TO 800
      CALL DLINTR (RPOS, IBUT, PPOS, ITW, DOIT)
      IF (.NOT.DOIT) GO TO 100
C                                       button D
         IF (IBUT.GE.8) GO TO 910
C                                       get TV and uv image pixels
         CALL YCURSE (FIXIT, F, T, RPOS, QUAD, LBUT, IRET)
         CALL IMA2MP (RPOS, CORN)
         IF (CORN(1).LT.CATBLK(IIWIN)) CORN(1) = CATBLK(IIWIN)
         IF (CORN(2).LT.CATBLK(IIWIN+1)) CORN(2) = CATBLK(IIWIN+1)
         IF (CORN(1).GT.CATBLK(IIWIN+2)) CORN(1) = CATBLK(IIWIN+2)
         IF (CORN(2).GT.CATBLK(IIWIN+3)) CORN(2) = CATBLK(IIWIN+3)
C                                       restrain DOIFS=0 to IFs
         IF (DOIFS.EQ.0) THEN
            FIX = .FALSE.
            I1 = LCIF(1) - BIF
            I1 = I1 * NCHAN - IMGWIN(1) + 5
            IF (I1.GT.CORN(1)) THEN
               FIX = .TRUE.
               CORN(1) = I1
               END IF
            I1 = LCIF(2) - BIF + 1
            I1 = I1 * NCHAN -1 - IMGWIN(1) + 5
            IF (I1.LT.CORN(1)) THEN
               FIX = .TRUE.
               CORN(1) = I1
               END IF
            IF (FIX) THEN
               CALL MP2IMA (CORN, RPOS)
               CALL YCURSE ('ONNN', F, F, RPOS, QUAD, I1, IRET)
               ROUTIN = 'YCURSE'
               IF (IRET.NE.0) GO TO 800
               END IF
            END IF
         TVX = IROUND (CORN(1))
         TVY = IROUND (CORN(2))
         CALL MP2IMA (CORN, RPOS)
C                                       Do CURVALUE anotation
         IF (DOANOT) THEN
            CALL YHOLD ('ONNN', I)
            GPH1OK = .FALSE.
            IWIN(1) = 1
            IWIN(2) = TVY
            IWIN(3) = TVX
            IWIN(4) = TVY
            CALL MINIT ('READ', LUN2, FIND2, CATBLK(KINAX),
     *         CATBLK(KINAX+1), IWIN, BUFF, JBUFSZ, 1, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1010) 'INIT (R)', IRET
               GO TO 900
               END IF
            CALL MDISK ('READ', LUN2, FIND2, BUFF, I, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1010) 'READ', IRET
               GO TO 900
               END IF
            PIXVAL = BUFF(I+TVX-1)
            ISOU = BUFF(I) + 0.01
            IF ((ISOU.LE.0) .OR. (ISOU.GT.MAXSOU)) ISOU = INSNUM
            BLANKD = PIXVAL.EQ.FBLANK
            IY = IY0
            ROUTIN = 'IMCHAR'
C                                       source name
            IF (MAXSOU.GT.0) THEN
               IF (ISOU.NE.LSOU) THEN
                  IF (ISOU.GT.0) THEN
                     CALL IMCHAR (GR1, IX0, IY, 0, 0,
     *                  SNAMES(ISOU)(:SL), SCRTCH, IRET)
                  ELSE
                     CALL IMCHAR (GR1, IX0, IY, 0, 0, BLNAME, SCRTCH,
     *                  IRET)
                     END IF
                  IF (IRET.NE.0) GO TO 800
                  END IF
               LSOU = ISOU
               IY = IY - 2*NEDGE - CSIZTV(2)
               END IF
C                                       time
            IF (TVY.NE.LTVY) THEN
               TEMP = TIMES(TVY)
               CALL TORMAT (TEMP, TFORM, STRING, NCTI)
               CALL IMCHAR (GR1, IX0, IY, 0, 0, STRING(:NCTI), SCRTCH,
     *            IRET)
               IF (IRET.NE.0) GO TO 800
               END IF
            LTVY = TVY
            IY = IY - 2*NEDGE - CSIZTV(2)
C                                       channel/IF
            IF (LTVX.NE.TVX) THEN
               IX = TVX + IMGWIN(1) - 5
               I1 = MOD (IX, NCHAN) + 1
               I2 = IX / NCHAN + BIF
               WRITE (STRING,1115) I1, I2
               CALL IMCHAR (GR1, IX0, IY, 0, 0, STRING(1:SL), SCRTCH,
     *            IRET)
               IF (IRET.NE.0) GO TO 800
               END IF
            IY = IY - 2*NEDGE - CSIZTV(2)
            LTVX = TVX
C                                       flux
            IF (BLANKD) THEN
               STRING = 'Blanked'
            ELSE IF (ABS(PIXVAL).LT.9.99) THEN
               WRITE (STRING,1127) PIXVAL
            ELSE IF (ABS(PIXVAL).LT.1000.) THEN
               WRITE (STRING,1126) PIXVAL
            ELSE
               WRITE (STRING,1125) PIXVAL
               END IF
            CALL IMCHAR (GR1, IX0, IY, 0, 0, STRING(1:8), SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 800
            CALL YHOLD ('OFFF', I)
            END IF
C                                       clear old graph 3 lines
         IF ((BRANCH.GE.3) .AND. (GR3.GT.0)) THEN
            GPH3OK = .FALSE.
            I = 2
            IF (DOBOX) I = 5
            IF ((DOBOX) .AND. (DOBLC.EQ.0)) I = 3
            CALL IMVECT ('OFFF', GR3, I, IXP, IYP, SCRTCH, IRET)
            ROUTIN = 'IMVECT'
            IF (IRET.NE.0) GO TO 800
C                                       flag a channel
            IF (BRANCH.EQ.7) THEN
               IXP(1) = IROUND (RPOS(1))
               IXP(2) = IXP(1)
               CORN(2) = LMGWIN(2)
               CALL MP2IMA (CORN, RPOS)
               IYP(1) = IROUND (RPOS(2))
               CORN(2) = LMGWIN(4)
               CALL MP2IMA (CORN, RPOS)
               IYP(2) = IROUND (RPOS(2))
               IYP(1) = MAX (IYP(1), LMGCOR(2))
               IYP(2) = MIN (IYP(2), LMGCOR(4))
C                                       flag a time
            ELSE IF (BRANCH.EQ.6) THEN
               IYP(1) = IROUND (RPOS(2))
               IYP(2) = IYP(1)
C                                       all IFs
               IF (DOIFS.EQ.1) THEN
                  TVX = LMGWIN(1)
                  CORN(1) = TVX
                  CALL MP2IMA (CORN, RPOS)
                  IXP(1) = IROUND (RPOS(1))
                  CORN(1) = LMGWIN(3)
                  CALL MP2IMA (CORN, RPOS)
                  IXP(2) = IROUND (RPOS(1))
                  IXP(1) = MAX (LMGCOR(1), IXP(1))
                  IXP(2) = MIN (LMGCOR(3), IXP(2))
C                                           some IFs ?? ok?
               ELSE IF (DOIFS.EQ.0) THEN
                  I1 = LCIF(1) - BIF
                  TVX = I1 * NCHAN - IMGWIN(1) + 5
                  CORN(1) = TVX
                  CALL MP2IMA (CORN, RPOS)
                  IXP(1) = IROUND (RPOS(1))
                  I1 = LCIF(2) - BIF + 1
                  TVX = I1 * NCHAN -1 - IMGWIN(1) + 5
                  CORN(1) = TVX
                  CALL MP2IMA (CORN, RPOS)
                  IXP(2) = IROUND (RPOS(1))
                  IXP(1) = MAX (LMGCOR(1), IXP(1))
                  IXP(2) = MIN (LMGCOR(3), IXP(2))
C                                       current IF
               ELSE
                  I1 = (TVX + IMGWIN(1) - 5)
                  I1 = I1 / NCHAN
                  TVX = I1 * NCHAN - IMGWIN(1) + 5
                  CORN(1) = TVX
                  CALL MP2IMA (CORN, RPOS)
                  IXP(1) = IROUND (RPOS(1))
                  CORN(1) = CORN(1) + NCHAN - 1
                  CALL MP2IMA (CORN, RPOS)
                  IXP(2) = IROUND (RPOS(1))
                  IXP(1) = MAX (LMGCOR(1), IXP(1))
                  IXP(2) = MIN (LMGCOR(3), IXP(2))
                  END IF
C                                       one channel, timerange
            ELSE IF (BRANCH.EQ.5) THEN
C                                       init blc
               IF (DOBLC.EQ.0) THEN
                  I = 3
                  IYP(1) = IROUND (RPOS(2))
                  IYP(2) = IYP(1)
                  IXP(2) = IROUND (RPOS(1))
                  IXP(3) = IXP(2)
                  CORN(2) = LMGWIN(4)
                  CALL MP2IMA (CORN, RPOS)
                  IYP(3) = IROUND (RPOS(2))
                  IYP(3) = MIN (IYP(3), LMGCOR(4))
                  IF (DOIFS.EQ.1) THEN
                     CORN(1) = LMGWIN(1)
                  ELSE IF (DOIFS.EQ.0) THEN
                     I1 = LCIF(1) - BIF
                     TVX = I1 * NCHAN - IMGWIN(1) + 5
                     CORN(1) = TVX
                  ELSE
                     I1 = (TVX + IMGWIN(1) - 5)
                     I1 = I1 / NCHAN
                     TVX = I1 * NCHAN - IMGWIN(1) + 5
                     CORN(1) = TVX
                     END IF
                  CALL MP2IMA (CORN, RPOS)
                  IXP(1) = IROUND (RPOS(1))
                  IXP(1) = MAX (LMGCOR(1), IXP(1))
C                                       blc
               ELSE IF (DOBLC.EQ.1) THEN
                  IYP(1) = IROUND (RPOS(2))
                  IYP(2) = IYP(1)
                  IXP(2) = IROUND (RPOS(1))
                  IXP(3) = IXP(2)
                  IF (DOIFS.EQ.-1) THEN
                     I1 = (TVX + IMGWIN(1) - 5)
                     I1 = I1 / NCHAN
                     TVX = I1 * NCHAN - IMGWIN(1) + 5
                     CORN(1) = TVX
                     CALL MP2IMA (CORN, RPOS)
                     IXP(1) = IROUND (RPOS(1))
                     IXP(1) = MAX (LMGCOR(1), IXP(1))
                     CORN(1) = CORN(1) + NCHAN - 1
                     CALL MP2IMA (CORN, RPOS)
                     IXP(4) = IROUND (RPOS(1))
                     IXP(4) = MIN (LMGCOR(3), IXP(4))
                     IXP(5) = IXP(4)
                     END IF
C                                       trc
               ELSE
                  IYP(3) = IROUND (RPOS(2))
                  IYP(4) = IYP(3)
                  IYP(5) = IYP(4)
                  IXP(2) = IROUND (RPOS(1))
                  IXP(3) = IXP(2)
                  IF (DOIFS.EQ.1) THEN
                     CORN(1) = LMGWIN(3)
                     CALL MP2IMA (CORN, RPOS)
                     IXP(4) = IROUND (RPOS(1))
                  ELSE IF (DOIFS.EQ.0) THEN
                     I1 = LCIF(2) - BIF + 1
                     TVX = I1 * NCHAN -1 - IMGWIN(1) + 5
                     CORN(1) = TVX
                     CALL MP2IMA (CORN, RPOS)
                     IXP(4) = IROUND (RPOS(1))
                  ELSE
                     I1 = (TVX + IMGWIN(1) - 5)
                     I1 = I1 / NCHAN
                     TVX = I1 * NCHAN - IMGWIN(1) + 5
                     CORN(1) = TVX
                     CALL MP2IMA (CORN, RPOS)
                     IXP(1) = IROUND (RPOS(1))
                     IXP(1) = MAX (LMGCOR(1), IXP(1))
                     CORN(1) = CORN(1) + NCHAN - 1
                     CALL MP2IMA (CORN, RPOS)
                     IXP(4) = IROUND (RPOS(1))
                     END IF
                  IXP(4) = MIN (LMGCOR(3), IXP(4))
                  IXP(5) = IXP(4)
                  END IF
C                                       start a box
            ELSE IF (DOBLC.EQ.0) THEN
               I = 3
               IYP(2) = IROUND (RPOS(2))
               IYP(3) = IYP(2)
C                                       timerange
               IF (BRANCH.EQ.4) THEN
                  IYP(1) = IYP(2)
                  IF (DOIFS.EQ.1) THEN
                     TVX = LMGWIN(1)
                     CORN(1) = TVX
                     CALL MP2IMA (CORN, RPOS)
                     IXP(1) = IROUND (RPOS(1))
                     CORN(1) = LMGWIN(3)
                     CALL MP2IMA (CORN, RPOS)
                     IXP(3) = IROUND (RPOS(1))
                  ELSE IF (DOIFS.EQ.0) THEN
                     I1 = LCIF(1) - BIF
                     TVX = I1 * NCHAN - IMGWIN(1) + 5
                     CORN(1) = TVX
                     CALL MP2IMA (CORN, RPOS)
                     IXP(1) = IROUND (RPOS(1))
                     I1 = LCIF(2) - BIF + 1
                     TVX = I1 * NCHAN -1 - IMGWIN(1) + 5
                     CORN(1) = TVX
                     CALL MP2IMA (CORN, RPOS)
                     IXP(3) = IROUND (RPOS(1))
                  ELSE
                     I1 = (TVX + IMGWIN(1) - 5)
                     I1 = I1 / NCHAN
                     TVX = I1 * NCHAN - IMGWIN(1) + 5
                     CORN(1) = TVX
                     CALL MP2IMA (CORN, RPOS)
                     IXP(1) = IROUND (RPOS(1))
                     CORN(1) = CORN(1) + NCHAN - 1
                     CALL MP2IMA (CORN, RPOS)
                     IXP(3) = IROUND (RPOS(1))
                     END IF
                  IXP(1) = MAX (LMGCOR(1), IXP(1))
                  IXP(3) = MIN (LMGCOR(3), IXP(3))
               ELSE
                  IXP(1) = IROUND (RPOS(1))
                  CORN(1) = LMGWIN(3)
                  IF (DOIFS.EQ.0) CORN(1) = LCIF(2)*NCHAN - IMGWIN(1)+5
                  CORN(2) = LMGWIN(4)
                  CALL MP2IMA (CORN, RPOS)
                  IYP(1) = IROUND (RPOS(2))
                  IXP(3) = IROUND (RPOS(1))
                  IYP(1) = MIN (IYP(1), LMGCOR(4))
                  IXP(3) = MIN (IXP(3), LMGCOR(3))
                  END IF
               IXP(2) = IXP(1)
C                                       redo blc
            ELSE IF (DOBLC.EQ.1) THEN
               IF (BRANCH.EQ.4) THEN
                  IF (DOIFS.LT.0) THEN
                     I1 = (TVX + IMGWIN(1) - 5)
                     I1 = I1 / NCHAN
                     TVX = I1 * NCHAN - IMGWIN(1) + 5
                     CORN(1) = TVX
                     CALL MP2IMA (CORN, RPOS)
                     IXP(1) = IROUND (RPOS(1))
                     CORN(1) = CORN(1) + NCHAN - 1
                     CALL MP2IMA (CORN, RPOS)
                     IXP(3) = IROUND (RPOS(1))
                     IXP(1) = MAX (LMGCOR(1), IXP(1))
                     IXP(3) = MIN (LMGCOR(3), IXP(3))
                     IXP(4) = IXP(3)
                     END IF
               ELSE
                  IXP(1) = IROUND (RPOS(1))
                  END IF
               IXP(2) = IXP(1)
               IXP(5) = IXP(1)
               IYP(2) = IROUND (RPOS(2))
               IYP(3) = IYP(2)
C                                       trc
            ELSE
               IF (BRANCH.EQ.4) THEN
                  IF (DOIFS.LT.0) THEN
                     I1 = (TVX + IMGWIN(1) - 5)
                     I1 = I1 / NCHAN
                     TVX = I1 * NCHAN - IMGWIN(1) + 5
                     CORN(1) = TVX
                     CALL MP2IMA (CORN, RPOS)
                     IXP(1) = IROUND (RPOS(1))
                     CORN(1) = CORN(1) + NCHAN - 1
                     CALL MP2IMA (CORN, RPOS)
                     IXP(3) = IROUND (RPOS(1))
                     IXP(1) = MAX (LMGCOR(1), IXP(1))
                     IXP(3) = MIN (LMGCOR(3), IXP(3))
                     IXP(2) = IXP(1)
                     IXP(5) = IXP(1)
                     END IF
               ELSE
                  IXP(3) = IROUND (RPOS(1))
                  END IF
               IXP(4) = IXP(3)
               IYP(4) = IROUND (RPOS(2))
               IYP(5) = IYP(4)
               IYP(1) = IYP(4)
               END IF
            CALL IMVECT ('ONNN', GR3, I, IXP, IYP, SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 800
            END IF
C                                       check buttons
         IF (IBUT.EQ.0) GO TO 100
C                                       button B, C = A w/o a TRC
         IF ((DOBOX) .AND. (DOBLC.LE.0)) IBUT = 1
C                                       switch BLC/TRC in box mode
         IF ((IBUT.EQ.1) .AND. (DOBOX)) THEN
            IF (DOBLC.LE.0) THEN
               DOBLC = 1
               I = 3
               CALL IMVECT ('OFFF', GR3, I, IXP, IYP, SCRTCH, IRET)
               IF (IRET.NE.0) GO TO 800
C                                       area
               IF (BRANCH.EQ.3) THEN
                  IYP(1) = IYP(2) + 10
                  IYP(4) = IYP(1)
                  IYP(5) = IYP(1)
                  IXP(3) = IXP(1) + 10
                  IXP(4) = IXP(3)
                  IXP(5) = IXP(1)
C                                       timerange
               ELSE IF (BRANCH.EQ.4) THEN
                  IYP(1) = IYP(2) + 10
                  IYP(4) = IYP(1)
                  IYP(5) = IYP(1)
                  IXP(4) = IXP(3)
                  IXP(5) = IXP(1)
C                                       channel-dt
               ELSE
                  IYP(3) = IYP(2) + 10
                  IYP(4) = IYP(3)
                  IYP(5) = IYP(4)
                  IF (DOIFS.EQ.-1) THEN
                     IXP(4) = IXP(1) + NCHAN - 1
                  ELSE IF (DOIFS.EQ.0) THEN
                     CORN(1) = LCIF(2)*NCHAN - IMGWIN(1)+5
                     CALL MP2IMA (CORN, RPOS)
                     IXP(4) = IROUND (RPOS(1))
                  ELSE
                     CORN(1) = LMGWIN(3)
                     CALL MP2IMA (CORN, RPOS)
                     IXP(4) = IROUND (RPOS(1))
                     END IF
                  IXP(4) = MIN (IXP(4), LMGCOR(3))
                  IXP(5) = IXP(4)
                  END IF
               I = 5
               CALL IMVECT ('ONNN', GR3, I, IXP, IYP, SCRTCH, IRET)
               IF (IRET.NE.0) GO TO 800
               END IF
            DOBLC = 3 - DOBLC
            I = 2*DOBLC
            RPOS(1) = IXP(I)
            IF (BRANCH.EQ.5) RPOS(1) = IXP(2)
            RPOS(2) = IYP(I)
            CALL YCURSE ('ONNN', F, T, RPOS, QUAD, LBUT, IRET)
            IF (IRET.NE.0) THEN
               ROUTIN = 'YCURSE'
               IF (IRET.NE.2) GO TO 800
               CALL YCURSE ('ONNN', F, F, RPOS, QUAD, LBUT, IRET)
               IF (IRET.NE.0) GO TO 800
               END IF
            GO TO 100
            END IF
C                                       confirm the pixel
         IF (BRANCH.EQ.2) THEN
            IF (.NOT.DOANOT) THEN
               TEMP = (TIMES(TVY) + TIMES(TVY+1)) / 2.0
               CALL TORMAT (TEMP, TFORM, STRING, NCTI)
               IX = TVX + 1 + IMGWIN(1) - 5
               END IF
            WRITE (MSGBUF,1200) IX, STRING(:NCTI)
 101        CALL INQSTR (TTY, MSGBUF, 4, CHTEMP, IRET)
            IF (IRET.EQ.10) THEN
               MSGTXT = 'STRING TOO LONG, TRY AGAIN'
               CALL MSGWRT (7)
               GO TO 101
               END IF
            IF (IRET.NE.0) GO TO 850
            CALL CHLTOU (4, CHTEMP)
            IF (CHTEMP(1:1).NE.'Y') THEN
               IF (IBUT.GE.4) GO TO 910
               GO TO 100
               END IF
            END IF
C                                       erase graphics first
         I = 2
         IF (DOBOX) I = 5
         IF ((BRANCH.GT.2) .AND. (GR3.GT.0)) THEN
            CALL IMVECT ('OFFF', GR3, I, IXP, IYP, SCRTCH, IRET)
            ROUTIN = 'IMVECT'
            IF (IRET.NE.0) GO TO 800
            END IF
C                                       clear data from TV
         LDOIFS = DOIFS
         IF (EIF.LE.BIF) LDOIFS = -1
         IF (BRANCH.EQ.7) THEN
            IXP(4) = IXP(2)
            IYP(4) = IYP(2)
            IYP(2) = IYP(1)
         ELSE IF (BRANCH.EQ.6) THEN
            IXP(4) = IXP(2)
            IXP(2) = IXP(1)
            IYP(4) = IYP(2)
         ELSE IF (BRANCH.EQ.5) THEN
            IXP(4) = IXP(2)
            IYP(4) = IYP(3)
         ELSE IF (BRANCH.LT.3) THEN
            IXP(2) = IROUND (RPOS(1))
            IXP(4) = IXP(2)
            IYP(2) = IROUND (RPOS(2))
            IYP(4) = IYP(2)
            END IF
         IF (IXP(2).GT.IXP(4)) THEN
            I = IXP(2)
            IXP(2) = IXP(4)
            IXP(4) = I
            END IF
         IF (IYP(2).GT.IYP(4)) THEN
            I = IYP(2)
            IYP(2) = IYP(4)
            IYP(4) = I
            END IF
C                                       test for excess area
         IF ((LDOIFS.GE.0) .AND. (BRANCH.EQ.3)) THEN
               RPOS(1) = IXP(2)
               RPOS(2) = IYP(2)
               CALL IMA2MP (RPOS, CORN)
               TVX = IROUND (CORN(1))
               I1 = TVX + IMGWIN(1) - 5
               I1 = I1 / NCHAN
               RPOS(1) = IXP(4)
               RPOS(2) = IYP(4)
               CALL IMA2MP (RPOS, CORN)
               TVX = IROUND (CORN(1))
               I2 = TVX + IMGWIN(1) - 5
               I2 = I2 / NCHAN
               IF (I2.NE.I1) THEN
                  IF (LDOIFS.EQ.1) THEN
                     MSGTXT = 'AREA crosses IF boundary, ignoring' //
     *                  ' ALL-IF'
                  ELSE
                     MSGTXT = 'AREA crosses IF boundary, ignoring' //
     *                  ' multiple IFs'
                     END IF
                  CALL MSGWRT (6)
                  LDOIFS = -1
                  END IF
               END IF
C                                       black out flagged data
         IF (DOTV) THEN
            CALL YHOLD ('ONNN', I)
            IF (LDOIFS.GE.0) THEN
               RPOS(1) = IXP(2)
               RPOS(2) = IYP(2)
               CALL IMA2MP (RPOS, CORN)
               TVX = IROUND (CORN(1))
               I1 = TVX + IMGWIN(1) - 5
               I1 = I1 / NCHAN
               IXP(2) = IXP(2) - I1 * LCHAN
               I2 = IXP(2)
               IF ((BRANCH.EQ.4) .OR. (BRANCH.EQ.6)) THEN
                  IXP(4) = IXP(2) + LCHAN - 1
               ELSE
                  RPOS(1) = IXP(4)
                  RPOS(2) = IYP(4)
                  CALL IMA2MP (RPOS, CORN)
                  TVX = IROUND (CORN(1))
                  I1 = TVX + IMGWIN(1) - 5
                  I1 = I1 / NCHAN
                  IXP(4) = IXP(4) - I1 * LCHAN
                  END IF
               I4 = IXP(4)
               DO 260 LIF = BIF,EIF
                  IF ((LDOIFS.EQ.1) .OR. ((LDOIFS.EQ.0) .AND.
     *               (LIF.GE.LCIF(1)) .AND. (LIF.LE.LCIF(2)))) THEN
                     IF ((IXP(4).GE.1) .AND. (IXP(2).LE.MAXXTV(1))) THEN
                        IXP(3) = MAX (1, IXP(2))
                        IXP(5) = MIN (MAXXTV(1), IXP(4))
                        CALL YFILL (1, IXP(3), IYP(2), IXP(5), IYP(4),
     *                     0, SCRTCH, IRET)
                        IF (IRET.NE.0) GO TO 265
                        END IF
                     END IF
                  IXP(2) = IXP(2) + LCHAN
                  IXP(4) = IXP(4) + LCHAN
 260              CONTINUE
               IXP(2) = I2
               IXP(4) = I4
            ELSE
               CALL YFILL (1, IXP(2), IYP(2), IXP(4), IYP(4), 0, SCRTCH,
     *            IRET)
               END IF
 265        CALL YHOLD ('OFFF', I)
            ROUTIN = 'YFILL'
            IF (IRET.NE.0) GO TO 800
            END IF
         DOBLC = 0
         RPOS(1) = PPOS(1)
         RPOS(2) = PPOS(2)
         ROUTIN = 'YCURSE'
         CALL YCURSE ('OFFF', F, F, RPOS, QUAD, LBUT, IRET)
         IF (IRET.NE.0) GO TO 800
C                                       set corners
         RPOS(1) = IXP(2)
         RPOS(2) = IYP(2)
         CALL IMA2MP (RPOS, CORN)
         IXL = IROUND (CORN(1))
         IXL = IXL - 3
         IF (LDOIFS.GE.0) THEN
            IXL = IXL + (EIF+1) * NCHAN
            IXL = MOD (IXL-1, NCHAN) + 1
            END IF
         IF (IXL.LT.1) IXL = 1
         RPOS(1) = IXP(4)
         CALL IMA2MP (RPOS, CORN)
         IXH = IROUND (CORN(1))
         IF (IXH.GT.CATBLK(KINAX)) IXH = CATBLK(KINAX)
         IXH = IXH - 3
         IF (LDOIFS.GE.0) THEN
            IF ((BRANCH.EQ.4) .OR. (BRANCH.EQ.6)) THEN
               IXH = IXL + NCHAN - 1
            ELSE
               IXH = IXH + (EIF+1) * NCHAN
               IXH = MOD (IXH-1, NCHAN) + 1
               END IF
            END IF
C                                       clear data from TV file
         NRPL = NBPS / (NB * CATBLK(KINAX))
         IF (NRPL.LT.1) NRPL = 1
         IWIN(1) = 1
         IWIN(3) = CATBLK(KINAX)
         IXH = IXH - IXL + 1
         IXL = IXL - 1
         IF (LDOIFS.GE.0) IXL = MOD (IXL, NCHAN)
         RPOS(1) = IXP(2)
         RPOS(2) = IYP(2)
         CALL IMA2MP (RPOS, CORN)
         IYL = CORN(2) + 0.01
         IF (IYL.LT.1) IYL = 1
         RPOS(2) = IYP(4)
         CALL IMA2MP (RPOS, CORN)
         IYH = IROUND (CORN(2))
         IF (IYH.GT.CATBLK(KINAX+1)) IYH = CATBLK(KINAX+1)
         IWIN(2) = ((IYL - 1) / NRPL) * NRPL + 1
         IWIN(4) = ((IYH - 1 + NRPL) / NRPL) * NRPL
         IF (IWIN(2).LT.1) IWIN(2) = 1
         IF (IWIN(2).GT.CATBLK(KINAX+1)) IWIN(2) = CATBLK(KINAX+1)
         IF (IWIN(4).LT.1) IWIN(4) = 1
         IF (IWIN(4).GT.CATBLK(KINAX+1)) IWIN(4) = CATBLK(KINAX+1)
         IF (DOTV) THEN
            CALL MINIT ('READ', LUN2, FIND2, CATBLK(KINAX),
     *         CATBLK(KINAX+1), IWIN, BUFF, JBUFSZ, 1, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1010) 'INIT (R)', IRET
               GO TO 900
               END IF
            CALL MINIT ('WRIT', LUN3, FIND3, CATBLK(KINAX),
     *         CATBLK(KINAX+1), IWIN, BUFF2, JBUFSZ, 1, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1010) 'INIT (W)', IRET
               GO TO 900
               END IF
            I1 = IWIN(2)
            I2 = IWIN(4)
            DO 280 IY = I1,I2
               CALL MDISK ('READ', LUN2, FIND2, BUFF, IB1, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1010) 'READ', IRET
                  GO TO 900
                  END IF
               CALL MDISK ('WRIT', LUN3, FIND3, BUFF2, IB2, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1010) 'WRIT', IRET
                  GO TO 900
                  END IF
               CALL RCOPY (CATBLK(KINAX), BUFF(IB1), BUFF2(IB2))
               IF ((IY.GE.IYL) .AND. (IY.LE.IYH)) THEN
                  IB2 = IB2 + 3
                  IF (LDOIFS.EQ.-1) THEN
                     CALL RFILL (IXH, FBLANK, BUFF2(IB2+IXL))
C                                       ?? okay?
                  ELSE
                     DO 275 LIF = BIF,EIF
                        IF ((LDOIFS.EQ.1) .OR. ((LDOIFS.EQ.0) .AND.
     *                     (LIF.GE.LCIF(1)) .AND. (LIF.LE.LCIF(2))))
     *                     CALL RFILL (IXH, FBLANK, BUFF2(IB2+IXL))
                        IB2 = IB2 + NCHAN
 275                    CONTINUE
                     END IF
                  END IF
 280           CONTINUE
            CALL MDISK ('FINI', LUN3, FIND3, BUFF2, IB2, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1010) 'FINI', IRET
               GO TO 900
               END IF
            END IF
C                                       clear the uv file
         NRPL = NBPS / (NB * CATIMG(KINAX))
         IF (NRPL.LT.1) NRPL = 1
C                                       open FC table
         CALL PCFCOP (FCLUN, DISKOU, CNOOUT, FCVERS, CATIMG, FCNUMB,
     *      NNFLAG, FCBUF, IRET)
         FCNUMB = FCNUMB + 1
         IF (IRET.NE.0) GO TO 999
         NSNUMS = 0
         SNUMS(1) = 0
         IWIN(1) = 1
         IWIN(3) = CATIMG(KINAX)
         IF (((BRANCH.EQ.4) .OR. (BRANCH.EQ.6)) .AND. (LDOIFS.EQ.1))
     *      THEN
            IXL = 0
            IXH = (CATIMG(KINAX) - 3) / NUMVAL
         ELSE
            IXL = IXL + IMGWIN(1) - 1
            IF (LDOIFS.GE.0) IXL = MOD (IXL-1, NCHAN) + 1
            IXL = IXL * NUMVAL
            END IF
         IYL0 = IYL
         IYH0 = IYH
         IF (BRANCH.EQ.7) THEN
            IYL = 1
            IYH = CATIMG(KINAX+1)
         ELSE
            TIM1 = TIMES(IYL0) - MINTS(IYL0)/2.0
            TIM2 = TIMES(IYH0) + MINTS(IYH0) / 2.0
            CALL GETIME (TIM1, TIM2, IYL, IYH, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1280) TIM1, TIM2, IYL, IYH
               CALL MSGWRT (8)
               GO TO 325
               END IF
            END IF
         IWIN(2) = ((IYL - 1) / NRPL) * NRPL + 1
         IWIN(4) = ((IYH - 1 + NRPL) / NRPL) * NRPL
         IF (IWIN(2).LT.1) IWIN(2) = 1
         IF (IWIN(2).GT.CATIMG(KINAX+1)) IWIN(2) = CATIMG(KINAX+1)
         IF (IWIN(4).LT.1) IWIN(4) = 1
         IF (IWIN(4).GT.CATIMG(KINAX+1)) IWIN(4) = CATIMG(KINAX+1)
         IF (DOANT.EQ.0) THEN
            KBBASL = 1
            KEBASL = CATIMG(KINAX+3)
         ELSE
            KBBASL = PLANT
            KEBASL = PLANT
            END IF
         DO 321 KBASL = KBBASL,KEBASL
            IF (DOANT.GT.0) THEN
               KST = PLANT
               IF (KST.NE.KBASL) GO TO 321
               END IF
         DO 320 KST = 1,4
            IF (.NOT.DOSTOK (ILSTOK, STKFLG, KST)) GO TO 320
            IDEPTH(1) = KST
            IDEPTH(2) = KBASL
            IDEPTH(3) = 1
            IDEPTH(4) = 1
            IDEPTH(5) = 1
            CALL COMOFF (CATIMG(KIDIM), CATIMG(KINAX), IDEPTH, IBLKOF,
     *         IRET)
            IBLKOF = IBLKOF + 1
            CALL MINIT ('READ', LUN0, FIND0, CATIMG(KINAX),
     *         CATIMG(KINAX+1), IWIN, BUFF, JBUFSZ, IBLKOF, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1015) 'INIT (R)', IRET
               GO TO 900
               END IF
            CALL MINIT ('WRIT', LUN1, FIND1, CATIMG(KINAX),
     *         CATIMG(KINAX+1), IWIN, BUFF2, JBUFSZ, IBLKOF, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1015) 'INIT (W)', IRET
               GO TO 900
               END IF
            I1 = IWIN(2)
            I2 = IWIN(4)
            DO 315 IY = I1,I2
               CALL MDISK ('READ', LUN0, FIND0, BUFF, IB1, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1015) 'READ', IRET
                  GO TO 900
                  END IF
               CALL MDISK ('WRIT', LUN1, FIND1, BUFF2, IB2, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1015) 'WRITE', IRET
                  GO TO 900
                  END IF
               CALL RCOPY (CATIMG(KINAX), BUFF(IB1), BUFF2(IB2))
               IF ((IY.GE.IYL) .AND. (IY.LE.IYH)) THEN
                  IF (DOSOUR) THEN
                     ISNUM = BUFF2(IB2) + 0.01
                     IF (ISNUM.LE.0) ISNUM = INSNUM
                     IF (ISNUM.GT.0) THEN
                        IF (NSNUMS.GT.0) THEN
                           DO 290 IX = 1,NSNUMS
                              IF (ISNUM.EQ.SNUMS(IX)) GO TO 295
 290                          CONTINUE
                           END IF
                        NSNUMS = NSNUMS + 1
                        SNUMS(NSNUMS) = ISNUM
                        END IF
                     END IF
 295              J = IB2 + IXL + 3
                  IF (LDOIFS.GE.0) THEN
                     DO 299 IX = 1,IXH
                        I4 = J
                        DO 298 LIF = BIF,EIF
                           IF ((LDOIFS.EQ.1) .OR. ((LDOIFS.EQ.0) .AND.
     *                        (LIF.GE.LCIF(1)) .AND. (LIF.LE.LCIF(2))))
     *                        THEN
                              IF (BUFF2(I4).EQ.0.0) THEN
                                 NFLAGD = NFLAGD + 1
                                 BUFF2(I4) = FCNUMB
                                 END IF
                              END IF
                           I4 = I4 + NUMVAL*NCHAN
 298                       CONTINUE
                        J = J + 3
 299                    CONTINUE
                  ELSE
                     DO 300 IX = 1,IXH
                        IF (BUFF2(J).EQ.0.0) THEN
                           NFLAGD = NFLAGD + 1
                           BUFF2(J) = FCNUMB
                           END IF
                        J = J + NUMVAL
 300                    CONTINUE
                     END IF
                  END IF
 315           CONTINUE
            CALL MDISK ('FINI', LUN1, FIND1, BUFF2, IB2, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1015) 'FINI', IRET
               GO TO 900
               END IF
 320        CONTINUE
 321        CONTINUE
C                                       record the flag(s)
 325     NSNUMS = MAX (1, NSNUMS)
         IF (NFLAGD.GT.0) THEN
            IF ((BRANCH.EQ.4) .OR. (BRANCH.EQ.6)) THEN
               FCCHAN(1) = 0
               FCCHAN(2) = 0
               IX = IXL / NUMVAL
               I1 = IX / NCHAN + BIF
               I2 = I1
            ELSE IF ((BRANCH.EQ.5) .OR. (BRANCH.EQ.7)) THEN
               IX = IXL / NUMVAL
               I1 = IX / NCHAN + BIF
               I2 = I1
               FCCHAN(1) = MOD (IX, NCHAN) + 1
               FCCHAN(2) = FCCHAN(1)
            ELSE
               IX = IXL / NUMVAL
               I1 = IX / NCHAN + BIF
               FCCHAN(1) = MOD (IX, NCHAN) + 1
               IX = IX + IXH - 1
               I2 = IX / NCHAN + BIF
               MCHAN = MOD (IX, NCHAN) + 1
               IF (I2.EQ.I1) THEN
                  FCCHAN(2) = MCHAN
               ELSE
                  FCCHAN(2) = CHNMAX
                  END IF
               END IF
            IF (BRANCH.EQ.7) THEN
               FCTIME(1) = START
               FCTIME(2) = STOP
            ELSE
               FCTIME(1) = TIM1
               FCTIME(2) = TIM2
               END IF
            FCIF(1) = LCIF(1)
            FCIF(2) = LCIF(2)
            DO 335 I = I1,I2
               IF ((DOIFS.EQ.-1) .OR. (I2.GT.I1)) THEN
                  FCIF(1) = I
                  FCIF(2) = I
                  END IF
               IF (I.GT.I1) FCCHAN(1) = 1
               IF ((I.EQ.I2) .AND. (I2.GT.I1)) FCCHAN(2) = MCHAN
               DO 330 IX = 1,NSNUMS
                  NNFLAG = NNFLAG + 1
                  FCSOUR = MAX (0, SNUMS(IX))
                  CALL TABIO ('WRIT', 0, NNFLAG, FCTIME, FCBUF, IRET)
                  IF (IRET.NE.0) GO TO 999
 330              CONTINUE
 335           CONTINUE
C                                       success message
            WRITE (MSGTXT,1330) NFLAGD
            CALL MSGWRT (3)
C                                       failed message
         ELSE
            MSGTXT = 'WARNING: No previously unflagged samples were ' //
     *         'flagged ********'
            CALL MSGWRT (6)
            MSGTXT = 'So no entry was made in the Flag Command table'
            CALL MSGWRT (6)
            END IF
C                                       close FC file
         CALL TABIO ('CLOS', 0, NNFLAG, FCTIME, FCBUF, IRET)
         IF (IRET.NE.0) GO TO 999
C                                       reinit the TV
         CALL FILL (5, 1, IXP)
         CALL FILL (5, 1, IYP)
         RPOS(1) = PPOS(1)
         RPOS(2) = PPOS(2)
         PPOS(1) = 0.
         PPOS(2) = 0.
         CALL YCURSE ('ONNN', F, F, RPOS, QUAD, LBUT, IRET)
         ROUTIN = 'YCURSE'
         IF (IRET.NE.0) GO TO 800
         IF (IBUT.GE.4) GO TO 910
         GO TO 90
C                                       TV error
 800  WRITE (MSGTXT,1800) IRET, ROUTIN
      GO TO 900
C                                       TTY error
 850  IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1850) IRET
      ELSE IF (IRET.LT.0) THEN
         MSGTXT = 'Return to menu, non-numeric input'
         IRET = 0
         END IF
C                                       Error message first
 900  CALL MSGWRT (8)
C                                       off cursor
 910  CALL YCURSE ('OFFF', F, F, RPOS, QUAD, LBUT, JERR)
      IF (FIND0.GT.0) CALL ZCLOSE (LUN0, FIND0, JERR)
      IF (FIND1.GT.0) CALL ZCLOSE (LUN1, FIND1, JERR)
      IF (FIND2.GT.0) CALL ZCLOSE (LUN2, FIND2, JERR)
      IF (FIND3.GT.0) CALL ZCLOSE (LUN3, FIND3, JERR)
C                                       erase graphics first
      CALL YHOLD ('ONNN', I)
      I = 2
      IF (DOBOX) I = 5
      IF ((BRANCH.GT.2) .AND. (GR3.GT.0)) THEN
         CALL IMVECT ('OFFF', GR3, I, IXP, IYP, SCRTCH, JERR)
         IF (JERR.EQ.0) GPH3OK = .TRUE.
         END IF
      IY = IY0
      NROW = 3
      IF (MAXSOU.GT.0) NROW = 4
      JERR = 0
      DO 915 I = 1,NROW
         IF (JERR.EQ.0) CALL IMCHAR (GR1, IX0, IY, 0, 0, BLNAME, SCRTCH,
     *      JERR)
         IY = IY - 2*NEDGE - CSIZTV(2)
 915     CONTINUE
      IF (JERR.EQ.0) GPH1OK = .TRUE.
      CALL YHOLD ('OFFF', I)
      GO TO 999
C                                       error message
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1005 FORMAT ('PCFLAG: UNABLE TO READ IMAGE HEADER, ERROR',I5)
 1010 FORMAT ('PCFLAG: UNABLE TO ',A,' TV SCRATCH FILE, ERROR',I5)
 1015 FORMAT ('PCFLAG: UNABLE TO ',A,' MAIN GRID FILE, ERROR',I5)
 1115 FORMAT ('Ch',I5,'/',I2)
 1125 FORMAT (F8.1)
 1126 FORMAT (F8.3)
 1127 FORMAT (F8.5)
 1200 FORMAT ('Flag Channel=',I5,'  Time=',A,3X,'Y or N ?')
 1280 FORMAT ('PCFLAG: GETIME ERROR T1,T2,IYL,IYH=',2(1PE12.4),2I6)
 1330 FORMAT ('Flagged',I11,' more samples in the master grid file')
 1800 FORMAT ('TV ERROR ',I6,' IN ',A)
 1850 FORMAT ('TERMINAL ERROR',I5)
      END
      SUBROUTINE PCFCLP (BRANCH, IMGWIN, TTY, SCRTCH, BIGBOY, KIGBOY,
     *   IRET)
C-----------------------------------------------------------------------
C   does flagging of all pixels in the TV image outside a user-set range
C   of intensities.  That range is set in PCFCLP.
C   Inputs:
C      BRANCH   I      1 => clip levels entered on terminal
C                      2 => clip levels entered interactively
C                      3 => clip range of channels/IFs based on the
C                           clip parms of previous clip.
C      IMGWIN   I(4)   currently loaded image window
C   Output:
C      SCRTCH   I(*)   TV scratch buffer
C      BIGBOY   R(*)   Large IO buffers
C      IRET     I      error code
C-----------------------------------------------------------------------
      INTEGER   BRANCH, IMGWIN(4), TTY(2), KIGBOY(*), SCRTCH(*), IRET
      REAL      BIGBOY(*)
C
      INCLUDE 'INCS:PTVC.INC'
      CHARACTER ROUTIN*6, MSGBUF*72, STRING*12, DSTKFG*4, OP*8,
     *   TTKFLG*4, STKFS(4)*4, CHST(13)*2
      HOLLERITH CATH(256), HDUM(4)
      INTEGER   GR1, NPIX, NROW, NEDGE, MAG, IX0, IY0, IX, IY, I, QUAD,
     *   IBUT, ITW(3), J, JERR, I1, I2, ICL, ALUT(TVMLUT,3),
     *   LLUT(TVMLUT), CLSUBS, LBUT, NOFF, DLTYPE, DLSTOK, DLSMOO,
     *   DLANT, DWIND(4), PNFLAG, IFL, FFL, PFCNUM, KBBASL, KEBASL,
     *   TLBL, TLST, ITEMP(2), DLSCAN, ZAND, MASK, IPL, IDUM(4)
      LOGICAL   DOIT, F, T, DONMSG, TDOBL, TDOIF, DOSTOK
      REAL      CATR(256), RPOS(2), PPOS(2), RMIN, RMAX, TVMIN, TVMAX,
     *   CLMIN, CLMAX, CLIMIT(2)
      DOUBLE PRECISION CATD(128), DCLIM(2)
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'PCFLG.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DTVC.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'PCFLG.BUF'
      EQUIVALENCE (CATBLK, CATR, CATD, CATH), (IDUM, HDUM)
      EQUIVALENCE (CLIMIT(1), CLMIN),    (CLIMIT(2), CLMAX)
      DATA T, F /.TRUE.,.FALSE./
      DATA CHST /'HV','VH','HH','VV', 'LR','RL','LL','RR', '??',
     *   'I','Q','U ','V '/
C-----------------------------------------------------------------------
      CALL YWINDO ('READ', WINDTV, IRET)
      IF (IRET.NE.0) THEN
         WINDTV(1) = 1
         WINDTV(2) = 1
         WINDTV(3) = MAXXTV(1)
         WINDTV(4) = MAXXTV(2)
         IRET = 0
         END IF
      NOFF = MAX (WINDTV(3)-WINDTV(1), WINDTV(4)-WINDTV(2))
      NOFF = 0.015 * NOFF + 0.5
      NOFF = MAX (2, NOFF)
      DONMSG = .FALSE.
      GR1 = 1 + NGRAY
C                                       get image header
      IX = (WINDTV(1) + WINDTV(3)) / 2
      IY = (WINDTV(2) + WINDTV(4)) / 2
      IF (XYCENT(1).GT.0) IX = XYCENT(1)
      IF (XYCENT(2).GT.0) IY = XYCENT(2)
      CALL YCREAD (1, IX, IY, CATBLK, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET
         GO TO 990
         END IF
C                                       get the clip levels
      RMIN = PIXRNG(1,5)
      RMAX = PIXRNG(2,5)
      TVMIN = CATR(IRRAN)
      TVMAX = CATR(IRRAN+1)
C                                       ask user min and max
      IF (BRANCH.EQ.1) THEN
         IF ((PLTYPE.LT.3) .OR. (PLTYPE.GT.6)) THEN
            WRITE (MSGBUF,1010) RMIN, RMAX
            CALL INQFLT (TTY, MSGBUF, 2, DCLIM, IRET)
C                                       ask user only max on rms's
         ELSE
            DCLIM(1) = -1.0E-3
            WRITE (MSGBUF,1015) RMAX
            CALL INQFLT (TTY, MSGBUF, 1, DCLIM(2), IRET)
            END IF
         IF (IRET.NE.0) GO TO 850
         CLIMIT(1) = DCLIM(1)
         CLIMIT(2) = DCLIM(2)
C                                       TV interaction
      ELSE IF (BRANCH.EQ.2) THEN
         CLMIN = -1.0E-3
         IF ((PLTYPE.LT.3) .OR. (PLTYPE.GT.6)) CLMIN = RMIN -
     *      0.01 * (RMAX - RMIN)
         CLMAX = RMAX + 0.01 * (RMAX - RMIN)
C                                       clear and select graphics
         IF (NGRAPH.LE.1) MENUOK = .FALSE.
         IF (.NOT.GPH1OK) THEN
            ROUTIN = 'YZERO'
            CALL YZERO (GR1, IRET)
            IF (IRET.NE.0) GO TO 800
            END IF
         MASK = 2 ** (GR1 - 1)
         MASK = ZAND (MASK, TVLIMG(1))
         IF (MASK.EQ.0) THEN
            ROUTIN = 'YSLECT'
            CALL YSLECT ('ONNN', GR1, 0, SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 800
            END IF
C                                       CURVAL display location
         NPIX = 11 * CSIZTV(1)
         NEDGE = (2 * MAXXTV(1)) / 512
         IF (NEDGE.LT.2) NEDGE = 2
         NROW = 2 * (2*NEDGE + CSIZTV(2))
         MAG = 1 + TVZOOM(1)
         IF (MXZOOM.GT.0) MAG = 2 ** TVZOOM(1)
         IX0 = WINDTV(1) - (MAG-1)/2
         IY0 = WINDTV(4) - MAG*NROW + 1 - (MAG-1)/2
         IF (MAG.GT.1) IY0 = IY0 + MAG
         IX0 = (IX0 - TVZOOM(2))/MAG + TVZOOM(2)
         IY0 = (IY0 - TVZOOM(3))/MAG + TVZOOM(3)
         IX0 = MAX (1, IX0)
         IY0 = MAX (1, IY0)
         IF (IX0+NPIX-1.GT.MAXXTV(1)) IX0 = MAXXTV(1) - NPIX + 1
         IF (IY0+NROW-1.GT.MAXXTV(2)) IY0 = MAXXTV(2) - NROW + 1
C                                       set to top row of text
         IX0 = IX0 + NEDGE
         IY0 = IY0 + 3*NEDGE + CSIZTV(2)
C                                       get current LUTs
         ROUTIN = 'YLUT'
         CALL YLUT ('READ', 1, 1, F, ALUT(1,1), IRET)
         IF (IRET.NE.0) GO TO 800
         CALL YLUT ('READ', 1, 2, F, ALUT(1,2), IRET)
         IF (IRET.NE.0) GO TO 800
         CALL YLUT ('READ', 1, 4, F, ALUT(1,3), IRET)
         IF (IRET.NE.0) GO TO 800
C                                       cursor on
         QUAD = -1
         CLSUBS = 2
         RPOS(1) = NOFF + WINDTV(1) + (WINDTV(3) - WINDTV(1)- 2.*NOFF) *
     *      (CLIMIT(CLSUBS) - RMIN) / (RMAX - RMIN)
         RPOS(2) = (WINDTV(2) + WINDTV(4)) / 2
         IF (RPOS(1).LT.WINDTV(1)) RPOS(1) = MAX (WINDTV(1), 2)
         IF (RPOS(1).GT.WINDTV(3)) RPOS(1) = WINDTV(3)
         CALL YCURSE ('ONNN', F, F, RPOS, QUAD, IBUT, IRET)
         ROUTIN = 'YCURSE'
         IF (IRET.NE.0) GO TO 800
         PPOS(1) = 0.0
         PPOS(2) = 0.0
         CALL ZTIME (ITW)
         IF ((PLTYPE.LT.3) .OR. (PLTYPE.GT.6)) THEN
            MSGTXT = 'Hit button A or B to switch between upper and'
     *         // ' lower clip limits'
            CALL MSGWRT (1)
            END IF
         MSGTXT = 'Hit button C to do the clipping, then go to the menu'
         CALL MSGWRT (1)
         MSGTXT = 'Hit button D to return to the menu without clipping'
         CALL MSGWRT (1)
C                                        read until cursor moves
 30      CALL YCURSE ('READ', F, F, RPOS, QUAD, IBUT, IRET)
            ROUTIN = 'YCURSE'
            IF (IRET.NE.0) GO TO 800
            CALL DLINTR (RPOS, IBUT, PPOS, ITW, DOIT)
            IF (.NOT.DOIT) GO TO 30
C                                       button D - exit now
C                                       button C do flag now
            IF (IBUT.GE.4) GO TO 50
C                                       respond to position
            CLIMIT(CLSUBS) = (RPOS(1) - WINDTV(1) - NOFF) *
     *          (RMAX - RMIN) / (WINDTV(3) - WINDTV(1) - 2.*NOFF) + RMIN
C                                       impact on LUTs
            J = MAXINT + 1
            I1 = MAXINT * (CLIMIT(1)-TVMIN) / (TVMAX-TVMIN) + 1.5
            IF (I1.LT.1) I1 = 1
            IF (I1.GT.J) I1 = J
            I2 = MAXINT * (CLIMIT(2)-TVMIN) / (TVMAX-TVMIN) + 1.5
            IF (I2.LT.1) I2 = 1
            IF (I2.GT.J) I2 = J
            I2 = I2 - I1 + 1
            CALL FILL (J, 0, LLUT)
            DO 40 I = 1,3
               ICL = 2 ** (I-1)
               CALL COPY (I2, ALUT(I1,I), LLUT(I1))
               ROUTIN = 'YLUT'
               CALL YLUT ('WRIT', 1, ICL, T, LLUT, IRET)
               IF (IRET.NE.0) GO TO 800
 40            CONTINUE
C                                       CURV-like display
            CALL YHOLD ('ONNN', JERR)
            ROUTIN = 'IMCHAR'
            IY = IY0
            WRITE (STRING,1040) CLIMIT(1)
            CALL IMCHAR (GR1, IX0, IY, 0, 0, STRING(1:11), SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 800
            GPH1OK = .FALSE.
            IY = IY - 2*NEDGE - CSIZTV(2)
            WRITE (STRING,1040) CLIMIT(2)
            CALL IMCHAR (GR1, IX0, IY, 0, 0, STRING(1:11), SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 800
            CALL YHOLD ('OFFF', JERR)
C                                       on button check window
            IF (IBUT.GT.0) THEN
               CALL YWINDO ('READ', WINDTV, IRET)
               IF (IRET.NE.0) THEN
                  WINDTV(1) = 1
                  WINDTV(2) = 1
                  WINDTV(3) = MAXXTV(1)
                  WINDTV(4) = MAXXTV(2)
                  IRET = 0
                  END IF
C                                       buttons A, B switch which one
               IF ((PLTYPE.LT.3) .OR. (PLTYPE.GT.6)) CLSUBS =
     *            3 - CLSUBS
               RPOS(1) = NOFF + WINDTV(1) + (CLIMIT(CLSUBS) - RMIN) *
     *            (WINDTV(3) - WINDTV(1) - 2.*NOFF) / (RMAX - RMIN)
               RPOS(2) = (WINDTV(2) + WINDTV(4)) / 2
               IF (RPOS(1).LT.WINDTV(1)) RPOS(1) = MAX (WINDTV(1), 2)
               IF (RPOS(1).GT.WINDTV(3)) RPOS(1) = WINDTV(3)
               CALL YCURSE ('ONNN', F, F, RPOS, QUAD, LBUT, IRET)
               ROUTIN = 'YCURSE'
               IF (IRET.NE.0) GO TO 800
               PPOS(1) = 0.0
               PPOS(2) = 0.0
               END IF
            GO TO 30
C                                       clean up the TV:
C                                       put back current LUTs
 50      ROUTIN = 'YLUT'
         CALL YLUT ('WRIT', 1, 1, F, ALUT(1,1), IRET)
         IF (IRET.NE.0) GO TO 800
         CALL YLUT ('WRIT', 1, 2, F, ALUT(1,2), IRET)
         IF (IRET.NE.0) GO TO 800
         CALL YLUT ('WRIT', 1, 4, F, ALUT(1,3), IRET)
         IF (IRET.NE.0) GO TO 800
C                                       clear graphics
         IY = IY0
         STRING = ' '
         CALL IMCHAR (GR1, IX0, IY, 0, 0, STRING(1:11), SCRTCH, IRET)
         IF (IRET.NE.0) GO TO 800
         IY = IY - 2*NEDGE - CSIZTV(2)
         CALL IMCHAR (GR1, IX0, IY, 0, 0, STRING(1:11), SCRTCH, IRET)
         IF (IRET.NE.0) GO TO 800
         GPH1OK = .TRUE.
C                                       off cursor
         RPOS(1) = (WINDTV(1) + WINDTV(3)) / 2
         RPOS(2) = (WINDTV(2) + WINDTV(4)) / 2
         ROUTIN = 'YCURSE'
         CALL YCURSE ('OFFF', F, F, RPOS, QUAD, LBUT, IRET)
         IF (IRET.NE.0) GO TO 800
C                                       Button D exits no clip
         IF (IBUT.GE.8) GO TO 910
         END IF
C                                       Do a clipping:
C                                       announce the range
      IF (BRANCH.LE.2) THEN
         IF (CLMIN.GE.CLMAX) GO TO 980
         IF ((CLMIN.LE.RMIN) .AND. (CLMAX.GE.RMAX)) GO TO 980
         IF ((CLMAX.LE.RMIN) .OR. (CLMIN.GE.RMAX)) GO TO 980
         IF ((PLTYPE.LT.3) .OR. (PLTYPE.GT.6)) THEN
            WRITE (MSGTXT,1090) CLIMIT
         ELSE
            WRITE (MSGTXT,1091) CLMAX
            END IF
         CALL MSGWRT (2)
         CALL PCFCOP (FCLUN, DISKOU, CNOOUT, FCVERS, CATIMG, FCNUMB,
     *      NNFLAG, FCBUF, IRET)
         IF (IRET.NE.0) GO TO 999
         FCNUMB = FCNUMB + 1
         CALL PCFLIP (IMGWIN, CLIMIT, FCBUF, SCRTCH, BIGBOY(BIGPT(3)),
     *      BIGBOY(BIGPT(4)), BIGBOY(BIGPT(5)), BIGBOY(BIGPT(6)), IRET)
         IF (IRET.NE.0) GO TO 999
         CALL TABIO ('CLOS', 0, NNFLAG, FCTIME, FCBUF, IRET)
         GO TO 999
         END IF
C                                       based on old
      IF (BRANCH.EQ.3) THEN
C                                       inquire which flag
         CALL PCFCOP (FCLUN, DISKOU, CNOOUT, FCVERS, CATIMG, FCNUMB,
     *      NNFLAG, FCBUF, IRET)
         IF (IRET.NE.0) GO TO 999
         CALL TABIO ('CLOS', 0, NNFLAG, FCTIME, FCBUF, IRET)
         IF (IRET.NE.0) GO TO 999
         FFL = 1
         IF (FCNUMB.GT.1) THEN
            WRITE (MSGBUF,1100) FCNUMB
            CALL INQINT (TTY, MSGBUF, 1, IDUM, IRET)
            FFL = IDUM(1)
            IF (IRET.NE.0) GO TO 850
            IF ((FFL.LT.1) .OR. (FFL.GT.FCNUMB)) THEN
               IRET = -1
               WRITE (MSGTXT,1105) FFL, FCNUMB
               CALL MSGWRT (6)
               GO TO 999
               END IF
            END IF
C                                       save load parms
         DLTYPE = LTYPE
         DLSTOK = LSTOKS
         DLSMOO = LSMOO
         DLSCAN = LSCAN
         DLANT = LANT
         CALL COPY (4, IMGWIN, DWIND)
         DSTKFG = STKFLG
C                                       open FC table
         CALL PCFCOP (FCLUN, DISKOU, CNOOUT, FCVERS, CATIMG, FCNUMB,
     *      NNFLAG, FCBUF, IRET)
         IF (IRET.NE.0) GO TO 999
         PNFLAG = NNFLAG
         PFCNUM = FCNUMB
         DO 110 IFL = 1,PNFLAG
            CALL TABIO ('READ', 0, IFL, FCTIME, FCBUF, IRET)
            IF (IRET.GT.0) GO TO 951
            IF (IRET.LT.0) GO TO 110
            IF (FCNUMB.EQ.FFL) GO TO 120
 110        CONTINUE
         IRET = -1
         WRITE (MSGTXT,1110) FFL
         GO TO 950
C                                       found requested command
 120     CALL H2CHR (8, 1, FCOPER, OP)
         IF (OP.NE.'CLIP ') THEN
            CALL PCFCLI (1)
            IRET = -1
            MSGTXT = 'ABOVE FLAG COMMAND IS NOT A CLIP COMMAND:'
     *         // ' USE ''LIST FLAGS'''
            GO TO 950
            END IF
         CALL TABIO ('CLOS', 0, NNFLAG, FCTIME, FCBUF, IRET)
         IF (IRET.NE.0) GO TO 999
         MSGTXT = 'Pattern flag command is:'
         CALL MSGWRT (2)
         CALL PCFCLI (2)
C                                       save pattern parms
         LTYPE = FCTVTY
         LSMOO = FCTVAV / CATIR(KRCIC+1) + 0.1
         LSCAN = FCTVSC / CATIR(KRCIC+1) + 0.1
         CALL COPY (4, FCTVWI, IMGWIN)
         TLST = (FCTVST - CATID(KDCRV+2)) / CATIR(KRCIC+2) +
     *      CATIR(KRCRP+2) + 0.1
         TLBL = FCTVBL
         TDOBL = FCBASL(1).EQ.0
         TDOIF = FCIF(1).EQ.0
         HDUM(1) = FCSFLG
         CALL H2CHR (4, 1, HDUM, TTKFLG)
         CLIMIT(1) = FCLIPR(1)
         CLIMIT(2) = FCLIPR(2)
         IF ((TDOBL) .OR. (CATIMG(KINAX+3).LE.1)) THEN
            KBBASL = 1
            KEBASL = CATIMG(KINAX+3)
         ELSE
            WRITE (MSGBUF,1132) CATIMG(KINAX+3)
            CALL INQINT (TTY, MSGBUF, 2, ITEMP, IRET)
            IF (IRET.NE.0) GO TO 850
            KBBASL = MAX (1, MIN (ITEMP(1), CATIMG(KINAX+3)))
            IF (ITEMP(2).LT.KBBASL) ITEMP(2) = CATIMG(KINAX+3)
            KEBASL = MAX (1, MIN (ITEMP(2), CATIMG(KINAX+3)))
            END IF
C                                       ask about Stokes maybe
         STKFS(1) = TTKFLG
         STKFS(2) = TTKFLG
         STKFS(3) = TTKFLG
         STKFS(4) = TTKFLG
         NSTOKS = CATIMG(KINAX+2)
         IF (NSTOKS.GT.1) THEN
            DO 140 I = 1,NSTOKS
               IF (.NOT.DOSTOK(ILSTOK, TTKFLG, I)) THEN
                  J = ILSTOK(I) + 9
                  WRITE (MSGBUF,1135) CHST(J)
 139              CALL INQSTR (TTY, MSGBUF, 4, TTKFLG, IRET)
                  IF (IRET.EQ.10) THEN
                     MSGTXT = 'STRING TOO LONG, TRY AGAIN'
                     CALL MSGWRT (7)
                     GO TO 139
                     END IF
                  IF (IRET.NE.0) GO TO 850
                  CALL CHLTOU (4, TTKFLG)
                  CALL MKSTOK (ILSTOK, TTKFLG, STKFS(I), IRET)
                  IF (IRET.NE.0) THEN
                     STKFS(I) = ' '
                     IRET = 0
                  ELSE
                     IF (.NOT.DOSTOK (ILSTOK, STKFS(I), I))
     *                  STKFS(I) = ' '
                     END IF
                  END IF
 140           CONTINUE
            END IF
         DO 165 LANT = KBBASL,KEBASL
            DO 160 LSTOKS = 1,NSTOKS
               IF ((LANT.EQ.TLBL) .AND. (LSTOKS.EQ.TLST)) GO TO 160
               IF (STKFS(LSTOKS).EQ.' ') GO TO 160
               J = ILSTOK(LSTOKS) + 9
               WRITE (MSGTXT,1150) CHST(J), LANT
               CALL MSGWRT (2)
C                                       load TV
               IPL = 1
               CALL PCFOAD (IPL, IMGWIN, DIMB2, ABUF, IOBUF, SCRTCH,
     *            BIGBOY(1), BIGBOY(BIGPT(2)), KIGBOY(BIGPT(3)),
     *            BIGBOY(BIGPT(4)), BIGBOY(BIGPT(5)), BIGBOY(BIGPT(6)),
     *            IRET)
               IF (IRET.GT.0) THEN
                  WRITE (MSGTXT,1152) IRET
                  GO TO 950
               ELSE IF (IRET.LT.0) THEN
                  GO TO 160
                  END IF
               PLTYPE = LTYPE
               PESOFF = RESOFF
               PLSTOK = LSTOKS
               PLSMOO = LSMOO
               PLSCAN = LSCAN
               PLANT = LANT
               LANTV = LANT
C                                       open table
               CALL PCFCOP (FCLUN, DISKOU, CNOOUT, FCVERS, CATIMG,
     *            FCNUMB, NNFLAG, FCBUF, IRET)
               IF (IRET.NE.0) GO TO 999
               FCNUMB = FCNUMB + 1
C                                       record in FC table
               FCTVTY = LTYPE
               FCTVBL = LANT
               FCTVIF = 0
               FCTVST = ILSTOK(LSTOKS)
               CALL COPY (4, IMGWIN, FCTVWI)
               FCTVAV = LSMOO * CATIR(KRCIC+1)
               FCTVSC = LSCAN * CATIR(KRCIC+1)
               IF (TDOBL) THEN
                  FCBASL(1) = 0
                  FCBASL(2) = 0
               ELSE
                  FCBASL(1) = LANTV
                  FCBASL(2) = LANTV
                  END IF
               FCIF(1) = 0
               FCIF(2) = 0
               CALL CHR2H (4, STKFS(LSTOKS), 1, HDUM)
               FCSFLG = HDUM(1)
C                                       do flagging
               IF ((PLTYPE.LT.3) .OR. (PLTYPE.GT.6)) THEN
                  WRITE (MSGTXT,1090) CLIMIT
               ELSE
                  WRITE (MSGTXT,1091) CLMAX
                  END IF
               CALL MSGWRT (2)
               CALL PCFLIP (IMGWIN, CLIMIT, FCBUF, SCRTCH,
     *            BIGBOY(BIGPT(3)), BIGBOY(BIGPT(4)), BIGBOY(BIGPT(5)),
     *            BIGBOY(BIGPT(6)), IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1154) IRET
                  GO TO 950
                  END IF
C                                       close table each time to save
               CALL TABIO ('CLOS', 0, NNFLAG, FCTIME, FCBUF, IRET)
               IF (IRET.NE.0) GO TO 999
 160           CONTINUE
 165        CONTINUE
C                                       recover load parms
         LTYPE = DLTYPE
         LSTOKS = DLSTOK
         LSMOO = DLSMOO
         LSCAN = DLSCAN
         LANT = DLANT
         CALL COPY (4, DWIND, IMGWIN)
         STKFLG = DSTKFG
         END IF
      GO TO 999
C                                       TV error
 800  WRITE (MSGTXT,1800) IRET, ROUTIN
      GO TO 900
C                                       TTY error
 850  IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1850) IRET
      ELSE IF (IRET.LT.0) THEN
         MSGTXT = 'FORMAT ERROR: RETURN TO MENU'
         END IF
      CALL MSGWRT (8)
      GO TO 999
C                                       error message first
 900  CALL MSGWRT (8)
C                                       off cursor
 910  CALL YCURSE ('OFFF', F, F, RPOS, QUAD, LBUT, JERR)
      CALL YHOLD ('OFFF', JERR)
      GO TO 999
C                                       close down table
 950  CALL MSGWRT (8)
 951  CALL TABIO ('CLOS', 0, NNFLAG, FCTIME, FCBUF, JERR)
      GO TO 999
C                                       bad range
 980  WRITE (MSGTXT,1980) CLIMIT
C                                       error message
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('PCFCLP: UNABLE TO READ IMAGE HEADER, ERROR',I5)
 1010 FORMAT ('Enter clip lower/upper limits in range',2(1PE12.4),
     *   '  Q quits')
 1015 FORMAT ('Enter clip upper limit (1 real) in range 0.0 to',
     *   1PE12.4,'  Q quits')
 1040 FORMAT (1PE11.3)
 1090 FORMAT ('Begin clipping outside range',2(1PE12.4))
 1091 FORMAT ('Begin clipping above',1PE12.4)
 1100 FORMAT ('Enter clip command number (1 integer) <=',I5)
 1105 FORMAT ('CLIP COMMAND NUMBER',I5,' NOT IN RANGE 1 -',I5,
     *   ' RETURN TO MENU')
 1110 FORMAT ('CLIP COMMAND NUMBER',I5,' NOT FOUND: USE ''LIST FLAGS''')
 1132 FORMAT ('Enter range of baseline numbers within 1 through',I5,
     *   ' (2 I''s)')
 1135 FORMAT ('Enter Stokes flag pattern applied to Stokes ',A2,
     *   ' (4 chars left justified)')
 1150 FORMAT ('Begin work on Stokes ',A2,' baseline',I5)
 1152 FORMAT ('PCFCLP: ERROR',I5,' RETURNED BY PCFOAD')
 1154 FORMAT ('PCFCLP: ERROR',I5,' RETURNED BY PCFLIP')
 1800 FORMAT ('TV ERROR ',I6,' IN ',A)
 1850 FORMAT ('TERMINAL ERROR',I5)
 1980 FORMAT ('CLIP RANGE',2(1PE12.4),' NOT GOOD, EXIT CLIP')
      END
      SUBROUTINE PCFLIP (IMGWIN, CLIMIT, LFCBUF, SCRTCH, BUFF0, BUFF1,
     *   BUFF2, BUFF3, IRET)
C-----------------------------------------------------------------------
C   does flagging of all pixels in the TV image outside a user-set range
C   of intensities.  That range is set in PCFCLP.
C   Inputs:
C      IMGWIN   I(4)   currently loaded image window
C      CLIMIT   R(2)   clip limits to set
C   In/out:
C      LFCBUF   I(512) Open FC table to write
C   Output:
C      SCRTCH   I(*)   TV scratch buffer
C      BUFF0    R(*)   IO buffer
C      BUFF1    R(*)   IO buffer
C      BUFF2    R(*)   IO buffer
C      BUFF3    R(*)   IO buffer
C      IRET     I      error code
C   Requires CATBLK = TV image in /MAPHDR/
C-----------------------------------------------------------------------
      INTEGER   IMGWIN(4), LFCBUF(512), SCRTCH(*), IRET
      REAL      CLIMIT(2), BUFF0(*), BUFF1(*), BUFF2(*), BUFF3(*)
C
      INCLUDE 'INCS:DSEL.INC'
      CHARACTER PHNAME*48, OPERS*8, ROUTIN*6
      HOLLERITH CATH(256)
      INTEGER   IB0, I, LUN1, LUN2, FIND1, FIND2, J, IR, JERR, IXP, IYP,
     *   LUN0, FIND0, IROUND, I1, I2, LUN3, FIND3, IYL, IYH, IB1, IB2,
     *   IB3, IBLKOF, IDEPTH(5), KBBASL, KEBASL, KBASL, KBIF, KEIF, KIF,
     *   IWIN(4), NROWS, NX, NY, ILSMOO, IYB1(MAXCIF), IERR, NCHAN,
     *   IYB2(MAXCIF), KST, KBST, KEST, NCC, IYSU(MAXCIF), LSU, ICH,
     *   IIF
      LOGICAL   T, F, ISLAST, SSLAST, DOTV, DOSTOK
      REAL      CATR(256), RPOS(2), CORN(2), TIM1, CLMIN, CLMAX, TIM2
      DOUBLE PRECISION CATD(128)
      INCLUDE 'PCFLG.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DTVC.INC'
      EQUIVALENCE (CATBLK, CATR, CATD, CATH)
      DATA T, F /.TRUE.,.FALSE./
      DATA LUN0, LUN1, LUN2, LUN3 /16,17,18,19/
      DATA OPERS /'CLIP '/
C-----------------------------------------------------------------------
      CALL CHR2H (8, OPERS, 1, FCOPER)
      CLMIN = CLIMIT(1)
      CLMAX = CLIMIT(2)
      NCHAN = CHNMAX
      I = MAXCIF
      CALL FILL (I, -1, IYB1)
      CALL FILL (I, -1, IYB2)
      FIND0 = 0
      FIND1 = 0
      FIND2 = 0
      FIND3 = 0
C                                       Do the clipping:
      FCLIPR(1) = CLMIN
      FCLIPR(2) = CLMAX
C                                       open TV image SC file
      CALL ZPHFIL ('SC', SCRVOL(TVFILE), SCRCNO(TVFILE), 1, PHNAME,
     *   IRET)
      CALL ZOPEN (LUN2, FIND2, SCRVOL(TVFILE), PHNAME, T, F, T, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1100) 'OPEN (R)', IRET
         GO TO 990
         END IF
      CALL ZOPEN (LUN3, FIND3, SCRVOL(TVFILE), PHNAME, T, F, T, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1100) 'OPEN (W)', IRET
         GO TO 990
         END IF
C                                       open master file
      CALL ZPHFIL ('MA', DISKOU, CNOOUT, 1, PHNAME, IRET)
      CALL ZOPEN (LUN1, FIND1, DISKOU, PHNAME, T, F, T, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1110) 'OPEN (W)', IRET
         GO TO 900
         END IF
      CALL ZOPEN (LUN0, FIND0, DISKOU, PHNAME, T, F, T, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1110) 'OPEN (R)', IRET
         GO TO 900
         END IF
      IF (DOANT.EQ.0) THEN
         KBBASL = 1
         KEBASL = CATIMG(KINAX+3)
      ELSE
         KBBASL = PLANT
         KEBASL = PLANT
         END IF
      DOTV = DOSTOK (ILSTOK, STKFLG, PLSTOK)
      IF (.NOT.DOTV) THEN
         MSGTXT = 'WARNING: flag command does not apply to displayed'
     *      // ' Stokes'
         CALL MSGWRT (6)
         END IF
      CALL DOSTKS (ILSTOK, STKFLG, KBST, KEST)
      NCC = 0
      CALL YHOLD ('ONNN', JERR)
      DO 305 KBASL = KBBASL,KEBASL
         IF (DOANT.GT.1) THEN
            KST = PLANT
            IF (KST.NE.KBASL) GO TO 305
            END IF
      DO 300 KST = KBST,KEST
         ISLAST = (KBASL.EQ.KEBASL) .AND. (KST.EQ.KEST) .AND. (DOTV)
         IF (.NOT.DOSTOK (ILSTOK, STKFLG, KST)) GO TO 300
C                                       init for read/write TV SC file
         IWIN(1) = 1
         IWIN(2) = 1
         IWIN(3) = CATBLK(KINAX)
         IWIN(4) = CATBLK(KINAX+1)
         CALL MINIT ('READ', LUN2, FIND2, CATBLK(KINAX),
     *      CATBLK(KINAX+1), IWIN, BUFF2, JBUFSZ, 1, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1100) 'INIT (R)', IRET
            GO TO 900
            END IF
         IF (ISLAST) THEN
            CALL MINIT ('WRIT', LUN3, FIND3, CATBLK(KINAX),
     *         CATBLK(KINAX+1), IWIN, BUFF3, JBUFSZ, 1, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1100) 'INIT (R)', IRET
               GO TO 900
               END IF
            END IF
C                                       open master file
         IWIN(3) = CATIMG(KINAX)
         IWIN(4) = CATIMG(KINAX+1)
         NROWS = 0
         IDEPTH(1) = KST
         IDEPTH(2) = KBASL
         IDEPTH(3) = 1
         IDEPTH(4) = 1
         IDEPTH(5) = 1
         CALL COMOFF (CATIMG(KIDIM), CATIMG(KINAX), IDEPTH, IBLKOF,
     *      IRET)
         IBLKOF = IBLKOF + 1
         CALL MINIT ('READ', LUN0, FIND0, CATIMG(KINAX),
     *      CATIMG(KINAX+1), IWIN, BUFF0, JBUFSZ, IBLKOF, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1110) 'INIT (R)', IRET
            GO TO 900
            END IF
         CALL MINIT ('WRIT', LUN1, FIND1, CATIMG(KINAX),
     *      CATIMG(KINAX+1), IWIN, BUFF1, JBUFSZ, IBLKOF, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1110) 'INIT (W)', IRET
            GO TO 900
            END IF
C                                       skip through lower border of
C                                       master file
         NY = IMGWIN(2) - 1
         IF (NY.LE.0) GO TO 170
            DO 160 J = 1,NY
               NROWS = NROWS + 1
               CALL MDISK ('READ', LUN0, FIND0, BUFF0, IB0, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1110) 'READ', IRET
                  GO TO 900
                  END IF
               CALL MDISK ('WRIT', LUN1, FIND1, BUFF1, IB1, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1110) 'WRITE', IRET
                  GO TO 900
                  END IF
               CALL RCOPY (CATIMG(KINAX), BUFF0(IB0), BUFF1(IB1))
 160           CONTINUE
C                                       read TV scratch file
 170     NY = CATBLK(KINAX+1)
         NX = CATBLK(KINAX) - 3
         DO 210 J = 1,NY
            CALL MDISK ('READ', LUN2, FIND2, BUFF2, IB2, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1100) 'READ', IRET
               GO TO 900
               END IF
            IF (ISLAST) THEN
               CALL MDISK ('WRIT', LUN3, FIND3, BUFF3, IB3, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1100) 'WRITE', IRET
                  GO TO 900
                  END IF
               CALL RCOPY (CATBLK(KINAX), BUFF2(IB2), BUFF3(IB3))
               END IF
            TIM1 = BUFF2(IB2+1) - BUFF2(IB2+2)/2.0
            TIM2 = BUFF2(IB2+1) + BUFF2(IB2+2)/2.0
            CALL GETIME (TIM1, TIM2, IYL, IYH, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1180) TIM1, TIM2, NROWS
               CALL MSGWRT (8)
               GO TO 210
               END IF
            IF ((IYL.NE.NROWS) .AND. (IYL.NE.NROWS+1)) THEN
               WRITE (MSGTXT,1185) NROWS, IYL, TIM1, TIM2
               CALL MSGWRT (6)
               END IF
            IYL = NROWS + 1
            ILSMOO = IYH - IYL + 1
            IF (NROWS+ILSMOO.GT.CATIMG(KINAX+1)) ILSMOO =
     *         CATIMG(KINAX+1) - NROWS
            LSU = 0
            DO 205 IR = 1,ILSMOO
               CALL MDISK ('READ', LUN0, FIND0, BUFF0, IB0, IRET)
               NROWS = NROWS + 1
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1110) 'READ', IRET
                  GO TO 900
                  END IF
               CALL MDISK ('WRIT', LUN1, FIND1, BUFF1, IB1, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1110) 'WRITE', IRET
                  GO TO 900
                  END IF
               CALL RCOPY (CATIMG(KINAX), BUFF0(IB0), BUFF1(IB1))
               IF (DOSOUR) THEN
                  LSU = BUFF1(IB1) + 0.01
                  IF (LSU.LE.0) LSU = INSNUM
                  END IF
               SSLAST = (ISLAST) .AND. (IR.EQ.ILSMOO)
               DO 200 I = 1,NX
                  I1 = IB2 + I + 2
                  ICH = MOD (I-1, NCHAN)
                  IIF = (I-1) / NCHAN
                  IF (BUFF2(I1).EQ.FBLANK) GO TO 200
C                                       point inside range now
                  IF ((BUFF2(I1).GE.CLMIN) .AND. (BUFF2(I1).LE.CLMAX))
     *               THEN
C                                       but previously bad
C                                       (only true if SSLAST)
                     IF (IYB1(I).GT.0) THEN
C                                       add to flag table
                        NNFLAG = NNFLAG + 1
                        FCCHAN(1) = ICH + IMGWIN(1)
                        FCCHAN(2) = FCCHAN(1)
                        IF (DOIFS.EQ.-1) THEN
                           FCIF(1) = IIF + BIF
                           FCIF(2) = IIF + BIF
                        ELSE IF (DOIFS.EQ.0) THEN
                           FCIF(1) = LCIF(1)
                           FCIF(2) = LCIF(2)
                           END IF
                        FCTIME(1) = TIMES(IYB1(I))
                        FCTIME(2) = TIMES(IYB2(I)+1)
                        FCSOUR = MAX (IYSU(I), 0)
                        IYB1(I) = -1
                        IYB2(I) = -1
                        CALL TABIO ('WRIT', 0, NNFLAG, FCTIME, LFCBUF,
     *                     IRET)
                        IF (IRET.NE.0) GO TO 999
                        END IF
C                                       point outside range now
                  ELSE
                     IF (DOIFS.EQ.1) THEN
                        KBIF = 1
                        KEIF = EIF - BIF + 1
                     ELSE IF (DOIFS.EQ.0) THEN
                        KBIF = LCIF(1) - BIF + 1
                        KEIF = LCIF(2) - BIF + 1
                     ELSE
                        KBIF = IIF + 1
                        KEIF = KBIF
                        END IF
                     DO 185 KIF = KBIF,KEIF
                        I2 = ICH + IMGWIN(1) + NCHAN * (KIF-1)
                        I2 = IB1 + NUMVAL * (I2-1) + 3
                        IF (BUFF1(I2).EQ.0.0) THEN
                           BUFF1(I2) = FCNUMB
                           NCC = NCC + 1
                           END IF
 185                    CONTINUE
C                                       clear TV file
                     IF (SSLAST) THEN
                        DO 190 KIF = KBIF,KEIF
                           I1 = IB3 + ICH + 3 + NCHAN * (KIF-1)
                           BUFF3(I1) = FBLANK
C                                       clear TV
                           CORN(1) = ICH + 4 + NCHAN * (KIF-1)
                           CORN(2) = J
                           CALL MP2IMA (CORN, RPOS)
                           IXP = IROUND (RPOS(1))
                           IYP = IROUND (RPOS(2))
                           IF ((IXP.GE.1) .AND. (IXP.LE.MAXXTV(1)) .AND.
     *                        (IYP.GE.1) .AND. (IYP.LE.MAXXTV(2))) THEN
                              ROUTIN = 'YFILL'
                              CALL YFILL (1, IXP, IYP, IXP, IYP, 0,
     *                           SCRTCH, IRET)
                              IF (IRET.NE.0) GO TO 800
                              END IF
 190                       CONTINUE
C                                       source changed
                        IF ((IYB1(I).GT.0) .AND. (LSU.NE.IYSU(I))) THEN
C                                       add to flag table
                           NNFLAG = NNFLAG + 1
                           FCCHAN(1) = ICH + IMGWIN(1)
                           FCCHAN(2) = FCCHAN(1)
                           IF (DOIFS.EQ.-1) THEN
                              FCIF(1) = IIF + BIF
                              FCIF(2) = IIF + BIF
                           ELSE IF (DOIFS.EQ.0) THEN
                              FCIF(1) = LCIF(1)
                              FCIF(2) = LCIF(2)
                              END IF
                           FCTIME(1) = TIMES(IYB1(I))
                           FCTIME(2) = TIMES(IYB2(I)+1)
                           FCSOUR = MAX (0, IYSU(I))
                           IYB1(I) = -1
                           CALL TABIO ('WRIT', 0, NNFLAG, FCTIME,
     *                        LFCBUF, IRET)
                           IF (IRET.NE.0) GO TO 999
                           END IF
                        IYB2(I) = J
                        IF (IYB1(I).LE.0) IYB1(I) = J
                        IYSU(I) = LSU
                        END IF
                     END IF
 200              CONTINUE
 205           CONTINUE
 210        CONTINUE
C                                       copy last of UV master image
         NROWS = CATIMG(KINAX+1) - NROWS
         IF (NROWS.LE.0) GO TO 230
            DO 220 J = 1,NROWS
               CALL MDISK ('READ', LUN0, FIND0, BUFF0, IB0, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1110) 'READ', IRET
                  GO TO 900
                  END IF
               CALL MDISK ('WRIT', LUN1, FIND1, BUFF1, IB1, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1110) 'WRITE', IRET
                  GO TO 900
                  END IF
               CALL RCOPY (CATIMG(KINAX), BUFF0(IB0), BUFF1(IB1))
 220           CONTINUE
C                                       finish the writing
 230     IF (.NOT.ISLAST) GO TO 295
            CALL MDISK ('FINI', LUN3, FIND3, BUFF3, IB3, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1100) 'FINI', IRET
               GO TO 900
               END IF
C                                       any entries for flagtable?
            DO 240 I = 1,NX
               IF (IYB1(I).GT.0) THEN
                  ICH = MOD (I-1, NCHAN)
                  IIF = (I-1) / NCHAN
                  NNFLAG = NNFLAG + 1
                  FCCHAN(1) = ICH + IMGWIN(1)
                  FCCHAN(2) = FCCHAN(1)
                  IF (DOIFS.EQ.-1) THEN
                     FCIF(1) = IIF + BIF
                     FCIF(2) = FCIF(1)
                  ELSE IF (DOIFS.EQ.0) THEN
                     FCIF(1) = LCIF(1)
                     FCIF(2) = LCIF(2)
                     END IF
                  FCTIME(1) = TIMES(IYB1(I))
                  FCTIME(2) = TIMES(IYB2(I)+1)
                  FCSOUR = MAX (0, IYSU(I))
                  CALL TABIO ('WRIT', 0, NNFLAG, FCTIME, LFCBUF, IRET)
                  IF (IRET.NE.0) GO TO 999
                  END IF
 240           CONTINUE
 295     CALL MDISK ('FINI', LUN1, FIND1, BUFF1, IB1, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1110) 'FINI', IRET
            GO TO 900
            END IF
 300     CONTINUE
 305     CONTINUE
      IF (NCC.GT.0) THEN
         WRITE (MSGTXT,1300) NCC
         CALL MSGWRT (3)
      ELSE
         MSGTXT = 'NO PREVIOUSLY UNFLAGGED PIXELS DELETED IN'
     *      // ' MASTER GRID'
         CALL MSGWRT (6)
         END IF
      GO TO 910
C                                       TV error
 800  WRITE (MSGTXT,1800) IRET, ROUTIN
      GO TO 900
C                                       error message first
 900  CALL MSGWRT (8)
C                                       off cursor
 910  IF (FIND0.GT.0) CALL ZCLOSE (LUN0, FIND0, JERR)
      IF (FIND1.GT.0) CALL ZCLOSE (LUN1, FIND1, JERR)
      IF (FIND2.GT.0) CALL ZCLOSE (LUN2, FIND2, JERR)
      IF (FIND3.GT.0) CALL ZCLOSE (LUN3, FIND3, JERR)
      CALL YHOLD ('OFFF', JERR)
      GO TO 999
C                                       error message
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1100 FORMAT ('PCFLIP: UNABLE TO ',A,' TV SCRATCH FILE, ERROR',I5)
 1110 FORMAT ('PCFLIP: UNABLE TO ',A,' MAIN GRID FILE, ERROR',I5)
 1180 FORMAT ('PCFLIP: GETIME ERROR: T1,T2,NROWS=',2(1PE12.4),I6)
 1185 FORMAT ('PCFLIP UNEXPECTED NROWS, IYL, T1, T2=',2I6,2(1PE12.4))
 1300 FORMAT ('Deleted',I9,' pixels in master grid')
 1800 FORMAT ('TV ERROR ',I6,' IN ',A)
      END
      SUBROUTINE PCFUNF (BRANCH, TTY, IMGWIN, BUFF0, BIGBOY, KIGBOY,
     *   SCRTCH, IRET)
C-----------------------------------------------------------------------
C   does unflag-related operations on the master grid.
C   Inputs:
C      BRANCH   I      =9  => list flag commands
C                      =10 => undo flag commands
C                      =11 => re-flag master grid based on current FC
C                             file
C      TTY      I(2)   LUN, IND of open terminal to talk to user
C      IMGWIN   I(4)   Currently loaded image window
C   Output:
C      BUFF0    R(*)   IO buffer (overlap end of BIGBOY okay)
C      BIGBOY   R(*)   Large IO buffers
C      KIGBOY   I(*)   Large IO buffers
C      SCRTCH   I(*)   scratch buffer for TV
C      IRET     I      Error return: > 0 => quit
C                         -1 => nothing really done
C-----------------------------------------------------------------------
      REAL      BUFF0(*), BIGBOY(*)
      INTEGER   BRANCH, TTY(2), IMGWIN(4), KIGBOY(*), SCRTCH(*), IRET
C
      INTEGER   NCC, I, J, IERR, J1, FCNLIM(2), FCNCNT, FCNFLG(50),
     *   LUN0, LUN1, FIND0, NX, FIND1, EST, KIF, KBASL, KST, IWIN(4),
     *   IDEPTH(5), IBLKOF, NY, IB0, IB1, I1, I2, IROUND, K, NCF, J2,
     *   NVER, FCNWAS, IFL1, PNFLAG, DLTYPE, DLSTOK, DLSMOO, DLANT,
     *   DWIND(4), FCBUF2(512), IXL, IXH, IYL, IYH, LUNFC2, IY, NRPL,
     *   KBBASL, KEBASL, KBIF, KEIF, NCFLAG, DLSCAN, IOFF, NCHAN, IPL
      HOLLERITH HDUM(4)
      REAL      CLIMIT(2)
      LOGICAL   T, F, DOSTOK
      CHARACTER OP*8, MSGBUF*72, PHNAME*48, DSTKFG*4
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'PCFLG.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'PCFLG.BUF'
      DATA T, F /.TRUE.,.FALSE./
      DATA LUN0, LUN1, LUNFC2 /16, 17, 26/
C-----------------------------------------------------------------------
      IRET = 0
      IF ((BRANCH.LT.9) .OR. (BRANCH.GT.11)) GO TO 999
      NCHAN = CHNMAX
C                                       open the FC file
      CALL PCFCOP (FCLUN, DISKOU, CNOOUT, FCVERS, CATIMG, FCNUMB,
     *   NNFLAG, FCBUF, IRET)
      IF (IRET.NE.0) GO TO 999
      NCFLAG = FCNUMB + 1
      IF ((FCNUMB.LE.0) .OR. (NNFLAG.LE.0)) THEN
         MSGTXT = 'No entries in the FC table to LIST, UNDO, or REDO'
         CALL MSGWRT (6)
         IRET = -1
         GO TO 900
         END IF
C                                       list
 100  IF (BRANCH.EQ.9) THEN
         IF (FCNUMB.LE.1) THEN
            FCNLIM(1) = 1
            FCNLIM(2) = 1
         ELSE
            WRITE (MSGBUF,1100) FCNUMB
            CALL INQINT (TTY, MSGBUF, 2, FCNLIM, IRET)
            IF (IRET.NE.0) GO TO 850
            FCNLIM(1) = MAX (1, MIN (FCNLIM(1), FCNUMB))
            IF (FCNLIM(2).LT.FCNLIM(1)) FCNLIM(2) = FCNUMB
            FCNLIM(2) = MAX (1, MIN (FCNLIM(2), FCNUMB))
            END IF
         NCF = 0
         NCC = 0
         DO 150 I = 1,NNFLAG
            CALL TABIO ('READ', 0, I, FCTIME, FCBUF, IRET)
            IF (IRET.LT.0) GO TO 150
            IF (IRET.NE.0) GO TO 900
            IF ((FCNUMB.LT.FCNLIM(1)) .OR. (FCNUMB.GT.FCNLIM(2)))
     *         GO TO 150
            IF (FCNUMB.EQ.NCF) THEN
               NCC = NCC + 1
            ELSE
C                                       give number flags
               IF (NCC.GT.1) THEN
                  WRITE (MSGTXT,1101) NCC
                  CALL MSGWRT (3)
                  END IF
C                                       new flag kind
               NCC = 1
               NCF = FCNUMB
               CALL PCFCLI (3)
               END IF
 150        CONTINUE
C                                       give number flags
         IF (NCC.GT.1) THEN
            WRITE (MSGTXT,1101) NCC
            CALL MSGWRT (3)
            END IF
C                                       UNDO 1 or more flags
      ELSE IF (BRANCH.EQ.10) THEN
         FCNLIM(1) = FCNUMB
         FCNLIM(2) = 1
         IF (FCNUMB.LE.1) THEN
            I = 2
            FCNFLG(1) = 1
         ELSE
            DO 210 I = 1,50
               WRITE (MSGBUF,1200) I, FCNUMB
 205           CALL INQINT (TTY, MSGBUF, 1, FCNFLG(I), IRET)
               IF (IRET.NE.0) GO TO 850
               IF (FCNFLG(I).GT.FCNUMB) GO TO 205
               IF (FCNFLG(I).LE.0) GO TO 215
               FCNLIM(1) = MIN (FCNLIM(1), FCNFLG(I))
               FCNLIM(2) = MAX (FCNLIM(2), FCNFLG(I))
 210           CONTINUE
            I = 51
            END IF
 215     FCNCNT = I - 1
         IF (FCNCNT.LE.0) GO TO 900
C                                       flag them in FC file
         NCC = 0
         I1 = 0
         J1 = 0
         NCF = 0
         DO 230 I = 1,NNFLAG
            CALL TABIO ('READ', 0, I, FCTIME, FCBUF, IRET)
            IF (IRET.LT.0) GO TO 230
            IF (IRET.NE.0) GO TO 900
            I2 = I1
            I1 = I
            J2 = J1
            J1 = FCNUMB
            IF ((FCNUMB.LT.FCNLIM(1)) .OR. (FCNUMB.GT.FCNLIM(2)))
     *         GO TO 230
               IF (FCNLIM(1).EQ.FCNLIM(2)) GO TO 225
                  DO 220 J = 1,FCNCNT
                     IF (FCNUMB.EQ.FCNFLG(J)) GO TO 225
 220                 CONTINUE
                  GO TO 230
C                                       flag the line
 225           NCC = NCC + 1
               CALL TABIO ('FLAG', 0, I, FCTIME, FCBUF, IRET)
               IF (IRET.NE.0) GO TO 900
               I1 = I2
               J1 = J2
               IF (NCF.NE.FCNUMB) THEN
                  NCF = FCNUMB
                  MSGTXT = '******** Undoing :'
                  CALL MSGWRT (2)
                  CALL PCFCLI (2)
                  END IF
 230        CONTINUE
         IF (NCC.LE.0) THEN
            MSGTXT = 'NO LINES DELETED IN THE FC FILE, RETURN TO MENU'
            CALL MSGWRT (6)
            IRET = -1
            GO TO 900
         ELSE
            WRITE (MSGTXT,1231) NCC
            CALL MSGWRT (2)
            END IF
C                                       reduce number of records
         IF (I1.LT.NNFLAG) THEN
            I2 = NNFLAG - I1
            WRITE (MSGTXT,1232) I2, I1
            CALL MSGWRT (3)
            FCBUF(5) = I1
            NNFLAG = I1
            J2 = NCFLAG
            NCFLAG = J1 + 1
            WRITE (MSGTXT,1233) J2, NCFLAG
            CALL MSGWRT (3)
            END IF
C                                       open master file
         MSGTXT = 'WARNING: checking whole master file takes a while'
         CALL MSGWRT (1)
         CALL ZPHFIL ('MA', DISKOU, CNOOUT, 1, PHNAME, IRET)
         CALL ZOPEN (LUN1, FIND1, DISKOU, PHNAME, T, F, T, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1250) IRET, 'OPEN W'
            GO TO 900
            END IF
         CALL ZOPEN (LUN0, FIND0, DISKOU, PHNAME, T, F, T, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1250) IRET, 'OPEN R'
            GO TO 900
            END IF
         NCC = 0
         EST = CATIMG(KINAX+2)
         KEBASL = CATIMG(KINAX+3)
         DO 290 KBASL = 1,KEBASL
         DO 289 KST = 1,EST
C                                       init master file
            IWIN(1) = 1
            IWIN(2) = 1
            IWIN(3) = CATIMG(KINAX)
            IWIN(4) = CATIMG(KINAX+1)
            IDEPTH(1) = KST
            IDEPTH(2) = KBASL
            IDEPTH(3) = 1
            IDEPTH(4) = 1
            IDEPTH(5) = 1
            CALL COMOFF (CATIMG(KIDIM), CATIMG(KINAX), IDEPTH, IBLKOF,
     *         IRET)
            IBLKOF = IBLKOF + 1
            CALL MINIT ('READ', LUN0, FIND0, CATIMG(KINAX),
     *         CATIMG(KINAX+1), IWIN, BUFF0, JBUFSZ, IBLKOF, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1250) IRET, 'INIT R'
               GO TO 900
               END IF
            CALL MINIT ('WRIT', LUN1, FIND1, CATIMG(KINAX),
     *         CATIMG(KINAX+1), IWIN, BIGBOY, JBUFSZ, IBLKOF, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1250) IRET, 'INIT W'
               GO TO 900
               END IF
            NY = CATIMG(KINAX+1)
            NX = (CATIMG(KINAX) - 3) / 3
            DO 250 J = 1,NY
               CALL MDISK ('READ', LUN0, FIND0, BUFF0, IB0, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1250) IRET, 'READ'
                  GO TO 900
                  END IF
               CALL MDISK ('WRIT', LUN1, FIND1, BIGBOY, IB1, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1250) IRET, 'WRITE'
                  GO TO 900
                  END IF
               CALL RCOPY (CATIMG(KINAX), BUFF0(IB0), BIGBOY(IB1))
               DO 245 I = 1,NX
                  I1 = IB1 + NUMVAL*(I-1) + 3
                  IF (BIGBOY(I1).EQ.FBLANK) GO TO 245
                  I2 = IROUND (BIGBOY(I1))
                  IF ((I2.LT.FCNLIM(1)) .OR. (I2.GT.FCNLIM(2)))
     *               GO TO 245
                     IF (FCNLIM(1).EQ.FCNLIM(2)) GO TO 240
                        DO 235 K = 1,FCNCNT
                           IF (I2.EQ.FCNFLG(K)) GO TO 240
 235                       CONTINUE
                        GO TO 245
 240                 NCC = NCC + 1
                     BIGBOY(I1) = 0.0
 245              CONTINUE
 250           CONTINUE
C                                       finish the writing
            CALL MDISK ('FINI', LUN1, FIND1, BIGBOY, IB1, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1250) IRET, 'FINI'
               GO TO 900
               END IF
 289        CONTINUE
 290        CONTINUE
         IF (NCC.LE.0) THEN
            MSGTXT = 'NO PIXELS RESTORED IN THE MASTER GRID FILE,'
     *         // ' RETURN TO MENU'
            CALL MSGWRT (6)
            IRET = -1
         ELSE
            WRITE (MSGTXT,1290) NCC
            CALL MSGWRT (2)
            END IF
         CALL ZCLOSE (LUN0, FIND0, IERR)
         CALL ZCLOSE (LUN1, FIND1, IERR)
C                                       Redo the remaining flags
      ELSE IF (BRANCH.EQ.11) THEN
C                                       find first flag in FC file
         NCF = 10000000
         DO 305 I = 1,NNFLAG
            CALL TABIO ('READ', 0, I, FCTIME, FCBUF, IRET)
            IF (IRET.GT.0) GO TO 900
            IF (IRET.LT.0) THEN
               NCF = FCNUMB
               GO TO 310
               END IF
 305        CONTINUE
         MSGTXT = 'All flag commands seem to be redone already'
         CALL MSGWRT (6)
         IRET = -1
         GO TO 900
C                                       there is some to do
 310     WRITE (MSGTXT,1310) NCF
         CALL MSGWRT (1)
C                                       open master file
         CALL ZPHFIL ('MA', DISKOU, CNOOUT, 1, PHNAME, IRET)
         CALL ZOPEN (LUN1, FIND1, DISKOU, PHNAME, T, F, T, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1250) IRET, 'OPEN W'
            GO TO 900
            END IF
         CALL ZOPEN (LUN0, FIND0, DISKOU, PHNAME, T, F, T, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1250) IRET, 'OPEN R'
            GO TO 900
            END IF
C                                       clear master file high flags
         NCC = 0
         EST = CATIMG(KINAX+2)
         KEBASL = CATIMG(KINAX+3)
         IWIN(1) = 1
         IWIN(2) = 1
         IWIN(3) = CATIMG(KINAX)
         IWIN(4) = CATIMG(KINAX+1)
         DO 325 KBASL = 1,KEBASL
         DO 324 KST = 1,EST
            IDEPTH(1) = KST
            IDEPTH(2) = KBASL
            IDEPTH(3) = 1
            IDEPTH(4) = 1
            IDEPTH(5) = 1
            CALL COMOFF (CATIMG(KIDIM), CATIMG(KINAX), IDEPTH, IBLKOF,
     *         IRET)
            IBLKOF = IBLKOF + 1
            CALL MINIT ('READ', LUN0, FIND0, CATIMG(KINAX),
     *         CATIMG(KINAX+1), IWIN, BUFF0, JBUFSZ, IBLKOF, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1250) IRET, 'INIT R'
               GO TO 900
               END IF
            CALL MINIT ('WRIT', LUN1, FIND1, CATIMG(KINAX),
     *         CATIMG(KINAX+1), IWIN, BIGBOY, JBUFSZ, IBLKOF, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1250) IRET, 'INIT W'
               GO TO 900
               END IF
            DO 320 J = 1,NY
               CALL MDISK ('READ', LUN0, FIND0, BUFF0, IB0, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1250) IRET, 'READ'
                  GO TO 900
                  END IF
               CALL MDISK ('WRIT', LUN1, FIND1, BIGBOY, IB1, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1250) IRET, 'WRITE'
                  GO TO 900
                  END IF
               CALL RCOPY (CATIMG(KINAX), BUFF0(IB0), BIGBOY(IB1))
               DO 315 I = 1,NX
                  I1 = IB1 + NUMVAL*(I-1) + 3
                  IF (BIGBOY(I1).NE.FBLANK) THEN
                     I2 = IROUND (BIGBOY(I1))
                     IF (I2.GE.NCF) THEN
                        NCC = NCC + 1
                        BIGBOY(I1) = 0.0
                        END IF
                     END IF
 315              CONTINUE
 320           CONTINUE
C                                       finish the writing
            CALL MDISK ('FINI', LUN1, FIND1, BIGBOY, IB1, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1250) IRET, 'FINI'
               GO TO 900
               END IF
 324        CONTINUE
 325        CONTINUE
         IF (NCC.LE.0) THEN
            MSGTXT = 'NO PIXELS WERE FLAGGED AFTER THE LOWEST'
     *         // ' UNDONE COMMAND'
            CALL MSGWRT (6)
            IRET = -1
            GO TO 900
         ELSE
            WRITE (MSGTXT,1326) NCC
            CALL MSGWRT (2)
            END IF
         MSGTXT = 'Now reapply the remaining commands'
         CALL MSGWRT (1)
         NRPL = NBPS / (2 * CATIMG(KINAX))
         IF (NRPL.LT.1) NRPL = 1
C                                       make a new FC file
         NVER = FCVERS + 1
         CALL PCFCOP (LUNFC2, DISKOU, CNOOUT, NVER, CATIMG, I, J,
     *      FCBUF2, IRET)
         IF (IRET.NE.0) GO TO 100
C                                       save load parms
         DLTYPE = LTYPE
         DLSTOK = LSTOKS
         DLSMOO = LSMOO
         DLSCAN = LSCAN
         DLANT = LANT
         CALL COPY (4, IMGWIN, DWIND)
         DSTKFG = STKFLG
C                                       init counters
         PNFLAG = NNFLAG
         NNFLAG = 0
         NCFLAG = 0
         FCNWAS = 0
         NX = (CATIMG(KINAX) - 3) / 3
         NY = CATIMG(KINAX+1)
         DO 390 IFL1 = 1,PNFLAG
            CALL TABIO ('READ', 0, IFL1, FCTIME, FCBUF, IRET)
            IF (IRET.GT.0) GO TO 951
            IF (IRET.LT.0) GO TO 390
C                                       copy early records
            IF (NCF.GT.FCNUMB) THEN
               IF (FCNUMB.NE.FCNWAS) THEN
                  FCNWAS = FCNUMB
                  NCFLAG = NCFLAG + 1
                  END IF
               FCNUMB = NCFLAG
               NNFLAG = NNFLAG + 1
               CALL TABIO ('WRIT', 0, NNFLAG, FCTIME, FCBUF2, IRET)
               IF (IRET.NE.0) GO TO 951
C                                       reapply flags
            ELSE
               CALL H2CHR (8, 1, FCOPER, OP)
               HDUM(1) = FCSFLG
               CALL H2CHR (4, 1, HDUM, STKFLG)
C                                       "simple" rectangles
               IF (OP.NE.'CLIP') THEN
                  IF (FCNUMB.NE.FCNWAS) NCFLAG = NCFLAG + 1
                  FCNWAS = FCNUMB
                  FCNUMB = NCFLAG
                  NNFLAG = NNFLAG + 1
                  CALL TABIO ('WRIT', 0, NNFLAG, FCTIME, FCBUF2, IRET)
                  IF (IRET.NE.0) GO TO 951
C                                       X-coordinate list
                  IF (OP.EQ.'CHANL-DT') THEN
                     IXL = FCCHAN(1)
                     IXH = IXL
                  ELSE IF ((OP.EQ.'TIME') .OR. (OP.EQ.'TIMERANG')) THEN
                     IXL = 1
                     IXH = NCHAN
                  ELSE
                     IXL = FCCHAN(1)
                     IXH = FCCHAN(2)
                     END IF
                  NCC = 0
                  CALL GETIME (FCTIME(1), FCTIME(2), IYL, IYH, IERR)
                  IF (IERR.NE.0) THEN
                     WRITE (MSGTXT,1335) FCTIME, IYL, IYH
                     CALL MSGWRT (8)
                     GO TO 365
                     END IF
                  IWIN(1) = 1
                  IWIN(2) = 1
                  IWIN(2) = ((IYL - 1) / NRPL) * NRPL + 1
                  IWIN(4) = ((IYH - 1 + NRPL) / NRPL) * NRPL
                  IWIN(2) = MAX (1, MIN (IWIN(2), NY))
                  IWIN(4) = MAX (1, MIN (IWIN(4), NY))
                  IF (FCIF(1).LE.0) THEN
                     KBIF = BIF
                     KEIF = EIF
                  ELSE
                     KBIF = FCIF(1)
                     KEIF = FCIF(2)
                     END IF
                  IF (FCBASL(1).LE.0) THEN
                     KBBASL = 1
                     KEBASL = CATIMG(KINAX+3)
                  ELSE
                     KBBASL = FCBASL(1)
                     KEBASL = FCBASL(1)
                     END IF
                  MSGTXT = '******** Restoring :'
                  CALL MSGWRT (2)
                  CALL PCFCLI (2)
                  DO 361 KBASL = KBBASL,KEBASL
                  DO 360 KST = 1,4
                     IF (.NOT.DOSTOK (ILSTOK, STKFLG, KST)) GO TO 360
                     IDEPTH(1) = KST
                     IDEPTH(2) = KBASL
                     IDEPTH(3) = 1
                     IDEPTH(4) = 1
                     IDEPTH(5) = 1
                     CALL COMOFF (CATIMG(KIDIM), CATIMG(KINAX), IDEPTH,
     *                  IBLKOF, IRET)
                     IBLKOF = IBLKOF + 1
                     CALL MINIT ('READ', LUN0, FIND0, CATIMG(KINAX),
     *                  CATIMG(KINAX+1), IWIN, BUFF0, JBUFSZ, IBLKOF,
     *                  IRET)
                     IF (IRET.NE.0) THEN
                        WRITE (MSGTXT,1250) IRET, 'INIT R'
                        GO TO 950
                        END IF
                     CALL MINIT ('WRIT', LUN1, FIND1, CATIMG(KINAX),
     *                  CATIMG(KINAX+1), IWIN, BIGBOY, JBUFSZ, IBLKOF,
     *                  IRET)
                     IF (IRET.NE.0) THEN
                        WRITE (MSGTXT,1250) IRET, 'INIT W'
                        GO TO 950
                        END IF
                     I1 = IWIN(2)
                     I2 = IWIN(4)
                     DO 350 IY = I1,I2
                        CALL MDISK ('READ', LUN0, FIND0, BUFF0, IB0,
     *                     IRET)
                        IF (IRET.NE.0) THEN
                           WRITE (MSGTXT,1250) IRET, 'READ'
                           GO TO 950
                           END IF
                        CALL MDISK ('WRIT', LUN1, FIND1, BIGBOY, IB1,
     *                     IRET)
                        IF (IRET.NE.0) THEN
                           WRITE (MSGTXT,1250) IRET, 'WRITE'
                           GO TO 950
                           END IF
                        CALL RCOPY (CATIMG(KINAX), BUFF0(IB0),
     *                     BIGBOY(IB1))
                        IF ((IY.GE.IYL) .AND. (IY.LE.IYH) .AND.
     *                     (IXL.GT.0)) THEN
                           DO 345 KIF = KBIF,KEIF
                              IOFF = IB1 + NUMVAL * NCHAN * (KIF-BIF)
                              DO 340 I = IXL,IXH
                                 I1 = IOFF + NUMVAL*(I-1) + 3
                                 IF (BIGBOY(I1).EQ.0.0) THEN
                                    NCC = NCC + 1
                                    BIGBOY(I1) = FCNUMB
                                    END IF
 340                             CONTINUE
 345                          CONTINUE
                           END IF
 350                    CONTINUE
C                                       finish the writing
                     CALL MDISK ('FINI', LUN1, FIND1, BIGBOY, IB1, IRET)
                     IF (IRET.NE.0) THEN
                        WRITE (MSGTXT,1250) IRET, 'FINI'
                        GO TO 950
                        END IF
 360                 CONTINUE
 361                 CONTINUE
 365              WRITE (MSGTXT,1365) NNFLAG, NCC
                  CALL MSGWRT (2)
C                                       CLIP: call PCFOAD, PCFLIP
C                                       on 1st one only
               ELSE IF (FCNUMB.NE.FCNWAS) THEN
                  FCNWAS = FCNUMB
                  NCFLAG = NCFLAG + 1
                  FCNUMB = NCFLAG
                  MSGTXT = '******** Restoring :'
                  CALL MSGWRT (2)
                  CALL PCFCLI (2)
C                                       close uv data file
                  CALL ZCLOSE (LUN0, FIND0, IERR)
                  CALL ZCLOSE (LUN1, FIND1, IERR)
C                                       create flag against TV file
                  LTYPE = FCTVTY
                  LSTOKS = (FCTVST - CATID(KDCRV+2)) / CATIR(KRCIC+2) +
     *               CATIR(KRCRP+2) + 0.1
                  LSMOO = FCTVAV / CATIR(KRCIC+1) + 0.1
                  LSCAN = FCTVSC / CATIR(KRCIC+1) + 0.1
                  LANT = FCTVBL
                  CALL COPY (4, FCTVWI, IMGWIN)
                  IPL = 1
                  CALL PCFOAD (IPL, IMGWIN, DIMB2, ABUF, IOBUF, SCRTCH,
     *               BIGBOY(1), BIGBOY(BIGPT(2)), KIGBOY(BIGPT(3)),
     *               BIGBOY(BIGPT(4)), BIGBOY(BIGPT(5)),
     *               BIGBOY(BIGPT(6)), IRET)
                  IF (IRET.GT.0) THEN
                     WRITE (MSGTXT,1370) IRET
                     GO TO 950
                  ELSE IF (IRET.LT.0) THEN
                     GO TO 390
                     END IF
                  PLTYPE = LTYPE
                  PESOFF = RESOFF
                  PLSTOK = LSTOKS
                  PLSMOO = LSMOO
                  PLSCAN = LSCAN
                  PLANT = LANT
C                                       do flagging
                  CLIMIT(1) = FCLIPR(1)
                  CLIMIT(2) = FCLIPR(2)
                  CALL PCFLIP (IMGWIN, CLIMIT, FCBUF2, SCRTCH,
     *               BIGBOY(BIGPT(3)), BIGBOY(BIGPT(4)),
     *               BIGBOY(BIGPT(5)), BIGBOY(BIGPT(6)), IRET)
                  IF (IRET.NE.0) THEN
                     WRITE (MSGTXT,1371) IRET
                     GO TO 950
                     END IF
C                                       reopen uv files
                  CALL ZOPEN (LUN1, FIND1, DISKOU, PHNAME, T, F, T,
     *               IRET)
                  IF (IRET.NE.0) THEN
                     WRITE (MSGTXT,1250) IRET, 'OPEN W'
                     GO TO 950
                     END IF
                  CALL ZOPEN (LUN0, FIND0, DISKOU, PHNAME, T, F, T,
     *               IRET)
                  IF (IRET.NE.0) THEN
                     WRITE (MSGTXT,1250) IRET, 'OPEN R'
                     GO TO 950
                     END IF
                  END IF
               END IF
 390        CONTINUE
C                                       close uv data file
         CALL ZCLOSE (LUN0, FIND0, IERR)
         CALL ZCLOSE (LUN1, FIND1, IERR)
C                                       recover load parms
         LTYPE = DLTYPE
         LSTOKS = DLSTOK
         LSMOO = DLSMOO
         LSCAN = DLSCAN
         LANT = DLANT
         CALL COPY (4, DWIND, IMGWIN)
         STKFLG = DSTKFG
C                                       kill old one
         CALL TABIO ('CLOS', 0, NNFLAG, FCTIME, FCBUF, IERR)
         CALL TABIO ('CLOS', 0, J1, FCTIME, FCBUF2, IERR)
         CALL ZPHFIL ('FC', DISKOU, CNOOUT, FCVERS, PHNAME, IERR)
         CALL ZDESTR (DISKOU, PHNAME, IRET)
         FCVERS = NVER
         GO TO 999
         END IF
      GO TO 900
C                                       TTY error
 850  IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1850) IRET
         CALL MSGWRT (8)
      ELSE IF (IRET.LT.0) THEN
         MSGTXT = 'FORMAT ERROR: RETURN TO MENU'
         CALL MSGWRT (6)
         END IF
C                                       close FC file
 900  CALL TABIO ('CLOS', 0, NNFLAG, FCTIME, FCBUF, IERR)
      GO TO 999
C                                       close 2 FC files on error
 950  CALL MSGWRT (8)
 951  CALL TABIO ('CLOS', 0, NNFLAG, FCTIME, FCBUF, IERR)
      CALL TABIO ('CLOS', 0, J1, FCTIME, FCBUF2, IERR)
C                                       kill new one
      CALL ZPHFIL ('FC', DISKOU, CNOOUT, NVER, PHNAME, IERR)
      CALL ZDESTR (DISKOU, PHNAME, IERR)
      CALL DELEXT ('FC', DISKOU, CNOOUT, 'WRWR', BUFFER, BUFFER(257),
     *   NVER, IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1100 FORMAT ('Enter range of flag commands to display (2 I) from 1 to',
     *   I4)
 1101 FORMAT (8X,'Required',I6,' individual flagging instructions')
 1200 FORMAT ('Enter the',I3,'th flag number to delete <=',I4,
     *   ' (one I), 0 ends list')
 1231 FORMAT ('Deleted',I6,' lines in FC table -',
     *   ' now clear flags in grid file')
 1232 FORMAT ('Dropping',I5,' lines from end of FC table, size now',
     *   I6,' lines')
 1233 FORMAT ('Next flag number changed from',I5,' to',I5)
 1250 FORMAT ('PCFUNF: ERROR',I5,' DOING ',A,' ON MASTER GRID')
 1290 FORMAT ('Restored ',I10,' pixels in the master grid file')
 1310 FORMAT ('Begin by clearing commands >',I4,' from master grid')
 1326 FORMAT ('Restored',I9,' pixels flagged after the lowest undone',
     *   ' command')
 1335 FORMAT ('PCFUNF: GETIME ERROR T1,T2,IYL,IYH=',2(1PE12.4),2I6)
 1365 FORMAT ('New flag command line',I5,' flagged',I6,' pixels')
 1370 FORMAT ('ERROR',I6,' LOADING TV TO REDO CLIP OPERATION')
 1371 FORMAT ('ERROR',I6,' REDOING CLIP OPERATION')
 1850 FORMAT ('TERMINAL ERROR',I5)
      END
      SUBROUTINE PCFCLI (MSGLEV)
C-----------------------------------------------------------------------
C   displays contents of an FC table line on the message file/terminal
C   Inputs:
C      MSGLEV   I   message level to use
C   Common:
C      Must have the FC line in its common
C-----------------------------------------------------------------------
      INTEGER   MSGLEV
C
      INTEGER   IBL1, IBL2, JBL2, IS1, I, NT1, NT2
      REAL      T1, T2
      CHARACTER OP*8, STR*16, CHTYPE(10)*8, CHST(13)*2, REAZON*24,
     *   TS1*20, TS2*20
      HOLLERITH HDUM(4)
      INCLUDE 'PCFLG.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      DATA CHST /'HV','VH','HH','VV', 'LR','RL','LL','RR', '??',
     *   'I','Q','U ','V '/
      DATA CHTYPE /'AMPLTUDE', 'PHASE   ', 'RMS AMPL', 'RMS/MEAN',
     *   'RMS VAMP', 'VRMS/AVG', 'VEC DIFF', 'AMP DIFF', 'PHS DIFF',
     *   '????????'/
C-----------------------------------------------------------------------
      CALL H2CHR (24, 1, FCREAS, REAZON)
      CALL H2CHR (8, 1, FCOPER, OP)
      IF ((OP.NE.'CHANNEL') .AND. (OP.NE.'CLIP')) THEN
         T1 = MAX (START, MIN (STOP, FCTIME(1)))
         CALL TORMAT (T1, TFORM, TS1, NT1)
         T2 = MAX (START, MIN (STOP, FCTIME(2)))
         CALL TORMAT (T2, TFORM, TS2, NT2)
         END IF
      IF ((OP.EQ.'PIXEL') .OR. (OP.EQ.'CHANL-DT')) THEN
         WRITE (MSGTXT,1010) FCNUMB, OP, FCCHAN(1), TS1(:NT1), TS2(:NT2)
      ELSE IF (OP.EQ.'TIME') THEN
         WRITE (MSGTXT,1020) FCNUMB, OP, TS1(:NT1), TS2(:NT2)
      ELSE IF (OP.EQ.'CHANNEL') THEN
         WRITE (MSGTXT,1030) FCNUMB, OP, FCCHAN(1)
      ELSE IF (OP.EQ.'TIMERANG') THEN
         WRITE (MSGTXT,1020) FCNUMB, OP, TS1(:NT1), TS2(:NT2)
      ELSE IF (OP.EQ.'AREA') THEN
         WRITE (MSGTXT,1060) FCNUMB, OP, FCCHAN
         CALL MSGWRT (MSGLEV)
         WRITE (MSGTXT,1061) TS1(:NT1), TS2(:NT2)
      ELSE IF (OP.EQ.'CLIP') THEN
         I = FCTVTY
         IF ((I.LT.1) .OR. (I.GT.9)) I = 10
         WRITE (MSGTXT,1070) FCNUMB, OP, CHTYPE(I), FCLIPR
         CALL MSGWRT (MSGLEV)
         JBL2 = FCTVST + 9
         IF ((JBL2.LT.1) .OR. (JBL2.GT.13)) JBL2 = 9
         IBL2 = FCTVAV + 0.5
         IS1 = SUBARR
         IBL1 = FCTVBL
         WRITE (MSGTXT,1071) CHST(JBL2), FCTVIF, IBL1, IS1, IBL2
         CALL MSGWRT (MSGLEV)
         IF ((I.GE.5) .AND. (I.LE.7)) THEN
            WRITE (MSGTXT,1072) FCTVWI, IBL2
         ELSE
            WRITE (MSGTXT,1073) FCTVWI
            END IF
         END IF
      CALL MSGWRT (MSGLEV)
      WRITE (MSGTXT,1080)
      HDUM(1) = FCSFLG
      CALL H2CHR (4, 1, HDUM, MSGTXT(22:25))
      IF (FCIF(1).LE.0) THEN
         MSGTXT(32:34) = 'All'
      ELSE
         WRITE (STR,1084) FCIF(1), FCIF(2)
         MSGTXT(32:37) = STR(:6)
         END IF
      IF (FCBASL(1).EQ.0) THEN
         MSGTXT(51:) = 'All'
      ELSE
         IS1 = SUBARR
         IBL1 = FCBASL(1)
         WRITE (STR,1083) IBL1, IS1
         MSGTXT(51:) = STR
         END IF
      CALL MSGWRT (MSGLEV)
C                                       source selection
      MSGTXT = ' '
      IF (FCSOUR.LE.0) THEN
         MSGTXT(9:) = 'Flag all sources meeting these criteria'
      ELSE
         MSGTXT(9:) = 'Flag only sources included in this PCFLG'
         END IF
      CALL MSGWRT (MSGLEV)
C                                       reason
      IF ((REAZON.NE.' ') .AND. (REAZON.NE.'PCFLG:date time')) THEN
         MSGTXT = 'Reason = ''' // REAZON // ''''
         CALL MSGWRT (MSGLEV)
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1010 FORMAT (I3,2X,A8,1X,'Ch =',I5,' Time range ',A,' - ',A)
 1020 FORMAT (I3,2X,A8,1X,'All channels at T = ',A,' - ',A)
 1030 FORMAT (I3,2X,A8,1X,'Channel',I5,'  at all times')
 1060 FORMAT (I3,2X,A8,1X,'Channel',I5,'  through channel =',I5)
 1061 FORMAT (14X,' Time range ',A,' - ',A)
 1070 FORMAT (I3,2X,A8,1X,'Type ',A8,' clip range',2(1PE13.5))
 1071 FORMAT (14X,'Based on Stokes ',A2,', IF',I3,', Ant',I3.2,'/',I2.2,
     *   ', Avg',I4,' s')
 1072 FORMAT (23X,'Window',4I6,'   Scan',I4)
 1073 FORMAT (23X,'Window',4I6)
 1080 FORMAT (8X,'Flag: Stokes ',4X,',  IF=',6X,',  Antenna=')
 1083 FORMAT (I3.2,' /',I3.2)
 1084 FORMAT (I3.2,'-',I2.2)
      END
      SUBROUTINE PCFMRK (BUFF1, BUFF2, IRET)
C-----------------------------------------------------------------------
C   Re-writes the PC table applying the FC commands
C   Output:
C      BUFF1    R(*)   scratch
C      BUFF2    R(*)   scratch
C      IRET    I       error code
C-----------------------------------------------------------------------
      INTEGER   IRET
      REAL      BUFF1(*), BUFF2(*)
C
      INCLUDE 'PCFLG.INC'
      INCLUDE 'PCDATA.INC'
      HOLLERITH CATH(256), HDUM(4)
      INTEGER   KIF, KBIF, KEIF, KCH, KBCH, KECH, I, J1, PCLUNI, PCLUNO,
     *   JERR, KEY(2,2), KEYSUB(2,2), PCBUFO(512), IROW, NROW, ANTNUM,
     *   FREQID, KPOL, ISUB, SOUNUM
      REAL      XT1, XT2, CATR(256), FKEY(2,2), TIMINT
      DOUBLE PRECISION CATD(128)
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:PFLG.INC'
      INCLUDE 'INCS:DFLG.INC'
      EQUIVALENCE (CATBLK, CATR, CATD, CATH)
      DATA PCLUNI, PCLUNO /16, 17/
      DATA KEYSUB /4*1/
C-----------------------------------------------------------------------
C                                       sort the FC table
      FGFLAG = 0
      KEY(1,1) = 3
      KEY(1,2) = 0
      KEY(2,1) = 0
      KEY(2,2) = 0
      FKEY(1,1) = 1.0
      FKEY(1,2) = 0.0
      FKEY(2,1) = 0.0
      FKEY(2,2) = 0.0
      CALL COPY (256, CATIMG, CATBLK)
      CALL TABSRT (DISKOU, CNOOUT, 'FC', FCVERS, FCVERS, KEY, KEYSUB,
     *   FKEY, FCBUF, CATBLK, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'SORTING THE FC TABLE'
         GO TO 990
         END IF
C                                       is it multisource
      CALL COPY (256, CATUV, CATBLK)
      CALL UVPGET (JERR)
      CALL PCFCOP (FCLUN, DISKOU, CNOOUT, FCVERS, CATIMG, FCNUMB,
     *   NNFLAG, FCBUF, IRET)
      IF (IRET.NE.0) GO TO 999
C                                       open PC table as read
      CALL PCINI ('READ', PCBUFF, DISKIN, CNOIN, OVER, CATBLK, PCLUNI,
     *   PCROW, PCKOLS, PCNUMV, PCNPOL, PCNIF, NUMTON, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING PC TABLE'
         GO TO 990
         END IF
C                                       open PC table as read
      CALL PCINI ('WRIT', PCBUFO, DISKIN, CNOIN, OVER, CATBLK, PCLUNO,
     *   PCROW, PCKOLS, PCNUMV, PCNPOL, PCNIF, NUMTON, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING PC TABLE'
         GO TO 990
         END IF
      PCBUFO(43) = PCBUFF(43)
      PCBUFO(44) = PCBUFF(44)
C                                       loop through PC table
      NROW = PCBUFF(5)
      DO 100 IROW = 1,NROW
C                                       read a row
         PCROW = IROW
         CALL TABPC ('READ', PCBUFF, PCROW, PCKOLS, PCNUMV, PCNPOL,
     *      TIME, TIMINT, SOUNUM, ANTNUM, ISUB, FREQID, CABCAL, STATE,
     *      PCFREQ, PCREAL, PCIMAG, PCRATE, IRET)
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READING PC TABLE FOR TIMES'
            GO TO 990
            END IF
         IF (IRET.LT.0) GO TO 100
C                                       loop through flags
         DO 80 I = 1,NNFLAG
            CALL TABIO ('READ', 0, I, FCTIME, FCBUF, IRET)
            IF (IRET.LT.0) GO TO 80
            IF (IRET.NE.0) GO TO 999
            XT1 = MAX (FCTIME(1), START-1.0)
            XT2 = MIN (FCTIME(2), STOP+1.0)
            IF ((TIME.LT.XT1) .OR. (TIME.GT.XT2)) GO TO 80
            J1 = FCBASL(1)
            IF ((J1.GT.0) .AND. (J1.NE.ANTNUM)) GO TO 80
            HDUM(1) = FCSFLG
            CALL H2CHR (4, 1, HDUM, USTFLG)
            KBCH = FCCHAN(1)
            KECH = FCCHAN(2)
            IF (KBCH.LE.0) KBCH = 1
            IF (KECH.LT.KBCH) KECH = CHNMAX
            KBIF = FCIF(1)
            KEIF = FCIF(2)
            IF (KBIF.LE.0) THEN
               KBIF = BIF
               KEIF = EIF
            ELSE IF (KEIF.LT.KBIF) THEN
               KEIF = EIF
               END IF
C                                       single baseline descriptor
            DO 70 KPOL = 1,PCNPOL
               IF (USTFLG(KPOL:KPOL).EQ.'1') THEN
                  DO 60 KIF = KBIF,KEIF
                     DO 50 KCH = KBCH,KECH
                        IF ((PCREAL(KPOL,KCH,KIF).NE.FBLANK) .OR.
     *                     (PCIMAG(KPOL,KCH,KIF).NE.FBLANK))
     *                     FGFLAG = FGFLAG + 1
                        PCREAL(KPOL,KCH,KIF) = FBLANK
                        PCIMAG(KPOL,KCH,KIF) = FBLANK
 50                     CONTINUE
 60                  CONTINUE
                  END IF
 70            CONTINUE
 80         CONTINUE
C                                       write the row
         PCROW = IROW
         CALL TABPC ('WRIT', PCBUFO, PCROW, PCKOLS, PCNUMV, PCNPOL,
     *      TIME, TIMINT, SOUNUM, ANTNUM, ISUB, FREQID, CABCAL, STATE,
     *      PCFREQ, PCREAL, PCIMAG, PCRATE, IRET)
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING PC TABLE FOR FLAGGING'
            GO TO 990
            END IF
 100     CONTINUE
      CALL TABIO ('CLOS', 0, NNFLAG, FCTIME, FCBUF, IRET)
      CALL TABPC ('CLOS', PCBUFO, PCROW, PCKOLS, PCNUMV, PCNPOL,
     *   TIME, TIMINT, SOUNUM, ANTNUM, ISUB, FREQID, CABCAL, STATE,
     *   PCFREQ, PCREAL, PCIMAG, PCRATE, IRET)
      CALL TABPC ('CLOS', PCBUFF, PCROW, PCKOLS, PCNUMV, PCNPOL,
     *   TIME, TIMINT, SOUNUM, ANTNUM, ISUB, FREQID, CABCAL, STATE,
     *   PCFREQ, PCREAL, PCIMAG, PCRATE, IRET)
      IRET = 0
      WRITE (MSGTXT,1080) FGFLAG, OVER
      CALL MSGWRT (4)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('ERROR',I5,' ON ',A)
 1080 FORMAT ('Flagged',I12,' pulse-cal values in PC table version',I6)
      END
      SUBROUTINE PCFLHI (BUFF0, BUFF1)
C-----------------------------------------------------------------------
C   PCFLHI adds to the history file of the input UV data set info on
C   what was flagged.  It then removes that flagging info from the
C   flag command file and from the master grid, when these are kept in
C   the image catalog.
C-----------------------------------------------------------------------
      REAL      BUFF0(*), BUFF1(*)
C
      CHARACTER HILINE*72
      INTEGER   HLUNI, IERR, I, I1, I2, PLBL, PIF, J, IANT1, IARR1,
     *   IRET, J2, IROUND, PLSU, LUN0, LUN1, FIND0, FIND1, NCC, KST,
     *   EST, KBASL, KEBASL, IWIN(4), IDEPTH(5), IBLKOF, NX, NY, IB0,
     *   IB1, PLBL2, NCT1, NCT2
      REAL      DTEMP
      LOGICAL   SAVE, T, F
      CHARACTER PHNAME*48, TS1*20, TS2*20
      INCLUDE 'PCFLG.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DHIS.INC'
      DATA HLUNI, LUN0, LUN1 /28, 16, 17/
      DATA SAVE, T, F /2*.TRUE.,.FALSE./
C-----------------------------------------------------------------------
C                                       history only if some flagged
      IF ((NNFLAG.LE.0) .OR. (XDOHST.LE.-9.5)) GO TO 200
      CALL HIINIT (3)
      CALL HIOPEN (HLUNI, DISKIN, CNOIN, BUFFER, IERR)
      IF (IERR.NE.0) GO TO 200
C                                       Task message
      WRITE (HILINE,1000) TSKNAM, RLSNAM, TTIME
      CALL HIADD (HLUNI, HILINE, BUFFER, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       Task parms
      DO 10 I = 1,30
         IF ((SOURCS(I).NE.' ') .AND. ((I.LT.2) .OR.
     *      (SOURCS(I).NE.SOURCS(I-1)))) THEN
            I1 = 1
            IF (SOURCS(I)(1:1).EQ.'-') I1 = 2
            IF (DOSWNT) WRITE (HILINE,1001) TSKNAM, SOURCS(I)(I1:)
            IF (.NOT.DOSWNT) WRITE (HILINE,1002) TSKNAM, SOURCS(I)(I1:)
            CALL HIADD (HLUNI, HILINE, BUFFER, IERR)
            IF (IERR.NE.0) GO TO 100
            END IF
 10      CONTINUE
C                                       start and stop times
      CALL HITIME (START, STOP, HLUNI, BUFFER, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       subarray, IF, chan
      WRITE (HILINE,1015) TSKNAM, SUBARR
      CALL HIADD (HLUNI, HILINE, BUFFER, IERR)
      IF (IERR.NE.0) GO TO 100
      WRITE (HILINE,1016) TSKNAM, BIF, EIF
      CALL HIADD (HLUNI, HILINE, BUFFER, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       calibration tables
      I1 = 1
      IF ((DESEL) .AND. (NXANT.GT.0)) THEN
         WRITE (HILINE,1030) TSKNAM
         CALL HIADD (HLUNI, HILINE, BUFFER, IERR)
         IF (IERR.NE.0) GO TO 100
         END IF
      IF (NXANT.LE.0) THEN
         WRITE (HILINE,1031) TSKNAM
         CALL HIADD (HLUNI, HILINE, BUFFER, IERR)
         IF (IERR.NE.0) GO TO 100
         END IF
 35   I2 = I1 + 12
      IF (I2.GT.NXANT) I2 = NXANT
      IF (I2.GE.I1) THEN
         WRITE (HILINE,1035) TSKNAM, (IXANT(I), I = I1,I2)
         CALL HIADD (HLUNI, HILINE, BUFFER, IERR)
         IF (IERR.NE.0) GO TO 100
         I1 = I2 + 1
         GO TO 35
         END IF
C                                       points included/dropped
      IF (NPOINT.GT.0.0D0) THEN
         WRITE (HILINE,1051) TSKNAM, NPOINT
         CALL HIADD (HLUNI, HILINE, BUFFER, IERR)
         IF (IERR.NE.0) GO TO 100
         END IF
C                                       flagging commands
      WRITE (HILINE,1055) TSKNAM, TSKNAM, TTIME
      CALL HIADD (HLUNI, HILINE, BUFFER, IERR)
      IF (IERR.NE.0) GO TO 100
      WRITE (HILINE,1056) TSKNAM, FGFLAG
      CALL HIADD (HLUNI, HILINE, BUFFER, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       option to list details
      IF (XDOHST.LE.0.0) GO TO 100
      PLBL = -1
      PLBL2 = -1
      PIF = -1
      PLSU = -1
      CALL PCFCOP (FCLUN, DISKOU, CNOOUT, FCVERS, CATIMG, FCNUMB,
     *   NNFLAG, FCBUF, IRET)
      IF (IRET.NE.0) GO TO 100
      DO 80 I = 1,NNFLAG
         CALL TABIO ('READ', 0, I, FCTIME, FCBUF, IRET)
         IF (IRET.LT.0) GO TO 80
         IF (IRET.NE.0) GO TO 100
         J = FCBASL(1)
         J2 = FCBASL(2)
         IF ((J.NE.PLBL) .OR. (J2.NE.PLBL2)) THEN
            IF (J.EQ.0) THEN
               IARR1 = 0
               HILINE = TSKNAM //
     *            'ANT = 0          / All antennas'
            ELSE
               IANT1 = J
               WRITE (HILINE,1062) TSKNAM, IANT1, SUBARR
               END IF
            CALL HIADD (HLUNI, HILINE, BUFFER, IERR)
            IF (IERR.NE.0) GO TO 100
            PLBL = J
            PLBL2 = J2
            END IF
         J = FCIF(1)
         IF (J.NE.PIF) THEN
            WRITE (HILINE,1063) TSKNAM, J, FCIF(2)
            IF (J.LE.0) WRITE (HILINE,1064) TSKNAM
            CALL HIADD (HLUNI, HILINE, BUFFER, IERR)
            IF (IERR.NE.0) GO TO 100
            PIF = J
            END IF
         IF (FCTIME(1).GT.-1.E5) THEN
            DTEMP = MAX (START, MIN (STOP, FCTIME(1)))
            CALL TORMAT (DTEMP, TFORM, TS1, NCT1)
            DTEMP = MAX (START, MIN (STOP, FCTIME(2)))
            CALL TORMAT (DTEMP, TFORM, TS2, NCT2)
            END IF
         IF (FCTIME(1).GT.-1.E5) THEN
            WRITE (HILINE,1067) TSKNAM, FCCHAN, TS1(:NCT1), TS2(:NCT2)
         ELSE
            WRITE (HILINE,1068) TSKNAM, FCCHAN
            END IF
         CALL HIADD (HLUNI, HILINE, BUFFER, IERR)
         IF (IERR.NE.0) GO TO 100
C                                       source number
         J = FCSOUR
         IF (J.NE.PLSU) THEN
            IF (J.GT.0) THEN
               WRITE (HILINE,1075) TSKNAM, J, SNAMES(J)
            ELSE
               WRITE (HILINE,1076) TSKNAM
               END IF
            CALL HIADD (HLUNI, HILINE, BUFFER, IERR)
            IF (IERR.NE.0) GO TO 100
            PLSU = J
            END IF
 80      CONTINUE
      CALL TABIO ('CLOS', 0, NNFLAG, FCTIME, FCBUF, IRET)
C                                       Close HI file
 100  CALL HICLOS (HLUNI, SAVE, BUFFER, IERR)
C                                       Clear FC file
 200  IF ((NNFLAG.GT.0) .AND. (XDOCAT.GT.0.0)) THEN
         MSGTXT = 'Removing applied flags from the master grid file'
         CALL MSGWRT (2)
         CALL PCFCOP (FCLUN, DISKOU, CNOOUT, FCVERS, CATIMG, FCNUMB,
     *      NNFLAG, FCBUF, IRET)
         IF (IRET.EQ.0) THEN
            FCBUF(5) = 0
            CALL TABIO ('CLOS', 0, NNFLAG, FCTIME, FCBUF, IRET)
            END IF
C                                       open master file
         CALL ZPHFIL ('MA', DISKOU, CNOOUT, 1, PHNAME, IRET)
         CALL ZOPEN (LUN1, FIND1, DISKOU, PHNAME, T, F, T, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1200) IRET, 'OPEN W'
            GO TO 900
            END IF
         CALL ZOPEN (LUN0, FIND0, DISKOU, PHNAME, T, F, T, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1200) IRET, 'OPEN R'
            GO TO 900
            END IF
         NCC = 0
         EST = CATIMG(KINAX+2)
         KEBASL = CATIMG(KINAX+3)
         DO 230 KBASL = 1,KEBASL
         DO 229 KST = 1,EST
C                                       init master file
            IWIN(1) = 1
            IWIN(2) = 1
            IWIN(3) = CATIMG(KINAX)
            IWIN(4) = CATIMG(KINAX+1)
            IDEPTH(1) = KST
            IDEPTH(2) = KBASL
            IDEPTH(3) = 1
            IDEPTH(4) = 1
            IDEPTH(5) = 1
            CALL COMOFF (CATIMG(KIDIM), CATIMG(KINAX), IDEPTH, IBLKOF,
     *         IRET)
            IBLKOF = IBLKOF + 1
            CALL MINIT ('READ', LUN0, FIND0, CATIMG(KINAX),
     *         CATIMG(KINAX+1), IWIN, BUFF0, JBUFSZ, IBLKOF, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1200) IRET, 'INIT R'
               GO TO 900
               END IF
            CALL MINIT ('WRIT', LUN1, FIND1, CATIMG(KINAX),
     *         CATIMG(KINAX+1), IWIN, BUFF1, JBUFSZ, IBLKOF, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1200) IRET, 'INIT W'
               GO TO 900
               END IF
            NY = CATIMG(KINAX+1)
            NX = (CATIMG(KINAX) - 3) / 3
            DO 220 J = 1,NY
               CALL MDISK ('READ', LUN0, FIND0, BUFF0, IB0, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1200) IRET, 'READ'
                  GO TO 900
                  END IF
               CALL MDISK ('WRIT', LUN1, FIND1, BUFF1, IB1, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1200) IRET, 'WRITE'
                  GO TO 900
                  END IF
               CALL RCOPY (CATIMG(KINAX), BUFF0(IB0), BUFF1(IB1))
               DO 210 I = 1,NX
                  I1 = IB1 + NUMVAL*(I-1) + 3
                  IF (BUFF1(I1).NE.FBLANK) THEN
                     I2 = IROUND (BUFF1(I1))
                     IF (I2.GT.0) THEN
                        NCC = NCC + 1
                        BUFF1(I1) = FBLANK
                        END IF
                     END IF
 210              CONTINUE
 220           CONTINUE
C                                       finish the writing
            CALL MDISK ('FINI', LUN1, FIND1, BUFF1, IB1, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1200) IRET, 'FINI'
               GO TO 900
               END IF
 229        CONTINUE
 230        CONTINUE
         IF (NCC.LE.0) THEN
            MSGTXT = 'NO PIXELS FULLY REMOVED FROM THE MASTER GRID FILE'
            CALL MSGWRT (6)
         ELSE
            WRITE (MSGTXT,1230) NCC
            CALL MSGWRT (2)
            END IF
         CALL ZCLOSE (LUN0, FIND0, IERR)
         CALL ZCLOSE (LUN1, FIND1, IERR)
         END IF
      GO TO 999
C                                       Error
 900  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT (A6,'RELEASE =''',A7,' ''  /********* Start ',
     *   A9,2X,A8)
 1001 FORMAT (A6,'SOURCES=''',A16,'''',9X,'/ Source name included')
 1002 FORMAT (A6,'SOURCES=''',A16,'''',9X,'/ Source name excluded')
 1015 FORMAT (A6,'SUBARRAY=',I3)
 1016 FORMAT (A6,'BIF=',I4,2X,'EIF=',I4,5X,'/ Range of IF axis')
 1030 FORMAT (A6,'/ All antennas except:')
 1031 FORMAT (A6,'/ All antennas')
 1035 FORMAT (A6,'ANTENNAS=',I3,12(',',I3),',')
 1051 FORMAT (A6,'/ Included',F13.0,' points in the grid')
 1055 FORMAT (A6,'REASON = ''',A5,1X,A9,1X,A8,'''')
 1056 FORMAT (A6,'/ Number FG table records written',I8)
 1062 FORMAT (A6,'ANT =',I3.2,I3.2,10X,'/ Antenna subarray')
 1063 FORMAT (A6,'IF =',I3,' -',I3)
 1064 FORMAT (A6,'IF = 0',10X,'/ All IFs')
 1067 FORMAT (A6,'CHAN =',I5,',',I5,'  TIMERANG= ',A,1X,A)
 1068 FORMAT (A6,'CHAN =',I5,',',I5,
     *   '  TIMERANG=  00/00:00:00,  00/00:00:00')
 1075 FORMAT (A6,'SOURCE =',I5,10X,'/ Source number for ',A)
 1076 FORMAT (A6,'SOURCE =    0',10X,'/ All source numbers')
 1200 FORMAT ('PCFLHI: ERROR',I5,' DOING ',A,' ON MASTER GRID')
 1230 FORMAT ('Removed fully',I10,' pixels from the master grid file')
      END
      SUBROUTINE PCFBOX (IG, IPL, BBLC, BTRC, XYCENT, SCRTCH, IERR)
C-----------------------------------------------------------------------
C   PCFBOX uses a graphics plane to show the user a rectangular box as
C   it is set with the cursor.
C   Inputs:
C      IG      I       graphics plane to use
C      IPL     I       TV grey plane in use
C   Output:
C      BBLC    R(7)    Bottom left corners
C      BTRC    R(7)    Top right corners
C      SCRTCH  I(*)    Scratch buffer: > X dimension (>1280)
C      IERR    I       Error code
C   Common:
C      /MAPHDR/ used - returns TV image header.
C-----------------------------------------------------------------------
      INTEGER   IG, IPL, XYCENT(2), SCRTCH(*), IERR
      REAL      BBLC(7), BTRC(7)
C
      INTEGER   ICH, ITW(3), IL, IX(5), IY(5), QUAD, IBUT, I, JERR,
     *   LTVSC(2), IPOS, NERR, IX0, IY0, LMGCOR(4)
      REAL      PPOS(2), RPOS(2)
      LOGICAL   T, F, DOIT, ONGR
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DTVC.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
C                                       Check inputs
      IERR = 2
      IF ((IG.LT.1) .OR. (IG.GT.NGRAPH)) GO TO 999
C                                       Init
      CALL YWINDO ('READ', WINDTV, IERR)
      IF (IERR.NE.0) THEN
         WINDTV(1) = 1
         WINDTV(2) = 1
         WINDTV(3) = MAXXTV(1)
         WINDTV(4) = MAXXTV(2)
         IERR = 0
         END IF
      CALL COPY (4, CATBLK(IICOR), LMGCOR)
C                                       get image header
      IX0 = (WINDTV(1) + WINDTV(3)) / 2
      IY0 = (WINDTV(2) + WINDTV(4)) / 2
      IF (XYCENT(1).GT.0) IX0 = XYCENT(1)
      IF (XYCENT(2).GT.0) IY0 = XYCENT(2)
      CALL YCREAD (IPL, IX0, IY0, CATBLK, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR
         CALL MSGWRT (8)
         GO TO 999
         END IF
      ICH = NGRAY + IG
      CALL ZTIME (ITW)
C                                       turn on graphics if needed
      LTVSC(1) = TVSCGX
      LTVSC(2) = TVSCGY
      I = 2 ** (NGRAY+IG-1)
      ONGR = MOD (TVLIMG(1)/I, 2) .EQ. 1
      IF (.NOT.ONGR) THEN
         CALL YSLECT ('ONNN', ICH, 0, SCRTCH, IERR)
         IPOS = 1
         IF (IERR.NE.0) GO TO 900
         END IF
      IPOS = 2
C                                       Init BLC of new box
      MSGTXT = 'Set B.L.C. : button A, B, C, or D to change to T.R.C.'
      CALL MSGWRT (1)
      IX(1) = (WINDTV(1) + WINDTV(3)) / 2
      IX(2) = IX(1)
      IX(3) = MAXXTV(1)
      IX(4) = IX(3)
      IX(5) = IX(4)
      IY(1) = MAXXTV(2)
      IY(2) = (WINDTV(2) + WINDTV(4)) / 2
      IY(3) = IY(2)
      IY(4) = IY(2)
      IY(5) = IY(4)
      RPOS(1) = IX(2)
      RPOS(2) = IY(2)
      IL = 1
C                                       No scroll correction
      QUAD = -1
C                                       ON cursor at desired position
 45   PPOS(1) = 0.0
      PPOS(2) = 0.0
      CALL YCURSE ('ONNN', F, T, RPOS, QUAD, IBUT, IERR)
      IF ((IERR.NE.0) .AND. (IERR.NE.2)) GO TO 900
      IF (IERR.EQ.2) CALL YCURSE ('ONNN', F, F, RPOS, QUAD, IBUT, IERR)
      IPOS = 3
      IF (IERR.NE.0) GO TO 900
C                                       Cursor read loop
 50   CALL YCURSE ('READ', F, T, RPOS, QUAD, IBUT, IERR)
         IPOS = 4
         IF (IERR.NE.0) GO TO 900
         IF (RPOS(1).LT.CATBLK(IICOR  )) RPOS(1) = LMGCOR(1)
         IF (RPOS(2).LT.LMGCOR(2)) RPOS(2) = LMGCOR(2)
         IF (RPOS(1).GT.LMGCOR(3)) RPOS(1) = LMGCOR(3)
         IF (RPOS(2).GT.LMGCOR(4)) RPOS(2) = LMGCOR(4)
         CALL DLINTR (RPOS, IBUT, PPOS, ITW, DOIT)
         IF (.NOT.DOIT) GO TO 50
C                                       Erase current box
         CALL IMVECT ('OFFF', ICH, 5, IX(1), IY(1), SCRTCH, IERR)
         IPOS = 5
         IF (IERR.NE.0) GO TO 900
C                                       New corners: bottom
         IF (IL.NE.2) THEN
            IX(1) = RPOS(1) + 0.01
            IX(2) = IX(1)
            IY(2) = RPOS(2) + 0.01
            IY(3) = IY(2)
            IF (IL.EQ.1) THEN
               IY(4) = IY(3)
               IY(5) = IY(4)
            ELSE
               IX(5) = IX(1)
               END IF
C                                       top: regular boxes
         ELSE
            IX(3) = RPOS(1) + 0.81
            IX(4) = IX(3)
            IY(1) = RPOS(2) + 0.81
            IY(4) = IY(1)
            IY(5) = IY(1)
            IX(5) = IX(1)
            END IF
C                                       draw all boxes
         CALL IMVECT ('ONNN', ICH, 5, IX(1), IY(1), SCRTCH, IERR)
         IPOS = 6 + 100
         IF (IERR.NE.0) GO TO 900
C                                       Respond to buttons
         IF (IBUT.EQ.0) GO TO 50
C                                       switch to TRC all buttons
            IF (IL.NE.1) GO TO 80
               IL = 2
               MSGTXT = 'Set T.R.C. : button A or B to repeat'
     *            // ' other corner'
               CALL MSGWRT (1)
               MSGTXT = 'Push C or D to exit'
               CALL MSGWRT (1)
               RPOS(1) = RPOS(1) + 10.0
               RPOS(2) = RPOS(2) + 10.0
               IF (RPOS(1).GT.MAXXTV(1)) RPOS(1) = MAXXTV(1)
               IF (RPOS(2).GT.MAXXTV(2)) RPOS(2) = MAXXTV(2)
               GO TO 45
C                                       switch to other corn, but A
 80         IF (IBUT.LE.2) THEN
               IF (IL.NE.3) THEN
                  IL = 3
                  RPOS(1) = IX(2)
                  RPOS(2) = IY(2)
                  MSGTXT = 'Reset B.L.C. : button A or B to repeat'
     *               // ' other corner'
               ELSE
                  IL = 2
                  RPOS(1) = IX(4)
                  RPOS(2) = IY(4)
                  MSGTXT = 'Reset T.R.C. : button A or B to repeat'
     *               // ' other corner'
                  END IF
               CALL MSGWRT (1)
               MSGTXT = 'Push C or D to exit'
               CALL MSGWRT (1)
               GO TO 45
               END IF
C                                       force real BLC, TRC
         CALL IMVECT ('OFFF', ICH, 5, IX(1), IY(1), SCRTCH, IERR)
         IF (IX(2).GT.IX(4)) THEN
            JERR = IX(2)
            IX(2) = IX(4)
            IX(4) = JERR
            END IF
         IF (IY(2).GT.IY(4)) THEN
            JERR = IY(2)
            IY(2) = IY(4)
            IY(4) = JERR
            END IF
C                                       BLCs with scroll now
         RPOS(1) = IX(2)
         RPOS(2) = IY(2)
         CALL YCUCOR (RPOS, QUAD, BBLC(1), IERR)
         IF (IERR.GT.1) GO TO 900
         IF (IERR.EQ.1) NERR = NERR + 1
C                                       TRC
         RPOS(1) = IX(4)
         RPOS(2) = IY(4)
         CALL YCUCOR (RPOS, QUAD, BTRC(1), IERR)
         IF (IERR.GT.1) GO TO 900
         IF (IERR.EQ.1) NERR = NERR + 1
C                                       correct for BL#, times
      BBLC(1) = BBLC(1) - 3
      BTRC(1) = BTRC(1) - 3
      IERR = 0
C                                       Off cursor, graphics, scroll
C                                       leave graphics on
 900  CALL YCURSE ('OFFF', F, T, RPOS, QUAD, IBUT, JERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1900) IERR, IPOS
         CALL MSGWRT (7)
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('ERROR',I5,' READING TV-IMAGE CATALOG')
 1900 FORMAT ('PCFBOX: ERROR CODE',I7,' AT',I5)
      END
      SUBROUTINE GETIME (T1, T2, IY1, IY2, IERR)
C-----------------------------------------------------------------------
C   finds the Y pixel range in the master grid file corresponding to the
C   time range given
C   Inputs:
C      T1     R   Start time in days
C      T2     R   End time in days
C   Output:
C      IY1    I   First row inside T1 - T2 (>= T1)
C      IY2    I   Last row inside T1 - T2  (<  T2)
C      IERR   I   Error code: 0 => ok
C                    1 => rows not found
C                    2 => between cracks
C-----------------------------------------------------------------------
      REAL      T1, T2
      INTEGER   IY1, IY2, IERR
C
      INTEGER   I, NY, J
      INCLUDE 'PCFLG.INC'
      INCLUDE 'INCS:DHDR.INC'
C-----------------------------------------------------------------------
      IERR = 1
      NY = CATIMG(KINAX+1) + 1
      IF ((T1.GT.MTIMES(NY+1)) .OR. (T2.LT.MTIMES(1))) GO TO 999
C                                       find start
      DO 10 I = 2,NY
         IF (MTIMES(I).GT.T1) GO TO 20
 10      CONTINUE
      I = NY
 20   IY1 = I - 1
      IY2 = I - 1
      IERR = 0
C                                       2 sources same time
      IF (T2.LE.T1) THEN
         IF (MTIMES(IY1).EQ.MTIMES(IY1-1)) THEN
            IY1 = IY1 - 1
            IY2 = IY2 - 1
            END IF
C                                       time advances
      ELSE
         J = IY1 + 1
         NY = NY - 1
         IF (J.LE.NY) THEN
            DO 30 I = J,NY
               IF (MTIMES(I).GE.T2) GO TO 999
               IY2 = I
 30            CONTINUE
            END IF
         END IF
C
 999  RETURN
      END
      SUBROUTINE PCFCOP (LUN, VOL, CNO, VER, CATBLK, FCNUM, LASTR, BUF,
     *   IERR)
C-----------------------------------------------------------------------
C   creates and/or opens for writing (and reading) a specified FC table
C   for Flag Commands from PCFLG
C   Inputs:
C      LUN     I         Logical unit number to use
C      VOL     I         Disk number
C      CNO     I         Catalog number
C   In/out:
C      VER     I         Input: desired version number 0 -> highest
C                           existing or new
C                        Output: that used
C      CATBLK  I(256)    File catalog header block
C   Output:
C      FCNUM   I         Highest current flag command number
C      LASTR   I         Highest current record written
C      BUF     I(512)    Required for later calls to TABIO
C      IERR    I         Error codes from TABINI or TABIO
C-----------------------------------------------------------------------
      INTEGER   LUN, VOL, CNO, VER, CATBLK(256), FCNUM, LASTR,
     *   BUF(512), IERR
C
      INTEGER   IRNO, NKEY, NREC, ITITLE(8), LBUF(256), CCODE(17), NCOL,
     *   RECORD(35), NUMBP
      HOLLERITH HTITLE(8)
      CHARACTER TTITLE*32, CTITLE(17)*8, UNITS(17)*8, TITLE*24
      REAL      RECORR(35)
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      EQUIVALENCE (ITITLE, HTITLE),  (RECORR, RECORD)
      DATA TTITLE /'AIPS PCFLG FLAG COMMAND TABLE   '/
      DATA CTITLE /'FLAGNUMB', 'FLAGOPER', 'FLAGTIME', 'FLAGBL  ',
     *   'FLAGCHAN', 'FLAGIF  ', 'FLAGSTOK', 'FLAGSOUR', 'CLIPRANG',
     *   'TVTYPE  ', 'TVCHAN  ', 'TVIF    ', 'TVSTOKES', 'TVWINDOW',
     *   'TVTIMAVG', 'TVSCAN  ', 'REASON'/
      DATA UNITS /2*' ', 'DAYS', 3*' ', 'BIT MASK', ' ', 'FLUX ',
     *   3*' ', 'STOKES', ' ', 2*'SECONDS ', ' '/
      DATA CCODE /14, 83, 22, 24, 24, 24, 43, 14, 22, 14, 14, 14, 14,
     *   44, 12, 12, 243/
C-----------------------------------------------------------------------
C                                       Init parameters
      NCOL = 17
      NKEY = 1
      NREC = 500
      CALL FILL (256, 0, LBUF)
      CALL COPY (NCOL, CCODE, LBUF(129))
C                                       Version number
      IF (VER.LE.0) CALL FNDEXT ('FC', CATBLK, VER)
C                                       create/open
      CALL TABINI ('WRIT', 'FC', VOL, CNO, VER, CATBLK, LUN, NKEY,
     *   NREC, NCOL, LBUF, BUF, IERR)
C                                       Error
      IF (IERR.GT.0) THEN
         WRITE (MSGTXT,1000) IERR, VER
         CALL MSGWRT (8)
C                                       pre-existing file
      ELSE IF (IERR.EQ.0) THEN
         NUMBP = LBUF(1)
         IF (BUF(5).GT.0) THEN
            CALL TABIO ('READ', 0, BUF(5), RECORR, BUF, IERR)
            FCNUM = RECORD(NUMBP)
            LASTR = BUF(5)
            IF (IERR.GT.0) THEN
               WRITE (MSGTXT,1010) IERR, VER, BUF(5)
               CALL MSGWRT (8)
               END IF
         ELSE
            FCNUM = 0
            LASTR = 0
            END IF
C                                       New file created
      ELSE
         FCNUM = 0
         LASTR = 0
C                                       write column titles
         DO 20 IRNO = 1,NCOL
            TITLE = CTITLE(IRNO)
            CALL CHR2H (24, TITLE, 1, HTITLE)
            CALL TABIO ('WRIT', 3, IRNO, HTITLE, BUF, IERR)
            IF (IERR.NE.0) GO TO 999
 20         CONTINUE
C                                       write units
         DO 30 IRNO = 1,NCOL
            TITLE = UNITS(IRNO)
            CALL CHR2H (24, TITLE, 1, HTITLE)
            CALL TABIO ('WRIT', 4, IRNO, HTITLE, BUF, IERR)
            IF (IERR.NE.0) GO TO 999
 30         CONTINUE
C                                       table title
         CALL CHR2H (32, TTITLE, 1, HTITLE)
         CALL COPY (8, ITITLE, BUF(101))
         END IF
      IERR = MAX (0, IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('ERROR',I5,' OPENING Flag-Command TABLE VERSION',I4)
 1010 FORMAT ('ERROR',I5,' READING Flag-Command TABLE VERSION',I4,
     *   ' RECORD',I8)
      END
      SUBROUTINE DOSTKS (ISTVAL, STKFLG, ISTLO, ISTHI)
C-----------------------------------------------------------------------
C   returns the DO loop limits for the Stokes flag loop on the uv file
C   Not all Stokes in between are necessarily to be accessed.
C   Inputs:
C      ISTVAL   I(4)   Stokes vales of 2 planes of master grid
C      STKFLG   C*4    Flag command string
C   Output:
C      ISTLO    I      Low limit over Stokes axis (0 => none)
C      ISTHI    I      Upper limit of Stokes loop (0 => none)
C-----------------------------------------------------------------------
      INTEGER   ISTVAL(4), ISTLO, ISTHI
      CHARACTER STKFLG*4
C
      LOGICAL   DOIT, DOSTOK
      INTEGER   I
C-----------------------------------------------------------------------
      ISTLO = 0
      ISTHI = 0
      DO 10 I = 1,4
         DOIT = DOSTOK (ISTVAL, STKFLG, I)
         IF (DOIT) THEN
            IF (ISTLO.EQ.0) ISTLO = I
            ISTHI = I
            END IF
 10      CONTINUE
C
 999  RETURN
      END
      LOGICAL FUNCTION DOSTOK (ISTVAL, STKFLG, IST)
C-----------------------------------------------------------------------
C   returns whether the current Stokes flag pattern applies to this
C   stokes axis position
C   Inputs:
C      ISTVAL   I(4)   Stokes values in master file
C      STKFLG   C*4    Flag command string (1's and 0's only)
C      IST      I      Current stokes axis position
C   Output:
C      DOSTOK   L      Current Stokes included in STKFLG ?
C-----------------------------------------------------------------------
      INTEGER   ISTVAL(4), IST
      CHARACTER STKFLG*4
C
      INTEGER   I
C-----------------------------------------------------------------------
      I = ABS (ISTVAL(IST))
      IF (I.GT.4) I = I - 4
      DOSTOK = (I.GT.0) .AND. (STKFLG(I:I).EQ.'1')
C
 999  RETURN
      END
      SUBROUTINE MKSTOK (ISTVAL, USTFLG, STKFLG, IRET)
C-----------------------------------------------------------------------
C   Converts the user's character string for Stokes flag into 1'a and
C   0's if possible and reasonable.  Note that the 1 and 0 string
C   assumes that the first correlator is I, RR, or VV.  Finding the
C   correct flag for the current actual Stokes is done by DOSTOK in
C   IBLED and by the flag routines in the calibration package.
C   Inputs:
C      ISTVAL   I(4)   Stokes values in master file
C      USTFLG   C*4    User's flag command string
C   Output:
C      STKFLG   C*4    Flag command string: 1s and 0s
C      IRET     I      Error code: 0 ok, 1 unrecognized string
C-----------------------------------------------------------------------
      INTEGER   ISTVAL(4), IRET
      CHARACTER USTFLG*4, STKFLG*4
C
      CHARACTER CHSTO1(15)*4, CHSTOI(7)*4, CHSTOR(9)*4, CHSTOX(9)*4
      INTEGER   I
      DATA CHSTO1 /'1000', '0100', '0010', '0001', '1100', '1010',
     *   '1001', '0110', '0101', '0011', '1110', '1101', '1011', '0111',
     *   '1111'/
      DATA CHSTOI /'I', 'Q', 'U', 'V', 'IQU', 'IQUV', 'IV'/
      DATA CHSTOR / 'RR', 'LL', 'RL', 'LR', 'HALF', 'NOLL', 'NORR',
     *   'RRLL', 'RLLR'/
      DATA CHSTOX / 'VV', 'HH', 'VH', 'HV', 'HALF', 'NOHH', 'NOVV',
     *   'VVHH', 'VHHV'/
C-----------------------------------------------------------------------
      IRET = 0
C                                       already 1s and 0s
      DO 10 I = 1,15
         IF (USTFLG.EQ.CHSTO1(I)) THEN
            STKFLG = USTFLG
            GO TO 999
            END IF
 10      CONTINUE
C                                       FULL
      IF (USTFLG.EQ.'FULL') THEN
         STKFLG = '1111'
         GO TO 999
         END IF
C                                       check it out
      IF (ISTVAL(1).GT.0) THEN
         DO 20 I = 1,7
            IF (USTFLG.EQ.CHSTOI(I)) THEN
               STKFLG = CHSTO1(I)
               IF (I.EQ.5) STKFLG = CHSTO1(11)
               IF (I.EQ.6) STKFLG = CHSTO1(15)
               GO TO 999
               END IF
 20         CONTINUE
      ELSE IF (ISTVAL(1).LE.-5) THEN
         DO 30 I = 1,9
            IF (USTFLG.EQ.CHSTOX(I)) THEN
               STKFLG = CHSTO1(I)
               IF (I.EQ.6) STKFLG = CHSTO1(13)
               IF (I.EQ.7) STKFLG = CHSTO1(14)
               IF (I.EQ.8) STKFLG = CHSTO1(5)
               IF (I.EQ.9) STKFLG = CHSTO1(10)
               GO TO 999
               END IF
 30         CONTINUE
      ELSE
         DO 40 I = 1,7
            IF (USTFLG.EQ.CHSTOR(I)) THEN
               STKFLG = CHSTO1(I)
               IF (I.EQ.6) STKFLG = CHSTO1(13)
               IF (I.EQ.7) STKFLG = CHSTO1(14)
               IF (I.EQ.8) STKFLG = CHSTO1(5)
               IF (I.EQ.9) STKFLG = CHSTO1(10)
               GO TO 999
               END IF
 40         CONTINUE
         END IF
      IRET = 1
C
 999  RETURN
      END
      SUBROUTINE CVSTOK (INT, INSTOK, OUT, OUTSTK)
C-----------------------------------------------------------------------
C   converts a Stokes flag mask (0s and 1s) from 1st Stokes type to 2nd
C   Inputs:
C      INT      I     Input type: ICOR0 value
C      INSTOK   C*4   Input stokes flag mask
C      OUT      I     Output type: ICOR0 value for output
C   Outputs:
C     OUTSTK    C*4   Stokes flag mask to use with output type
C-----------------------------------------------------------------------
      INTEGER   INT, OUT
      CHARACTER INSTOK*4, OUTSTK*4
C
C-----------------------------------------------------------------------
      OUTSTK = '0000'
C                                       input I type
      IF (INT.GT.0) THEN
         IF (OUT.GT.0) THEN
            OUTSTK = INSTOK
         ELSE IF (OUT.GE.-4) THEN
            IF (INSTOK(1:1).EQ.'1') OUTSTK(1:2) = '11'
            IF (INSTOK(2:2).EQ.'1') OUTSTK(3:4) = '11'
            IF (INSTOK(3:3).EQ.'1') OUTSTK(3:4) = '11'
            IF (INSTOK(4:4).EQ.'1') OUTSTK(1:2) = '11'
         ELSE
            IF (INSTOK(1:3).NE.'000') OUTSTK(1:2) = '11'
            IF (INSTOK(2:4).NE.'000') OUTSTK(3:4) = '11'
            END IF
C                                       input RR type
      ELSE IF (INT.GE.-4) THEN
         IF (OUT.GT.0) THEN
            IF (INSTOK(1:2).EQ.'11') OUTSTK(1:1) = '1'
            IF ((INSTOK(1:1).EQ.'1') .OR. (INSTOK(2:2).EQ.'1'))
     *         OUTSTK(4:4) = '1'
            IF ((INSTOK(3:3).EQ.'1') .OR. (INSTOK(4:4).EQ.'1'))
     *         OUTSTK(2:3) = '11'
         ELSE IF (OUT.GE.-4) THEN
            OUTSTK = INSTOK
         ELSE
            IF (INSTOK.NE.'0000') OUTSTK = '1111'
            END IF
C                                       input VV type
      ELSE
         IF (OUT.GT.0) THEN
            IF ((INSTOK(1:1).EQ.'1') .OR. (INSTOK(2:2).EQ.'1'))
     *         OUTSTK(1:1) = '1'
            IF ((INSTOK(3:3).EQ.'1') .OR. (INSTOK(4:4).EQ.'1'))
     *         OUTSTK(4:4) = '1'
            IF (INSTOK.NE.'0000') OUTSTK(2:3) = '11'
         ELSE IF (OUT.GE.-4) THEN
            IF (INSTOK.NE.'0000') OUTSTK = '1111'
         ELSE
            OUTSTK = INSTOK
            END IF
         END IF
C
 999  RETURN
      END
      SUBROUTINE PCFWED (DOIT, PLTYPE, IPL, SCRTCH, RBUF, IRET)
C-----------------------------------------------------------------------
C   writes or erases a step wedge from PCFLG's display
C   Inputs:
C      DOWEDG   L      T => write a wedge, f => erase one
C      PLTYPE   I      Type of current TV image: 1 amp, 2 phase, ...
C      IPL      I      TV plane to use
C   Output:
C      SCRTCH   I(*)   Buffer for TV use
C      RBUF     R(*)   Real data buffer
C      IRET     I      Error code: 0 okay, < 0 warning, > 0 quit
C-----------------------------------------------------------------------
      LOGICAL   DOIT
      INTEGER   PLTYPE, IPL, SCRTCH(*), IRET
      REAL      RBUF(*)
C
      INTEGER   IERR, LPL, NROW, NPIX, IX0, IY0, I
      LOGICAL   UNIQUE, ABOVE
      REAL      X, Y
      CHARACTER LINTYP*2, CORTYP(10)*8
      INCLUDE 'INCS:DTVC.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      DATA CORTYP /'AMPLTUDE', 'PHASE   ', 'RMS AMPL', 'RMS/MEAN',
     *   'RMS VAMP', 'RMS/VAVG', 'VEC DIFF', 'AMP DIFF', 'PHS DIFF',
     *   '????????'/
C-----------------------------------------------------------------------
C                                       Write a wedge
      IF (DOIT) THEN
         NROW = 16
         CALL YFIND (NGRAY, 'MA', LPL, UNIQUE, CATBLK, SCRTCH, IERR)
         IF ((IERR.NE.0) .OR. (LPL.NE.IPL)) THEN
            IRET = -1
            IF (IERR.EQ.3) IRET = 3
            WRITE (MSGTXT,1000) IERR
            GO TO 990
            END IF
         IY0 = CATBLK(IICOR+1) - CSIZTV(2)/2. - NROW
         IF (IY0.LT.2) THEN
            IY0 = CATBLK(IICOR+3) + CSIZTV(2)/2. + 0.5
            ABOVE = .TRUE.
         ELSE
            ABOVE = .FALSE.
            END IF
         IF (IY0+NROW.GE.MAXXTV(2)-2) THEN
            IRET = -1
            WRITE (MSGTXT,1005)
            GO TO 990
            END IF
         NPIX = CATBLK(IICOR+2) - CATBLK(IICOR) + 1
         IF (NPIX.LT.128) THEN
            CATBLK(IICOR) = CATBLK(IICOR) - (128 - NPIX) / 2
            IF (CATBLK(IICOR).LT.1) CATBLK(IICOR) = 1
            CATBLK(IICOR+2) = CATBLK(IICOR) + 127
            IF (CATBLK(IICOR+2).GT.MAXXTV(1)) THEN
               CATBLK(IICOR+2) = MAXXTV(1)
               CATBLK(IICOR) = CATBLK(IICOR+2) - 127
               END IF
            NPIX = CATBLK(IICOR+2) - CATBLK(IICOR) + 1
            END IF
         IX0 = CATBLK(IICOR)
         IF (CATR(IRRAN).EQ.CATR(IRRAN+1)) THEN
            CATR(IRRAN) = CATR(IRRAN) - 0.5
            CATR(IRRAN+1) = CATR(IRRAN+1) + 0.5
            END IF
         CATR(KRDMN) = CATR(IRRAN)
         CATR(KRDMX) = CATR(IRRAN+1)
         X = CATR(KRDMN)
         Y = CATR(KRDMX)
         Y = (Y - X) / (NPIX - 1)
         IF (Y.EQ.0.0) CATR(IRRAN) = 0.0
         IF (Y.EQ.0.0) CATR(IRRAN+1) = 10.0
         DO 10 I = 1,NPIX
            RBUF(I) = X + (I-1.0)*Y
 10         CONTINUE
C                                        Scale buffer like image
         CALL H2CHR (2, 1, CATH(IITRA), LINTYP)
         CALL ISCALE (LINTYP, MAXINT, CATR(IRRAN), NPIX, 1, RBUF,
     *      SCRTCH)
C                                       header stuff (non-zero)
         CALL CHR2H (2, 'WE', KHPTYO, CATH(KHPTY))
         LPL = PLTYPE
         IF ((LPL.LT.1) .OR. (LPL.GT.9)) LPL = 10
         CALL CHR2H (8, CORTYP(LPL), 1, CATH(KHCTP))
C                                       Erase a wedge
      ELSE
         CALL YFIND (NGRAY, 'WE', LPL, UNIQUE, CATBLK, SCRTCH, IERR)
         IF ((IERR.NE.0) .OR. (LPL.NE.IPL)) THEN
            IRET = -1
            IF (IERR.EQ.3) IRET = 3
            WRITE (MSGTXT,1100) IERR
            GO TO 990
            END IF
         IY0 = CATBLK(IICOR+1)
         NROW = CATBLK(IICOR+3) - IY0 + 1
         IX0 = CATBLK(IICOR)
         NPIX = CATBLK(IICOR+2) - IX0 + 1
         CALL FILL (NPIX, 0, SCRTCH)
C                                       header stuff (zero)
         CALL RFILL (5, HBLANK, CATH(KHIMN))
         CATBLK(KIIMS) = 0
         CATBLK(IIVOL) = 0
         CATBLK(IICNO) = 0
         CATR(KRDMX) = SCRTCH(NPIX)
         CATR(KRDMN) = SCRTCH(1)
         CATR(IRRAN) = CATR(KRDMN)
         CATR(IRRAN+1) = CATR(KRDMX)
         CALL RFILL (2, HBLANK, CATH(KHBUN))
         CALL RCOPY (2, CATH(KHBUN), CATH(KHCTP))
         CATBLK(KINIT) = 0
         CALL CHR2H (2, 'ZZ', KHPTYO, CATH(KHPTY))
         END IF
C                                       rest of header
      CATBLK(IICOR  ) = IX0
      CATBLK(IICOR+1) = IY0
      CATBLK(IICOR+2) = IX0 + NPIX - 1
      CATBLK(IICOR+3) = IY0 + NROW - 1
      CALL COPY (4, CATBLK(IICOR), CATBLK(IIWIN))
      CATR(KRCRP) = (CATBLK(IICOR) + CATBLK(IICOR+2)) / 2.0
      CATD(KDCRV) = (CATR(KRDMX) + CATR(KRDMN)) / 2.0
      CATR(KRCIC) = (CATR(KRDMX) - CATR(KRDMN)) / (CATBLK(IICOR+2) -
     *   CATBLK(IICOR))
      I = 2 * (KICTPN-1)
      CALL RFILL (I, HBLANK, CATH(KHCTP+2))
      IF (ABOVE) THEN
         CALL CHR2H (4, 'WETT', 1, CATH(KHCTP+I))
      ELSE
         CALL CHR2H (4, 'WEBB', 1, CATH(KHCTP+I))
         END IF
      CATR(KRCIC+1) = 0.0
      CATR(KRCRP+1) = CATBLK(IICOR+1) - 1
      CATD(KDCRV+1) = 0.0
C                                        Load to TV
      IY0 = IY0 - 1
      DO 110 I = 1,NROW
         IY0 = IY0 + 1
         CALL YIMGIO ('WRIT', IPL, IX0, IY0, 0, NPIX, SCRTCH, IERR)
         IF (IERR.GT.0) THEN
            IRET = IERR
            IF (IRET.EQ.2) IRET = -1
            WRITE (MSGTXT,1110) IERR, IY0
            GO TO 990
            END IF
 110     CONTINUE
C                                        Update catalog
      CALL YCWRIT (IPL, CATBLK(IICOR), CATBLK, SCRTCH, IERR)
      GO TO 999
C
 990  CALL MSGWRT (6)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('PCFWED: ERROR FINDING IMAGE IN CATALOG',I5)
 1005 FORMAT ('PCFWED: CAN''T FIT THE WEDGE ON THE TV AROUND THE',
     *   ' CURRENT IMAGE WINDOW')
 1100 FORMAT ('PCFWED: ERROR FINDING WEDGE IN CATALOG',I5)
 1110 FORMAT ('PCFWED: YIMGIO ERROR',I5,' ROW',I5)
      END
      SUBROUTINE PCFLAB (IPL, IMGWIN, SCRTCH, RBUF, IRET)
C-----------------------------------------------------------------------
C   PCFLAB draws labels in graphics plane 4.
C   Inputs:
C      IPL      I      Image plane containing image and wedge
C      IMGWIN   I(4)   BLC,TRC of loaded image
C   Outputs:
C      IRET     I      Error code
C-----------------------------------------------------------------------
      INTEGER   IPL, IMGWIN(4), SCRTCH(*), IRET
      REAL      RBUF(*)
C
      INTEGER   IGR, IERR, CATHDR(256), ILAB, LPL, IY0, IXCRN(4), NX,
     *   IYCRN(4), NY, I, IDX, IYL, IX0, NC, NCTI, NI, IA, I2, NCHAN,
     *   OXCRN(5), OYCRN(5), IXINC, LBIF, LEIF, LBCHAN, LECHAN, IL, IH
      REAL      TEMP
      LOGICAL   UNIQUE, ABOVE, DOGRID, IBELOW
      DOUBLE PRECISION T, DT
      CHARACTER STRING*20
      INCLUDE 'PCFLG.INC'
      INCLUDE 'INCS:DTVC.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DLOC.INC'
      INCLUDE 'INCS:DSEL.INC'
C-----------------------------------------------------------------------
      IRET = 0
      LOCNUM = 1
      IF (NGRAPH.LT.4) GO TO 999
      IGR = 4 + NGRAY
      NCHAN = CHNMAX
      LBIF = (IMGWIN(1) - 1) / NCHAN + BIF
      LEIF = (IMGWIN(3) - 1) / NCHAN + BIF
C                                       turn off
      IF (.NOT.DOLABL) THEN
         CALL YZERO (IGR, IRET)
         GPH4OK = .FALSE.
         CALL YSLECT ('OFFF', IGR, 0, SCRTCH, IRET)
C                                       turn on
      ELSE IF (GPH4OK) THEN
         CALL YSLECT ('ONNN', IGR, 0, SCRTCH, IRET)
C                                       redo
      ELSE
         GPH4OK = .TRUE.
         CALL YZERO (IGR, IRET)
         IF (IRET.GT.0) GO TO 999
         CALL YSLECT ('ONNN', IGR, 0, SCRTCH, IRET)
         IF (IRET.GT.0) GO TO 999
C                                       image header needed now
         CALL YFIND (NGRAY, 'MA', LPL, UNIQUE, CATHDR, SCRTCH, IERR)
         IF ((IERR.NE.0) .OR. (LPL.NE.IPL)) THEN
            IRET = -1
            IF (IERR.EQ.3) IRET = 3
            WRITE (MSGTXT,1000) IERR, 'FINDING IMAGE HEADER FROM TV'
            GO TO 990
            END IF
C                                       wedge label
         IBELOW = .TRUE.
         IF (DOWEDG) THEN
            CALL YFIND (NGRAY, 'WE', LPL, UNIQUE, CATBLK, SCRTCH, IERR)
            IF ((IERR.NE.0) .OR. (LPL.NE.IPL)) THEN
               IRET = -1
               IF (IERR.EQ.3) IRET = 3
               WRITE (MSGTXT,1000) IERR, 'FINDING WEDGE TO LABEL'
               GO TO 990
               END IF
            ABOVE = CATBLK(IICOR+1).GT.CATHDR(IICOR+1)
            IBELOW = ABOVE
C                                       fit?
            IY0 = CATBLK(IICOR+1) - 1.5 * CSIZTV(2)
            IF (ABOVE) IY0 = CATBLK(IICOR+3) + 0.5*CSIZTV(2) + 0.5
            IF ((IY0.LT.1) .OR. (IY0+CSIZTV(2).GT.MAXXTV(2))) THEN
               MSGTXT = 'PCFLAB: NOT ROOM FOR WEDGE LABEL'
               CALL MSGWRT (6)
               GO TO 100
               END IF
            ILAB = 7
            DOGRID = .TRUE.
            LABTYP(LOCNUM) = 0
            IGR = 4
            CALL IAXIS1 (RBUF, ILAB, IGR, 1, DOGRID, IERR)
            END IF
C                                       label image
 100     CALL COPY (256, CATHDR, CATBLK)
         OXCRN(1) = MAX (1, CATBLK(IICOR) - 1)
         OXCRN(2) = MIN (MAXXTV(1), CATBLK(IICOR+2) + 1)
         OXCRN(3) = OXCRN(2)
         OXCRN(4) = OXCRN(1)
         OXCRN(5) = OXCRN(1)
         OYCRN(1) = MAX (1, CATBLK(IICOR+1) - 1)
         OYCRN(2) = OYCRN(1)
         OYCRN(3) = MIN (MAXXTV(2), CATBLK(IICOR+3) + 1)
         OYCRN(4) = OYCRN(3)
         OYCRN(5) = OYCRN(1)
         IGR = 4 + NGRAY
         CALL IMVECT ('ONNN', IGR, 5, OXCRN, OYCRN, SCRTCH, IRET)
         IF ((IRET.NE.0) .AND. (IRET.NE.2)) GO TO 999
C                                       Y axis
         NY = CATBLK(KINAX+1)
         DT = (TIMES(NY) - TIMES(1))
         IF (DT.GT.2.) THEN
            DT = 3600.0D0 * 24.0
            NC = 3
            NI = 1
         ELSE
            DT = DT * 24.0D0
            IF (DT.GT.20.) THEN
               DT = 36000.D0
               NC = 5
               NI = 1
            ELSE IF (DT.GT.3.) THEN
               DT = 3600.D0
               NI = 4
               NC = 5
            ELSE
               DT = DT * 60.D0
               NI = 4
               IF (DT.GT.30) THEN
                  DT = 600.D0
                  NC = 8
               ELSE IF (DT.GT.3.) THEN
                  DT = 60.D0
                  NC = 8
               ELSE
                  DT = DT * 60.D0
                  NC = 11 + 2*TFORM
                  IF (DT.GT.20) THEN
                     DT = 10.0D0
                  ELSE
                     DT = 1.0D0
                     END IF
                  END IF
               END IF
            END IF
C                                       check day number
         IF (NI.GT.1) THEN
            IL = TIMES(1)
            I = TIMES(NY)
            IF ((IL.GT.0) .OR. (I.GT.0)) NI = 1
            END IF
         IX0 = CATBLK(IICOR) - (NC-NI+1.5)*CSIZTV(1)
         DT = DT / (24.0D0 * 3600.0D0)
         I = TIMES(1) / DT + 0.0001
         T = I * DT
         IDX = (CATBLK(IICOR+2) - CATBLK(IICOR)) / 30.0 + 0.5
         IDX = MAX (1, MIN (10, IDX))
         IXCRN(1) = OXCRN(1)
         IXCRN(2) = IXCRN(1) + IDX
         IXCRN(3) = OXCRN(2)
         IXCRN(4) = IXCRN(3) - IDX
         IYL = -1000
 110     T = T + DT
         IF (T.LE.TIMES(NY)) THEN
            DO 120 I = 1,NY-1
               IF ((T.GE.TIMES(I)) .AND. (T.LE.TIMES(I+1))) THEN
                  IYCRN(1) = CATBLK(IICOR+1) + I - 1
                  IYCRN(2) = IYCRN(1)
                  IYCRN(3) = IYCRN(1)
                  IYCRN(4) = IYCRN(1)
                  CALL IMVECT ('ONNN', IGR, 2, IXCRN(1), IYCRN(1),
     *               SCRTCH, IRET)
                  IF ((IRET.NE.0) .AND. (IRET.NE.2)) GO TO 999
                  CALL IMVECT ('ONNN', IGR, 2, IXCRN(3), IYCRN(3),
     *               SCRTCH, IRET)
                  IF ((IRET.NE.0) .AND. (IRET.NE.2)) GO TO 999
                  IF (IX0.GT.CSIZTV(1)/2) THEN
                     TEMP = T
                     CALL TORMAT (TEMP, TFORM, STRING, NCTI)
                     IY0 = IYCRN(1) - CSIZTV(2)/2
                     IF (IY0.GT.IYL+1) THEN
                        IF ((IX0.GE.1) .AND. (IY0.GE.1) .AND.
     *                     (IX0.LE.MAXXTV(1)-(NC-NI+1)*CSIZTV(1)) .AND.
     *                     (IY0.LE.MAXXTV(2)-CSIZTV(2))) THEN
                           CALL IMCHAR (IGR, IX0, IY0, 0, 0,
     *                        STRING(NI:NC), SCRTCH, IRET)
                           IF ((IRET.NE.0) .AND. (IRET.NE.2)) GO TO 999
                           END IF
                        IYL = IY0 + CSIZTV(2)
                        END IF
                     END IF
                  GO TO 110
                  END IF
 120           CONTINUE
            END IF
C                                       X axis
         IY0 = CATBLK(IICOR+1) - 1.5 * CSIZTV(2)
         IF (.NOT.IBELOW) IY0 = CATBLK(IICOR+3) + 0.5 * CSIZTV(2)
         IXINC = CATBLK(IICOR+2) - CATBLK(IICOR)
         IXINC = MAX (1, IXINC)
         IXINC = (CATBLK(IIWIN+2) - CATBLK(IIWIN)) / IXINC
         IXINC = MAX (1, IXINC)
         IF ((IY0.GT.1) .AND. (IY0+CSIZTV(2).LE.MAXXTV(2))) THEN
            IDX = (CATBLK(IICOR+3) - CATBLK(IICOR+1)) / 30.0 + 0.5
            IDX = MAX (1, MIN (10, IDX))
            IYCRN(1) = OYCRN(1)
            IYCRN(2) = IYCRN(1) + IDX
            IYCRN(3) = OYCRN(3)
            IYCRN(4) = IYCRN(3) - IDX
            NX = CATBLK(KINAX)
            IYL = -1000
            IF (NCHAN.GT.600) THEN
               DT = 200
            ELSE IF (NCHAN.GT.300) THEN
               DT = 100
            ELSE IF (NCHAN.GT.60) THEN
               DT = 20
            ELSE
               DT = 10
               END IF
            DO 140 I2 = LBIF,LEIF
               IF (I2.EQ.LBIF) THEN
                  LBCHAN = IMGWIN(1) - (I2-BIF)*NCHAN
               ELSE
                  LBCHAN = 1
                  END IF
               IF (I2.EQ.LEIF) THEN
                  LECHAN = IMGWIN(3) - (LEIF-BIF)*NCHAN
               ELSE
                  LECHAN = CHNMAX
                  END IF
               IA = LBCHAN / DT
               T = IA * DT
               IF (T.LT.LBCHAN) T = T + DT
               T = T - DT
 130           T = T + DT
               IF (T.LE.LECHAN) THEN
                  I = (T - 1 + (I2-BIF) * NCHAN -
     *               (IMGWIN(1)-1)) / IXINC
                  IXCRN(1) = CATBLK(IICOR) + I
                  IXCRN(2) = IXCRN(1)
                  IXCRN(3) = IXCRN(1)
                  IXCRN(4) = IXCRN(1)
                  CALL IMVECT ('ONNN', IGR, 2, IXCRN(1), IYCRN(1),
     *               SCRTCH, IRET)
                  IF ((IRET.NE.0) .AND. (IRET.NE.2)) GO TO 999
                  CALL IMVECT ('ONNN', IGR, 2, IXCRN(3), IYCRN(3),
     *               SCRTCH, IRET)
                  IF ((IRET.NE.0) .AND. (IRET.NE.2)) GO TO 999
                  I = T + 0.1
                  WRITE (STRING,1125) I
                  CALL CHTRIM (STRING, 8, STRING, NI)
                  IX0 = (0.5 - NI) * CSIZTV(1) + IXCRN(1)
                  IF (IX0.GT.IYL) THEN
                     IF ((IX0.GE.1) .AND. (IY0.GE.1) .AND.
     *                  (IX0.LE.MAXXTV(1)-NI*CSIZTV(1)) .AND.
     *                  (IY0.LE.MAXXTV(2)-CSIZTV(2))) THEN
                        CALL IMCHAR (IGR, IX0, IY0, 0, 0, STRING(:NI),
     *                     SCRTCH, IRET)
                        IF ((IRET.NE.0) .AND. (IRET.NE.2)) GO TO 999
                        END IF
                     IYL = IX0 + (NI+1)*CSIZTV(1)
                     END IF
                  GO TO 130
                  END IF
 140           CONTINUE
            IF (BIF.NE.EIF) THEN
               IYCRN(1) = OYCRN(3)
               IYCRN(2) = MIN (MAXXTV(2), IYCRN(1)+3*CSIZTV(2))
               IYCRN(3) = OYCRN(1)
               IYCRN(4) = MAX (1, IYCRN(3)-4*CSIZTV(2))
               IY0 = OYCRN(1) - 3*CSIZTV(2)
               IYL = -1000
               IA = OYCRN(3) + 0.5 * CSIZTV(2) + 0.5
               IF (IA+CSIZTV(2).GE.MAXXTV(2)) IA = 2 * MAXXTV(2)
               IF (DOWEDG) THEN
                  IF (IBELOW) THEN
                     IA = 2 * MAXXTV(2)
                  ELSE
                     IY0 = -1000
                     IA = IA + 1.33 * CSIZTV(2)
                     END IF
                  END IF
               DO 150 I2 = LBIF,LEIF
                  IF (I2.EQ.LBIF) THEN
                     LBCHAN = IMGWIN(1) - (I2-BIF)*NCHAN
                  ELSE
                     LBCHAN = 1
                     END IF
                  IF (I2.EQ.LEIF) THEN
                     LECHAN = IMGWIN(3) - (LEIF-BIF)*NCHAN
                  ELSE
                     LECHAN = CHNMAX
                     END IF
                  IF (I2.NE.LBIF) THEN
                     I = ((I2-BIF) * NCHAN - (IMGWIN(1)-1)) / IXINC
                     IL = I
                     IXCRN(1) = CATBLK(IICOR) + I
                     IXCRN(2) = IXCRN(1)
                     IXCRN(3) = IXCRN(1)
                     IXCRN(4) = IXCRN(1)
                     CALL IMVECT ('ONNN', IGR, 2, IXCRN(1), IYCRN(1),
     *                  SCRTCH, IRET)
                     IF ((IRET.NE.0) .AND. (IRET.NE.2)) GO TO 999
                     CALL IMVECT ('ONNN', IGR, 2, IXCRN(3), IYCRN(3),
     *                  SCRTCH, IRET)
                     IF ((IRET.NE.0) .AND. (IRET.NE.2)) GO TO 999
                  ELSE
                     IL = 1
                     END IF
                  IF (I2.NE.LEIF) THEN
                     I = (CHNMAX-1 + (I2-BIF) * NCHAN -
     *                  (IMGWIN(1)-1)) / IXINC
                     IH = I
                     IXCRN(1) = CATBLK(IICOR) + I
                     IXCRN(2) = IXCRN(1)
                     IXCRN(3) = IXCRN(1)
                     IXCRN(4) = IXCRN(1)
                     CALL IMVECT ('ONNN', IGR, 2, IXCRN(1), IYCRN(1),
     *                  SCRTCH, IRET)
                     IF ((IRET.NE.0) .AND. (IRET.NE.2)) GO TO 999
                     CALL IMVECT ('ONNN', IGR, 2, IXCRN(3), IYCRN(3),
     *                  SCRTCH, IRET)
                     IF ((IRET.NE.0) .AND. (IRET.NE.2)) GO TO 999
                  ELSE
                     IH = (LECHAN - 1 + (I2-BIF) * NCHAN -
     *                  (IMGWIN(1)-1)) / IXINC
                     END IF
                  I = (IH + IL) / 2
                  WRITE (STRING,1125) I2
                  CALL CHTRIM (STRING, 8, STRING, NI)
                  IX0 = -NI * 0.5 * CSIZTV(1) + CATBLK(IICOR) + I
                  IF (IX0.GT.IYL) THEN
                     IF ((IY0.GT.1) .AND. (IY0.LT.MAXXTV(2)-CSIZTV(2)))
     *                  THEN
                        CALL IMCHAR (IGR, IX0, IY0, 0, 0, STRING(:NI),
     *                     SCRTCH, IRET)
                        IF ((IRET.NE.0) .AND. (IRET.NE.2)) GO TO 999
                        END IF
                     IF ((IA.GT.1) .AND. (IA.LT.MAXXTV(2)-CSIZTV(2)))
     *                  THEN
                        CALL IMCHAR (IGR, IX0, IA, 0, 0, STRING(:NI),
     *                     SCRTCH, IRET)
                        IF ((IRET.NE.0) .AND. (IRET.NE.2)) GO TO 999
                        END IF
                     IYL = IX0 + (NI+1)*CSIZTV(1)
                     END IF
 150              CONTINUE
               END IF
            END IF
         END IF
      IRET = 0
      GO TO 999
C
 990  CALL MSGWRT (7)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('PCFLAB: ERROR',I3,' ON ',A)
 1125 FORMAT (I8)
      END
      SUBROUTINE PCFOAD (IPL, IMGWIN, DIMBUF, ABUF, IOBUF, SCRTCH,
     *   SBUFF, SB, NBUFF, BUFF1, BUFF2, BUFF3, IRET)
C-----------------------------------------------------------------------
C   loads the image smoothing across LSMOO times and converting to
C   currently desired type of display
C   Inputs:
C      IPL     I            channel to use
C      IMGWIN  I(4)         window into raw image
C      DIMBUF   I           dimension of SBUFF, NBUFF, 2nd axis of SB -1
C      ABUF     I           dimension of 3rd axis of SB
C      IOBUF    I           dimension of BUFF1, BUFF2, BUFF3
C   Output:
C      SCRTCH   I(*)        scratch buffer
C      SBUFF    R(DIMBUF)   summing buffer
C      SB       R(3,(DIMBUF+1),ABUF)   circular buffer for rolling
C                           window averaging
C      NBUFF    I(DIMBUF)   counting buffer
C      BUFF1    R(IOBUF)    IO buffer
C      BUFF2    R(IOBUF)    IO buffer
C      BUFF3    R(IOBUF)    IO buffer
C      IRET     I           error code: > 0 => TV error, > 100 IO error
C                              = -99 => no valid data found (warning)
C   In/Out: INCLUDE 'PCFLG' - many parameters used
C      returns TIMES(MXTIME) list of times by TV-file row
C   Expected values:
C      DIMBUF = MAXCHA + 10
C      ABUF = 50
C      IOBUF = UVBFSS
C-----------------------------------------------------------------------
      INTEGER   IPL, IMGWIN(4), DIMBUF, ABUF, IOBUF, SCRTCH(*), IRET
      REAL      SBUFF(DIMBUF), SB(3,(DIMBUF+1),ABUF), BUFF1(IOBUF),
     *   BUFF2(IOBUF), BUFF3(IOBUF)
      INTEGER   NBUFF(DIMBUF)
C
      CHARACTER PHNAME*48, CUNITS(2)*8, TRTYP(4)*2
      HOLLERITH CATH(256)
      INTEGER   NX, NY, TVWIN(4), LUN1, LUN2, FIND1, FIND2, I, IZ, NBYT,
     *   IBLKOF, IDEPTH(5), IX, IY, IR, BIND1, BIND2, IWIN(4), IJ, NIN,
     *   COUNT, IERR, IMCORN(4), INC(2), NINY, IROUND, LOOP, NTIMS, I1,
     *   I2, ISOU, LSOU, NBLN, LUN4, FIND4, BIND4, IK, JL, JJ, J, NSB,
     *   NWRIT, NSROWN(2,32768), J1, NS, INLSC, LTRTYP, NCHAN,
     *   CATSAV(256)
      REAL      LBLC(7), LTRC(7), CATR(256), TEMP, TEMP2, TEMP3, RMAX,
     *   RMIN, TIM, LTIM, DELTIM, T1, T2, CONFUN(1001)
      DOUBLE PRECISION CATD(128)
      LOGICAL   T, DOIT
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'PCFLG.INC'
      REAL      IMBUF(8192), IMBUFS(8192)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DTVC.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DUVH.INC'
      EQUIVALENCE (CATBLK, CATR, CATH, CATD)
      DATA T /.TRUE./
      DATA LUN1, LUN2, LUN4 /16,17,18/
      DATA CUNITS /'DEGREES ','RATIO   '/
      DATA TRTYP /'LN','LG','SQ','L2'/
C-----------------------------------------------------------------------
      INLSC = LSCAN
      IF ((ABUF.LT.25) .OR. (DIMBUF.LT.MAXCHA)) THEN
         I = MAXCHA + 10
         WRITE (MSGTXT,1000) ABUF, DIMBUF
         CALL MSGWRT (8)
         IRET = 2
         GO TO 999
         END IF
      MSGTXT = 'First compute the smoothed image of desired type'
      CALL MSGWRT (1)
      CALL COPY (256, CATBLK, CATSAV)
C                                       build catalog header
      DELTIM = (CATIR(KRCIC+1) * LSMOO - 0.0001) / (24. * 3600.)
      CALL COPY (256, CATIMG, CATBLK)
      CATR(KRCRP) = (CATIR(KRCRP)-4)/NUMVAL - IMGWIN(1) + 5.0
      CATR(KRCRP+1) = CATIR(KRCRP+1) - IMGWIN(2) + 1
      CATR(KRCRP+2) = CATIR(KRCRP+2) - LSTOKS + 1
      CATR(KRCRP+3) = 1.0
      CATD(KDCRV+3) = LANT
      CATR(KRCRP+1) = (CATR(KRCRP+1) - 1.) / LSMOO + 1.0 -
     *   (LSMOO-1.)/(2.*LSMOO)
      CATR(KRCIC) = 3.0 * CATIR(KRCIC)
      CATR(KRCIC+1) = CATIR(KRCIC+1) * LSMOO
      LTRTYP = MAX (1, MIN (4, ITRTYP))
      NCHAN = CHNMAX
C                                       compute # rows out
C                                       and pointers to rows
      I1 = IMGWIN(2)
      I2 = IMGWIN(4)
      IF (LSMOO.LE.1) THEN
         NY = 0
         DO 10 I = I1,I2
            NY = NY + 1
            SCRTCH(NY) = I
 10         CONTINUE
C                                       multi-source is messy
      ELSE
         NY = 0
         IZ = 0
         LTIM = -1.E5
         LSOU = -2
         DO 20 I = I1,I2
            ISOU = MSOU(I)
            TIM = MTIMES(I)
            IF (IZ.LE.0) THEN
               NY = NY + 1
               IZ = 1
               SCRTCH(NY) = I
               LSOU = ISOU
               LTIM = TIM
               IF (LSOU.LT.0) THEN
                  NBLN = NBLN + 1
               ELSE
                  NBLN = 0
                  END IF
            ELSE
C                                       if within time and same source
C                                       or blanked source
               IF ((TIM-LTIM.LT.DELTIM) .AND. ((ISOU.EQ.LSOU) .OR.
     *            ((ISOU.LT.0) .AND. (LSOU.GE.0)))) THEN
                  IZ = MOD (IZ + 1, LSMOO)
C                                       skip excess blanks
               ELSE IF ((ISOU.LT.0) .AND. (NBLN.GT.4)) THEN
                  IZ = 1
C                                       new row
               ELSE
                  NY = NY + 1
                  SCRTCH(NY) = I
                  IZ = 1
                  LSOU = ISOU
                  LTIM = TIM
                  IF (LSOU.LT.0) THEN
                     NBLN = NBLN + 1
                  ELSE
                     NBLN = 0
                     END IF
                  END IF
               END IF
 20         CONTINUE
         END IF
      SCRTCH(NY+1) = IMGWIN(4) + 1
C                                       open output file
      CALL ZPHFIL ('SC', SCRVOL(TVFILE), SCRCNO(TVFILE), 1, PHNAME,
     *   IERR)
      CALL ZOPEN (LUN2, FIND2, SCRVOL(TVFILE), PHNAME, T, T, T, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1010) 'OPEN', 'OUTPUT TV', IERR
         GO TO 990
         END IF
C                                       open smoothed file
      IF (LTYPE.GT.6) THEN
         CALL ZPHFIL ('SC', SCRVOL(SCFILE), SCRCNO(SCFILE), 1, PHNAME,
     *      IERR)
         CALL ZOPEN (LUN4, FIND4, SCRVOL(SCFILE), PHNAME, T, T, T, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1010) 'OPEN', 'INPUT SMOOTHED', IERR
            GO TO 990
            END IF
         END IF
C                                       open input file
      CALL ZPHFIL ('MA', DISKOU, CNOOUT, 1, PHNAME, IERR)
      CALL ZOPEN (LUN1, FIND1, DISKOU, PHNAME, T, T, T, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1010) 'OPEN', 'INPUT MASTER', IERR
         GO TO 990
         END IF
C                                       input dimensions
      NX = IMGWIN(3) - IMGWIN(1) + 1
      NINY = IMGWIN(4) - IMGWIN(2) + 1
      NBYT = 2 * IOBUF
      IDEPTH(1) = LSTOKS
      IDEPTH(2) = LANT
      IDEPTH(3) = 1
      IDEPTH(4) = 1
      IDEPTH(5) = 1
      IBLKOF = 1
C                                       write smoothed file
      IF (LTYPE.GT.6) THEN
C                                       list of rows for smooth
 100     LSCAN = MAX (LSCAN, LSMOO+2)
         JJ = LSCAN - LSMOO
         TEMP = CATIR(KRCIC+1) * JJ / (24. * 3600.)
         DO 120 IY = 1,NY
            I1 = SCRTCH(IY)
            I2 = SCRTCH(IY+1) - 1
            NS = MSOU(I1)
            T1 = MTIMES(I1) - TEMP
            T2 = MTIMES(I2+1) + TEMP
            DO 105 J = 1,JJ
               IF (MTIMES(I1-J).LT.T1) GO TO 106
               IF ((MSOU(I1-J).NE.NS) .AND. (MSOU(I1-J).GE.0)) GO TO 106
 105           CONTINUE
            J = JJ + 1
 106        NSROWN(1,IY) = I1 - J + 1
            DO 110 J = 1,JJ
               IF (MTIMES(I2+J).GT.T2) GO TO 111
               IF ((MSOU(I2+J).NE.NS) .AND. (MSOU(I2+J).GE.0)) GO TO 111
 110           CONTINUE
            J = JJ + 1
 111        NSROWN(2,IY) = I2 + J - 1
 115        IF (NSROWN(2,IY)-NSROWN(1,IY)+1.LE.LSCAN) GO TO 120
               NSROWN(2,IY) = NSROWN(2,IY) - 1
               IF (NSROWN(2,IY)-NSROWN(1,IY)+1.LE.LSCAN) GO TO 120
                  NSROWN(1,IY) = NSROWN(1,IY) + 1
                  GO TO 115
 120        CONTINUE
C                                       check that buffers will hold
         JL = 0
         DO 130 IY = 1,NY
            J1 = IY + 1
            DO 125 J = J1,NY
               IF (NSROWN(2,IY)-NSROWN(1,J).GE.0) THEN
                  JL = MAX (JL, J-IY)
               ELSE
                  GO TO 130
                  END IF
 125           CONTINUE
 130        CONTINUE
         JL = JL + 1
         IF (JL.GT.ABUF) THEN
            I = LSCAN - JL + ABUF
            IF (I.LT.LSMOO+2) THEN
               WRITE (MSGTXT,1130) LSMOO, LSCAN
               CALL MSGWRT (6)
               IRET = -99
               CALL ZCLOSE (LUN1, FIND1, IERR)
               CALL ZCLOSE (LUN2, FIND2, IERR)
               CALL ZCLOSE (LUN4, FIND4, IERR)
               GO TO 999
               END IF
            LSCAN = I
            GO TO 100
            END IF
         WRITE (MSGTXT,1131) LSCAN
         CALL MSGWRT (2)
         MSGTXT = 'This was reduced due to memory limitations'
         IF (INLSC.GT.LSCAN) CALL MSGWRT (2)
C                                       windows
         NSB = 3 * NX + 3
         CATBLK(KINAX) = NSB
         CATBLK(KINAX+1) = NY
         CATBLK(KINAX+2) = 1
         CATBLK(KINAX+3) = 1
         CATBLK(KINAX+4) = 1
         TVWIN(1) = 1
         TVWIN(2) = 1
         TVWIN(3) = NSB
         TVWIN(4) = NY
         IWIN(1) = 1
         IWIN(2) = MAX (1, NSROWN(1,1))
         IWIN(3) = NUMVAL * IMGWIN(3) + 3
         IWIN(4) = MIN (CATIMG(KINAX+1), NSROWN(2,NY))
         NINY = IWIN(4) - IWIN(2) + 1
C                                       init the IO
         CALL MINIT ('WRIT', LUN4, FIND4, TVWIN(3), NY, TVWIN, BUFF3,
     *      NBYT, IBLKOF, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1010) 'INIT', 'OUTPUT SMOOTHED', IERR
            GO TO 990
            END IF
C                                       init IO from input
         CALL COMOFF (CATIMG(KIDIM), CATIMG(KINAX), IDEPTH, IBLKOF,
     *      IERR)
         IBLKOF = IBLKOF + 1
         CALL MINIT ('READ', LUN1, FIND1, CATIMG(KINAX),
     *      CATIMG(KINAX+1), IWIN, BUFF1, NBYT, IBLKOF, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1010) 'INIT', 'INPUT MASTER', IERR
            GO TO 990
            END IF
C                                       init circular buffers
         DO 135 IY = 1,ABUF
            CALL RFILL (NSB, 0.0, SB(1,1,IY))
 135        CONTINUE
         NWRIT = 1
         JL = 1
C                                       read input master grid loop
         DO 160 IY = 1,NINY
            IK = IY - 1 + IWIN(2)
            CALL MDISK ('READ', LUN1, FIND1, BUFF1, BIND1, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1010) 'READ', 'INPUT MASTER', IERR, IK
               GO TO 990
               END IF
C                                       any buffers done?
 140        IF (IK.GT.NSROWN(2,NWRIT)) THEN
C                                       "write" row
               CALL MDISK ('WRIT', LUN4, FIND4, BUFF3, BIND4, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1010) 'WRITE', 'OUTPUT SMOOTH', IERR,
     *               NWRIT
                  GO TO 990
                  END IF
C                                       move data to out buffer
               CALL RCOPY (NSB, SB(1,1,JL), BUFF3(BIND4))
               CALL RFILL (NSB, 0.0, SB(1,1,JL))
               NWRIT = NWRIT + 1
C                                       advance row
               IF (NWRIT.GT.NY) GO TO 180
               JL = MOD (JL, ABUF) + 1
               GO TO 140
               END IF
C                                       add into buffers
            DO 155 J = 1,ABUF
               J1 = NWRIT + J - 1
               IF ((IK.GE.NSROWN(1,J1)) .AND. (IK.LE.NSROWN(2,J1))) THEN
                  JJ = JL + J - 1
                  IF (JJ.GT.ABUF) JJ = JJ - ABUF
                  IZ = NUMVAL*(IMGWIN(1)-1) + 3 + BIND1
C                                       scalar average
                  IF (LTYPE.EQ.8) THEN
                     DO 145 IX = 1,NX
                        IF (BUFF1(IZ).EQ.0.0) THEN
                           IJ = IX + 1
                           TEMP = BUFF1(IZ+1+RESOFF)*BUFF1(IZ+1+RESOFF)
     *                        + BUFF1(IZ+2+RESOFF)*BUFF1(IZ+2+RESOFF)
                           SB(1,IJ,JJ) = SB(1,IJ,JJ) + SQRT (TEMP)
                           SB(3,IJ,JJ) = SB(3,IJ,JJ) + 1.0
                           END IF
                        IZ = IZ + NUMVAL
 145                    CONTINUE
C                                       vector average
                  ELSE
                     DO 150 IX = 1,NX
                        IF (BUFF1(IZ).EQ.0.0) THEN
                           IJ = IX + 1
                           SB(1,IJ,JJ) = SB(1,IJ,JJ) +BUFF1(IZ+1+RESOFF)
                           SB(2,IJ,JJ) = SB(2,IJ,JJ) +BUFF1(IZ+2+RESOFF)
                           SB(3,IJ,JJ) = SB(3,IJ,JJ) + 1.0
                           END IF
                        IZ = IZ + NUMVAL
 150                    CONTINUE
                     END IF
                  END IF
 155           CONTINUE
 160        CONTINUE
C                                       more rows to run to output
 170     IF (NWRIT.GT.NY) GO TO 180
C                                       "write" row
            CALL MDISK ('WRIT', LUN4, FIND4, BUFF3, BIND4, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1010) 'WRITE', 'OUTPUT SMOOTH', IERR,
     *            NWRIT
               GO TO 990
               END IF
C                                       move data to out buffer
            CALL RCOPY (NSB, SB(1,1,JL), BUFF3(BIND4))
            NWRIT = NWRIT + 1
C                                       advance row
            JL = MOD (JL, ABUF) + 1
            GO TO 170
C                                       last flush
 180     CALL MDISK ('FINI', LUN4, FIND4, BUFF3, BIND4, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1010) 'FINISH', 'OUTPUT SMOOTH', IERR, NWRIT
            GO TO 990
            END IF
C                                       end smoothing
         END IF
C                                       final output windows
      IBLKOF = 1
      CATBLK(KINAX) = NX + 3
      CATBLK(KINAX+1) = NY
      CATBLK(KINAX+2) = 1
      CATBLK(KINAX+3) = 1
      CATBLK(KINAX+4) = 1
      TVWIN(1) = 1
      TVWIN(2) = 1
      TVWIN(3) = NX + 3
      TVWIN(4) = NY
      IWIN(1) = 1
      IWIN(2) = IMGWIN(2)
      IWIN(3) = NUMVAL * IMGWIN(3) + 3
      IWIN(4) = IMGWIN(4)
C                                       init IO to output
      CALL MINIT ('WRIT', LUN2, FIND2, TVWIN(3), NY, TVWIN, BUFF2, NBYT,
     *   IBLKOF, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1010) 'INIT', 'OUTPUT TV', IERR
         GO TO 990
         END IF
      IF (LTYPE.GT.6) THEN
         TVWIN(3) = (TVWIN(3) - 2) * 3
         CALL MINIT ('READ', LUN4, FIND4, TVWIN(3), NY, TVWIN, BUFF3,
     *      NBYT, IBLKOF, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1010) 'INIT', 'INPUT SMOOTHED', IERR
            GO TO 990
            END IF
         END IF
C                                       init IO from input
      CALL COMOFF (CATIMG(KIDIM), CATIMG(KINAX), IDEPTH, IBLKOF, IERR)
      IBLKOF = IBLKOF + 1
      CALL MINIT ('READ', LUN1, FIND1, CATIMG(KINAX), CATIMG(KINAX+1),
     *   IWIN, BUFF1, NBYT, IBLKOF, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1010) 'INIT', 'INPUT MASTER', IERR
         GO TO 990
         END IF
C                                       loop over output rows
      RMAX = -1.E10
      RMIN = 1.E10
      NIN = 0
      IF (LCSMOT.NE.CSMOTH) CONFUN(1) = -1.
      DO 800 IY = 1,NY
C                                       "write" row
         CALL MDISK ('WRIT', LUN2, FIND2, BUFF2, BIND2, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1010) 'WRITE', 'OUTPUT TV', IERR, IY
            GO TO 990
            END IF
C                                       get smoothed row
         IF (LTYPE.GT.6) THEN
            CALL MDISK ('READ', LUN4, FIND4, BUFF3, BIND4, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1010) 'WRITE', 'OUTPUT TV', IERR, IY
               GO TO 990
               END IF
            END IF
C                                       Zero accumulators
         BUFF2(BIND2) = 0.0
         BUFF2(BIND2+NX+1) = 0.0
         BUFF2(BIND2+NX+2) = 0.0
         NTIMS = 0
         IF ((LTYPE.EQ.5) .OR. (LTYPE.EQ.6)) THEN
            DO 550 LOOP = 1,NX
               BUFF2(BIND2+LOOP) = 0.0
               SBUFF(LOOP) = 0.0
               NBUFF(LOOP) = 0
               IMBUF(LOOP) = 0.0
               IMBUFS(LOOP) = 0.0
 550           CONTINUE
         ELSE
            DO 551 LOOP = 1,NX
               BUFF2(BIND2+LOOP) = 0.0
               SBUFF(LOOP) = 0.0
               NBUFF(LOOP) = 0
 551           CONTINUE
            END IF
C                                       loop over rows in sum
         LSOU = -2
         I1 = SCRTCH(IY)
         I2 = SCRTCH(IY+1) - 1
         DO 600 IR = I1,I2
            NIN = NIN + 1
            CALL MDISK ('READ', LUN1, FIND1, BUFF1, BIND1, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1010) 'READ', 'INPUT MASTER', IERR, IR
               GO TO 990
               END IF
C                                       Source number
            IF (BUFF1(BIND1).NE.FBLANK) THEN
               ISOU = IROUND (BUFF1(BIND1))
            ELSE
               ISOU = -1
               END IF
            IF (LSOU.LT.0) LSOU = ISOU
            BUFF2(BIND2) = LSOU
C                                       time
            IF (BUFF1(BIND1+1).NE.FBLANK) THEN
               IF (NTIMS.LE.0) THEN
                  BUFF2(BIND2+1) = BUFF1(BIND1+1)
                  BUFF2(BIND2+2) = BUFF1(BIND1+2)
               ELSE
                  BUFF2(BIND2+1) = MIN (BUFF2(BIND2+1),
     *               BUFF1(BIND1+1))
                  BUFF2(BIND2+2) = MAX (BUFF2(BIND2+2),
     *               BUFF1(BIND1+2))
                  END IF
               NTIMS = NTIMS + 1
               END IF
C                                       sum row
            IZ = NUMVAL*(IMGWIN(1)-1) + 3 + BIND1
C                                       Data in antenna order
C                                       RMS values
      INCLUDE 'INCS:ZVND.INC'
            IF ((LTYPE.EQ.3) .OR. (LTYPE.EQ.4)) THEN
               DO 560 IX = 1,NX
                  IF (BUFF1(IZ).EQ.0.0) THEN
                     IJ = BIND2 + IX + 2
                     NBUFF(IX) = NBUFF(IX) + 1
                     TEMP = BUFF1(IZ+1+RESOFF)*BUFF1(IZ+1+RESOFF) +
     *                  BUFF1(IZ+2+RESOFF)*BUFF1(IZ+2+RESOFF)
                     BUFF2(IJ) = BUFF2(IJ) + SQRT(TEMP)
                     SBUFF(IX) = SBUFF(IX) + TEMP
                     END IF
                  IZ = IZ + NUMVAL
 560              CONTINUE
C                                       Vector RMS values
            ELSE IF ((LTYPE.EQ.5) .OR. (LTYPE.EQ.6)) THEN
      INCLUDE 'INCS:ZVND.INC'
               DO 565 IX = 1,NX
                  IF (BUFF1(IZ).EQ.0.0) THEN
                     IJ = BIND2 + IX + 2
                     NBUFF(IX) = NBUFF(IX) + 1
                     BUFF2(IJ) = BUFF2(IJ) + BUFF1(IZ+1+RESOFF)
                     SBUFF(IX) = SBUFF(IX) + BUFF1(IZ+1+RESOFF) *
     *                  BUFF1(IZ+1+RESOFF)
                     IMBUF(IX) = IMBUF(IX) + BUFF1(IZ+2+RESOFF)
                     IMBUFS(IX) = IMBUFS(IX) + BUFF1(IZ+2+RESOFF) *
     *                  BUFF1(IZ+2+RESOFF)
                     END IF
                  IZ = IZ + NUMVAL
 565              CONTINUE
C                                       other data types
            ELSE
      INCLUDE 'INCS:ZVND.INC'
               DO 570 IX = 1,NX
                  IF (BUFF1(IZ).EQ.0.0) THEN
                     IJ = BIND2 + IX + 2
                     NBUFF(IX) = NBUFF(IX) + 1
                     BUFF2(IJ) = BUFF2(IJ) + BUFF1(IZ+1+RESOFF)
                     SBUFF(IX) = SBUFF(IX) + BUFF1(IZ+2+RESOFF)
                     END IF
                  IZ = IZ + NUMVAL
 570              CONTINUE
               END IF
 600        CONTINUE
C                                       average and convert:
         IJ = BIND2 + 3
         IK = BIND4 + 3
         IF (IY.LE.32768) THEN
            IF (NTIMS.GT.0) THEN
               TIMES(IY) = BUFF2(BIND2+1)
               MINTS(IY) = BUFF2(BIND2+2)
            ELSE IF (IY.GT.1) THEN
               BUFF2(BIND2+1) = TIMES(IY)
               MINTS(IY) = 2.0 * CATR(KRCIC+1) / (24. * 3600.)
            ELSE
               TIMES(IY) = START - CATR(KRCIC+1) / (24. * 3600. * 2.)
               MINTS(IY) = 2 * CATR(KRCIC+1) / (24. * 3600. * 2.)
               END IF
         ELSE
            IF (NTIMS.LE.0) THEN
               TEMP = TIMES(32768) + CATR(KRCIC+1) * (IY - 32768.) /
     *            (24. * 3600.)
               BUFF2(BIND2+1) = TEMP
               BUFF2(BIND2+2) = TEMP + CATR(KRCIC+1) / (24. * 3600.)
               END IF
            END IF
C                                       Amplitude
         IF (LTYPE.EQ.1) THEN
      INCLUDE 'INCS:ZVND.INC'
            IF (TYPUVD.LE.0) THEN
               DO 650 IX = 1,NX
                  IF (NBUFF(IX).GT.0) THEN
                     COUNT = MAX (1, NBUFF(IX))
                     BUFF2(IJ) = SQRT (BUFF2(IJ)*BUFF2(IJ) +
     *                  SBUFF(IX)*SBUFF(IX)) / COUNT
                  ELSE
                     BUFF2(IJ) = FBLANK
                     END IF
                  IJ = IJ + 1
 650              CONTINUE
            ELSE
      INCLUDE 'INCS:ZVND.INC'
               DO 655 IX = 1,NX
                  IF (NBUFF(IX).GT.0) THEN
                     COUNT = MAX (1, NBUFF(IX))
                     BUFF2(IJ) = BUFF2(IJ) / COUNT
                  ELSE
                     BUFF2(IJ) = FBLANK
                     END IF
                  IJ = IJ + 1
 655              CONTINUE
               END IF
C                                        phase
         ELSE IF (LTYPE.EQ.2) THEN
            LTRTYP = 1
      INCLUDE 'INCS:ZVND.INC'
            DO 670 IX = 1,NX
               IF ((BUFF2(IJ).NE.0.0) .OR. (SBUFF(IX).NE.0.0)) THEN
                  BUFF2(IJ) = ATAN2 (SBUFF(IX), BUFF2(IJ)) * 57.29578
               ELSE
                  BUFF2(IJ) = FBLANK
                  END IF
               IJ = IJ + 1
 670           CONTINUE
C                                       RMS
      INCLUDE 'INCS:ZVND.INC'
         ELSE IF (LTYPE.EQ.3) THEN
            DO 680 IX = 1,NX
               IF (NBUFF(IX).GT.1) THEN
                  TEMP2 = BUFF2(IJ) / NBUFF(IX)
                  SBUFF(IX) = SBUFF(IX) / NBUFF(IX)
                  BUFF2(IJ) = SQRT (MAX (0.0, SBUFF(IX) - TEMP2*TEMP2))
               ELSE
                  IF (NBUFF(IX).EQ.1) THEN
                     BUFF2(IJ) = 0.0
                  ELSE
                     BUFF2(IJ) = FBLANK
                     END IF
                  END IF
               IJ = IJ + 1
 680           CONTINUE
C                                       Vector RMS
         ELSE IF (LTYPE.EQ.5) THEN
      INCLUDE 'INCS:ZVND.INC'
            DO 690 IX = 1,NX
               IF (NBUFF(IX).GT.1) THEN
                  BUFF2(IJ) = BUFF2(IJ) / NBUFF(IX)
                  SBUFF(IX) = SBUFF(IX) / NBUFF(IX)
                  IMBUF(IX) = IMBUF(IX) / NBUFF(IX)
                  IMBUFS(IX) = IMBUFS(IX) /NBUFF(IX)
                  TEMP2 = BUFF2(IJ)
                  BUFF2(IJ) = SBUFF(IX) - TEMP2*TEMP2 + IMBUFS(IX) -
     *               IMBUF(IX)*IMBUF(IX)
                  BUFF2(IJ) = SQRT (MAX (0.0, BUFF2(IJ)))
               ELSE
                  IF (NBUFF(IX).EQ.1) THEN
                     BUFF2(IJ) = 0.0
                  ELSE
                     BUFF2(IJ) = FBLANK
                     END IF
                  END IF
               IJ = IJ + 1
 690           CONTINUE
C                                       RMS / mean
         ELSE IF (LTYPE.EQ.4) THEN
      INCLUDE 'INCS:ZVND.INC'
            DO 700 IX = 1,NX
               IF (NBUFF(IX).GT.1) THEN
                  TEMP2 = BUFF2(IJ) / NBUFF(IX)
                  SBUFF(IX) = SBUFF(IX) / NBUFF(IX)
                  IF (ABS (TEMP2).LT.1.0E-10) TEMP2 = 1.0
                  TEMP3 = SBUFF(IX) / (TEMP2*TEMP2) - 1.0
                  BUFF2(IJ) = SQRT (MAX (0.0, TEMP3))
               ELSE
                  IF (NBUFF(IX).EQ.1) THEN
                     BUFF2(IJ) = 0.0
                  ELSE
                     BUFF2(IJ) = FBLANK
                     END IF
                  END IF
               IJ = IJ + 1
 700           CONTINUE
C                                       RMS / mean
         ELSE IF (LTYPE.EQ.6) THEN
      INCLUDE 'INCS:ZVND.INC'
            DO 710 IX = 1,NX
               IF (NBUFF(IX).GT.1) THEN
                  BUFF2(IJ) = BUFF2(IJ) / NBUFF(IX)
                  SBUFF(IX) = SBUFF(IX) / NBUFF(IX)
                  IMBUF(IX) = IMBUF(IX) / NBUFF(IX)
                  IMBUFS(IX) = IMBUFS(IX) /NBUFF(IX)
                  TEMP2 = BUFF2(IJ) * BUFF2(IJ) + IMBUF(IX) * IMBUF(IX)
                  BUFF2(IJ) = SBUFF(IX) + IMBUFS(IX) - TEMP2
                  IF (TEMP2.LT.1.E-10) TEMP2 = 1.0
                  BUFF2(IJ) = SQRT (MAX (0.0, BUFF2(IJ)/TEMP2))
               ELSE
                  IF (NBUFF(IX).EQ.1) THEN
                     BUFF2(IJ) = 0.0
                  ELSE
                     BUFF2(IJ) = FBLANK
                     END IF
                  END IF
               IJ = IJ + 1
 710           CONTINUE
C                                       Vector amplitude difference
      INCLUDE 'INCS:ZVND.INC'
         ELSE IF (LTYPE.EQ.7) THEN
            DO 720 IX = 1,NX
               IF ((NBUFF(IX).GT.0) .AND. (BUFF3(IK+2).GT.0.0)) THEN
                  COUNT = MAX (1, NBUFF(IX))
                  TEMP = BUFF2(IJ) / COUNT - BUFF3(IK) / BUFF3(IK+2)
                  TEMP2 = SBUFF(IX) / COUNT - BUFF3(IK+1) / BUFF3(IK+2)
                  BUFF2(IJ) = SQRT (TEMP*TEMP + TEMP2*TEMP2)
               ELSE
                  BUFF2(IJ) = FBLANK
                  END IF
               IJ = IJ + 1
               IK = IK + 3
 720        CONTINUE
C                                       Amplitude difference
      INCLUDE 'INCS:ZVND.INC'
         ELSE IF (LTYPE.EQ.8) THEN
            DO 730 IX = 1,NX
               IF ((NBUFF(IX).GT.0) .AND. (BUFF3(IK+2).GT.0.0)) THEN
                  COUNT = MAX (1, NBUFF(IX))
                  TEMP = SQRT (BUFF2(IJ)*BUFF2(IJ) +
     *               SBUFF(IX)*SBUFF(IX)) / COUNT -
     *               BUFF3(IK) / BUFF3(IK+2)
                  BUFF2(IJ) = ABS (TEMP)
               ELSE
                  BUFF2(IJ) = FBLANK
                  END IF
               IJ = IJ + 1
               IK = IK + 3
 730        CONTINUE
C                                       phase
         ELSE IF (LTYPE.EQ.9) THEN
            LTRTYP = 1
      INCLUDE 'INCS:ZVND.INC'
            DO 740 IX = 1,NX
               IF ((NBUFF(IX).GT.0) .AND. (BUFF3(IK+2).GT.0.0)) THEN
                  TEMP = 0.0
                  IF ((BUFF3(IK).NE.0.0) .OR. (BUFF3(IK+1).NE.0.0))
     *               TEMP = ATAN2 (BUFF3(IK+1), BUFF3(IK))
                  TEMP2 = 0.0
                  IF ((BUFF2(IJ).NE.0.0) .OR. (SBUFF(IX).NE.0.0))
     *               TEMP2 = ATAN2 (SBUFF(IX), BUFF2(IJ))
                  TEMP3 = (TEMP2 - TEMP) * 57.29578
                  IF (TEMP3.LE.-180.0) TEMP3 = TEMP3 + 360.0
                  IF (TEMP3.GT.180.0) TEMP3 = TEMP3 - 360.0
                  BUFF2(IJ) = ABS (TEMP3)
               ELSE
                  BUFF2(IJ) = FBLANK
                  END IF
               IJ = IJ + 1
               IK = IK + 3
 740           CONTINUE
            END IF
C                                       frequency smooth
         CALL PCSMOT (CSMOTH, NX, NCHAN, IMGWIN(1), BUFF2(BIND2+3),
     *      CONFUN)
C                                       Max
         IJ = BIND2 + 2
         DO 770 IX = 1,NX
            IF (BUFF2(IX+IJ).NE.FBLANK) RMAX = MAX (RMAX, BUFF2(IX+IJ))
 770        CONTINUE
C                                       Min
         DO 780 IX = 1,NX
            IF (BUFF2(IX+IJ).NE.FBLANK) RMIN = MIN (RMIN, BUFF2(IX+IJ))
 780        CONTINUE
 800     CONTINUE
      TEMP = 0.005 * (RMAX - RMIN)
      RMAX = RMAX + TEMP
      RMIN = RMIN - TEMP
      LCSMOT = CSMOTH
C                                       "write" last row
      CALL MDISK ('FINI', LUN2, FIND2, BUFF2, BIND2, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1010) 'FINISH', 'OUTPUT TV', IERR
         GO TO 990
         END IF
      CALL ZCLOSE (LUN1, FIND1, IERR)
      IF (LTYPE.GT.6) CALL ZCLOSE (LUN4, FIND4, IERR)
      TIMES(NY+1) = TIMES(NY) + CATR(KRCIC+1) / (24. * 3600.)
      TIMES(NY+2) = TIMES(NY+1) + CATR(KRCIC+1) / (24. * 3600.)
      TIMES(NY+3) = TIMES(NY+2) + CATR(KRCIC+1) / (24. * 3600.)
C                                       No valid data found
      IF (RMAX.LE.RMIN) THEN
         IF ((LTYPE.GE.3) .AND. (LTYPE.LE.6)) THEN
            MSGTXT = 'PCFOAD: NO VALID RMS''S FOUND - INCREASE ' //
     *         'AVERAGING TIME'
         ELSE
            MSGTXT = 'PCFOAD: NO VALID PIXELS FOUND - RESET WINDOW OR'
     *         // ' BASELINE'
            END IF
         CALL MSGWRT (6)
C         CALL ZCLOSE (LUN2, FIND2, IERR)
C         CALL COPY (256, CATSAV, CATBLK)
C         IRET = -99
C         GO TO 999
         RMAX = 1.0
         RMIN = 0.0
         END IF
C                                       Finish image catalog header
      I = LTYPE
      IF ((I.EQ.5) .OR. (I.EQ.6)) I = I - 2
      IF ((I.EQ.7) .OR. (I.EQ.8)) I = 1
      IF (I.EQ.9) I = 2
      CALL RNGSET (PIXRNG(1,I), RMAX, RMIN, CATR(IRRAN))
      PIXRNG(1,5) = RMIN
      PIXRNG(2,5) = RMAX
      CATBLK(IIVOL) = 0
      CATBLK(IICNO) = 0
      CALL CHR2H (2, TRTYP(LTRTYP), 1, CATH(IITRA))
      IF ((LTYPE.EQ.2) .OR. (LTYPE.EQ.9)) CALL CHR2H (8, CUNITS(1),
     *   1, CATH(KHBUN))
      IF (LTYPE.EQ.4) CALL CHR2H (8, CUNITS(2), 1, CATH(KHBUN))
      IF (LTYPE.EQ.6) CALL CHR2H (8, CUNITS(2), 1, CATH(KHBUN))
      CALL RFILL (7, 1.0, LBLC)
      CALL RFILL (7, 1.0, LTRC)
      LBLC(1) = 4.
      LTRC(1) = NX + 3
      LTRC(2) = NY
      IJ = -1
      INC(1) = (CATBLK(KINAX)-4) / MAXXTV(1) + 1
      INC(2) = 1
C                                       Init
      TVWIN(1) = 0
      XYCENT(1) = 0
      CALL YWINDO ('READ', WINDTV, IERR)
      IF (IERR.NE.0) THEN
         WINDTV(1) = 1
         WINDTV(2) = 1
         WINDTV(3) = MAXXTV(1)
         WINDTV(4) = MAXXTV(2)
         IERR = 0
         TVWIN(2) = 0
      ELSE
         TVWIN(2) = WINDTV(2) + 16 + (MAXLAB*1.5 + 4.5)*CSIZTV(2) + 0.5
         IF (TVWIN(2)+NY-1.GT.WINDTV(4)) TVWIN(2) = 0
         IF (DOCENT.LE.0.0) THEN
            TVWIN(1) = WINDTV(3) - 6 - NX
            TVWIN(1) = MIN (TVWIN(1), MAXMEN+3+WINDTV(1))
            XYCENT(1) = TVWIN(1) + (NX-1)/2
            END IF
         END IF
      IF (TVWIN(2).LE.0) THEN
         XYCENT(2) = (WINDTV(2) + WINDTV(4)) / 2
      ELSE
         XYCENT(2) = TVWIN(2) + (NY-1) / 2
         END IF
      WRITE (MSGTXT,1800) CATR(IRRAN), CATR(IRRAN+1)
      CALL MSGWRT (2)
      IF (INC(1).GT.1) THEN
         WRITE (MSGTXT,1805) INC(1)
         CALL MSGWRT (2)
         END IF
      TEMP = 0.02 * ABS (RMAX-RMIN)
      DOIT = ABS (RMIN-CATR(IRRAN)).GT.TEMP
      DOIT = (ABS (RMAX-CATR(IRRAN+1)).GT.TEMP) .OR. DOIT
C                                       Tell range
      IF (DOIT) THEN
         WRITE (MSGTXT,1806) RMIN, RMAX
         CALL MSGWRT (2)
         END IF
      IRET = WINDTV(4)-WINDTV(2)+1
      IF (IRET.LT.NY) THEN
         WRITE (MSGTXT,1807) NY, IRET
         CALL MSGWRT (6)
         END IF
      CALL YSLECT ('ONNN', IPL, 0, BUFFER, IRET)
      IF (IRET.NE.0) GO TO 999
      CALL YZERO (IPL, IRET)
      IF (IRET.NE.0) GO TO 999
      CALL YCINIT (IPL, BUFFER)
C                                       Load image on TV.
      CALL TVWIND (IJ, INC, LBLC, LTRC, IPL, TVWIN, IMCORN, IRET)
      CALL TVLOAD (LUN2, FIND2, IPL, INC, TVWIN, IMCORN, NBYT, BUFF2,
     *   IRET)
      CALL ZCLOSE (LUN2, FIND2, IX)
      IF ((IRET.EQ.0) .AND. (DOWEDG)) THEN
         CALL PCFWED (DOWEDG, LTYPE, IPL, SCRTCH, BUFF2, IRET)
         END IF
      GO TO 999
C                                       error
 990  CALL MSGWRT (8)
      IRET = 104
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('BUFFER DIMS ABUF, DIMBUF =',I4,I7,' EXPECTED 50',I7)
 1010 FORMAT ('PCFOAD: UNABLE TO ',A,1X,A,' FILE, ERROR',2I4)
 1130 FORMAT ('SMOOTH LENGTH',I4,' TOO LONG FOR SCAN LENGTH',I4)
 1131 FORMAT ('Using scan length',I4,' for rolling-buffer average')
 1800 FORMAT ('Now load the TV memory from',1PE12.4,' TO',1PE12.4)
 1805 FORMAT ('***** WARNING: ONLY EVERY',I3,' CHANNEL IS DISPLAYED',
     *   ' *****')
 1806 FORMAT ('Current data range is',1PE12.4,' to',1PE12.4)
 1807 FORMAT ('Warning: image has',I7,' rows, TV only',I5,' rows')
      END
      SUBROUTINE PCSMOT (CW, NX, NCHAN, IMGWIN, ROW, CONFUN)
C-----------------------------------------------------------------------
C   PCSMOT does frequency smoothing
C   Inputs:
C      CW       R      FWHM in channels of Gaussian
C      NX       I      Number points in ROW
C      NCHAN    I      Number channels per IF
C      IMGWIN   I      starting spot in row
C   In/Out:
C      ROW      R(*)   Data row
C      CONFUN   R(*)   Convolving function (1) <= 0 -> recompute
C-----------------------------------------------------------------------
      INTEGER   NX, NCHAN, IMGWIN
      REAL      CW, ROW(*), CONFUN(*)
C
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:DDCH.INC'
      INTEGER   I, J, J1, J2, LC, JMIN, JMAX, IX
      REAL      V(MAXCHA), W(MAXCHA), WT, A
C-----------------------------------------------------------------------
      IF (CW.GT.0.0) THEN
         CALL RFILL (NX, 0.0, V)
         CALL RFILL (NX, 0.0, W)
         IF (CONFUN(1).LT.1.0) THEN
            A = -4.0 * LOG(2.0) / (CW * CW)
            J2 = 3. * CW + 1
            DO 10 I = 2,J2
               CONFUN(I) = EXP (A * (I-2) * (I-2))
               IF (CONFUN(I).GT.0.005) CONFUN(1) = I
 10            CONTINUE
            END IF
         JMIN = 1
         IX = IMGWIN - 1
         LC = MOD (IX, NCHAN)
         JMAX = NCHAN - LC
         DO 30 I = 1,NX
            LC = LC + 1
            IF (LC.GT.NCHAN) THEN
               LC = LC - NCHAN
               JMIN = JMIN + NCHAN
               JMAX = JMAX + NCHAN
               END IF
            J = CONFUN(1) + 0.1
            J = J - 2
            J1 = I - J
            J2 = I + J
            J1 = MAX (1, JMIN)
            J2 = MIN (NX, JMAX)
            DO 20 J = J1,J2
               IF (ROW(J).NE.FBLANK) THEN
                  WT = CONFUN (ABS(I-J)+2)
                  V(I) = V(I) + WT * ROW(J)
                  W(I) = W(I) + WT
                  END IF
 20            CONTINUE
 30         CONTINUE
         DO 40 I = 1,NX
            IF (W(I).GT.0.0) THEN
               ROW(I) = V(I) / W(I)
            ELSE
               ROW(I) = FBLANK
               END IF
 40         CONTINUE
         END IF
C
 999  RETURN
      END
      SUBROUTINE PRFRMT (PR, STR)
C-----------------------------------------------------------------------
C   Formats a pixrange pair
C   Inputs:
C      PR    R(2)   Pix range
C   Output
C      STR   C*15   Formatted string
C-----------------------------------------------------------------------
      REAL      PR(2)
      CHARACTER STR*(*)
C
      REAL      PMAX, PSCA
      INTEGER   I1, I2, I
      LOGICAL   PFLAG
      CHARACTER PREFIX*8
C-----------------------------------------------------------------------
      PMAX = MAX (ABS(PR(1)), ABS(PR(2)))
      IF (PMAX.EQ.0.0) PMAX = 1.0
      PSCA = PMAX
      CALL METSCA (PSCA, PREFIX, PFLAG)
      I2 = 8
      IF (PSCA.GE.9.9995) I2 = 7
      IF (PSCA.GE.99.9995) I2 = 6
      PSCA = PSCA / PMAX
C                                       1st value
      PMAX = PR(1) * PSCA
      WRITE (PREFIX,1000) PMAX
      I1 = 0
 10   I1 = I1 + 1
      IF ((PREFIX(I1:I1).EQ.' ') .AND. (I1.LT.8)) GO TO 10
      STR = '(' // PREFIX(I1:I2) // '-'
      I = I2 - I1 + 4
C                                       2nd value
      PMAX = PR(2) * PSCA
      WRITE (PREFIX,1000) PMAX
      I1 = 0
 20   I1 = I1 + 1
      IF ((PREFIX(I1:I1).EQ.' ') .AND. (I1.LT.8)) GO TO 20
      STR(I:) = PREFIX(I1:I2) // ')'
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT (F8.3)
      END
      SUBROUTINE TORMAT (TIME, TFORM, STRING, NC)
C-----------------------------------------------------------------------
C   TORMAT formats the time string
C   Inputs
C      TIME     R       Time in days
C      TFORM    I       Number digits after decimal
C   Outputs:
C      STRING   C*(*)   DD/HH:MM:SS or DD/HH:MM:SS.ssss
C      NC       I       Number chars in STRING
C-----------------------------------------------------------------------
      INTEGER   TFORM, NC
      REAL      TIME
      CHARACTER STRING*(*)
C
      INTEGER   IT(4), JT(3)
      REAL      RT
      CHARACTER LC*20
C-----------------------------------------------------------------------
      IF (TFORM.LE.0) THEN
         CALL TODHMS (TIME, IT)
         WRITE (LC,1000) IT
         NC = 11
      ELSE
         CALL TIDHMS (TIME, TFORM, JT, RT)
         WRITE (LC,1010) JT, RT
         IF (LC(10:10).EQ.' ') LC(10:10) = '0'
         NC = 12 + TFORM
         END IF
      STRING = LC(1:NC)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT (I2.2,'/',I2.2,2(':',I2.2))
 1010 FORMAT (I2.2,'/',2(I2.2,':'),F9.6)
      END
