LOCAL INCLUDE 'HOCLN.INC'
      INCLUDE 'INCS:PMAD.INC'
      INTEGER   SEQI(4), SEQO(2), DISKI(4), DISKO(2), CNOO(2), CNOI(4),
     *   CATOLD(256,4), CATNEW(256,2), NUMHIS, JBUFSZ
      HOLLERITH XNAME1(3), XCLAS1(2), XNAME2(3), XCLAS2(2), XNAME3(3),
     *   XCLAS3(2), XNAME4(3), XCLAS4(2), XNAMOU(3), CATOH(256,4),
     *   CATNH(256,2)
      CHARACTER NAME(4)*12, CLASS(4)*6, NAMEO(2)*12, CLASSO(2)*6,
     *   HISCRD(2)*64
      REAL      XSEQ1, XDISK1, XSEQ2, XDISK2, XSEQ3, XDISK3, XSEQ4,
     *   XDISK4, XSEQO, XDISKO, XNIT, GAIN, BMAJ, XDOTV,
     *   BUFFI(MABFSS), BUFFO(MABFSS), CATOR(256,4), CATNR(256,2)
      COMMON /INPARM/ XNAME1, XCLAS1, XSEQ1, XDISK1, XNAME2, XCLAS2,
     *   XSEQ2, XDISK2, XNAME3, XCLAS3, XSEQ3, XDISK3, XNAME4, XCLAS4,
     *   XSEQ4, XDISK4, XNAMOU, XSEQO, XDISKO, XNIT, GAIN, BMAJ, XDOTV
      COMMON /CHPARM/ NAME, CLASS, NAMEO, CLASSO, HISCRD
      COMMON /PARMS/ CATOLD, CATNEW, SEQI, SEQO, DISKI, DISKO, CNOI,
     *   CNOO, JBUFSZ, NUMHIS
      COMMON /BUFRS/ BUFFI, BUFFO
      EQUIVALENCE (CATOLD, CATOH, CATOR)
      EQUIVALENCE (CATNEW, CATNH, CATNR)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
LOCAL END
      PROGRAM HOCLN
C-----------------------------------------------------------------------
C! weighted sum of two or more data cubes with weight sum also output
C# Map
C-----------------------------------------------------------------------
C;  Copyright (C) 2023
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   Does a complex Clean of holography images
C   Inputs:
C      AIPS adverb  Prg. name.          Description.
C      INNAME         NAME(1)      Name of input image.
C      INCLASS        CLASS(1)     Class of input image.
C      INSEQ          SEQI(1)      Seq. of input image.
C      INDISK         DISKI(1)     Disk number of input image.
C      IN2NAME        NAME(2)      Name of 2nd input image.
C                                  ' ' => loop inseq:in2seq
C                                  and in3seq:(in2seq-inseq+in3seq)
C      IN2CLASS       CLASS(2)     Class of 2nd input image.
C      IN2SEQ         SEQI(2)      Seq. of 2nd input image.
C      IN2DISK        DISKI(2)     Disk number of 2nd input image.
C      IN3NAME        NAME(3)      Name of 1st weight image.
C      IN3CLASS       CLASS(3)     Class of 1st weight image.
C      IN3SEQ         SEQI(3)      Seq. of 1st weight image.
C      IN3DISK        DISKI(3)     Disk number of 1st weight image.
C      IN4NAME        NAME(4)      Name of 2nd weight image.
C      IN4CLASS       CLASS(4)     Class of 2nd weight image.
C      IN4SEQ         SEQI(4)      Seq. of 2nd weight image.
C      IN4DISK        DISKI(4)     Disk number of 2nd weight image.
C      OUTNAME        NAMEO        Name of the output image
C                                  Default output is input image.
C      OUTCLASS       CLASSO       Class of the output image.
C                                  Default is HOCLN
C                                  weight sum image is WHOCLN
C      OUTSEQ         SEQO         Seq. number of output image.
C      OUTDISK        DISKO        Disk number of the output image.
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET, NI, NB
      COMPLEX   IMAGE(512,512), BEAM(512,512), CSCR1(512,512),
     *   CSCR2(512,512)
      REAL      SCR1(512,512,2), SCR2(512,512,2)
      INCLUDE 'HOCLN.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA PRGM /'HOCLN '/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output files
      CALL HOCLIN (PRGM, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Read in and format images
      NI = CATOLD(KINAX,1)
      NB = CATOLD(KINAX,3)
      CALL HOCLRD (NI, IMAGE, SCR1, NB, BEAM, SCR2, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Clean
      CALL HOCLCL (NI, IMAGE, CSCR1, CSCR2, NB, BEAM, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Write out answer
      CALL HOCLWR (NI, IMAGE, SCR1, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       History
      CALL HOCLHI
C                                       Close down files, etc.
 990  CALL DIE (IRET, BUFFI)
C
 999  STOP
      END
      SUBROUTINE HOCLIN (PRGN, IRET)
C-----------------------------------------------------------------------
C   HOCLIN gets input parameters for HOCLN and creates an output file.
C   Inputs:
C      PRGN    C*6  Program name
C   Output:
C      IRET    I    Error code: 0 => ok
C                               4 => user routine detected error.
C                               5 => catalog troubles
C                               8 => can't start
C   Commons: /INPARM/ all input adverbs in order given by INPUTS
C                     file
C            /MAPHDR/ output file catalog header
C-----------------------------------------------------------------------
      INTEGER   IRET
      CHARACTER PRGN*6
C
      CHARACTER  STAT*4, MTYPE*2
      INTEGER   IERR, NPARM, IROUND, II
      LOGICAL   NOMATC
      INCLUDE 'HOCLN.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      JBUFSZ = 2 * MABFSS
      IRET = 0
      NUMHIS = 0
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
C                                       Get input parameters.
      NPARM = 37
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAME1, BUFFI, 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
      IF (RQUICK) CALL RELPOP (IRET, BUFFI, IERR)
      IF (IRET.NE.0) GO TO 999
      IRET = 5
C                                       Hollerith -> char.
      CALL H2CHR (12, 1, XNAME1, NAME(1))
      CALL H2CHR (12, 1, XNAME2, NAME(2))
      CALL H2CHR (12, 1, XNAME3, NAME(3))
      CALL H2CHR (12, 1, XNAME4, NAME(4))
      CALL H2CHR (6, 1, XCLAS1, CLASS(1))
      CALL H2CHR (6, 1, XCLAS2, CLASS(2))
      CALL H2CHR (6, 1, XCLAS3, CLASS(3))
      CALL H2CHR (6, 1, XCLAS4, CLASS(4))
      CALL H2CHR (12, 1, XNAMOU, NAMEO(1))
C                                       Crunch input parameters.
      SEQI(1) = IROUND (XSEQ1)
      SEQI(2) = IROUND (XSEQ2)
      SEQI(3) = IROUND (XSEQ3)
      SEQI(4) = IROUND (XSEQ4)
      SEQO(1) = IROUND (XSEQO)
      SEQO(2) = IROUND (XSEQO)
      DISKI(1) = IROUND (XDISK1)
      DISKI(2) = IROUND (XDISK2)
      DISKI(3) = IROUND (XDISK3)
      DISKI(4) = IROUND (XDISK4)
      DISKO(1) = IROUND (XDISKO)
C                                       Create new file.
C                                       Get CATBLK from old files
      DO 10 II = 1,4
         CNOI(II) = 1
         MTYPE = 'MA'
         CALL CATDIR ('SRCH', DISKI(II), CNOI(II), NAME(II), CLASS(II),
     *      SEQI(II), MTYPE, NLUSER, STAT, BUFFI, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1030) IERR, NAME(II), CLASS(II), SEQI(II),
     *         DISKI(II), NLUSER
            GO TO 990
            END IF
C                                       Read CATBLK and mark 'READ'.
         CALL CATIO ('READ', DISKI(II), CNOI(II), CATOLD(1,II), 'READ',
     *      BUFFI, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1040) IERR
            GO TO 990
            END IF
         NCFILE = NCFILE + 1
         FVOL(NCFILE) = DISKI(II)
         FCNO(NCFILE) = CNOI(II)
         FRW(NCFILE) = 0
 10      CONTINUE
C                                       Checks
      NOMATC = .FALSE.
      IF ((CATOLD(KINAX,1).NE.256) .AND. (CATOLD(KINAX,1).NE.512))
     *   NOMATC = .TRUE.
      IF ((CATOLD(KINAX,2).NE.CATOLD(KINAX,1)) .AND.
     *   (CATOLD(KINAX,2).NE.CATOLD(KINAX,1))) NOMATC = .TRUE.
      IF ((CATOLD(KINAX+1,1).NE.CATOLD(KINAX,1)) .AND.
     *   (CATOLD(KINAX+1,1).NE.CATOLD(KINAX,1))) NOMATC = .TRUE.
      IF ((CATOLD(KINAX+1,2).NE.CATOLD(KINAX,2)) .AND.
     *   (CATOLD(KINAX+1,2).NE.CATOLD(KINAX,2))) NOMATC = .TRUE.
      IF (NOMATC) THEN
         MSGTXT = 'IMAGES DO NOT MATCH EXPECTATIONS'
         CALL MSGWRT (8)
         GO TO 999
         END IF
      IF ((CATOLD(KINAX,3).NE.256) .AND. (CATOLD(KINAX,3).NE.512))
     *   NOMATC = .TRUE.
      IF ((CATOLD(KINAX,4).NE.CATOLD(KINAX,3)) .AND.
     *   (CATOLD(KINAX,4).NE.CATOLD(KINAX,3))) NOMATC = .TRUE.
      IF ((CATOLD(KINAX+1,3).NE.CATOLD(KINAX,3)) .AND.
     *   (CATOLD(KINAX+1,3).NE.CATOLD(KINAX,3))) NOMATC = .TRUE.
      IF ((CATOLD(KINAX+1,4).NE.CATOLD(KINAX,4)) .AND.
     *   (CATOLD(KINAX+1,4).NE.CATOLD(KINAX,4))) NOMATC = .TRUE.
      IF (NOMATC) THEN
         MSGTXT = 'BEAMS DO NOT MATCH EXPECTATIONS'
         CALL MSGWRT (8)
         GO TO 999
         END IF
C                                       Copy old CATBLK to new.
      CALL COPY (256, CATOLD(1,1), CATBLK)
C                                       Put new values in CATBLK.
      CLASSO = 'C_AMP'
      CALL MAKOUT (NAME, CLASS, SEQI, '      ', NAMEO, CLASSO, SEQO)
      CALL CHR2H (12, NAMEO(1), KHIMNO, CATH(KHIMN))
      CALL CHR2H (6, CLASSO(1), KHIMCO, CATH(KHIMC))
      CATBLK(KIIMS) = SEQO(1)
C                                       Create output file.
      CNOO(1) = 1
      IRET = 4
      CALL MCREAT (DISKO(1), CNOO(1), BUFFI, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1060) IERR
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKO(1)
      FCNO(NCFILE) = CNOO(1)
      FRW(NCFILE) = 2
      SEQO(1) = CATBLK(KIIMS)
      CALL COPY (256, CATBLK, CATNEW(1,1))
C                                       copy most keywords
      CALL KEYPCP (DISKI(1), CNOI(1), DISKO(1), CNOO(1), 0, ' ', IERR)
C                                       make second output
      NAMEO(2) = NAMEO(1)
      CLASSO(2) = 'C_PHA'
      DISKO(2) = DISKO(1)
      CALL COPY (256, CATOLD(1,3), CATBLK)
C                                       Put new values in CATBLK.
      CALL CHR2H (12, NAMEO(2), KHIMNO, CATH(KHIMN))
      CALL CHR2H (6, CLASSO(2), KHIMCO, CATH(KHIMC))
      CATBLK(KIIMS) = SEQO(2)
      CALL RCOPY (2, CATOH(KHBUN,2), CATH(KHBUN))
C                                       Create output file.
      CNOO(2) = 1
      IRET = 4
      CALL MCREAT (DISKO(2), CNOO(2), BUFFI, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1060) IERR
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKO(2)
      FCNO(NCFILE) = CNOO(2)
      FRW(NCFILE) = 2
      SEQO(2) = CATBLK(KIIMS)
C                                       copy most keywords
      CALL KEYPCP (DISKI(1), CNOI(1), DISKO(2), CNOO(2), 0, ' ', IERR)
      CALL COPY (256, CATBLK, CATNEW(1,2))
      IRET = 0
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('HOCLIN: ERROR',I3,' OBTAINING INPUT PARAMETERS')
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I3,' DISK=',
     *   I3,' USID=',I5)
 1040 FORMAT ('ERROR',I3,' COPYING CATBLK ')
 1060 FORMAT ('HOCLIN: ERROR',I3,' CREATING OUTPUT FILE')
      END
      SUBROUTINE HOCLRD (NI, IMAGE, WORK1, NB, BEAM, WORK2, IRET)
C-----------------------------------------------------------------------
C   HOCLRD reads the input files and makes image in ram for cleaning
C   Inputs:
C      NI      I      Size of images
C   Output:
C      IMAGE   C(*)   Real, imaginary  of image
C      BEAM    C(*)   Real, imaginary  of beam
C      WORK1   R(*)   real work array
C      WORK2   R(*)   real work array
C      IRET    I      Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   NI, NB, IRET
      COMPLEX   IMAGE(NI,NI), BEAM(NB,NB)
      REAL      WORK1(NI,NI,2), WORK2(NB,NB,2)
C
      CHARACTER IFILE*48
      INTEGER   LUNI, NYI, NXI, WINI(4), BOI, I1, I2, IPOS(7),
     *   II, BOTEMP, IBIND, INDI, NPIX
      REAL      BMAX, AMP, PHS
      LOGICAL   T, F
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'HOCLN.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:PSTD.INC'
      DATA LUNI /16/
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
C                                       Setup for I/O
      NXI = CATOLD(KINAX,1)
      NYI = CATOLD(KINAX+1,1)
      WINI(1) = 1
      WINI(2) = 1
      WINI(3) = NXI
      WINI(4) = NYI
C                                       LOOP POINT:
C                                       Open and init for read
      DO 30 II = 1,4
         CALL ZPHFIL ('MA', DISKI(II), CNOI(II), 1, IFILE, IRET)
         CALL ZOPEN (LUNI, INDI, DISKI(II), IFILE, T, F, T, IRET)
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1000) IRET, II, 'OPEN FILE'
            GO TO 990
            END IF
         CALL FILL (7, 1, IPOS)
C                                       Init. files, 1st & 2nd input.
         CALL COMOFF (CATOLD(KIDIM,II), CATOLD(KINAX,II), IPOS(3),
     *      BOTEMP, IRET)
         BOI = BOTEMP + 1
         CALL MINIT ('READ', LUNI, INDI, NXI, NYI, WINI, BUFFI, JBUFSZ,
     *      BOI, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, II, 'INIT READ'
            GO TO 990
            END IF
         DO 20 I2 = 1,NYI
            IPOS(2) = I2
            IPOS(1) = 1
C                                       Read.
            CALL MDISK ('READ', LUNI, INDI, BUFFI, IBIND, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, II, 'READ ROW'
               GO TO 990
               END IF
C                                       Check max, min, blanking.
            IF (II.LE.2) THEN
               CALL RCOPY (NXI, BUFFI(IBIND), WORK1(1,I2,II))
            ELSE
               CALL RCOPY (NXI, BUFFI(IBIND), WORK2(1,I2,II-2))
               END IF
 20         CONTINUE
         IF (II.EQ.2) THEN
            NXI = CATOLD(KINAX,3)
            NYI = CATOLD(KINAX+1,3)
            WINI(3) = NXI
            WINI(4) = NYI
            END IF
C                                       Close input map.
         CALL ZCLOSE (LUNI, INDI, IRET)
 30      CONTINUE
C                                       Find max min
      BMAX = 0.0
      DO 50 I2 = 1,NB
         DO 40 I1 = 1,NB
            IF ((WORK2(I1,I2,1).NE.FBLANK) .AND.
     *         (WORK2(I1,I2,2).NE.FBLANK)) BMAX = MAX (BMAX,
     *         WORK2(I1,I2,1))
 40         CONTINUE
 50      CONTINUE
      WRITE (MSGTXT,1050) BMAX
      CALL MSGWRT (2)
C                                       To real/imaginary
      NPIX = 0
      DO 70 I2 = 1,NI
         DO 60 I1 = 1,NI
            IF ((WORK1(I1,I2,1).NE.FBLANK) .AND.
     *         (WORK1(I1,I2,2).NE.FBLANK)) THEN
               AMP = WORK1(I1,I2,1)
               PHS = DG2RAD * WORK1(I1,I2,2)
               IMAGE(I1,I2) = AMP * CMPLX (COS(PHS), SIN(PHS))
               NPIX = NPIX + 1
            ELSE
               IMAGE(I1,I2) = CMPLX (FBLANK, FBLANK)
               END IF
 60         CONTINUE
 70      CONTINUE
      WRITE (MSGTXT,1070) 'IMAGE', NPIX
      CALL MSGWRT (2)
      NPIX = 0
      DO 90 I2 = 1,NB
         DO 80 I1 = 1,NB
            IF ((WORK2(I1,I2,1).NE.FBLANK) .AND.
     *         (WORK2(I1,I2,2).NE.FBLANK)) THEN
               AMP = WORK2(I1,I2,1) / BMAX
               PHS = DG2RAD * WORK2(I1,I2,2)
               BEAM(I1,I2) = AMP * CMPLX (COS(PHS), SIN(PHS))
               NPIX = NPIX + 1
            ELSE
               BEAM(I1,I2) = CMPLX (FBLANK, FBLANK)
               END IF
 80         CONTINUE
 90      CONTINUE
      WRITE (MSGTXT,1070) 'BEAM ', NPIX
      CALL MSGWRT (2)
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('HOCLDO: ERROR',I3,' FILE',I2,' ON ',A)
 1050 FORMAT ('Scaling beam by maximum',F10.4)
 1070 FORMAT (A,' image has',I8,' unblanked pixels')
      END
      SUBROUTINE HOCLWR (NI, IMAGE, WORK, IRET)
C-----------------------------------------------------------------------
C   HOCLWR write out the answer
C   Inputs
C      NI      I      Number pixels on axis
C      IMAGE   C(*)   Image
C   Outputs
C      WORK    R(*)   Work array
C      IRET    I      Error code
C-----------------------------------------------------------------------
      INTEGER   NI, IRET
      COMPLEX   IMAGE(NI,NI)
      REAL      WORK(NI,NI,2)
C
      INTEGER   IX, IY, WINO(4), LUNO, INDO, BOO, BOTEMP, II, OBIND,
     *   CORN(5)
      REAL      AMAX, AMIN, PMAX, PMIN
      LOGICAL   BLNKD, T
      CHARACTER IFILE*48
      INCLUDE 'HOCLN.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:PSTD.INC'
      DATA T /.TRUE./,   CORN /5*0/
      DATA LUNO /16/
C-----------------------------------------------------------------------
C                                       convert to amplitude/phase
      AMAX = -1.E10
      AMIN = -AMAX
      PMAX = AMAX
      PMIN = AMIN
      BLNKD = .FALSE.
      DO 20 IY = 1,NI
         DO 10 IX = 1,NI
            IF (REAL(IMAGE(IX,IY)).EQ.FBLANK) THEN
               WORK(IX,IY,1) = FBLANK
               WORK(IX,IY,2) = FBLANK
               BLNKD = .TRUE.
            ELSE
               WORK(IX,IY,1) = CABS (IMAGE(IX,IY))
               WORK(IX,IY,2) = RAD2DG *
     *            ATAN2 (IMAG(IMAGE(IX,IY)), REAL(IMAGE(IX,IY)))
               AMAX = MAX (AMAX, WORK(IX,IY,1))
               AMIN = MIN (AMIN, WORK(IX,IY,1))
               PMAX = MAX (PMAX, WORK(IX,IY,2))
               PMIN = MIN (PMIN, WORK(IX,IY,2))
               END IF
 10         CONTINUE
 20      CONTINUE
      CATNR(KRDMX,1) = AMAX
      CATNR(KRDMX,2) = PMAX
      CATNR(KRDMN,1) = AMIN
      CATNR(KRDMN,2) = PMIN
      WRITE (MSGTXT,2000) AMIN, AMAX
      CALL MSGWRT (2)
      WRITE (MSGTXT,2001) PMIN, PMAX
      CALL MSGWRT (2)
C                                       Mark blanking in CATBLK.
      CATNR(KRBLK,1) = 0.0
      IF (BLNKD) CATNR(KRBLK,1) = FBLANK
      CATNR(KRBLK,2) = 0.0
      IF (BLNKD) CATNR(KRBLK,2) = FBLANK
C                                       Now write them out
      WINO(1) = 1
      WINO(2) = 1
      WINO(3) = NI
      WINO(4) = NI
C                                       Open and init for output
      DO 100 II = 1,2
         CALL ZPHFIL ('MA', DISKO(II), CNOO(II), 1, IFILE, IRET)
         CALL ZOPEN (LUNO, INDO, DISKO(II), IFILE, T, T, T, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, II, 'OPENING FILE'
            GO TO 990
            END IF
         CALL COMOFF (CATNEW(KIDIM,II), CATNEW(KINAX,II), CORN, BOTEMP,
     *      IRET)
         BOO = BOTEMP + 1
         CALL MINIT ('WRIT', LUNO, INDO, NI, NI, WINO, BUFFO, JBUFSZ,
     *      BOO, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, II, 'INIT I/O'
            GO TO 990
            END IF
         DO 40 IY = 1,NI
            CALL MDISK ('WRIT', LUNO, INDO, BUFFO, OBIND, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, II, 'WRITE FILE'
               GO TO 990
               END IF
            CALL RCOPY (NI, WORK(1,IY,II), BUFFO(OBIND))
 40         CONTINUE
C                                       Flush buffer.
         CALL MDISK ('FINI', LUNO, INDO, BUFFO, OBIND, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, II, 'FLUSH OUTPUT BUFFER'
            GO TO 990
            END IF
         CALL ZCLOSE (LUNO, INDO, IRET)
C                                       update catalog
         CALL CATIO ('UPDT', DISKO(1), CNOO(1), CATNEW(1,1), 'REST',
     *      BUFFI, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, II, 'UPDATING CATALOG HEADER'
            GO TO 990
            END IF
 100     CONTINUE
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('HOCLWR: ERROR',I4,' FILE',I2,' ON ',A)
 2000 FORMAT ('Writing amplitude range',2(1PE12.4))
 2001 FORMAT ('Writing phase range    ',2F7.1)
      END
      SUBROUTINE HOCLTV (ITER, NI, IMAGE, SCRTCH, IRET)
C-----------------------------------------------------------------------
C   Displays residual on TV - gets quit command
C   Inputs
C      ITER     I      Iteration number: 0 at start, -1 final image
C                         -99 component sum image
C      NI       I      Image size
C      IMAGE    R(*)   Image(NI,NI,2)
C   Outputs
C      SCRTCH   R(*)   Scratch image
C      IRET     I      Error code
C-----------------------------------------------------------------------
      INTEGER   ITER, NI, IRET
      COMPLEX   IMAGE(NI,NI)
      REAL      SCRTCH(*)
C
      INTEGER   IX, IY, I, ICH, TVWIN(4), IBUFF(1024), IQ, IB, HORIZ,
     *   IYTV, VX(5), VY(5), IGR, NSUM, INCHAR
      REAL      IMAX(2), TD, RPOS(2), SUM, SUMS
      CHARACTER TRANFN*2, STRING*48
      LOGICAL   F
      INCLUDE 'HOCLN.INC'
      INCLUDE 'INCS:DTVC.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA F /.FALSE./
C-----------------------------------------------------------------------
      HORIZ = 0
      IMAX(1) = 0.0
      IMAX(2) = 0.0
      NSUM = 0
      SUM = 0.0
      SUMS = 0.0
      DO 20 IY = 1,NI
         DO 10 IX = 1,NI
            I = I + 1
            IF (REAL(IMAGE(IX,IY)).NE.FBLANK) THEN
               SCRTCH(I) = CABS (IMAGE(IX,IY))
               NSUM = NSUM + 1
               SUM = SUM + SCRTCH(I)
               SUMS = SUMS + SCRTCH(I) * SCRTCH(I)
               IMAX(2) = MAX (IMAX(2), SCRTCH(I))
            ELSE
               SCRTCH(I) = FBLANK
               END IF
 10         CONTINUE
 20      CONTINUE
      IF (NSUM.GT.0) THEN
         SUM = SUM / NSUM
         SUMS = SUMS/NSUM - SUM*SUM
         IF (SUMS.GT.0.0) SUMS = SQRT (SUMS)
         END IF
      IF (ITER.GE.0) THEN
         WRITE (MSGTXT,1010) ITER, IMAX(2), SUMS
         WRITE (STRING,2010) ITER, IMAX(2), SUMS
      ELSE IF (ITER.EQ.-1) THEN
         WRITE (MSGTXT,1011) IMAX(2), SUMS
         WRITE (STRING,2011) IMAX(2), SUMS
      ELSE
         WRITE (MSGTXT,1012) IMAX(2), SUMS
         WRITE (STRING,2012) IMAX(2), SUMS
         END IF
      CALL MSGWRT (2)
      IRET = 0
      IF (XDOTV.LE.0.0) GO TO 999
      CALL REFRMT (STRING, '_', INCHAR)
C                                       open TV
      CALL TVOPEN (BUFFI, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING TV'
         GO TO 990
         END IF
      ICH = 1
      CALL TVSET (ICH, BUFFI, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'INIT TV'
         GO TO 980
         END IF
      IGR = 2 + NGRAY
      CALL YZERO (IGR, IRET)
      TVWIN(1) = (MAXXTV(1) - NI) / 2
      TVWIN(2) = (MAXXTV(2) - NI) / 2
      TVWIN(3) = TVWIN(1) + NI - 1
      TVWIN(4) = TVWIN(2) + NI - 1
C                                       image catalog
      CALL COPY (256, CATNEW(1,1), CATBLK)
      CALL COPY (4, TVWIN, CATBLK(IICOR))
      CATBLK(IIWIN) = 1
      CATBLK(IIWIN+1) = 1
      CATBLK(IIWIN+2) = NI
      CATBLK(IIWIN+3) = NI
      CALL CHR2H (2, TRANFN, 1, CATH(IITRA))
      CATR(IRRAN) = IMAX(1)
      CATR(IRRAN+1) = IMAX(2)
      CALL CHR2H (8, 'Holorast', 1, CATH(KHOBJ))
      CALL FILL (5, 1, CATBLK(IIDEP))
      CATR(KRDMX) = IMAX(2)
      CALL YCWRIT (ICH, TVWIN, CATBLK, IBUFF, IRET)
C                                       label
      IYTV = TVWIN(4) + 2.5 * CSIZTV(2) + 0.5
      CALL IMANOT ('ONNN', 2, TVWIN(1), IYTV, 0, 0, STRING(:INCHAR),
     *   SCRTCH, IRET)
      CALL IMANOT ('WRIT', 2, TVWIN(1), IYTV, 0, 0, STRING(:INCHAR),
     *   SCRTCH, IRET)
      VX(1) = TVWIN(1) - 1
      VY(1) = TVWIN(2) - 1
      VX(2) = TVWIN(3) + 1
      VY(2) = VY(1)
      VX(3) = VX(2)
      VY(3) = TVWIN(4) + 1
      VX(4) = VX(1)
      VY(4) = VY(3)
      VX(5) = VX(1)
      VY(5) = VY(1)
      CALL IMVECT ('ONNN', IGR, 6, VX, VY, SCRTCH, IRET)
      CALL IAXIS1 (SCRTCH, 3, 2, 0, .FALSE., IRET)
C
      IYTV = TVWIN(2) - 1
      I = 1 - NI
      TRANFN = 'LN'
      DO 40 IY = 1,NI
         IYTV = IYTV + 1
         I = I + NI
         CALL ISCALE (TRANFN, MAXINT, IMAX, NI, 1, SCRTCH(I), IBUFF)
         CALL YIMGIO ('WRIT', ICH, TVWIN(1), IYTV, HORIZ, NI, IBUFF,
     *      IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'LOADING TV'
            GO TO 980
            ENDIF
 40      CONTINUE
C                                       stop now?
      IY = XNIT + 0.1
      IF (ITER.EQ.-1) GO TO 150
      MSGTXT = 'Hit button D within 15 seconds to stop cleaning now'
      IF (ITER.LT.0) MSGTXT = 'Hit button D to see restored image now'
      IF (ITER.EQ.IY) MSGTXT =
     *   'Hit button D to see components image now'
      CALL MSGWRT (1)
      MSGTXT = 'Hit buttons A, B, or C to continue sooner'
      CALL MSGWRT (1)
      RPOS(1) = (WINDTV(1) + WINDTV(3)) / 2.0
      RPOS(2) = (WINDTV(2) + WINDTV(4)) / 2.0
      TD = 0.4
      CALL YCURSE ('ONNN', F, F, RPOS, IQ, IB, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CALLING YCURSE'
         GO TO 980
         END IF
      DO 130 I = 1,75
         CALL ZDELAY (TD, IRET)
         CALL YCURSE ('READ', F, F, RPOS, IQ, IB, IRET)
         IF (IB.GT.7) GO TO 140
         IF (IB.GT.0) GO TO 135
         IF (IRET .NE.0) GO TO 135
 130     CONTINUE
 135  MSGTXT = 'Continuing'
      CALL MSGWRT (1)
      IRET = 0
      GO TO 150
C                                       Wants to quit
 140  MSGTXT = 'TV Button D hit: have done enough I guess'
      CALL MSGWRT (3)
      IRET = -1
 150  CALL TVCLOS (BUFFI, I)
      GO TO 999
C
 980  CALL MSGWRT (8)
      CALL TVCLOS (BUFFI, I)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('HOCLTV ERROR',I4,' ON ',A)
 1010 FORMAT ('At iteration',I4,' pixel max',1PE12.4,'  rms',1PE12.4)
 1011 FORMAT ('Final image, pixel max',1PE12.4,'  rms',1PE12.4)
 1012 FORMAT ('Component image, pixel max',1PE12.4,'  rms',1PE12.4)
 2010 FORMAT ('ITER',I3,'____ MAX',F7.2,'___  RMS',F8.3)
 2011 FORMAT ('FINAL IMAGE MAX',F7.2,'___ RMS',F8.3)
 2012 FORMAT ('COMPONENT IMAGE MAX',F7.2,'___ RMS',F8.3)
      END
      SUBROUTINE HOCLHI
C-----------------------------------------------------------------------
C   HOCLHI copies and updates history file.
C-----------------------------------------------------------------------
      CHARACTER LABEL*8, LINE*80, NOTTYP*2
      INTEGER   LUN1, LUN2, IERR, I
      LOGICAL   T
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'HOCLN.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA LUN1, LUN2 /27,28/
      DATA T /.TRUE./
      DATA NOTTYP /'CC'/
C-----------------------------------------------------------------------
      CALL HIINIT (3)
C                                       Write History: output 1
C                                       Copy/open history file.
      CALL COPY (256, CATNEW(1,1), CATBLK)
      CALL HISCOP (LUN1, LUN2, DISKI(1), DISKO(1), CNOI(1), CNOO,
     *   CATBLK, BUFFI, BUFFO, IERR)
      IF (IERR.GT.2) THEN
         WRITE (MSGTXT,1000) 1, IERR
         CALL MSGWRT (6)
         GO TO 100
         END IF
C                                       New history
      CALL HENCO1 (TSKNAM, NAME(1), CLASS(1), SEQI(1), DISKI(1), LUN2,
     *   BUFFO, IERR)
      IF (IERR.NE.0) GO TO 100
      CALL HENCO2 (TSKNAM, NAME(2), CLASS(2), SEQI(2), DISKI(2), LUN2,
     *   BUFFO, IERR)
      IF (IERR.NE.0) GO TO 100
      CALL HENCO3 (TSKNAM, NAME(3), CLASS(3), SEQI(3), DISKI(3), LUN2,
     *   BUFFO, IERR)
      IF (IERR.NE.0) GO TO 100
      CALL HENCO4 (TSKNAM, NAME(4), CLASS(4), SEQI(4), DISKI(4), LUN2,
     *   BUFFO, IERR)
      IF (IERR.NE.0) GO TO 100
      CALL HENCOO (TSKNAM, NAMEO(1), CLASSO(1), SEQO(1), DISKO(1), LUN2,
     *   BUFFO, IERR)
      IF (IERR.NE.0) GO TO 100
      WRITE (LINE,2000) TSKNAM, GAIN
      CALL HIADD (LUN2, LINE, BUFFO, IERR)
      IF (IERR.NE.0) GO TO 100
      WRITE (LINE,2001) TSKNAM, BMAJ
      CALL HIADD (LUN2, LINE, BUFFO, IERR)
      IF (IERR.NE.0) GO TO 100
      I = XNIT + 0.1
      WRITE (LINE,2002) TSKNAM, I
      CALL HIADD (LUN2, LINE, BUFFO, IERR)
      IF (IERR.NE.0) GO TO 100
C                                      Add any user supplied history.
      IF (NUMHIS.GT.0) THEN
         WRITE (LABEL,1010) TSKNAM
         LINE(1:8) = LABEL(1:8)
         DO 50 I = 1,NUMHIS
            LINE(9:64) = HISCRD(I)(1:64)
            CALL HIADD (LUN2, LINE, BUFFO, IERR)
            IF (IERR.NE.0) GO TO 100
 50         CONTINUE
         END IF
C                                       Close HI file
 100  CALL HICLOS (LUN2, T, BUFFO, IERR)
C                                        Update CATBLK.
      CALL CATIO ('UPDT', DISKO(1), CNOO(1), CATBLK, 'REST', BUFFI,
     *   IERR)
C                                       Write History: output 1
C                                       Copy/open history file.
      CALL COPY (256, CATNEW(1,2), CATBLK)
      CALL HISCOP (LUN1, LUN2, DISKI(3), DISKO(2), CNOI(3), CNOO(2),
     *   CATBLK, BUFFI, BUFFO, IERR)
      IF (IERR.GT.2) THEN
         WRITE (MSGTXT,1000) 2, IERR
         CALL MSGWRT (6)
         GO TO 200
         END IF
C                                       New history
      CALL HENCO3 (TSKNAM, NAME(3), CLASS(3), SEQI(3), DISKI(3), LUN2,
     *   BUFFO, IERR)
      IF (IERR.NE.0) GO TO 200
      CALL HENCO4 (TSKNAM, NAME(4), CLASS(4), SEQI(4), DISKI(4), LUN2,
     *   BUFFO, IERR)
      IF (IERR.NE.0) GO TO 200
      CALL HENCOO (TSKNAM, NAMEO(2), CLASSO(2), SEQO(2), DISKO(2), LUN2,
     *   BUFFO, IERR)
      IF (IERR.NE.0) GO TO 200
      WRITE (LINE,2000) TSKNAM, GAIN
      CALL HIADD (LUN2, LINE, BUFFO, IERR)
      IF (IERR.NE.0) GO TO 100
      WRITE (LINE,2001) TSKNAM, BMAJ
      CALL HIADD (LUN2, LINE, BUFFO, IERR)
      IF (IERR.NE.0) GO TO 100
      I = XNIT + 0.1
      WRITE (LINE,2002) TSKNAM, I
      CALL HIADD (LUN2, LINE, BUFFO, IERR)
      IF (IERR.NE.0) GO TO 100
C                                      Add any user supplied history.
      IF (NUMHIS.GT.0) THEN
         WRITE (LABEL,1010) TSKNAM
         LINE(1:8) = LABEL(1:8)
         DO 150 I = 1,NUMHIS
            LINE(9:64) = HISCRD(I)(1:64)
            CALL HIADD (LUN2, LINE, BUFFO, IERR)
            IF (IERR.NE.0) GO TO 200
 150        CONTINUE
         END IF
C                                       Close HI file
 200  CALL HICLOS (LUN2, T, BUFFO, IERR)
C                                        Copy tables
      CALL ALLTAB (1, NOTTYP, LUN1, LUN2, DISKI, DISKO, CNOI, CNOO,
     *   CATBLK, BUFFI, BUFFO, IERR)
      IF (IERR.GT.2) THEN
         MSGTXT = 'ERROR COPYING TABLE FILES'
         CALL MSGWRT (6)
         END IF
C                                        Update CATBLK.
      CALL CATIO ('UPDT', DISKO(2), CNOO(2), CATBLK, 'REST', BUFFI,
     *   IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('HOCLHI: COPY/OPEN HISTORY FILE #',I2,' ERROR',I3)
 1010 FORMAT (A6,' /')
 2000 FORMAT (A6,'GAIN =',F6.3,'   / Clean loop gain')
 2001 FORMAT (A6,'BMAJ =',F6.3,'   / Restoring beam FWHN pixels')
 2002 FORMAT (A6,'NITER =',I5,'   / Number major cycles used')
      END
      SUBROUTINE HOCLCL (NI, IMAGE, WORK, CSUM, NB, BEAM, IRET)
C-----------------------------------------------------------------------
C   HOCLCL does the actual Clean operation
C   Inputs:
C      NI      I      Size of image
C      NB      I      Size of beam
C      BEAM    C(*)   Beam
C   In/out:
C      IMAGE   C(*)   image
C   Output
C      WORK    C(*)   work array
C      CSUM    C(*)   sum of Clean comps
C      IRET    I      Error code
C-----------------------------------------------------------------------
      INTEGER   NI, NB, IRET
      COMPLEX   IMAGE(NI,NI), WORK(NI,NI), CSUM(NI,NI), BEAM(NB,NB)
C
      INCLUDE 'HOCLN.INC'
      INTEGER   CX, CY, BX, BY, IX, IY, JX, JY, ITER, NITER, KX, KY,
     *   CBL, CBH, NPIX
      COMPLEX   PIXVAL
      REAL      PEAK, CB(25,25), F, R, SCRTCH(512,512), TOT
      LONGINT   NTOT
C-----------------------------------------------------------------------
C                                       zero CSUM
      DO 20 IY = 1,NI
         DO 10 IX = 1,NI
            CSUM(IX,IY) = CMPLX (0.0, 0.0)
 10         CONTINUE
 20      CONTINUE
C                                       init display
      CALL HOCLTV (0, NI, IMAGE, SCRTCH, IRET)
      IF (IRET.LT.0) THEN
         IRET = 0
         GO TO 999
      ELSE IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1000) IRET, 'INIT DISPLAY ON TV'
         GO TO 990
         END IF
C                                       Outer loop
      NITER = XNIT + 0.1
      CX = NI / 2
      CY = NI /2 + 1
      BX = NB / 2
      BY = NB / 2 + 1
      DO 100 ITER = 1,NITER
         WRITE (MSGTXT,1010) ITER
         CALL MSGWRT (2)
         IX = 2 * NI * NI
         CALL CXCOPY (IX, IMAGE, WORK)
C                                       loop over current resid
         NPIX = 0
         NTOT = 0
         DO 60 IY = 1,NI
            DO 50 IX = 1,NI
               IF (REAL(WORK(IX,IY)).NE.FBLANK) THEN
                  PIXVAL = GAIN * WORK(IX,IY)
                  NPIX = NPIX + 1
                  DO 40 JY = 1,NB
                     DO 30 JX = 1,NB
                        KX = JX - BX + IX
                        KY = JY - BY + IY
                        IF ((KX.GE.1) .AND. (KX.LE.NI) .AND. (KY.GE.1)
     *                     .AND. (KY.LE.NI)) THEN
                           IF (REAL(IMAGE(KX,KY)).NE.FBLANK) THEN
                              IMAGE(KX,KY) = IMAGE(KX,KY) -
     *                           PIXVAL * BEAM(JX,JY)
                              NTOT = NTOT + 1
                              END IF
                           END IF
 30                     CONTINUE
 40                  CONTINUE
                  END IF
 50            CONTINUE
 60         CONTINUE
         WRITE (MSGTXT,1060) NPIX, NTOT
         CALL MSGWRT (2)
C                                       add to CCs
         DO 80 IY = 1,NI
            DO 70 IX = 1,NI
               IF (REAL(IMAGE(IX,IY)).NE.FBLANK) THEN
                  CSUM(IX,IY) = CSUM(IX,IY) + WORK(IX,IY)
                  END IF
 70            CONTINUE
 80         CONTINUE
C                                       TV display
         CALL HOCLTV (ITER, NI, IMAGE, SCRTCH, IRET)
         IF (IRET.LT.0) THEN
            IRET = 0
            GO TO 110
         ELSE IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1000) IRET, 'DISPLAY ON TV'
            GO TO 990
            END IF
 100     CONTINUE
C                                       restore CCs
C                                       get the beam
 110  MSGTXT = 'Restoring components'
      CALL MSGWRT (2)
      XNIT = MIN (ITER, NITER)
      IF (BMAJ.LE.0.0) THEN
         PEAK = CABS (BEAM(BX,BY))
         DO 120 IX = 1,12
            IF (CABS(BEAM(BX-IX,BY)).LT.PEAK/2.) THEN
               BMAJ = IX - (PEAK/2.-BEAM(BX-IX+1,BY)) / (BEAM(BX-IX,BY)
     *            - BEAM(BX-IX+1,BY))
               BMAJ = 2 * BMAJ
               GO TO 130
               END IF
 120        CONTINUE
         BMAJ = 8.
         END IF
 130  F = 2 * LOG(2.0) / (BMAJ * BMAJ)
      DO 145 IX = 1,25
         DO 140 IY = 1,25
            R = (IX-13)**2 + (IY-13)**2
            CB(IX,IY) = EXP (-F * R)
 140        CONTINUE
 145     CONTINUE
      DO 150 IX = 1,25
         IF (CB(IX,13).GT.0.001) GO TO 155
 150     CONTINUE
 155  CBL = IX
      CBH = 26 - IX
C                                       scale
      TOT = 0.0
      DO 165 JY = CBL,CBH
         DO 160 JX = CBL,CBH
            TOT = TOT + CB(JX,JY)
 160        CONTINUE
 165     CONTINUE
      DO 175 JY = 1,25
         DO 170 JX = 1,25
            CB(JX,JY) = CB(JX,JY) / TOT
 170        CONTINUE
 175     CONTINUE
C                                       now restore
      DO 250 IY = 1,NI
         DO 240 IX = 1,NI
            IF (REAL(IMAGE(IX,IY)).NE.FBLANK) THEN
               PIXVAL = CSUM(IX,IY)
               DO 220 JY = CBL,CBH
                  DO 210 JX = CBL,CBH
                     KX = JX - 13 + IX
                     KY = JY - 13 + IY
                     IF ((KX.GE.1) .AND. (KX.LE.NI) .AND. (KY.GE.1)
     *                  .AND. (KY.LE.NI)) THEN
                        IF (REAL(IMAGE(KX,KY)).NE.FBLANK) THEN
                           IMAGE(KX,KY) = IMAGE(KX,KY) + CB(JX,JY) *
     *                        PIXVAL
                           END IF
                        END IF
 210                 CONTINUE
 220              CONTINUE
               END IF
 240        CONTINUE
 250     CONTINUE
C                                       final displays
      CALL HOCLTV (-99, NI, CSUM, SCRTCH, IRET)
      CALL HOCLTV (-1, NI, IMAGE, SCRTCH, IRET)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('HOCLCL: ERRIR',I4,' ON ',A)
 1010 FORMAT ('Start major cycle',I4)
 1060 FORMAT (I6,' pixels with',I14,' total subtractions')
      END
