LOCAL INCLUDE 'ACIMG.INC'
C                                       Local include for ACIMG
      INCLUDE 'INCS:ZPBUFSZ.INC'
      INCLUDE 'INCS:PUVD.INC'
C
      HOLLERITH XNAMEI(3), XCLAIN(2), XNAMEO(3), XCLAOU(2), XSOUR(4,30),
     *   XCALC, XSTOK
      REAL      XSIN, XDISIN, XSOU, XDISOU, XANT(50), TIMER(8),
     *   BPARM(10), XQUAL, XBAND, XFREQ, XFQID, XSUBA, XBIF, XEIF,
     *   XBCHAN, XECHAN, XCHAVG, XDOCAL, XGUSE, XDOPOL, XPDVER,
     *   XBLVER, XFLAG, XDOBND, XBPVER, XSMOTH(3), BADD(10)
      DOUBLE PRECISION FOFF(MAXIF), DXC, DYC, DZC, RAS, DECS, OFREQ,
     *   FREQS(16384)
      REAL      BUFF1(UVBFSS), TBEG, TFIN, FRPIX, TAVG, FINC(MAXIF)
      CHARACTER NAMEIN*12, CLAIN*6, NAMEOU*12, CLAOU*6
      INTEGER   SEQIN, DISKIN, SEQOU, DISKOU, LUNI, INDI, JBUFSZ,
     *   NPARMS, NCHAVG, FREQID, KNCS, KNCF, KNCIF, CATOLD(256),
     *   IANT1, IANT2
      LOGICAL   ISFREQ
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XNAMEO, XCLAOU,
     *   XSOU, XDISOU, XANT, TIMER, XSTOK, BPARM, XSOUR, XQUAL, XCALC,
     *   XBAND, XFREQ, XFQID, XSUBA, XBIF, XEIF, XBCHAN, XECHAN, XCHAVG,
     *   XDOCAL, XGUSE, XDOPOL, XPDVER, XBLVER, XFLAG, XDOBND, XBPVER,
     *   XSMOTH, BADD
      COMMON /BUFRS/ BUFF1, JBUFSZ
      COMMON /FTPCOM/ FOFF, CATOLD, FREQS, OFREQ, DXC, DYC, DZC, RAS,
     *   DECS, FINC, TBEG, TFIN, TAVG, FRPIX, ISFREQ, SEQIN, DISKIN,
     *   LUNI, INDI, NPARMS, FREQID, KNCS, KNCF, KNCIF, SEQOU, DISKOU,
     *   NCHAVG, IANT1, IANT2
      COMMON /CHRCOM/ NAMEIN, CLAIN, NAMEOU, CLAOU
C                                                          End ACIMG.
LOCAL END
      PROGRAM ACIMG
C-----------------------------------------------------------------------
C! images autocorrelation data as a function of time and frequency
C# UV Analysis
C-----------------------------------------------------------------------
C;  Copyright (C) 2020-2022
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   ACIMG creates an image file to display the DFT of the visibilities
C   for an arbitrary position in the sky.  Plots resulting flux on
C   frequency and time axes.
C   NOTE 1: ACIMG wants the first key of the sort order of the UV data
C           base to be TIME.
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     ANTENNAS       XANT          antennas included
C     BPARM......Control parameters:
C        2 = averaging interval in sec
C        3 = write weight image
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   NX, NY, NZ, NWORDS, IRET
      REAL      IMAGE(2), ERROR(2), WEIGHT(2)
      LONGINT   PIMAGE, PERROR, PWEIGH
      INCLUDE 'ACIMG.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 /'ACIMG '/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL ACIMGI (PRGM, NX, NY, NZ, IRET)
      IF (IRET.NE.0) GO TO 995
C                                       allocate image
      NWORDS = (NX * NY * NZ - 1) / 1024 + 4
      CALL ZMEMRY ('GET ', PRGM, NWORDS, IMAGE, PIMAGE, IRET)
      IF (IRET.EQ.0) CALL ZMEMRY ('GET ', PRGM, NWORDS, ERROR, PERROR,
     *   IRET)
      IF (IRET.EQ.0) CALL ZMEMRY ('GET ', PRGM, NWORDS, WEIGHT, PWEIGH,
     *   IRET)
      IF (IRET.NE.0) THEN
         MSGTXT = 'FAILED TO GET DYNAMIC MEMORY'
         CALL MSGWRT (8)
         GO TO 995
         END IF
C                                       Do DFT's
      CALL ACIMGC (NX, NY, NZ, IMAGE(1+PIMAGE), ERROR(1+PERROR),
     *   WEIGHT(1+PWEIGH), IRET)
      IF (IRET.NE.0) GO TO 995
C                                       output
      CALL ACIMGO (NX, NY, NZ, IMAGE(1+PIMAGE), ERROR(1+PERROR), IRET)
C                                       Close down
 995  CALL DIE (IRET, BUFF1)
C
 999  STOP
      END
      SUBROUTINE ACIMGI (PRGM, NX, NY, NZ, JERR)
C-----------------------------------------------------------------------
C   ACIMGI gets input parameters for ACIMG .
C   Inputs:
C      PRGM    C*6    Program name
C   Output:
C      NX      I      Number spectral channels
C      NY      I      Number of times
C      NZ      I      Number of antennas
C      JERR    I      Error code: 0 => ok, else quit
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   NX, NY, NZ, JERR
C
      INCLUDE 'ACIMG.INC'
      CHARACTER BNDCOD(MAXIF)*8, CSTOK(12)*4
      INTEGER   OLDCNO, IUSER, I, IERR, IROUND, FQVER, NIF, CHBUFF(512),
     *   ISBAND(MAXIF), LUNCH, LF, LC, IC
      REAL      CATR(256), RPARM(20)
      LOGICAL   T
      DOUBLE PRECISION CATD(128), DFREQ, DFREQS
      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:DANS.INC'
      INCLUDE 'INCS:PSTD.INC'
      EQUIVALENCE (CATBLK, CATR, CATD)
      DATA T /.TRUE./
      DATA CSTOK /'RR', 'LL', 'RL', 'LR', 'VV', 'HH', 'VH', 'HV', 'I',
     *   'Q', 'U', 'V'/
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
C                                       Get input parameters.
      NPARMS = 235
      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.
      IUSER = NLUSER
      SEQIN = IROUND (XSIN)
      DISKIN = IROUND (XDISIN)
      SEQOU = IROUND (XSOU)
      DISKOU = IROUND (XDISOU)
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)
      CALL H2CHR (4, 1, XSTOK, STOKES)
      CALL H2CHR (4, 1, XCALC, SELCOD)
      DO 5 I = 1,10
         IBAD(I) = IROUND (BADD(I))
 5       CONTINUE
      DO 10 I = 1,30
         CALL H2CHR (16, 1, XSOUR(1,I), SOURCS(I))
 10      CONTINUE
      SELQUA = IROUND (XQUAL)
      NCHAVG = XCHAVG + 0.1
      NCHAVG = MAX (1, NCHAVG)
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
      DO 15 I = 1,50
         ANTENS(I) = IROUND (XANT(I))
 15      CONTINUE
      CALL ANTFND (ANTENS, NANTSL, DOAWNT)
      DOACOR = .TRUE.
      DOXCOR = .FALSE.
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
      NCHAVG = MIN (NCHAVG, ECHAN-BCHAN+1)
      NX = (ECHAN - BCHAN + 1) / NCHAVG
      ECHAN = BCHAN - 1 + NX * NCHAVG
      NX = NX * (EIF - BIF + 1)
      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                                       Get start/stop times
      CALL TBTIME (TBEG, TFIN, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'FINDING START AND STOP TIMES'
         GO TO 980
         END IF
C                                       set bin count, T averaging
      IF (BPARM(2).LE.0.001) BPARM(2) = 60.0
      TAVG = BPARM(2) / 86400.
      NY = (TFIN - TBEG) / TAVG + 1.5
C                                       number antennas
      IF ((NANTSL.GT.0) .AND. (DOAWNT)) THEN
         IANT1 = MAXANT
         IANT2 = 0
         DO 20 I = 1,NANTSL
            IANT1 = MIN (IANT1, ANTENS(I))
            IANT2 = MAX (IANT2, ANTENS(I))
 20         CONTINUE
      ELSE
         CALL GETANT (IUDISK, IUCNO, SUBARR, CATUV, BUFF1, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'READING ANTENNA INFORMATION'
            GO TO 980
            END IF
         IANT1 = 1
         IANT2 = NSTNS
         END IF
      NZ = IANT2 - IANT1 + 1
      RAS = RA
      DECS = DEC
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)
C                                       compute frequency array
      IC = 0
      ISFREQ = .TRUE.
      DO 40 LF = BIF,EIF
         DO 30 LC = BCHAN,ECHAN,NCHAVG
            IC = IC + 1
            FREQS(IC) = FOFF(LF) + FINC(LF) * (LC + (NCHAVG-1.0)/2.0 -
     *         FRPIX)
            IF (IC.EQ.2) THEN
               DFREQ = FREQS(2) - FREQS(1)
               DFREQS = ABS(DFREQ) / 100.0D0
            ELSE IF (IC.GT.2) THEN
               IF (ABS(FREQS(IC)-FREQS(IC-1)-DFREQ).GT.DFREQS)
     *            ISFREQ = .FALSE.
               END IF
 30         CONTINUE
 40      CONTINUE
      IF (ISFREQ) THEN
         MSGTXT = 'Freqencies on a fixed grid, will use FREQ axis'
      ELSE
         MSGTXT = 'Frequencies not all on same grid, FQ axis needed'
         END IF
      CALL MSGWRT (2)
C                                       Update catalog header.
      FRW(NCFILE) = 0
      JERR = 0
C                                       Check correlator display
      DO 50 I = 1,12
         IF (STOKES.EQ.CSTOK(I)) THEN
            BPARM(1) = I
            GO TO 999
            END IF
 50      CONTINUE
C                                       Stokes unavailable
      WRITE (MSGTXT,1900) STOKES
      JERR = 1
C
 980  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('ACIMGI: ERROR',I3,' ON ',A)
 1050 FORMAT ('ERROR',I5,' READING FREQUENCIES WITH CHNDAT')
 1900 FORMAT ('REQUESTED STOKES PARAMETER ''',A,''' NOT ALLOWED')
      END
      SUBROUTINE ACIMGC (NX, NY, NZ, IMAGE, ERROR, WEIGHT, IRET)
C-----------------------------------------------------------------------
C   ACIMGC accumlates the flux density for each averaging interval as
C   well as an estimate of the error. Also sets scaling for later use.
C   Inputs:
C      NX      I      X pixels in image
C      NY      I      Number of times
C      NZ      I      Number of antennas
C   Output:
C      IMAGE   R(*)   DFT image
C      ERROR   R(*)   Error estimate
C      IRET    I      Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   NX, NY, NZ, IRET
      REAL      IMAGE(NX,NY,*), ERROR(NX,NY,*), WEIGHT(NX,NY,*)
C
      INCLUDE 'ACIMG.INC'
      INTEGER   FLAG, NUMVIS, XUMVIS, I, IA1, IA2, IA, IY
      REAL      VIS(UVBFSS), RPARM(20)
      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
      I = NX * NY * NZ
      CALL RFILL (I, 0.0, IMAGE)
      CALL RFILL (I, 0.0, ERROR)
      CALL RFILL (I, 0.0, WEIGHT)
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                                       Is this a valid point ?
         CALL WANTED (RPARM, VIS, FLAG)
C                                       there is data
         IF (FLAG.EQ.0) THEN
            IY = (RPARM(1+ILOCT) - TBEG) / TAVG + 0.001
            IF ((IY.GE.1) .AND. (IY.LE.NY)) THEN
               IF (ILOCB.GE.0) THEN
                  IA1 = INT (RPARM(ILOCB+1)) / 256
                  IA2 = MOD (INT (RPARM(ILOCB+1)), 256)
               ELSE
                  IA1 = RPARM(ILOCA1+1) + 0.1
                  IA2 = RPARM(ILOCA2+1) + 0.1
                  END IF
C                                       Good point
               IF ((IA1.EQ.IA2) .AND. (IA1.GE.IANT1) .AND.
     *            (IA2.LE.IANT2)) THEN
                  IA = IA1 - IANT1 + 1
                  CALL DOIMG (FLAG, VIS, NX, NY, NZ, IY, IA, IMAGE,
     *               ERROR, WEIGHT, IRET)
                  XUMVIS = XUMVIS + 1
                  END IF
               END IF
            END IF
         GO TO 100
         END IF
C                                       Any valid points
      IF (XUMVIS.LE.1) THEN
         IRET = 4
         WRITE (MSGTXT,1200) XUMVIS
         GO TO 990
      ELSE
         WRITE (MSGTXT,1201) XUMVIS
         CALL MSGWRT (3)
         END IF
      FLAG = 2
      CALL DOIMG (FLAG, VIS, NX, NY, NZ, IY, IA, IMAGE, ERROR, WEIGHT,
     *   IRET)
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 ('ACIMGC: ERROR',I3,' ON ',A)
 1200 FORMAT ('FOUND',I5,' POINTS: NOT VERY INTERESTING')
 1201 FORMAT ('Found',I10,' data samples')
      END
      SUBROUTINE WANTED (RPBUF, VIS, 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   Outputs:
C      FLAG    I      0 => data selected as good
C                     1    data NO GOOD
C-----------------------------------------------------------------------
      REAL      RPBUF(*), VIS(*)
      INTEGER   FLAG
C
      INTEGER   LAD, IIF, ICH, IROUND
      LOGICAL   GOOD, ANY
      INCLUDE 'ACIMG.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                                       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
      FLAG = 0
C
 999  RETURN
      END
      SUBROUTINE DOIMG (FLAG, VIS, NX, NY, NZ, IY, IA, IMAGE, ERROR,
     *   WEIGHT, IRET)
C-----------------------------------------------------------------------
C   DODFT computes the DFT for a given set of visibilities with the
C   proper sky offset applied.
C   Inputs:
C      FLAG     I      If 0, continue summing DFT
C                      If 2, wrap it up, clear
C      VIS      R(*)   one visibility record - data
C      NX       I      Number of frequencies
C      NY       I      Number of times
C      NZ       I      Number of antennas
C      IY       I      row number in images
C      IA       I      plane number
C   In/out
C      IMAGE    R(*)   image
C      ERROR    R(*)   error
C      WEIGHT   R(*)   weight
C   Outputs:
C      IRET     I      0 => operation sucessful
C                      1 => trouble
C                      -1 => no data to average
C-----------------------------------------------------------------------
      INTEGER   FLAG, NX, NY, NZ, IY, IA, IRET
      REAL      VIS(*), IMAGE(NX,NY,*), ERROR(NX,NY,*), WEIGHT(NX,NY,*)
C
      REAL      TR, SMN, WT, DELS
      INTEGER   IIF, ICH, TAMP, LAD, IX, LCH, LY, LZ
      INCLUDE 'ACIMG.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:PSTD.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
C-----------------------------------------------------------------------
      IRET = 0
C                                       loop over IF and channel
      IF (FLAG.EQ.0) THEN
         IX = 0
         DO 50 IIF = BIF,EIF
            DO 40 ICH = BCHAN,ECHAN,NCHAVG
               IX = IX + 1
               DO 30 LCH = ICH,ICH+NCHAVG-1
                  LAD = 1 + (LCH-BCHAN)*KNCF + (IIF-BIF)*KNCIF
C                                       Find visibilities and weights
                  IF (VIS(LAD+2).GT.0.0) THEN
                     TR = VIS(LAD)
                     WT = VIS(LAD+2)
C                                       sum it up
                     IMAGE(IX,IY,IA) = IMAGE(IX,IY,IA) + WT * TR
                     ERROR(IX,IY,IA) = ERROR(IX,IY,IA) + WT * TR * TR
                     WEIGHT(IX,IY,IA) = WEIGHT(IX,IY,IA) + WT
                     END IF
 30               CONTINUE
 40            CONTINUE
 50         CONTINUE
C                                      Finish up full image
      ELSE
         IRET = -1
         DO 90 LZ = 1,NZ
            DO 80 LY = 1,NY
               DO 70 IX = 1,NX
                  IF (WEIGHT(IX,LY,LZ).GT.0.0) THEN
                     SMN = IMAGE(IX,LY,LZ) / WEIGHT(IX,LY,LZ)
                     DELS = ERROR(IX,LY,LZ) / WEIGHT(IX,LY,LZ) - SMN*SMN
                     DELS = SQRT (MAX (0.0, DELS))
                     IMAGE(IX,LY,LZ) = SMN
                     ERROR(IX,LY,LZ) = DELS / SQRT (MAX (1.0, TAMP-1.))
                     IRET = 0
                  ELSE
                     IMAGE(IX,LY,LZ) = FBLANK
                     ERROR(IX,LY,LZ) = FBLANK
                     END IF
 70               CONTINUE
 80            CONTINUE
 90         CONTINUE
         END IF
C
 999  RETURN
      END
      SUBROUTINE ACIMGO (NX, NY, NZ, IMAGE, ERROR, IRET)
C-----------------------------------------------------------------------
C   ACIMGO constructs an image header and writes out the waterfall
C   image and possibly the error as well
C   Inputs:
C      NX      I      Number of frequencies
C      NY      I      Number of times
C      NZ      I      Number of antennas
C      IMAGE   R(*)   Image(NX,NY,NZ)
C      ERROR   R(*)   Error(NX,NY,NZ)
C   Outputs:
C      IRET    I      Error condition
C-----------------------------------------------------------------------
      INTEGER   NX, NY, NZ, IRET
      REAL      IMAGE(NX,NY,*), ERROR(NX,NY,*)
C
      INCLUDE 'ACIMG.INC'
      INTEGER   IX, IY, IZ, I, J, SLOT, LUNO, INDO, BIND, WIN(4), BOI,
     *   IDEPTH(5)
      REAL      BMIN, BMAX, CATOR(256), CATR(256)
      LOGICAL   WASBLK
      DOUBLE PRECISION CATOD(128), CATD(128)
      HOLLERITH CATOH(256), CATH(256)
      CHARACTER PHNAME*48
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DFIL.INC'
      EQUIVALENCE (CATBLK, CATR, CATH, CATD)
      EQUIVALENCE (CATOLD, CATOD, CATOR, CATOH)
      DATA LUNO /39/
C-----------------------------------------------------------------------
C                                       make up a header
      CALL COPY (256, CATOLD, CATBLK)
      CALL UVPGET (IRET)
C
      CALL CHR2H (8, 'JY      ', 1, CATH(KHBUN))
C                                       random parameters
      J = KHPTP
      I = 2 * KIPTPN
      CALL RFILL (I, HBLANK, CATH(J))
C                                       axis parameters
      DO 20 I = 1,KICTPN
         J = I - 1
         CALL RFILL (2, HBLANK, CATH(KHCTP+2*J))
         CATR(KRCIC+J) = 1.0
         CATR(KRCRP+J) = 1.0
         CATBLK(KINAX+J) = 1
 20      CONTINUE
      CATBLK(KIGCN) = 0
      CATBLK(KIPCN) = 0
C                                       extensions
      CALL CATCLR (CATBLK)
C                                       now details
      CATBLK(KINAX) = NX
      IF (ISFREQ) THEN
         CATBLK(KIDIM) = 4
         CALL CHR2H (8, 'FREQ    ', 1, CATH(KHCTP))
         CATD(KDCRV) = OFREQ + FREQS(1)
         CATR(KRCIC) = FREQS(2) - FREQS(1)
      ELSE
         CATBLK(KIDIM) = 5
         CALL CHR2H (8, 'FQID    ', 1, CATH(KHCTP))
         CATD(KDCRV) = 1.0D0
         CALL CHR2H (8, 'FREQ    ', 1, CATH(KHCTP+8))
         CATBLK(KINAX+4) = 1
         CATD(KDCRV+4) = OFREQ
         CATR(KRCIC+4) = FINC(1)
         END IF
      CALL CHR2H (8, 'TIME    ', 1, CATH(KHCTP+2))
      CATBLK(KINAX+1) = NY
      CATD(KDCRV+1) = TBEG + TAVG/2.0
      CATR(KRCIC+1) = TAVG
      CALL CHR2H (8, 'ANTENNA ', 1, CATH(KHCTP+4))
      CATBLK(KINAX+2) = NZ
      CATD(KDCRV+2) = IANT1
      CALL CHR2H (8, 'STOKES  ', 1, CATH(KHCTP+6))
      CATBLK(KINAX+3) = 1
      J = BPARM(1) + 0.1
      IF (J.LE.8) THEN
         CATD(KDCRV+3) = -J
         CATR(KRCIC+3) = -1.0
      ELSE
         CATD(KDCRV+3) = J - 8
         CATR(KRCIC+3) = 1.0
         END IF
      IF ((JLOCR.GE.0) .AND. (JLOCD.GE.0) .AND. (RAS.NE.0.0D0) .AND.
     *   (DECS.NE.0.0D0)) THEN
         J = CATBLK(KIDIM)
         CATBLK(KIDIM) = J + 2
         CALL CHR2H (8, 'RA---SIN', 1, CATH(KHCTP+2*J))
         CALL CHR2H (8, 'DEC--SIN', 1, CATH(KHCTP+2*J+2))
         CATR(KRCIC+J) = 0.0
         CATR(KRCIC+J+1) = 0.0
         CATD(KDCRV+J) = RAS
         CATD(KDCRV+J+1) = DECS
         END IF
      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
      WASBLK = .FALSE.
      BMIN = 1.E10
      BMAX = -BMIN
      WIN(1) = 1
      WIN(2) = 1
      WIN(3) = NX
      WIN(4) = NY
      CALL FILL (5, 1, IDEPTH)
      DO 50 IZ = 1,NZ
         IDEPTH(1) = IZ
         CALL COMOFF (CATBLK(KIDIM), CATBLK(KINAX), IDEPTH, 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,NY
            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
            DO 30 IX = 1,NX
               IF (IMAGE(IX,IY,IZ).EQ.FBLANK) THEN
                  WASBLK = .TRUE.
               ELSE
                  BMIN = MIN (BMIN, IMAGE(IX,IY,IZ))
                  BMAX = MAX (BMAX, IMAGE(IX,IY,IZ))
                  END IF
               BUFF1(BIND+IX-1) = IMAGE(IX,IY,IZ)
 30            CONTINUE
 40         CONTINUE
         CALL MDISK ('FINI', LUNO, INDO, BUFF1, BIND, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'FINISH WRITING OUTPUT IMAGE'
            GO TO 990
            END IF
 50      CONTINUE
      CALL ZCLOSE (LUNO, INDO, IRET)
      CATR(KRDMX) = BMAX
      CATR(KRDMN) = BMIN
      CATR(KRBLK) = 0.0
      IF (WASBLK) CATR(KRBLK) = FBLANK
C                                       history
      CALL ACIMGH (NX, DISKOU, SLOT, IUCNO, IRET)
C                                       error image
      IF (BPARM(3).GT.0.0) THEN
         CLAOU = 'AC err'
         CALL CHR2H (6, CLAOU, KHIMCO, CATH(KHIMN))
         CATBLK(KIIMS) = SEQOU
         CALL MCREAT (DISKOU, SLOT, BUFF1, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'CREATE ERROR 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 ERROR IMAGE'
            GO TO 990
            END IF
         WASBLK = .FALSE.
         BMIN = 1.E10
         BMAX = -BMIN
         WIN(1) = 1
         WIN(2) = 1
         WIN(3) = NX
         WIN(4) = NY
         DO 90 IZ = 1,NZ
            IDEPTH(1) = IZ
            CALL COMOFF (CATBLK(KIDIM), CATBLK(KINAX), IDEPTH, 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 ERROR IMAGE'
               GO TO 990
               END IF
            DO 80 IY = 1,NY
               CALL MDISK ('WRIT', LUNO, INDO, BUFF1, BIND, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1000) IRET, 'WRITING ERROR IMAGE'
                  GO TO 990
                  END IF
               DO 70 IX = 1,NX
                  IF (ERROR(IX,IY,IZ).EQ.FBLANK) THEN
                     WASBLK = .TRUE.
                  ELSE
                     BMIN = MIN (BMIN, ERROR(IX,IY,IZ))
                     BMAX = MAX (BMAX, ERROR(IX,IY,IZ))
                     END IF
                  BUFF1(BIND+IX-1) = ERROR(IX,IY,IZ)
 70               CONTINUE
 80            CONTINUE
            CALL MDISK ('FINI', LUNO, INDO, BUFF1, BIND, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'FINISH WRITING ERROR IMAGE'
               GO TO 990
               END IF
 90         CONTINUE
         CALL ZCLOSE (LUNO, INDO, IRET)
         CATR(KRDMX) = BMAX
         CATR(KRDMN) = BMIN
         CATR(KRBLK) = 0.0
         IF (WASBLK) CATR(KRBLK) = FBLANK
C                                       history
         CALL ACIMGH (NX, DISKOU, SLOT, IUCNO, IRET)
         END IF
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('ACIMGO: ERROR',I4,' ON ',A)
      END
      SUBROUTINE ACIMGH (NX, DISK, CNO, INCNO, IRET)
C-----------------------------------------------------------------------
C   writes history to ACIMG
C   Inputs:
C      DISK   I   Disk number
C      CNO    I   Catalog number of output image
C   Output
C      IRET   I   Error code
C-----------------------------------------------------------------------
      INTEGER   NX, DISK, CNO, INCNO, IRET
C
      INCLUDE 'ACIMG.INC'
      INTEGER   LUN1, LUN2, IBUFF(256), OBUFF(256), I, VER, NI,
     *   FQID, IFSIDE, LF, LC
      CHARACTER HILINE*72, CLASS*6, BNDCOD*8
      DOUBLE PRECISION IFFREQ
      REAL      IFCHW, IFTBW
      HOLLERITH CATH(256)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DHDR.INC'
      EQUIVALENCE (CATBLK, CATH)
      DATA LUN1, LUN2 / 45,46/
C-----------------------------------------------------------------------
C                                       Initialize HITAB
      CALL HIINIT (3)
C                                       Create and copy history file.
      CALL HISCOP (LUN1, LUN2, DISKIN, DISK, INCNO, CNO, 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), CLASS)
      CALL HENCOO (TSKNAM, NAMEOU, CLASS, CATBLK(KIIMS), DISK, LUN2,
     *   OBUFF, IRET)
      IF (IRET.NE.0) GO TO 100
C                                       NCHAVG
      WRITE (HILINE,2001) TSKNAM, NCHAVG
      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)
C                                       write FQ table
      IF (.NOT.ISFREQ) THEN
         VER = 1
         NI = 1
         CALL FQINI ('WRIT', FQBUFF, DISK, CNO, VER, CATBLK, LUN1,
     *      IFQRNO, FQKOLS, FQNUMV, NI, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'CREATING FQ TABLE'
            CALL MSGWRT (8)
            GO TO 200
            END IF
C                                       write
         IFSIDE = 1
         I = 0
         BNDCOD = ' '
         DO 120 LF = BIF,EIF
            DO 110 LC = BCHAN,ECHAN,NCHAVG
               I = I + 1
               IFQRNO = I
               IFFREQ = FREQS(I)
               FQID = I
               IFCHW = FINC(LF)*NCHAVG
               IFTBW = FINC(LF)*NCHAVG
               CALL TABFQ ('WRIT', FQBUFF, IFQRNO, FQKOLS, FQNUMV, NI,
     *            FQID, IFFREQ, IFCHW, IFTBW, IFSIDE, BNDCOD, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1000) IRET, 'WRITING FQ TABLE'
                  CALL MSGWRT (8)
                  GO TO 200
                  END IF
 110           CONTINUE
 120        CONTINUE
         CALL TABFQ ('CLOS', FQBUFF, IFQRNO, FQKOLS, FQNUMV, NUMIF,
     *      FQID, IFFREQ, IFCHW, IFTBW, IFSIDE, BNDCOD, I)
         END IF
C
 200  CALL CATIO ('UPDT', DISK, CNO, CATBLK, 'CLWR', IBUFF, I)
      IF (I.NE.0) THEN
         WRITE (MSGTXT,1000) I, 'ON UPDATE HEADER WITH CATIO'
         CALL MSGWRT (8)
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('ACIMGH: ERROR',I4,' ON ',A)
 2001 FORMAT (A6,'NCHAVG=',I4,18X,'/ channels averaged')
      END
