LOCAL INCLUDE 'MOD3D.INC'
C                                                          Include MOD3D
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:ZPBUFSZ.INC'
C                                       NOTE: uses PARAMETER in DGDS.INC
      INTEGER   NCOMP(MAXFLD), BCOMP(MAXFLD)
      INTEGER   UVBLK(256), DISKIN, DISKO, DISK2, OLDCNO, CLNCNO,
     *   NEWCNO, SEQIN, SEQ2, SEQOUT, VER, ISTOKE, METHOD, MODEL, BIF,
     *   EIF, CH1, FRQSEL, BUFF3(UVBFSS), SCRTCH(512)
      REAL   XSIN, XDISIN, XS2, XDISK2, XSOUT, XDISO, XVER, XNMAPS,
     *   XBCOMP(MAXAFL), XNCOMP(MAXAFL), XFLUX, BLC(7), TRC(7),
     *   BUFF1(UVBFSS), BUFF2(UVBFSS)
      HOLLERITH XNAMEI(3), XCLAIN(2), XNAME2(3), XCLAS2(2), XNAMOU(3),
     *   XCLAOU(2)
      CHARACTER NAMEIN*12, CLAIN*6, NAME2*12, CLAS2*6, NAMOUT*12,
     *   CLAOUT*6
      COMMON /INFO/ UVBLK,
     *   BCOMP, NCOMP,
     *   DISKIN, DISKO, DISK2, OLDCNO, CLNCNO, NEWCNO, ISTOKE,
     *   SEQIN, SEQOUT, SEQ2, VER, METHOD, MODEL,
     *   BIF, EIF, CH1, FRQSEL
      COMMON /BUFRS/ BUFF1, BUFF2, BUFF3, SCRTCH
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XNAME2, XCLAS2, XS2,
     *   XDISK2, XVER, XNMAPS, XNAMOU, XCLAOU, XSOUT, XDISO, XBCOMP,
     *   XNCOMP, XFLUX, BLC, TRC
      COMMON /CHRCOM/ NAMEIN, CLAIN, NAME2, CLAS2, NAMOUT, CLAOUT
C                                                          End MOD3D
LOCAL END
LOCAL INCLUDE 'MOD3DI.INC'
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   CCBUFF(512), CCKOLS(MAXCCC), CCNUMV(MAXCCC), CCRNO,
     *   CCLUN, NCOL, CCOUNT
      COMMON /MOD3DI/ CCBUFF, CCKOLS, CCNUMV, CCRNO, CCLUN, NCOL, CCOUNT
LOCAL END
      PROGRAM MOD3D
C-----------------------------------------------------------------------
C! Forms a single 3D CC file from a set of facets
C# UV AP-appl Modeling
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   MOD3D is an AIPS task to form a 3D CC file from a set of facet
C   image files' CC tables.
C   Inputs:
C      AIPS adverb  Prg. name.          Description.
C      INNAME         NAMEIN        Name of input UV data.
C      INCLASS        CLASIN        Class of input UV data.
C      INSEQ          SEQIN         Seq. of input UV data.
C      INDISK         DISKIN        Disk number of input UV data.
C      IN2NAME        NAME2         Name of map with CLEAN components.
C      IN2CLASS       CLAS2         Class of map with CLEAN components.
C      IN2SEQ         SEQ2          Seq. of map with CLEAN components.
C      IN2DISK        DISK2         Vol. of map with CLEAN components.
C      INVER          VER           Version no. of CC file.
C      NMAPS          NMAPS         Number of input images.
C      OUTNAME        NAMOUT        Name of the output image file.
C      OUTCLASS       CLAOUT        Class of the output image file.
C      OUTSEQ         SEQOUT        Seq. number of output file
C      OUTDISK        DISKO         Disk number of the output file.
C      BCOMP(64)      BCOMP         Start clean component to sub.
C                                   1 per field.
C      NCOMP(64)      NCOMP         Last Clean component no to sub.
C                                      1 per field, 0 => all
C      BLC/TRC        BLC, TRC      subimage window of CC file 1 -> out
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET, CATSAV(256)
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:DGDS.INC'
      INCLUDE 'MOD3D.INC'
      INCLUDE 'MOD3DI.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DSCD.INC'
      DATA PRGM /'MOD3D '/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL MOD3IN (PRGM, IRET)
      IF (IRET.NE.0) GO TO 990
      CALL COPY (256, CATBLK, CATSAV)
      DATDIV = .FALSE.
C                                       Process data
C                                       Else Subtraction
      CALL MOD3DS (MODEL, METHOD, UVBLK, BUFF1, BUFF2, BUFF3, IRET)
      CALL UNSETG (BUFF2)
C                                       If no error, update history
      CALL COPY (256, CATSAV, CATBLK)
      CATBLK(KINIT) = CCOUNT
      IF (IRET.EQ.0) CALL SUBHIS
C                                       Close down
 990  CALL DIE (IRET, SCRTCH)
C
      STOP
      END
      SUBROUTINE MOD3IN (PRGN, IERR)
C-----------------------------------------------------------------------
C   MOD3IN gets input parameters for MOD3D and creates an output file
C   if necessary.
C   Inputs: PRGN   C*6       Task name
C   Output: IERR   I         Error code: non-zero => quit
C-----------------------------------------------------------------------
      CHARACTER STAT*4, PRGN*6, BLANK*6, UTYPE*2
      INTEGER   JERR
      INTEGER   INMETH, NPARM, IERR, I, IBUFF(512), IROUND, MXFLD
      LOGICAL   T, F, WASOME
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'MOD3D.INC'
      INCLUDE 'INCS:DGDS.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DUVH.INC'
      EQUIVALENCE (IBUFF, BUFF2)
      DATA BLANK /' '/
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
C                                       Initialize I/O
      CALL ZDCHIN (T, SCRTCH)
      CALL VHDRIN
      MXFLD = MAXAFL
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      IERR = 0
      JERR = 0
C                                       Get input parameters.
      NPARM = 38 + 2 * MXFLD
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         RQUICK = .TRUE.
         JERR = 8
         IF (IERR.EQ.1) GO TO 999
            WRITE (MSGTXT,1000) IERR
            CALL MSGWRT (8)
         END IF
C                                       Restart AIPS
      IF (RQUICK) CALL RELPOP (JERR, SCRTCH, IERR)
      IF (JERR.NE.0) GO TO 999
      IERR = 5
C                                       Crunch input parameters.
C                                       Convert characters
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      CALL H2CHR (12, 1, XNAME2, NAME2)
      CALL H2CHR (6, 1, XCLAS2, CLAS2)
      CALL H2CHR (12, 1, XNAMOU, NAMOUT)
      CALL H2CHR (6, 1, XCLAOU, CLAOUT)
C                                       File sequence numbers
      SEQIN = IROUND (XSIN)
      SEQOUT = IROUND (XSOUT)
      SEQ2 = IROUND (XS2)
C                                       File disk numbers
      DISKIN = IROUND (XDISIN)
      DISK2 = IROUND (XDISK2)
      DISKO = IROUND (XDISO)
C                                       CC file version number
      VER = IROUND (XVER)
C                                       IFs
      BIF = 1
C                                       Default EIF when have CATBLK
C                                       Number of fields
      MFIELD = 1
      IF (XNMAPS.GT.0.0) MFIELD = IROUND (XNMAPS)
      LIMFLX = XFLUX
C                                       Start component number
      NONEG = F
      WASOME = F
      DO 8 I = 1,MFIELD
         IF (I.LE.MAXAFL) THEN
            BCOMP(I) = XBCOMP(I) + 0.1
            BCOMP(I) = MAX (BCOMP(I), 1)
            NCOMP(I) = ABS (XNCOMP(I)) + 0.1
            IF (XNCOMP(I).LE.-0.5) NONEG = T
            IF (NCOMP(I).GT.0) WASOME = T
         ELSE
            BCOMP(I) = 1
            NCOMP(I) = 0
            IF (WASOME) NCOMP(I) = 1000000000
            END IF
 8       CONTINUE
C                                       Factor
      FACGRD(1) = 1.0
      FACGRD(2) = 1.0
C                                       Get  modeling method
      METHOD = -1
C                                       Get  model type
      MODEL = 1
C                                       Get CATBLK from old file.
      OLDCNO = 1
      UTYPE = 'UV'
      CALL CATDIR ('SRCH', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN, UTYPE,
     *   NLUSER, STAT, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1010) IERR, NAMEIN, CLAIN, SEQIN, 'UV',
     *      DISKIN, NLUSER
         GO TO 990
         END IF
      CALL CATIO ('READ', DISKIN, OLDCNO, CATBLK, 'REST', SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1020) IERR
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = OLDCNO
      FRW(NCFILE) = 0
C                                       Get uv header info.
      CALL UVPGET (IERR)
      IF (IERR.NE.0) GO TO 999
C                                       Reject multisource files (it is
C                                       not strictly necessary to do
C                                       this but input files can not
C                                       contain more than one source
C                                       and MOD3D would need to verify
C                                       this here)
      IF (ILOCSU.GE.0) THEN
         MSGTXT = 'INPUT FILE MUST BE A SINGLE-SOURCE FILE.'
         CALL MSGWRT (8)
         MSGTXT = 'USE SPLIT TO EXTRACT DESIRED DATA.'
         CALL MSGWRT (8)
         IERR = 1
         GO TO 999
         END IF
C                                       Setup common for modeling
C                                       routines
C                                       Uv header block
      CALL COPY  (256, CATBLK, UVBLK)
      INMETH = METHOD
      ISTOKE = 1
      DOPTMD = .FALSE.
C                                       If NONEG or DOPTMD use DFT
C                                       Warn user if changing METHOD
C                                       Get info on model file(s)
      CALL SETGDS (DISKIN, OLDCNO, NAME2, CLAS2, SEQ2, DISK2, MFIELD,
     *   VER, NCOMP, BCOMP, MODEL, METHOD, BUFF1, BUFF2, ISTOKE, IERR)
      IF (IERR.NE.0) GO TO 999
      MSGTXT = 'Using Clean Component source model'
      CALL MSGWRT (3)
      CALL FACSET (DISKIN, OLDCNO, 1, 0, MODEL, FACGRD, IERR)
      IF (IERR.NE.0) GO TO 999
C                                       make the image
      CALL MOD3IM (IERR)
      IF (IERR.NE.0) GO TO 999
C                                        Put input file in READ
      STAT = 'READ'
      UTYPE = 'UV'
      CALL CATDIR ('CSTA', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN, UTYPE,
     *   NLUSER, STAT, SCRTCH, IERR)
      IERR = 0
      SEQOUT = CATBLK(KIIMS)
C                                       copy keywords ??
      CALL KEYCOP (DISKIN, OLDCNO, DISKO, NEWCNO, IERR)
      GO TO 999
C                                       Error messages output
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('MOD3IN: ERROR',I3,' OBTAINING INPUT PARAMETERS')
 1010 FORMAT ('ERROR',I3,' FINDING ',A12,' . ',A6,' . ',
     *   I3,2X,A2,' DISK=',I3,' USID=',I4)
 1020 FORMAT ('ERROR',I3,' COPYING CATBLK ')
      END
      SUBROUTINE MOD3IM (IERR)
C-----------------------------------------------------------------------
C   MOD3IM subimages the first Clean image and writes the output image
C   It opens the output CC file
C   Output
C      IERR   I   Error code
C-----------------------------------------------------------------------
      INTEGER   IERR
C
      INTEGER   IDIMS(7), ISLUN, ISIND, IDLUN, IDIND, IROUND, ISWIN(4),
     *   IDWIN(4), ISPOS, IDPOS, NX, NY, IX, IY, CATCLN(256), IBLKOF,
     *   NBY, OVER, KLNBL2(256), LFIELD
      REAL      RMIN, RMAX
      LOGICAL   WASBLK
      CHARACTER MATYPE*2, STAT*4, CBLANK*6
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'MOD3D.INC'
      INCLUDE 'MOD3DI.INC'
      INCLUDE 'INCS:DGDS.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA IDIMS /7*1/
      DATA ISLUN, IDLUN /17, 18/
      DATA CBLANK /' '/
C-----------------------------------------------------------------------
      WASBLK = .FALSE.
      RMAX = -1.E10
      RMIN = -RMAX
      NBY = 2 * UVBFSS
C                                       get clean map header
      CLNCNO = 1
      MATYPE = 'MA'
      CALL CATDIR ('SRCH', DISK2, CLNCNO, NAME2, CLAS2, SEQ2, MATYPE,
     *   NLUSER, STAT, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'FINDING CLEAN IMAGE IN CATALOG'
         GO TO 980
         END IF
      CALL CATIO ('READ', DISK2, CLNCNO, CATBLK, 'REST', SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READING CLEAN IMAGE HEADER'
         GO TO 980
         END IF
      CALL COPY (2, CATBLK(KINAX), IDIMS)
      CALL WINDOW (CATBLK(KIDIM), IDIMS, BLC, TRC, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'SETTING IMAGE WINDOW'
         GO TO 980
         END IF
      CALL MAKOUT (NAMEIN, CLAIN, SEQIN, CBLANK, NAMOUT, CLAOUT, SEQOUT)
      CALL CHR2H (12, NAMOUT, KHIMNO, CATH(KHIMN))
      CALL CHR2H (6, CLAOUT, KHIMCO, CATH(KHIMC))
      CALL CHR2H (2, 'MA', KHPTYO, CATH(KHPTY))
      CATBLK(KIIMS) = SEQOUT
      CALL SUBHDR (BLC, TRC, 1.0, 1.0)
      CALL MCREAT (DISKO, NEWCNO, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'CREATING OUTPUT IMAGE'
         GO TO 980
         END IF
      CALL KEYCOP (DISK2, CLNCNO, DISKO, NEWCNO, IERR)
C                                       Open files
      CALL MAPOPN ('READ', DISK2, NAME2, CLAS2, SEQ2, MATYPE, NLUSER,
     *   ISLUN, ISIND, CLNCNO, CATCLN, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING CLEAN IMAGE FOR READ'
         GO TO 980
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISK2
      FCNO(NCFILE) = CLNCNO
      FRW(NCFILE) = 0
      CALL MAPOPN ('INIT', DISKO, NAMOUT, CLAOUT, SEQOUT, MATYPE,
     *   NLUSER, IDLUN, IDIND, NEWCNO, CATBLK, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING OUTPUT IMAGE'
         GO TO 980
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKO
      FCNO(NCFILE) = NEWCNO
      FRW(NCFILE) = 2
      ISWIN(1) = IROUND (BLC(1))
      ISWIN(2) = IROUND (BLC(2))
      ISWIN(3) = IROUND (TRC(1))
      ISWIN(4) = IROUND (TRC(2))
      NX = ISWIN(3) - ISWIN(1) + 1
      NY = ISWIN(4) - ISWIN(2) + 1
      IDWIN(1) = 1
      IDWIN(2) = 1
      IDWIN(3) = NX
      IDWIN(4) = NY
      IBLKOF = 1
      CALL MINIT ('READ', ISLUN, ISIND, IDIMS(1), IDIMS(2), ISWIN,
     *   BUFF1, NBY, IBLKOF, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'INIT READ OF CLEAN IMAGE'
         GO TO 980
         END IF
      CALL MINIT ('WRIT', IDLUN, IDIND, NX, NY, IDWIN, BUFF2, NBY,
     *   IBLKOF, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'INIT WRITE OF OUTPUT IMAGE'
         GO TO 980
         END IF
      DO 100 IY = 1,NY
         CALL MDISK ('READ', ISLUN, ISIND, BUFF1, ISPOS, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'R5EADING CLEAN IMAGE'
            GO TO 980
            END IF
         CALL MDISK ('WRIT', IDLUN, IDIND, BUFF2, IDPOS, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'WRITE OUTPUT IMAGE'
            GO TO 980
            END IF
         DO 50 IX = 1,NX
            IF (BUFF1(ISPOS+IX-1).EQ.FBLANK) THEN
               WASBLK = .TRUE.
            ELSE
               RMAX = MAX (RMAX, BUFF1(ISPOS+IX-1))
               RMIN = MIN (RMIN, BUFF1(ISPOS+IX-1))
            END IF
            BUFF2(IDPOS+IX-1) = BUFF1(ISPOS+IX-1)
 50         CONTINUE
 100     CONTINUE
      CALL MDISK ('FINI', IDLUN, IDIND, BUFF2, IDPOS, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'FINISH OUTPUT IMAGE'
         GO TO 980
         END IF
      CATR(KRDMX) = RMAX
      CATR(KRDMN) = RMIN
      CATR(KRBLK) = 0.0
      IF (WASBLK) CATR(KRBLK) = FBLANK
C                                       Clean comp files
      CCLUN = 91
      NY = 0
      DO 120 LFIELD = 1,MFIELD
C                                       Make sure this header applies
C                                       to this image
         CALL CATIO ('READ', CCDISK(LFIELD), CCCNO(LFIELD), KLNBL2,
     *      'REST', SCRTCH, IERR)
         IF ((IERR.NE.0) .AND. (IERR.LT.5)) THEN
            WRITE (MSGTXT,1000) IERR, 'READ HEADER WITH CATIO'
            GO TO 980
            END IF
C                                       Tabini can update header on disk
         CALL CCMINI ('READ', CCBUFF, CCDISK(LFIELD), CCCNO(LFIELD),
     *      CCVER(LFIELD), KLNBL2, CCLUN, CCRNO, CCKOLS, CCNUMV, NCOL,
     *      IERR)
         IF (IERR.GT.1) THEN
            WRITE (MSGTXT,1000) IERR, 'OPENING CLEAN COMPS FILE'
            GO TO 980
            END IF
         NY = MAX (NY, NCOL)
         CALL TABIO ('CLOS', 0, CCRNO, BUFF1, CCBUFF, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'CLOSING CC TABLE'
            GO TO 980
            END IF
 120     CONTINUE
      CCLUN = 91
      NCOL = NY + 1
      OVER = 1
      CALL CCMINI ('WRIT', CCBUFF, DISKO, NEWCNO, OVER, CATBLK,
     *   CCLUN, CCRNO, CCKOLS, CCNUMV, NCOL, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPENING OUTPUT CC TABLE'
         GO TO 980
         END IF
      GO TO 999
C
 980  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('MOD3IM: ERROR',I4,' ON ',A)
      END
      SUBROUTINE SUBHIS
C-----------------------------------------------------------------------
C  SUBHIS copies and updates history file.
C-----------------------------------------------------------------------
      CHARACTER AMETH*4, AMODL*4, HILINE*72
      INTEGER   LUN1, LUN2, IERR, I
      LOGICAL   T
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'MOD3D.INC'
      INCLUDE 'INCS:DGDS.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA LUN1, LUN2 /27,28/
      DATA T /.TRUE./
C-----------------------------------------------------------------------
C                                       Write History.
      CALL HIINIT (3)
C                                       Copy/open history file.
      CALL HISCOP (LUN1, LUN2, DISKIN, DISKO, OLDCNO, NEWCNO, CATBLK,
     *   BUFF1, BUFF3, IERR)
      IF (IERR.GT.2) THEN
         WRITE (MSGTXT,1000) IERR
         CALL MSGWRT (6)
         GO TO 100
         END IF
C                                       New history
      CALL HENCO1 (TSKNAM, NAMEIN, CLAIN, SEQIN, DISKIN, LUN2, BUFF3,
     *   IERR)
      IF (IERR.NE.0) GO TO 100
C                                       Model file(s)
      CALL HENCO2 (TSKNAM, NAME2, CLAS2, SEQ2, DISK2, LUN2, BUFF3,
     *   IERR)
      IF (IERR.NE.0) GO TO 100
      WRITE (HILINE,1020) TSKNAM, VER
      IF (MODEL.EQ.1) CALL HIADD (LUN2, HILINE, BUFF3, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       Number of input images
      WRITE (HILINE,1025) TSKNAM, MFIELD
      CALL HIADD (LUN2, HILINE, BUFF3, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       Add no. clean comps.
      DO 25 I = 1,MFIELD
         NCOMP(I) = NSUBG(I) - 1
         WRITE (HILINE,1021) TSKNAM, I, BCOMP(I), I, NCOMP(I)
         IF (MODEL.EQ.1) CALL HIADD (LUN2, HILINE, BUFF3, IERR)
         IF (IERR.NE.0) GO TO 100
 25      CONTINUE
      CALL HENCOO (TSKNAM, NAMOUT, CLAOUT, CATBLK(KIIMS), DISKO, LUN2,
     *   BUFF3, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       Modeling method
      AMETH = 'DFT '
      WRITE (HILINE,1027) TSKNAM, AMETH
      CALL HIADD (LUN2, HILINE, BUFF3, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       Model type
C                                       CC or image
      AMODL = 'COMP'
      WRITE (HILINE,1028) TSKNAM, AMODL
      CALL HIADD (LUN2, HILINE, BUFF3, IERR)
      IF (IERR.NE.0) GO TO 100
C                                       Close history file.
 100  CALL HICLOS (LUN2, T, BUFF3, IERR)
C                                        Update CATBLK.
      CALL CATIO ('UPDT', DISKO, NEWCNO, CATBLK, 'REST', SCRTCH, IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SUBHIS: ERROR',I3,' COPY/OPEN HISTORY FILE')
 1020 FORMAT (A6,'VER     = ',I6,' / CC file ver. no.')
 1021 FORMAT (A6,'BCOMP(',I2,')=',I6,', NCOMP(',I3,') =',I6,
     *   ' / First-last comp. no.')
 1025 FORMAT (A6,'NMAPS   = ',I6,' / Number of model images')
 1027 FORMAT (A6,'CMETHOD = ',1H',A4,1H',' / Model method')
 1028 FORMAT (A6,'CMODEL  = ',1H',A4,1H',' / Model type')
      END
      SUBROUTINE MOD3DS (MODEL, METHOD, CATBLK, BUFF1, BUFF2, BUFF3,
     *   IRET)
C-----------------------------------------------------------------------
C   MOD3DS calls MOD3DV to project CC coordinates and save in output.
C   Inputs:
C      MODEL    I        1=> clean components, 2=>image.
C      METHOD   I        1=>gridded, -1=>DFT, 0=>chose.
C      CATBLK   I(256)   UV data catalog header record.
C   Inputs from COMMON /MAPDES/:
C      MFIELD   I        Number of fields
C      NSUBG    I(*)     Number of components already sub.
C      NCLNG    I(*)     Number of components per field.
C      CCDISK   I(*)     Disk numbers for CC files
C      CCCNO    I(*)     Catalog slot numbers for CC files.
C      CCVER    I(*)     CC file version number for each field.
C      FACGRD   R(2)     Value to multiply clean component fluxes
C                        by before subtraction (negative for sum).
C                        FACGRD(2) is for data and 0 or 1 only values
C                        used.  Model added not subtracted when data are
C                        ignored.
C      NONEG    L        Stop reading comps. from a file past the first
C                        negative component.
C      LIMFLX   R        Stop reading comps < LIMFLX in abs value
C   Output:
C      BUFF1    R(*)     Work buffers.
C      BUFF2    R(*)     Work buffers.
C      BUFF3    I(*)     Work buffers.
C      IRET     I        Return error code. 0=>OK, otherwise failed.
C-----------------------------------------------------------------------
      INTEGER   MODEL, METHOD, CATBLK(256), BUFF3(*), IRET
      REAL      BUFF1(*), BUFF2(*)
C
      INTEGER   SCRGRD, SCRWRK, LUN, INMETH, OUMETH
      LOGICAL   DODFT
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DGDS.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DSCD.INC'
      SAVE LUN, SCRGRD, SCRWRK
      DATA SCRGRD, SCRWRK /0, 0/, LUN /27/
C-----------------------------------------------------------------------
      IRET = 0
      NGRDAT = .FALSE.
C                                       Store CATBLK for later use
      IF (.NOT.DATDIV) THEN
         CALL COPY (256, CATBLK, SCRCAT)
         SCLREC = LREC
         SCRPRM = NRPARM
         COMPDT = CATBLK(KINAX).EQ.1
         END IF
C                                       Decide model computation method.
      INMETH = METHOD
      DODFT = (METHOD.LT.0) .AND. (MODEL.EQ.1)
      IF (DODFT) OUMETH = -1
      CALL MOD3DV ('SUB ', CATBLK, BUFF1, BUFF2, BUFF3, IRET)
C
 999  RETURN
      END
      SUBROUTINE MOD3DV (OPCODE, CATBLK, BUFF1, BUFF2, IBUFF, IRET)
C-----------------------------------------------------------------------
C   MOD3DV subtracts/divides CLEAN components from/into ungridded
C   visibility data by a DFT model computation.  Only model components
C   of a single type are processed.  Point components will be taken as
C   Gaussians or Spheres as needed if some of the fields are extended
C   and some not.
C   All un subtracted data processed in one call.
C   Inputs:
C      OPCODE   C*4      Opcode 'SUB ', or 'DIV '
C      CATR     R(256)   UV data catalog header record.
C   Inputs: from commons
C      MODMAX   I        DMOD.INC - if set, this controls facets/chans
C      MFIELD   I        Number of fields
C      NCLNG    I(16)    Number of components per field. -
C                        changed if flux limit hit
C      NSUBG    I(16)    The next component to subtract.
C      CCDISK   I(16)    Disk numbers of the clean images.
C      CCCNO    I(16)    Catalog slot numbers of clean images.
C      CCVER    I(*)     CC file version number for each field.
C      NGRDAT   L        If FALSE get map size, scaling etc. parms
C                        from the model map cat. header. If TRUE
C                        then the values filled in by GRDAT must
C                        already be filled into the common.
C      LREC     I        Length in words of vis record.
C      NVIS     I        Number of vis. records
C      NONEG    L        Stop reading comps. from a file past the first
C                        negative component.
C      LIMFLX   R        Stop if abs(flux) < LIMFLX
C      DOPTMD   L        Use the point model specified by PTFLX, PTRAOF,
C                        PTDCOF
C      PTFLX    R        Point model flux density (Jy) (I pol. only)
C      PTRAOF   R        Point model RA offset from uv phase center
C                        (asec)
C      PTDCOF   R        Point model Dec. offset from uv phase center
C      PARMOD   R(6)     Model parameters for non point models; used
C                        only if DOPTMOD is true.
C                        1=> model type, 0=point, 1=gaussian, 3=sphere
C                        Gaussian: (2)=major axis(asec), (3)=minor axis
C                                  (4)=PA (degrees)
C                        Sphere: (2)=radius (asec).
C      KSTOK    I        (DGDS.INC) If a point model is specified a
C                        value of 2 indicates a Q pol model, 3 U and
C                        4 V pol.AC
C   In/out:
C      CNOSCO   I        IN: output file catalog slot number or /CFILES/
C                        scratch file number. Will create a scratch file
C                        if CNOSCO and DISKO .le. 0.
C                        Out: file /CFILES/ number if created.
C   Output:
C      BUFF1    R(*)     I/O buffers.
C      BUFF2    R(*)     I/O buffers.
C      IBUFF    I(*)     I/O Buffer.
C      IRET     I        Return code, 0 => ok, otherwise not.
C                            8 => model types not compatible/illegal
C                            9 => Buffers too small to load AP.
C                           10 => Too many components for division.
C-----------------------------------------------------------------------
      CHARACTER OPCODE*4
      INTEGER   CATBLK(256), IBUFF(*), IRET
      REAL      BUFF1(*), BUFF2(*)
C
      CHARACTER MDTYP(4)*8, ERRTXT*40, UMET*4
      INTEGER   JCOMP, XNCOMP, JT, LUNC, ITYPE, LENMOD, CCTYPE, JLREC,
     *   JNREC, I, LFIELD, LMOD(4), I2, MODTYP, KLNBL2(256), CLTYPE
      REAL      XXOFF, YYOFF, ZZOFF, XYZ(3), XP(3), UMAT(3,3),
     *   PMAT(3,3), PARMS(3), XX, YY, ZZ, FLUX
      DOUBLE PRECISION XRA, XDEC, CONST
      LOGICAL   T, F
      INCLUDE 'INCS:PSTD.INC'
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:DMOD.INC'
      LOGICAL   DONE(MAXFLD), ONZE
      INTEGER   LFR, CLKOLS(MAXCCC), CLNUMV(MAXCCC), CLBUFF(512), CLRNO
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DGDS.INC'
      INCLUDE 'INCS:DMPR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DAPM.INC'
      INCLUDE 'MOD3DI.INC'
      PARAMETER (CONST = DG2RAD * TWOPI)
      SAVE ONZE
      DATA LMOD /4, 7, 7, 6/
      DATA MDTYP /'Point   ', 'Gaussian', 'Unknown ', 'Sphere  '/
      DATA LUNC /29/
      DATA T, F /.TRUE.,.FALSE./, ONZE/.FALSE./
C-----------------------------------------------------------------------
      UMET = 'DFT'
      LFIELD = 0
      CCOUNT = 0
      TFLUXG = 0.0
      MODMAX = MFIELD
C                                       Decide component type.
C                                       From CC model passed
      LFIELD = 1
C                                       Get field info. if nec.
      IF (.NOT.NGRDAT) THEN
         CALL GRDAT (F, LFIELD, CATBLK, IBUFF(2049), IRET)
         IF (IRET.NE.0) GO TO 999
         END IF
C                                       If NGRDAT read CLEAN CATBLK.
      IF (NGRDAT) THEN
         ERRTXT = 'READING CLEAN CATBLK'
         CALL CATIO ('READ', CCDISK(LFIELD), CCCNO(LFIELD), KLNBLK,
     *      'REST', IBUFF(2049), IRET)
         IF ((IRET.GT.0) .AND. (IRET.LT.5)) GO TO 990
         END IF
C                                       For point model
      MODTYP = 0
      XNCOMP = 0
C                                       check all CC files
      LFR = 0
      DO 10 I = 1,MODMAX
         LFIELD = I
         JNREC = 1
         JLREC = 0
C                                       Make sure this header applies
C                                       to this image
         CALL CATIO ('READ', CCDISK(LFIELD), CCCNO(LFIELD), KLNBL2,
     *      'REST', IBUFF(2049), IRET)
         IF ((IRET.NE.0) .AND. (IRET.LT.5)) THEN
            ERRTXT =  'READ HEADER WITH CATIO'
            GO TO 990
            END IF
C                                       Tabini can update header on disk
         ERRTXT = 'OPENING CLEAN COMPS FILE'
         CALL CCMINI ('READ', CLBUFF, CCDISK(LFIELD), CCCNO(LFIELD),
     *      CCVER(LFIELD), KLNBL2, LUNC, CLRNO, CLKOLS, CLNUMV, JLREC,
     *      IRET)
         IF (IRET.GT.1) GO TO 990
         IF (NCLNG(LFIELD).LE.0) NCLNG(LFIELD) = CLBUFF(5)
         DONE(I) = F
         XNCOMP = XNCOMP + NCLNG(LFIELD)
C                                       More complex models
C                                       Find columns (physical)
         IF (JLREC.GT.4) THEN
C                                       Read 1st record
            CALL TABCCM ('READ', CLBUFF, CLRNO, CLKOLS, CLNUMV, JLREC,
     *         XX, YY, ZZ, FLUX, CLTYPE, PARMS, IRET)
            IF (IRET.GT.0) THEN
               WRITE (MSGTXT,1090) IRET, CLRNO
               GO TO 995
               END IF
            IF ((JLREC.EQ.4) .OR. (JLREC.EQ.8)) THEN
               MSGTXT = 'THIS TASK FOR CC FILES WITH NO Z COLUMN'
               IRET = 10
               GO TO 995
               END IF
C                                       Get model type.
            ITYPE = CLTYPE
            IF (LFIELD.EQ.1) MODTYP = ITYPE
            IF (MODTYP.NE.ITYPE) THEN
               IF ((MODTYP.EQ.0) .OR. (ITYPE.EQ.0)) THEN
                  MSGTXT = 'MOD3DV: will treat points as extended'
                  CALL MSGWRT(6)
                  MODTYP = MAX (MODTYP, ITYPE)
               ELSE
                  WRITE (MSGTXT,1000) MODTYP, ITYPE
                  IRET = 8
                  GO TO 995
                  END IF
               END IF
            END IF
C                                       Close CLEAN components file.
         CALL TABCCM ('CLOS', CLBUFF, CLRNO, CLKOLS, CLNUMV, JLREC,
     *      XX, YY, ZZ, FLUX, CLTYPE, PARMS, IRET)
 10      CONTINUE
C                                       Bad model type.
      IF ((MODTYP.NE.0) .AND. (MODTYP.NE.1) .AND. (MODTYP.NE.3)) THEN
         IRET = 8
         WRITE (MSGTXT,1002) MODTYP
         GO TO 995
         END IF
C                                       Tell model type once
      IF (.NOT.ONZE) THEN
         MSGTXT = 'MOD3DV: Model components of type '//MDTYP(MODTYP+1)
         CALL MSGWRT (2)
         ONZE = .NOT. ONZE
         END IF
C                                       Set model length
      LENMOD = LMOD(MODTYP+1)
C                                       If Not single component model.
      DO 150 LFIELD = 1,MODMAX
C                                       Get field info. if nec.
         IF (.NOT.NGRDAT) THEN
            CALL GRDAT (F, LFIELD, CATBLK, IBUFF(2049), IRET)
            IF (IRET.NE.0) GO TO 999
            END IF
C                                       If NGRDAT read CLEAN CATBLK.
         IF (NGRDAT) THEN
            ERRTXT = 'READING CLEAN CATBLK'
            CALL CATIO ('READ', CCDISK(LFIELD), CCCNO(LFIELD),
     *         KLNBLK, 'REST', IBUFF(2049), IRET)
            IF ((IRET.GT.0) .AND. (IRET.LT.5)) GO TO 990
            END IF
C                                       Set field center offsets.
         XXOFF = DXCG(LFIELD) * CCROT + DYCG(LFIELD) * SSROT
         YYOFF = DYCG(LFIELD) * CCROT - DXCG(LFIELD) * SSROT
         ZZOFF = DZCG(LFIELD)
         CALL XYSHFT (RA, DEC, XSHIFT(LFIELD), YSHIFT(LFIELD),
     *      MAPROT, XRA, XDEC)
         IF (DO3DIM) THEN
            CALL PRJMAT (RA, DEC, UVROT, XRA, XDEC, MAPROT, UMAT,
     *         PMAT)
         ELSE
            CALL P2DMAT (RA, DEC, UVROT, XRA, XDEC, MAPROT, UMAT,
     *         PMAT)
            END IF
C                                       Load CLEAN components
C                                       Open components file.
         JNREC = 1
         JLREC = 0
         ERRTXT = 'OPENING CLEAN COMPS FILE'
         CALL CCMINI ('READ', CLBUFF, CCDISK(LFIELD), CCCNO(LFIELD),
     *      CCVER(LFIELD), KLNBL2, LUNC, CLRNO, CLKOLS, CLNUMV, JLREC,
     *      IRET)
         IF (IRET.GT.1) GO TO 990
         JCOMP = 1
C                                       Make sure that there are some
         IF (CLBUFF(5).LE.0) GO TO 140
         IF (NCLNG(LFIELD).LE.0) NCLNG(LFIELD) = CLBUFF(5)
C                                       Loop loading components.
C                                       Check next component
         JCOMP = 1
         DO 110 I = 1,NCLNG(LFIELD)
            CALL TABCCM ('READ', CLBUFF, CLRNO, CLKOLS, CLNUMV, JLREC,
     *         XX, YY, ZZ, FLUX, CLTYPE, PARMS, IRET)
            IF (IRET.GT.0) THEN
               WRITE (MSGTXT,1090) IRET, JCOMP
               GO TO 995
               END IF
C                                        Check that point comp.
            JCOMP = JCOMP + 1
            JT = JT + 1
            IF (JLREC.LE.4) THEN
               ITYPE = 0
            ELSE
               ITYPE = CLTYPE
               END IF
            IF ((ITYPE.NE.MODTYP) .AND. (ITYPE.NE.0)) THEN
               WRITE (MSGTXT,1070) LFIELD, JCOMP-1
               CALL MSGWRT (6)
               END IF
            IF (((ITYPE.EQ.MODTYP) .OR. (ITYPE.EQ.0)) .AND.
     *         (IRET.EQ.0)) THEN
C                                       If req. sum flux
               TFLUXG = TFLUXG + FLUX
               CCOUNT = CCOUNT + 1
               XP(1) = (XX + XPOFF(LFIELD)) * CONST
               XP(2) = (YY + YPOFF(LFIELD)) * CONST
               XP(3) = 0.0
               CALL PRJMUL (2, XP, UMAT, XYZ)
               XYZ(1) = (XYZ(1) + XXOFF) / CONST
               XYZ(2) = (XYZ(2) + YYOFF) / CONST
               XYZ(3) = (XYZ(3) + ZZOFF) / CONST
               IF (NCOL.LE.4) THEN
                  CCTYPE = 0
                  CALL RFILL (3, 0.0, PARMS)
               ELSE
                  CCTYPE = ITYPE
                  END IF
               CALL TABCCM ('WRIT', CCBUFF, CCRNO, CCKOLS, CCNUMV, NCOL,
     *               XYZ(1), XYZ(2), XYZ(3), FLUX, CCTYPE, PARMS,
     *            IRET)
               IF (IRET.NE.0) THEN
                  ERRTXT = 'WRITING OUTPUT CC TABLE'
                  GO TO 990
                  END IF
               END IF
 110        CONTINUE
C                                       Close CLEAN components file.
 140     CALL TABCCM ('CLOS', CLBUFF, CLRNO, CLKOLS, CLNUMV, JLREC,
     *      XX, YY, ZZ, FLUX, CLTYPE, PARMS, IRET)
 150     CONTINUE
      CALL TABCCM ('CLOS', CCBUFF, CCRNO, CCKOLS, CCNUMV, NCOL,
     *   XYZ(1), XYZ(2), XYZ(3), FLUX, CCTYPE, PARMS, IRET)
      IF (IRET.NE.0) THEN
         ERRTXT = 'CLOSING OUTPUT CC TABLE'
         GO TO 990
         END IF
C                                       summary
      WRITE (MSGTXT,1150) TFLUXG, CCOUNT
      CALL MSGWRT (4)
      IRET = 0
      GO TO 999
C                                       Error
 990  WRITE(MSGTXT,1990,ERR=999) IRET, ERRTXT
 995  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('MOD3DV: MODEL TYPES =',I2,I2,' INCOMPATIBLE')
 1002 FORMAT ('MOD3DV: ILLEGAL MODEL TYPE =',I3)
 1070 FORMAT ('MOD3DV WRONG MODTYP AT FIELD, COMP',I5,I9)
 1090 FORMAT ('MOD3DV: ERROR',I5,' READING CLEAN COMPS REC',I5)
 1150 FORMAT ('MOD3DV found',F9.3,' Jy in',I8,' components')
 1990 FORMAT ('MOD3DV: ERROR',I5,' ',A)
      END
