LOCAL INCLUDE 'DFTQU.INC'
C                                       Local include for DFTQU
      INCLUDE 'INCS:ZPBUFSZ.INC'
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   MAXSAM
      PARAMETER (MAXSAM=10000)
C
      HOLLERITH XNAMEI(3), XCLAIN(2), XNAMEO(3), XCLAOU(2), XSOUR(4),
     *   XCALC(1)
      REAL      XSIN, XDISIN, XSOU, XDISOU, XIMSIZ(2), UVRANG(2),
     *   TIMER(8), SHIFT(2), BPARM(10), XQUAL, XBAND, XFREQ, XFQID,
     *   XSUBA, XBIF, XEIF, XBCHAN, XECHAN, XANT(50), XBASL(50), XDOCAL,
     *   XGUSE, XDOPOL, XPDVER, XBLVER, XFLAG, XDOBND, XBPVER,
     *   XSMOTH(3), BADD(10)
      DOUBLE PRECISION FOFF(MAXIF), DXC, DYC, DZC, RAS, DECS
      REAL      BUFF1(UVBFSS), TIMR(MAXSAM), DFT(MAXSAM,3), TBEG, TFIN,
     *   ERROR(MAXSAM,3), XYSCL(2,3), XYOFF(2,3), AREA(2), OFREQ, FRPIX,
     *   TAVG, XNUL, FINC(MAXIF), VRANGE(2,2), XY(2,3)
      CHARACTER NAMEIN*12, CLAIN*6, NAMEOU*12, CLAOU*6
      INTEGER   SEQIN, DISKIN, LUNI, INDI, LABEL, VER, NBASL, BCNT,
     *   TESTEM(2), JBUFSZ, GRCHN, TVCHN, TVCORN(4), NPARMS, IPLOT,
     *   FREQID, KNCS, KNCF, KNCIF, LTYPE, NPOL, NXANT, IXANT(50),
     *   NXBASL, IXBASL(50), NX, NY, SCRTCH(256), CATOLD(256), SEQOU,
     *   DISKOU, OLDCNO
      LOGICAL   UVREV, SCALEM(2), NOUVR, PACKED, DESEL
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XNAMEO, XCLAOU,
     *   XSOU, XDISOU, XIMSIZ, UVRANG, TIMER, SHIFT, BPARM, XSOUR,
     *   XQUAL, XCALC, XBAND, XFREQ, XFQID, XSUBA, XBIF, XEIF, XBCHAN,
     *   XECHAN, XANT, XBASL, XDOCAL, XGUSE, XDOPOL, XPDVER, XBLVER,
     *   XFLAG, XDOBND, XBPVER, XSMOTH, BADD
      COMMON /BUFRS/ BUFF1, JBUFSZ
      COMMON /FTPCOM/ FOFF, CATOLD, DXC, DYC, DZC, RAS, DECS, FINC,
     *   TIMR, DFT, ERROR, TBEG, TFIN, TAVG, XYSCL, XYOFF, OFREQ, FRPIX,
     *   AREA, XNUL, UVREV, SCALEM, NOUVR, NBASL, BCNT, SEQIN,
     *   DISKIN, SEQOU, DISKOU, LUNI, INDI, LABEL, VER, TESTEM, GRCHN,
     *   TVCHN, TVCORN, NPARMS, IPLOT, FREQID, PACKED, KNCS, KNCF,
     *   KNCIF, LTYPE, NPOL, VRANGE, NXANT, IXANT, NXBASL, IXBASL,
     *   DESEL, NX, NY, XY, SCRTCH, OLDCNO
      COMMON /CHRCOM/ NAMEIN, CLAIN, NAMEOU, CLAOU
C                                                          End DFTQU.
LOCAL END
      PROGRAM DFTQU
C-----------------------------------------------------------------------
C! Computes summed uv data for a position in the sky in Q & U vs time
C# UV polarization
C-----------------------------------------------------------------------
C;  Copyright (C) 2025
C;  Associated Universities, Inc. Washington DC, USA.
C;
C;  This program is free software; you can redistribute it and/or
C;  modify it under the terms of the GNU General Public License as
C;  published by the Free Software Foundation; either version 2 of
C;  the License, or (at your option) any later version.
C;
C;  This program is distributed in the hope that it will be useful,
C;  but WITHOUT ANY WARRANTY; without even the implied warranty of
C;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C;  GNU General Public License for more details.
C;
C;  You should have received a copy of the GNU General Public
C;  License along with this program; if not, write to the Free
C;  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge,
C;  MA 02139, USA.
C;
C;  Correspondence concerning AIPS should be addressed as follows:
C;         Internet email: aipsmail@nrao.edu.
C;         Postal address: AIPS Project Office
C;                         National Radio Astronomy Observatory
C;                         520 Edgemont Road
C;                         Charlottesville, VA 22903-2475 USA
C-----------------------------------------------------------------------
C   DFTQU creates a 'PL' extension file for display of the DFT of the
C   Qpol and Upol visibilities for an arbitrary position in the sky.
C   Color is used to indicate time.
C   NOTE 1: DFTQU wants the first key of the sort order of the UV data
C           base to be TIME.
C   NOTE 2: At present, DFTQU will only plot up to 10000 bins.C
C   Inputs:
C     INNAME         NAMEIN        Name of input UV data.
C     INCLASS        CLAIN         Class of input UV data.
C     INSEQ          SEQIN         Seq. of input UV data.
C     INDISK         DISKIN        Disk number of input VU data.
C     UVRANGE....Range of UV projected spacings to include (Klambda)
C     TIMER......Selection parameters:
C        1 = Start IAT day (day 0 = first day in data base)
C        2 = Start IAT hour
C        3 = Start IAT minute
C        4 = Start IAT second
C        5 = Stop IAT day (day 0 = first day in data base)
C        6 = Stop IAT hour
C        7 = Stop IAT minute
C        8 = Stop IAT second
C        9 = Offset in right ascension (asec)
C       10 = Offset in declination (asec)
C     BPARM......Control parameters:
C        1 = Change color each BP(1) averaging intervals
C        2 = averaging interval in sec
C        3 = Do not autoscale if > zero, use following values:
C        4 = Minimum of X-axis,
C        5 = Maximum of X-axis,
C        6 = Minimum of Y-axis.
C        7 = Maximum of Y-axis,
C        8 = X to Y ratio
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET, NWORDS
      REAL      IMAGE(2)
      LONGINT   PIMAGE
      INCLUDE 'DFTQU.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DGPH.INC'
      INCLUDE 'INCS:DLOC.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DUVH.INC'
      DATA PRGM /'DFTQU '/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL FTPIN (PRGM, IRET)
      IF (IRET.NE.0) GO TO 995
C                                       Do DFT's
      CALL ACDFT (IRET)
      IF (IRET.NE.0) GO TO 995
C                                       Grid image
      NWORDS = (NX * NY * 3 - 1) / 1024 + 4
      CALL ZMEMRY ('GET ', TSKNAM, NWORDS, IMAGE, PIMAGE, IRET)
      IF (IRET.NE.0) THEN
         MSGTXT = 'COULD NOT GET DYNAMIC MEMORY'
         CALL MSGWRT (8)
         GO TO 995
         END IF
      CALL GRDFT (NX, NY, IMAGE(1+PIMAGE), IRET)
      IF (IRET.NE.0) GO TO 995
C                                       Plot 'em up
      CALL OUTFT (NX, NY, IMAGE(1+PIMAGE), IRET)
C                                       Close down
 995  CALL DIE (IRET, BUFF1)
C
 999  STOP
      END
      SUBROUTINE FTPIN (PRGM, JERR)
C-----------------------------------------------------------------------
C   FTPIN gets input parameters for DFTQU .
C   Inputs:
C      PRGM    C*6    Program name
C   Output:
C      JERR    I      Error code: 0 => ok, else quit
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   JERR
C
      INCLUDE 'DFTQU.INC'
      CHARACTER BNDCOD(MAXIF)*8, CSTOK(11)*4
      INTEGER   IUSER, I, IERR, IROUND, FQVER, NIF, CHBUFF(512),
     *   ISBAND(MAXIF), LUNCH
      REAL      CATR(256), RPARM(20)
      LOGICAL   T
      DOUBLE PRECISION RA0, DEC0, CATD(128)
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:PSTD.INC'
      EQUIVALENCE (CATBLK, CATR, CATD)
      DATA T /.TRUE./
      DATA CSTOK /'RR', 'LL', 'I', 'V', 'Q', 'U', 'VV', 'HH', 'HALF',
     *   'IQU', 'FPA'/
C-----------------------------------------------------------------------
C                                       Init IO et al.
      CALL ZDCHIN (T, BUFF1)
      CALL VHDRIN
      CALL SELINI
      JBUFSZ = UVBFSS * 2
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      JERR = 0
      VER = MAXSAM
C                                       Get input parameters.
      NPARMS = 173
      CALL GTPARM (PRGM, NPARMS, RQUICK, XNAMEI, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         JERR = 8
         RQUICK = .TRUE.
         IF (IERR.EQ.1) GO TO 999
         WRITE (MSGTXT,1000) IERR, 'GETTING USER ADVERB VALUES'
         CALL MSGWRT (8)
         END IF
C                                       Restart AIPS
      IF (RQUICK) CALL RELPOP (JERR, BUFF1, IERR)
      IF (JERR.NE.0) GO TO 999
      JERR = 5
C                                       Crunch input parameters.
      DO 5 I = 1,10
         IBAD(I) = IROUND(BADD(I))
 5       CONTINUE
      IUSER = NLUSER
      SEQIN = IROUND (XSIN)
      DISKIN = IROUND (XDISIN)
      SEQOU = IROUND (XSOU)
      DISKOU = IROUND (XDISOU)
      TBEG = TIMER(1) + (TIMER(2)+(TIMER(3)+TIMER(4)/60.)/60.)/24.
      TFIN = TIMER(5) + (TIMER(6)+(TIMER(7)+TIMER(8)/60.)/60.)/24.
      IF (TFIN.LE.TBEG) TFIN = 1.E6
      IF (TBEG.LE.0.0) TBEG = -1.E6
C                                       Convert characters
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      CALL H2CHR (12, 1, XNAMEO, NAMEOU)
      CALL H2CHR (6, 1, XCLAOU, CLAOU)
      STOKES ='QU'
      NPOL = 2
      CALL H2CHR (4, 1, XCALC, SELCOD)
      CALL H2CHR (16, 1, XSOUR, SOURCS(1))
      SELQUA = IROUND (XQUAL)
C                                       Antennas
      CALL SETANT (50, XANT, XBASL, NXANT, NXBASL, IXANT, IXBASL, DESEL)
      IF ((NXANT.LE.0) .AND. (NXBASL.GT.0)) THEN
         CALL COPY (NXBASL, IXBASL, IXANT)
         NXANT = NXBASL
         NXBASL = 0
         END IF
C                                       Info for UVGET:
C                                       Put selection criteria into
C                                       correct common.
      UNAME = NAMEIN
      UCLAS = CLAIN
      UDISK = DISKIN
      USEQ = SEQIN
      DOCAL = XDOCAL.GT.0.0
      DOWTCL = DOCAL .AND. (XDOCAL.LE.99.0)
      DOACOR = .FALSE.
      CALL RCOPY (8, TIMER, TIMRNG)
      DOPOL = IROUND(XDOPOL)
      IF (XDOPOL.GT.0.0) DOPOL = MAX (1, DOPOL)
      PDVER = IROUND (XPDVER)
      DOAPPL = .FALSE.
      SUBARR = IROUND (XSUBA)
      IF (SUBARR.LT.0) SUBARR = 0
      FGVER = IROUND (XFLAG)
      DOBAND = IROUND (XDOBND)
      BPVER = IROUND (XBPVER)
      CALL RCOPY (3, XSMOTH, SMOOTH)
      CLVER = IROUND (XGUSE)
      CLUSE = IROUND (XGUSE)
      BLVER = IROUND (XBLVER)
      BCHAN = XBCHAN
      ECHAN = XECHAN
      BIF = XBIF
      EIF = XEIF
C                                       Test UV range
      NOUVR = .FALSE.
      IF ((UVRANG(1).GE.UVRANG(2)) .OR. (UVRANG(1).LT.0.0)) THEN
         NOUVR = .TRUE.
         UVRANG(1) = 0.0
         UVRANG(2) = 1.E10
         END IF
      UVRNG(1) = UVRANG(1)
      UVRNG(2) = UVRANG(2)
      UVRANG(1) = UVRANG(1) * 1.0E3
      UVRANG(2) = UVRANG(2) * 1.0E3
C                                       Autoscale ?
      SCALEM(1) = (BPARM(3).LE.0.0) .OR. (BPARM(4).EQ.BPARM(5))
      SCALEM(2) = (BPARM(3).LE.0.0) .OR. (BPARM(6).EQ.BPARM(7))
      TESTEM(1) = 1
      IF (BPARM(4).GT.BPARM(5)) TESTEM(1) = -1
      IF ((BPARM(3).EQ.0.0) .OR. (BPARM(4).EQ.BPARM(5))) TESTEM(1) = 0
      TESTEM(2) = 1
      IF (BPARM(6).GT.BPARM(7)) TESTEM(2) = -1
      IF ((BPARM(3).EQ.0.0) .OR. (BPARM(6).EQ.BPARM(7))) TESTEM(2) = 0
C                                       X/Y ratio ?
      AREA(1) = 1000.
      AREA(2) = 1000.
C                                       Get CATBLK from UVGET
      CALL UVGET ('INIT', RPARM, BUFF1, IERR)
      IF (IERR.LT.0) THEN
         MSGTXT = 'INITIAL UVGET RETURNS NO DATA FOUND'
         GO TO 980
      ELSE IF (IERR.GT.0) THEN
         WRITE (MSGTXT,1000) IERR, 'INITIAL UVGET CALL'
         GO TO 980
         END IF
C                                       save adverbs
      XSIN = IUSEQ
      XDISIN = IUDISK
      CALL CHR2H (12, UNAME, 1, XNAMEI)
      CALL CHR2H (6, UCLAS, 1, XCLAIN)
      OLDCNO = IUCNO
      XBCHAN = BCHAN
      XECHAN = ECHAN
      XBIF = BIF
      XEIF = EIF
      XSUBA = SUBARR
      CALL UVGET ('CLOS', RPARM, BUFF1, IERR)
      IF (NCFILE.LE.0) THEN
         NCFILE = 1
         FVOL(NCFILE) = IUDISK
         FCNO(NCFILE) = IUCNO
         FRW(NCFILE) = 0
         END IF
      CALL COPY (256, CATUV, CATBLK)
      CALL COPY (256, CATUV, CATOLD)
C                                       UVPGET was called for output
      IF ((ILOCSU.GE.0) .OR. ((RA.EQ.0.0D0) .AND. (DEC.EQ.0.0D0))) THEN
         IERR = 8
         MSGTXT = 'YOU MUST SELECT ONLY ONE SOURCE'
         GO TO 980
         END IF
C                                       Source offsets
      RA0 = RA
      DEC0 = DEC
      IF (COS(DG2RAD*DEC0).NE.0.0D0) RA = RA0 + SHIFT(1) / 3600.D0
     *   / COS(DG2RAD * DEC0)
      DEC = DEC + SHIFT(2) / 3600.D0
      RAS = RA
      DECS = DEC
      DXC = SIN (DG2RAD * (RA-RA0)) * COS (DEC * DG2RAD)
      DYC = COS (DEC0 * DG2RAD) * SIN (DEC * DG2RAD) -
     *   SIN (DEC0 * DG2RAD) * COS (DEC * DG2RAD) *
     *   COS ((RA - RA0) * DG2RAD)
      DZC = SIN (DG2RAD * DEC0) * SIN (DG2RAD * DEC) +
     *   COS (DG2RAD * DEC0) * COS (DG2RAD * DEC) *
     *   COS (DG2RAD * (RA - RA0)) - 1.0D0
      DXC = TWOPI * DXC
      DYC = TWOPI * DYC
      DZC = TWOPI * DZC
C                                       Sort order OK ?
      IF (ISORT(:1).NE.'T') THEN
         MSGTXT = 'FIRST KEY OF SORT ORDER MUST BE TIME !!'
         CALL MSGWRT (6)
         JERR = 1
         GO TO 999
         END IF
C                                       Frequency and bandwidth
      IF (JLOCIF.LT.0) THEN
         FOFF(1) = 0.0D0
         FINC(1) = CATR(KRCIC+JLOCF)
      ELSE
         FQVER = 1
         LUNCH = 87
         CALL CHNDAT ('READ',  CHBUFF, DISKIN, OLDCNO, FQVER, CATBLK,
     *      LUNCH, NIF, FOFF, ISBAND, FINC, BNDCOD, FREQID, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1050) IERR
            CALL MSGWRT (7)
            JERR = 1
            GO TO 999
            END IF
         END IF
      OFREQ = CATD(KDCRV+JLOCF)
      FRPIX = CATR(KRCRP+JLOCF)
      NX = XIMSIZ(1) + 0.1
      NY = XIMSIZ(2) + 0.1
      IF (NX.LT.128) NX = 1024
      IF (NY.LT.128) NY = 1024
C                                       Update catalog header.
      FRW(NCFILE) = 0
      JERR = 0
      GO TO 999
C
 980  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('FTPIN: ERROR',I3,' ON ',A)
 1050 FORMAT ('ERROR',I5,' READING FREQUENCIES WITH CHNDAT')
      END
      SUBROUTINE ACDFT (IRET)
C-----------------------------------------------------------------------
C   ACDFT accumlates the flux density for each averaging interval as
C   well as an estimate of the error. Also sets scaling for later use.
C   Output:
C      IRET   I    Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'DFTQU.INC'
      INTEGER   FLAG, NUMVIS, XUMVIS, IA1, IA2
      REAL      VIS(UVBFSS), RPARM(20), BASEN
      DOUBLE PRECISION T1, T2
      LOGICAL   REQBAS
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
C-----------------------------------------------------------------------
C                                       Set up binning
      XNUL = FBLANK
      CALL RFILL (MAXSAM, XNUL, DFT)
      CALL RFILL (MAXSAM, XNUL, TIMR)
      CALL RFILL (MAXSAM, 0.0, ERROR)
C                                       Get start/stop times
      CALL TBTIME (TBEG, TFIN, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'FINDING START AND STOP TIMES'
         GO TO 990
         END IF
C                                       set bin count, T averaging
      BCNT = 1
      IF (BPARM(2).LE.0.001) BPARM(2) = 864. * (TFIN - TBEG)
      TAVG = BPARM(2) / 86400.
      T1 = TBEG
      T2 = T1 + TAVG
C                                       Init vis file for read.
      CALL UVGET ('INIT', RPARM, VIS, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'INIT UV IO'
         GO TO 990
         END IF
      NUMVIS = 0
      XUMVIS = 0
      KNCS = INCS
      KNCF = INCF
      KNCIF = INCIF
C                                       Loop
C                                       Read vis. record.
 100  CALL UVGET ('READ', RPARM, VIS, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1000) IRET, 'READING UV DATA'
         GO TO 990
      ELSE IF (IRET.EQ.0) THEN
C                                       antenna/baseline
         IF (ILOCB.GE.0) THEN
            BASEN = RPARM(1+ILOCB)
            IA1 = BASEN / 256. + 0.1
            IA2 = BASEN - IA1*256. + 0.1
         ELSE
            IA1 = RPARM(1+ILOCA1) + 0.1
            IA2 = RPARM(1+ILOCA2) + 0.1
            END IF
         IF (.NOT.REQBAS (IA1, IA2, DESEL, IXANT, NXANT, IXBASL,
     *      NXBASL)) GO TO 100
C                                       Is this a valid point ?
 125     CALL WANTED (RPARM, VIS, T1, T2, FLAG)
C                                       Bad point, try again
         IF (FLAG.EQ.1) GO TO 100
C                                       End of time search
         IF (FLAG.EQ.3) GO TO 200
C                                       Next time interval
         IF (FLAG.EQ.2) THEN
            CALL DODFT (RPARM, VIS, T1, T2, FLAG, IRET)
            T1 = T2
            T2 = T1 + TAVG
            GO TO 125
            END IF
C                                       Good point
         CALL DODFT (RPARM, VIS, T1, T2, FLAG, IRET)
         XUMVIS = XUMVIS + 1
         GO TO 100
         END IF
C                                       Any valid points
 200  IF (XUMVIS.LE.1) THEN
         IRET = 4
         WRITE (MSGTXT,1200) XUMVIS
         GO TO 990
         END IF
C                                       Get plot ranges and scales
      BCNT = BCNT - 1
      CALL XYSCAL (IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1110) IRET
         GO TO 990
         END IF
C                                       close UV data
      CALL UVGET ('CLOS', RPARM, VIS, IRET)
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('ACDFT: ERROR',I3,' ON ',A)
 1110 FORMAT ('ACDFT: XYSCL ERROR',I3)
 1200 FORMAT ('FOUND',I5,' POINTS: NOT ENOUGH TO SELF-SCALE')
      END
      SUBROUTINE XYSCAL (IRET)
C-----------------------------------------------------------------------
C   XYSCAL converts to FPA if reqested, finds max/min over data, and
C   finds the scaling parameters needed to fit X and Y into a 1000x1000
C   plotting area .
C   Outputs:
C      XY      R(2,3)   Min, max of up to 3 parameters
C      XYOFF   R(2,3)   when added to XY changes minimum to zero .
C      XYSCL   R(2,3)   scale XY so that maximum is 1000.
C      IRET    I        Error return code , non-zero if error .
C-----------------------------------------------------------------------
      INTEGER   IRET
c
      INTEGER   I, IROUND, J, IP
      REAL      RI, TEMP
      INCLUDE 'DFTQU.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:PSTD.INC'
C-----------------------------------------------------------------------
      IRET = 0
C                                       MAX/MIN
      XY(1,1) = 1.E10
      XY(2,1) = -1.E10
      XY(1,2) = 1.E10
      XY(2,2) = -1.E10
      XY(1,3) = 1.E10
      XY(2,3) = -1.E10
      DO 40 I = 1,BCNT
         IF (TIMR(I).NE.FBLANK) THEN
            DO 35 IP = 1,NPOL
               IF (DFT(I,IP).NE.FBLANK) THEN
                  RI = DFT(I,IP)
                  XY(1,IP) = MIN (XY(1,IP), RI)
                  XY(2,IP) = MAX (XY(2,IP), RI)
                  END IF
 35            CONTINUE
            END IF
 40      CONTINUE
      CALL RCOPY (6, XY, VRANGE(1,1))
C                                       Are they in requested range
      J = IROUND (BPARM(3))
      IF (J.GT.0) THEN
         IF (BPARM(4).LT.BPARM(5)) THEN
            XY(1,1) = BPARM(4)
            XY(2,1) = BPARM(5)
            END IF
         IF (BPARM(6).LT.BPARM(7)) THEN
            XY(1,2) = BPARM(6)
            XY(2,2) = BPARM(7)
            END IF
      ELSE IF (J.LT.0) THEN
         IF (BPARM(4).LT.BPARM(5)) THEN
            XY(1,1) = MAX (XY(1,1), BPARM(4))
            XY(2,1) = MIN (XY(2,1), BPARM(5))
            END IF
         IF (BPARM(6).LT.BPARM(7)) THEN
            DO 50 IP = 1,NPOL
               XY(1,IP) = MAX (XY(1,IP), BPARM(6))
               XY(2,IP) = MIN (XY(2,IP), BPARM(7))
 50            CONTINUE
            END IF
         END IF
C                                       provide room at edges too.
      TEMP = 0.01 * (XY(2,1) - XY(1,1))
      XY(1,1) = XY(1,1) - TEMP
      XY(2,1) = XY(2,1) + TEMP
      TEMP = 0.01 * (XY(2,2) - XY(1,2))
      XY(1,2) = XY(1,2) - TEMP
      XY(2,2) = XY(2,2) + TEMP
C
 999  RETURN
      END
      SUBROUTINE WANTED (RPBUF, VIS, T1, T2, FLAG)
C-----------------------------------------------------------------------
C   WANTED determines whether the current visibility sample is valid
C   and selected via the selection parameters.
C   Inputs:
C      RPBUF   R(*)   Random parameters
C      VIS     R(*)   Visibilities
C      T1      D      Start desired time range
C      T2      D      End desired time range
C   Outputs:
C      FLAG    I      0 => data selected as good
C                     1    data NO GOOD
C                     2    time exceeds T2
C                     3    time exceeds TFIN
C-----------------------------------------------------------------------
      REAL      RPBUF(*), VIS(*)
      DOUBLE PRECISION T1, T2
      INTEGER   FLAG
C
      REAL      TEMP
      INTEGER   LAD, IIF, ICH, IROUND
      LOGICAL   GOOD, ANY
      INCLUDE 'DFTQU.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DUVH.INC'
C-----------------------------------------------------------------------
      FLAG = 1
C                                       Check FREQID
      IF (ILOCFQ.GE.0) THEN
         IIF = IROUND (RPBUF(1+ILOCFQ))
         IF ((FREQID.GT.0) .AND. (IIF.GT.0) .AND. (IIF.NE.FREQID))
     *      GO TO 999
         END IF
C                                       Check UV range
      IF (.NOT.NOUVR) THEN
         TEMP = SQRT (RPBUF(1+ILOCU)**2 + RPBUF(1+ILOCV)**2)
         IF ((TEMP.LT.UVRANG(1)) .OR. (TEMP.GT.UVRANG(2))) GO TO 999
         END IF
C                                       Are data flagged?
      ANY = .FALSE.
      DO 20 IIF = BIF,EIF
         DO 10 ICH = BCHAN,ECHAN
            LAD = 1 + (IIF-BIF)*KNCIF + (ICH-BCHAN)*KNCF
            GOOD = VIS(LAD+2).GT.0.0
            ANY = ANY .OR. GOOD
 10         CONTINUE
 20      CONTINUE
      IF (.NOT.ANY) GO TO 999
C                                       Test time range
      TEMP = RPBUF(1+ILOCT)
      IF (TEMP.LT.T1) GO TO 999
      FLAG = 2
      IF (TEMP.GE.T2) GO TO 999
      FLAG = 3
      IF (TEMP.GT.TFIN) GO TO 999
      FLAG = 0
C
 999  RETURN
      END
      SUBROUTINE GRDFT (KX, KY, IMAGE, IRET)
C-----------------------------------------------------------------------
C   GRDFT grids the qu data into an image
C   Inputs
C      KX      I      X axis dimension
C      KY      I      Y axis dimension
C   Outputs
C      IMAGE   R(*)   IMAGE
C      IRET    I      error code
C-----------------------------------------------------------------------
      INTEGER   KX, KY, IRET
      REAL      IMAGE(KX,KY,3)
C
      INCLUDE 'DFTQU.INC'
      INTEGER   IM, IX, IY, I, NCOL, EX, LX, LY
      REAL      COLV, DCOLV, COL(3)
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
      IF (BPARM(1).LT.1) BPARM(1) = 1
      IF (BCNT/BPARM(1).LT.3.) BPARM(1) = 1
      NCOL = (BCNT - 1) / BPARM(1) + 1
      IM = BPARM(1)
      EX = BPARM(8) + 0.1
      DCOLV = 0.97 / (NCOL-1)
      COLV = -DCOLV

      DO 100 I = 1,BCNT
         IF (MOD(I-1,IM).EQ.0) THEN
            COLV = COLV + DCOLV
            CALL COLOR3 (COLV, .FALSE., COL)
            END IF
         IX = (DFT(I,1) - XY(1,1)) / (XY(2,1) - XY(1,1)) * (NX - 1)
     *      + 1.5
         IY = (DFT(I,2) - XY(1,2)) / (XY(2,2) - XY(1,2)) * (NY - 1)
     *      + 1.5
         DO 80 LY = MAX(1,IY-EX),MIN(KY,IY+EX)
            DO 70 LX = MAX(1,IX-EX),MIN(KX,IX+EX)
               IMAGE(LX,LY,1) = COL(1)
               IMAGE(LX,LY,2) = COL(2)
               IMAGE(LX,LY,3) = COL(3)
 70            CONTINUE
 80         CONTINUE
 100     CONTINUE
      IRET = 0
C
 999  RETURN
      END
      SUBROUTINE DODFT (RPBUF, VIS, T1, T2, FLAG, IRET)
C-----------------------------------------------------------------------
C   DODFT computes the DFT for a given set of visibilities with the
C   proper sky offset applied.
C   Inputs:
C     RPBUF   R(*)   one visibility record - random parameters
C     VIS     R(*)   one visibility record - data
C     T1      D      Start of interval
C     T2      D      End of interval
C     FLAG    I      If 0, continue summing DFT
C                    If 2, wrap it up, clear
C   Outputs:
C     IRET    I      0 => operation sucessful
C                    1 => trouble
C                    -1 => no data to average
C-----------------------------------------------------------------------
      REAL      RPBUF(*), VIS(*)
      INTEGER   FLAG, IRET
C
      REAL      TR, TI, WT, DELS, UU, VV, WW, SMN, TNR, TNI, TNU1(3,3),
     *   TNU2(3,3), TUMWT(3), TNA, XX
      DOUBLE PRECISION T1, T2, AFREQ
      INTEGER   IIF, ICH, TAMP(3), LAD, IP, J
      LOGICAL   GOOD
      INCLUDE 'DFTQU.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:PSTD.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      SAVE TNU1, TNU2, TUMWT, TAMP
      DATA TNU1, TNU2, TUMWT, TAMP /21*0.0, 3*0/
C-----------------------------------------------------------------------
      TR = 0.0
      TI = 0.0
      IRET = 0
      IF (FLAG.NE.0) GO TO 500
C                                       loop over IF and channel
      DO 100 IIF = BIF,EIF
         DO 90 ICH = BCHAN,ECHAN
            AFREQ = OFREQ + FOFF(IIF) + (ICH-FRPIX) * FINC(IIF)
C                                       Set U and V
            UU = RPBUF(ILOCU+1) * AFREQ / OFREQ
            VV = RPBUF(ILOCV+1) * AFREQ / OFREQ
            WW = RPBUF(ILOCW+1) * AFREQ / OFREQ
            DO 80 IP = 1,NPOL
C                                       Find visibilities and weights
               LAD = 1 + (ICH-BCHAN)*KNCF + (IIF-BIF)*KNCIF +
     *            (IP-1)*KNCS
               IF (VIS(LAD+2).GT.0.0) THEN
                  TR = VIS(LAD)
                  TI = VIS(LAD+1)
                  WT = VIS(LAD+2)
C                                       sum it up
                  XX = UU * DXC + VV * DYC + WW * DZC
                  TNR = TR * COS (XX) + TI * SIN (XX)
                  TNI = TI * COS (XX) - TR * SIN (XX)
                  TNA = SQRT (TNR*TNR + TNI*TNI)
                  TNU1(IP,1) = TNU1(IP,1) + WT * TNR
                  TNU2(IP,1) = TNU2(IP,1) + WT * TNR * TNR
                  TNU1(IP,2) = TNU1(IP,2) + WT * TNI
                  TNU2(IP,2) = TNU2(IP,2) + WT * TNI * TNI
                  TNU1(IP,3) = TNU1(IP,3) + WT * TNA
                  TNU2(IP,3) = TNU2(IP,3) + WT * TNA * TNA
                  TUMWT(IP) = TUMWT(IP) + WT
                  TAMP(IP) = TAMP(IP) + 1
                  END IF
 80            CONTINUE
 90         CONTINUE
 100     CONTINUE
      GO TO 999
C                                      Finish up this interval
 500  GOOD = .FALSE.
      J = 1
       DO 510 IP = 1,NPOL
         IF (TUMWT(IP).GT.0.0) THEN
            GOOD = .TRUE.
            SMN = TNU1(IP,J) / TUMWT(IP)
            DELS = TNU2(IP,J) / TUMWT(IP) - SMN*SMN
            DELS = SQRT (MAX (0.0, DELS))
            DFT(BCNT,IP) = SMN
            ERROR(BCNT,IP) = DELS / SQRT (MAX (1.0, TAMP(IP)-1.))
            TIMR(BCNT) = (T1+T2)/2.
         ELSE
            DFT(BCNT,IP) = FBLANK
            ERROR(BCNT,IP) = FBLANK
            END IF
 510     CONTINUE
      IF (GOOD) THEN
         IRET = 0
         BCNT = BCNT + 1
      ELSE
         IRET = -1
         END IF
      CALL RFILL (9, 0.0, TNU1)
      CALL RFILL (9, 0.0, TNU2)
      CALL RFILL (3, 0.0, TUMWT)
      CALL FILL (3, 0, TAMP)
C
 999  RETURN
      END
      SUBROUTINE OUTFT (KX, KY, IMAGE, IRET)
C-----------------------------------------------------------------------
C   OUTFT writes the qu iimage to aips image file
C   Inputs
C      KX      I      X axis dimension
C      KY      I      Y axis dimension
C      IMAGE   R(*)   Image
C   Outputs
C      IRET    I      error code
C-----------------------------------------------------------------------
      INTEGER   KX, KY, IRET
      REAL      IMAGE(KX,KY,3)
C
      INCLUDE 'DFTQU.INC'
      INTEGER   IX, IY, IC, SLOT, LUNO, INDO, WIN(4), BOI, DEPTH(5),
     *   IBUFF(256), OBUFF(256), LUN1, LUN2, BIND, I
      LOGICAL   BLANKD
      REAL      RMIN, RMAX
      HOLLERITH CATOH(256)
      CHARACTER AXTY(5)*8, PHNAME*48, HILINE*72
      EQUIVALENCE (CATOLD, CATOH)
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DFIL.INC'
      DATA LUNO, LUN1, LUN2, DEPTH /39, 40, 41, 5*1/
      DATA AXTY /'Q','U','RGB','RA','DEC'/
C-----------------------------------------------------------------------
C                                       max/min, blanked?
      BLANKD = .FALSE.
      RMIN = 1.E10
      RMAX = -1.E10
      DO 20 IY = 1,KY
         DO 15 IX = 1,KX
            DO 10 IC = 1,3
               IF (IMAGE(IX,IY,IC).EQ.FBLANK) THEN
                  BLANKD = .TRUE.
               ELSE
                  RMIN = MIN (RMIN, IMAGE(IX,IY,IC))
                  RMAX = MAX (RMAX, IMAGE(IX,IY,IC))
                  END IF
 10            CONTINUE
 15         CONTINUE
 20      CONTINUE
      CALL CATINI (CATBLK)
      CALL RCOPY (2, XSOUR, CATH(KHOBJ))
      CALL RCOPY (2, CATOH(KHTEL), CATH(KHTEL))
      CALL RCOPY (2, CATOH(KHINS), CATH(KHINS))
      CALL RCOPY (2, CATOH(KHOBS), CATH(KHOBS))
      CALL RCOPY (2, CATOH(KHDOB), CATH(KHDOB))
      CALL CHR2H (8, 'COLOR   ', 1, CATH(KHBUN))
      CATBLK(KIDIM) = 5
      DO 25 I = 1,5
         CALL CHR2H (8, AXTY(I), 1, CATH(KHCTP+2*I-2))
 25      CONTINUE
      CATBLK(KINAX) = KX
      CATBLK(KINAX+1) = KY
      CATBLK(KINAX+2) = 3
      CATBLK(KINAX+4) = 1
      CATD(KDCRV) = XY(1,1)
      CATD(KDCRV+1) = XY(1,2)
      CATD(KDCRV+2) = 1.0D0
      CATD(KDCRV+3) = RAS
      CATD(KDCRV+4) = DECS
      CATR(KRCIC) = (XY(2,1) - XY(1,1)) / (KX-1.0)
      CATR(KRCIC+1) = (XY(2,2) - XY(1,2)) / (KY-1.0)
      CATR(KRDMN) = RMIN
      CATR(KRDMX) = RMAX
      IF (NAMEOU.EQ.' ') NAMEOU = NAMEIN
      IF (CLAOU.EQ.' ') CLAOU = TSKNAM
      CALL CHR2H (12, NAMEOU, KHIMNO, CATH(KHIMN))
      CALL CHR2H (6, CLAOU, KHIMCO, CATH(KHIMN))
      CALL CHR2H (2, 'MA', KHPTYO, CATH(KHIMN))
      CATBLK(KIIMS) = SEQOU
      CALL MCREAT (DISKOU, SLOT, BUFF1, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CREATE OUTPUT IMAGE FILE'
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKOU
      FCNO(NCFILE) = SLOT
      FRW(NCFILE) = 2
C                                       start IO
      CALL ZPHFIL ('MA', DISKOU, SLOT, 1, PHNAME, IRET)
      CALL ZOPEN (LUNO, INDO, DISKOU, PHNAME, .TRUE., .TRUE., .TRUE.,
     *   IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING OUTPUT IMAGE'
         GO TO 990
         END IF
      WIN(1) = 1
      WIN(2) = 1
      WIN(3) = NX
      WIN(4) = NY
      DO 50 IC = 1,3
         DEPTH(1) = IC
         CALL COMOFF (CATBLK(KIDIM), CATBLK(KINAX), DEPTH, BOI, IRET)
         BOI = BOI + 1
         CALL MINIT ('WRIT', LUNO, INDO, NX, NY, WIN, BUFF1, JBUFSZ,
     *      BOI, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'INIT I/O TO OUTPUT IMAGE'
            GO TO 990
            END IF
         DO 40 IY = 1,KY
            CALL MDISK ('WRIT', LUNO, INDO, BUFF1, BIND, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'WRITING OUTPUT IMAGE'
               GO TO 990
               END IF
            CALL RCOPY (KX, IMAGE(1,IY,IC), BUFF1(BIND))
 40         CONTINUE
         CALL MDISK ('FINI', LUNO, INDO, BUFF1, BIND, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'FINISH WRITE OUTPUT'
            GO TO 990
            END IF
 50      CONTINUE
      CALL ZCLOSE (LUNO, INDO, IRET)
C                                       history
C                                       Initialize HITAB
      CALL HIINIT (3)
C                                       Create and copy history file.
      CALL HISCOP (LUN1, LUN2, DISKIN, DISKOU, OLDCNO, SLOT, CATBLK,
     *   IBUFF, OBUFF, IRET)
      IF (IRET.GT.3) GO TO 999
      IF (IRET.EQ.3) GO TO 100
C                                       Add SUBIM history.
      CALL HENCO1 (TSKNAM, NAMEIN, CLAIN, SEQIN, DISKIN, LUN2, OBUFF,
     *   IRET)
      IF (IRET.NE.0) GO TO 100
      CALL H2CHR (6, KHIMCO, CATH(KHIMC), CLAOU)
      CALL HENCOO (TSKNAM, NAMEOU, CLAOU, CATBLK(KIIMS), DISKOU, LUN2,
     *   OBUFF, IRET)
      IF (IRET.NE.0) GO TO 100
C                                       shift
      WRITE (HILINE,2000) TSKNAM, SHIFT
      CALL HIADD (LUN2, HILINE, OBUFF, IRET)
      IF (IRET.NE.0) GO TO 100
C                                       SOLINT
      WRITE (HILINE,2001) TSKNAM, BPARM(2)
      CALL HIADD (LUN2, HILINE, OBUFF, IRET)
      IF (IRET.NE.0) GO TO 100
      I = BPARM(1) + 0.1
      WRITE (HILINE,2002) TSKNAM, I
      CALL HIADD (LUN2, HILINE, OBUFF, IRET)
      IF (IRET.NE.0) GO TO 100
      I = BPARM(8) + 0.1
      WRITE (HILINE,2003) TSKNAM, I
      CALL HIADD (LUN2, HILINE, OBUFF, IRET)
      IF (IRET.NE.0) GO TO 100
C                                       cal adverbs
      CALL CALHIS (LUN2, OBUFF, IRET)
      IF (IRET.NE.0) GO TO 100
C                                       close
 100  CALL HICLOS (LUN2, .TRUE., OBUFF, I)
      CALL CATIO ('UPDT', DISKOU, SLOT, CATBLK, 'CLWR', IBUFF, I)
      IF (I.NE.0) THEN
         WRITE (MSGTXT,1000) I, 'ON UPDATE HEADER WITH CATIO'
         CALL MSGWRT (8)
         END IF
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('OUTFT: ERROR',I4,' ON ',A)
 2000 FORMAT (A6,'SHIFT=',F9.4,',',F9.4,4X,'/ position shift in asec')
 2001 FORMAT (A6,'BPARM(2)=',F7.1,15X,'/ seconds averaging time')
 2002 FORMAT (A6,'BPARM(1)=',I7,18X,'/ intervals at same color')
 2003 FORMAT (A6,'BPARM(8)=',I7,18X,'/ pixel expansion number')
      END
