      PROGRAM CCMRG
C-----------------------------------------------------------------------
C! Merge CC / CX (CLEAN components) table.
C# EXT-util
C-----------------------------------------------------------------------
C;  Copyright (C) 1995-1996, 2009, 2020
C;  Associated Universities, Inc. Washington DC, USA.
C;
C;  This program is free software; you can redistribute it and/or
C;  modify it under the terms of the GNU General Public License as
C;  published by the Free Software Foundation; either version 2 of
C;  the License, or (at your option) any later version.
C;
C;  This program is distributed in the hope that it will be useful,
C;  but WITHOUT ANY WARRANTY; without even the implied warranty of
C;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C;  GNU General Public License for more details.
C;
C;  You should have received a copy of the GNU General Public
C;  License along with this program; if not, write to the Free
C;  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge,
C;  MA 02139, USA.
C;
C;  Correspondence concerning AIPS should be addressed as follows:
C;         Internet email: aipsmail@nrao.edu.
C;         Postal address: AIPS Project Office
C;                         National Radio Astronomy Observatory
C;                         520 Edgemont Road
C;                         Charlottesville, VA 22903-2475 USA
C-----------------------------------------------------------------------
C   Task CCMRG sorts AIPS CC tables to bring all components at the same
C   cell together, then it sums them, and finally it resorts the file
C   into the original order (by flux of the new components).
C   Inputs:
C      AIPS Adverb   Prg. Name          Description
C      INNAME         NAME          File name.
C      INCLASS        CLASS         File class.
C      INSEQ          SEQ           File sequence number.
C      INDISK         DISK          Disk volume on which file resides.
C      INVER          INVER         Input file version number
C      IN2VER         OUTVER        Output file version number
C      BADDISK        IBADD(10)     Disks to avoid for scratch.
C-----------------------------------------------------------------------
      CHARACTER NAME*12, CLASS*6, PTYPE*2, PRGM*6, ATIME*8, ADATE*12,
     *   HILINE*72, TTYPE*2
      INTEGER   CATBLK(256), USERID, SEQ, INVER, OUTVER, CNO, DISK,
     *   IRET, BUFSZ, NPARM, IBUF(1), IROUND, LUN, FIND, IERR, ID(3),
     *   IT(3), HLUN, I, INPCMP, OUTCMP, MVERS
      REAL      XSEQ, XDISK, XVER, X2VER, BADD(10), CATR(256),
     *   BUFFER(8196)
      DOUBLE PRECISION CATD(64)
      HOLLERITH XNAME(3), XCLASS(2), CATH(256)
      LOGICAL   T, DOCX
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DHIS.INC'
      INCLUDE 'INCS:DFIL.INC'
      COMMON /INPARM/ XNAME, XCLASS, XSEQ, XDISK, XVER, X2VER, BADD
      COMMON /MAPHDR/ CATBLK
      EQUIVALENCE (CATBLK, CATR, CATD, CATH)
      EQUIVALENCE (IBUF, BUFFER)
      DATA PRGM  /'CCMRG '/
      DATA LUN, HLUN /16,27/
      DATA T /.TRUE./
C-----------------------------------------------------------------------
C                                       Init I/O, parameters
      NPARM = 19
      CALL SETUP (PRGM, NPARM, XNAME, IBUF, IRET)
      IF (IRET.NE.0) GO TO 990
      USERID = NLUSER
      SEQ = IROUND (XSEQ)
      DISK = IROUND (XDISK)
      INVER = IROUND (XVER)
      OUTVER = IROUND (X2VER)
      CALL H2CHR (12, 1, XNAME, NAME)
      CALL H2CHR (6, 1, XCLASS, CLASS)
C                                       Open file and get CATBLK.
      PTYPE = '  '
      CALL MAPOPN ('WRIT', DISK, NAME, CLASS, SEQ, PTYPE, USERID,
     *   LUN, FIND, CNO, CATBLK, IBUF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET
         CALL MSGWRT (8)
         GO TO 990
         END IF
C                                       Mark in /CFILES/
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISK
      FCNO(NCFILE) = CNO
      FRW(NCFILE) = 1
C                                       Close file, leave marked.
      CALL ZCLOSE (LUN, FIND, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1010) IERR
         CALL MSGWRT (8)
         GO TO 990
         END IF
C                                       BADDISK
      DO 25 I = 1,10
         IBAD(I) = IROUND (BADD(I))
 25      CONTINUE
C                                       CC or CX?
      CALL FNDEXT ('CC', CATBLK, MVERS)
      TTYPE = 'CC'
      DOCX = MVERS.LE.0
      IF (DOCX) THEN
         CALL FNDEXT ('CX', CATBLK, MVERS)
         IF (MVERS.LE.0) THEN
            MSGTXT = 'NEITHER CC NOR CX TABLES FOUND'
            CALL MSGWRT (8)
            IERR = 10
            GO TO 990
            END IF
         TTYPE = 'CX'
         END IF
C                                       Sort: to scratch (1)
      BUFSZ = 8192
      IF (DOCX) THEN
         CALL CXMERG (DISK, CNO, INVER, OUTVER, INPCMP, OUTCMP, BUFSZ,
     *      BUFFER, IRET)
      ELSE
         CALL CCMERG (DISK, CNO, INVER, OUTVER, INPCMP, OUTCMP, BUFSZ,
     *      BUFFER, IRET)
         END IF
      IF (IRET.NE.0) GO TO 990
C                                       History
      CALL HIINIT (3)
      CALL HIOPEN (HLUN, DISK, CNO, IBUF, IERR)
      IF (IERR.EQ.0) GO TO 110
         WRITE (MSGTXT,1100) IERR
         CALL MSGWRT (6)
         GO TO 990
C                                       Version, date, time
 110  CALL ZDATE (ID)
      CALL ZTIME (IT)
      CALL TIMDAT (IT, ID, ATIME, ADATE)
      WRITE (HILINE,1110) TSKNAM, RLSNAM, ADATE, ATIME
      CALL HIADD (HLUN, HILINE, IBUF, IERR)
      IF (IERR.NE.0) GO TO 120
C                                       Input vers, number
      WRITE (MSGTXT,1111) INPCMP, TTYPE, INVER
      CALL MSGWRT (3)
      WRITE (HILINE,1112) TSKNAM, INPCMP, TTYPE, INVER
      CALL HIADD (HLUN, HILINE, IBUF, IERR)
      IF (IERR.NE.0) GO TO 120
C                                       Output vers, number
      WRITE (MSGTXT,1113) OUTCMP, TTYPE, OUTVER
      CALL MSGWRT (3)
      WRITE (HILINE,1114) TSKNAM, OUTCMP, TTYPE, OUTVER
      CALL HIADD (HLUN, HILINE, IBUF, IERR)
      IF (IERR.NE.0) GO TO 120
C
 120  CALL HICLOS (HLUN, T, IBUF, IERR)
C                                       Write end message
 990  CALL DIE (IRET, IBUF)
C
 999  STOP
C-----------------------------------------------------------------------
 1000 FORMAT ('ERROR:',I7,' OPENING MAP FILE')
 1010 FORMAT ('ERROR:',I7,' CLOSING MAP FILE')
 1100 FORMAT ('ERROR:',I7,' OPENING HISTORY FILE')
 1110 FORMAT (A6,'RELEASE =''',A7,' ''  /********* Run',
     *   A12,2X,A8)
 1111 FORMAT ('Read ',I10,' CLEAN components from ',A,' file version',
     *   I3)
 1112 FORMAT (A6,'/Read ',I10,' CLEAN components from ',A,
     *   ' file version',I3)
 1113 FORMAT ('Wrote',I10,' CLEAN components to ',A,' file version',I3)
 1114 FORMAT (A6,'/Wrote',I10,' CLEAN components to ',A,
     *   ' file version',I3)
      END
      SUBROUTINE CXMERG (DISK, CNO, INVER, OUTVER, INPCMP, OUTCMP,
     *   JBUFS, BUFFER, IRET)
C-----------------------------------------------------------------------
C   CXMERG sorts AIPS CX tables to bring all components at the same
C   cell together, then it sums them, and finally it resorts the file
C   into the original order (by flux of the new components).
C   Inputs:
C      DISK     I      File disk number
C      CNO      I      File catalog number
C      JBUFS    I      Number words in BUFFER
C   In/out:
C      INVER    I      Input CC version number: 0 => MAXVER
C      OUTVER   I      Output CC version number: 0 => MAXVER+1
C   Output:
C      BUFFER   I(*)   sort buffer
C      INPCMP   I      Number components on input.
C      OUTCMP   I      Number components on output.
C      IRET     I      Error code
C   Common: /MAPHDR/ CATBLK for the affected image file
C   The routine assumes that the CATBLK is in this common already and
C   that the file has been opened in the catalog for WRITE.  (The image
C   file itself does not need to be open.)  The routine assumes that
C   the CFIL common is initialized especially IBAD (BADDISK).
C-----------------------------------------------------------------------
      INTEGER   DISK, CNO, INVER, OUTVER, JBUFS, INPCMP, OUTCMP, IRET
      REAL      BUFFER(*)
C
      CHARACTER CCTIT1(4)*8, TYPE*2, PHNAME*48, CHTMP*2
      INTEGER   SCVER(2), EQUKOL(10), SUMKOL(10), MAXVER, KEY(2,4),
     *   TABUFF(512), BUFSZ, I, LUN(2), JCOL1, JP, IERR, NKEY, NCOL,
     *   NREC, DATP(128,2), EMAX, EMIN, IVER, INSCR, CATSAV(256),
     *   KEYSUB(2,2)
      REAL      TSTKOL(10), FKEY(2,2), EPS
      LOGICAL   T
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA TYPE /'CX'/
      DATA EPS, T /0.05, .TRUE./
      DATA LUN /16,17/
      DATA KEYSUB /4*1/
      DATA CCTIT1 /'X', 'Y', 'REAL', 'IMAG'/
C-----------------------------------------------------------------------
      INSCR = NSCR + 1
      IF (INSCR.LE.0) NSCR = 0
      IF (INSCR.LE.0) INSCR = 1
C                                       find version numbers
      CALL FNDEXT (TYPE, CATBLK, MAXVER)
      IF (MAXVER.GT.0) GO TO 10
         WRITE (MSGTXT,1000)
         GO TO 990
 10   IF ((INVER.LE.0) .OR. (INVER.GT.MAXVER)) INVER = MAXVER
      IF (OUTVER.LE.0) OUTVER = MAXVER + 1
      SCVER(1) = MAX (OUTVER, MAXVER+1)
      SCVER(2) = SCVER(1) + 1
C                                       Open table file
      NKEY = 0
      NCOL = 0
      NREC = 0
      CALL TABINI ('READ', TYPE, DISK, CNO, INVER, CATBLK, LUN, NKEY,
     *   NREC, NCOL, DATP, TABUFF, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1010) IERR, TYPE, INVER
         GO TO 990
         END IF
C                                       Number input components
      INPCMP = TABUFF(5)
C                                       Find columns
      CALL FILL (10, 0, EQUKOL)
      CALL FILL (10, 0, SUMKOL)
      JCOL1 = 2
      CALL FNDCOL (JCOL1, CCTIT1(1), 8, T, TABUFF, EQUKOL, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1020) IERR
         GO TO 990
         END IF
      CALL FNDCOL (2, CCTIT1(3), 8, T, TABUFF, SUMKOL, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1020) IERR
         GO TO 990
         END IF
C                                       insort
      KEY(1,1) = EQUKOL(2)
      KEY(2,1) = 0
      KEY(1,2) = EQUKOL(1)
      KEY(2,2) = 0
C                                       outsort
      KEY(1,3) = -SUMKOL(1)
      KEY(2,3) = 0
      KEY(1,4) = -SUMKOL(2)
      KEY(2,4) = 0
C                                       sort weights: not sum cols
      FKEY(1,1) = -1.0
      FKEY(2,1) = 0.0
      FKEY(1,2) = -1.0
      FKEY(2,2) = 0.0
C                                       tolerances
      TSTKOL(1) = EPS * ABS (CATR(KRCIC))
      TSTKOL(2) = EPS * ABS (CATR(KRCIC+1))
C                                       Close the table file
      CALL TABIO ('CLOS', 0, 0, DATP, TABUFF, IERR)
C                                       Sort: to scratch (1)
      IRET = 0
      IF (INPCMP.GT.0) THEN
         BUFSZ = JBUFS * 2
         WRITE (MSGTXT,1030) SCVER(1)
         CALL MSGWRT (2)
         CALL TABSRT (DISK, CNO, TYPE, INVER, SCVER(1), KEY, KEYSUB,
     *      FKEY, TABUFF, CATBLK, IRET)
         IF (IRET.NE.0) GO TO 999
C                                       Merge: scratch(2)
         WRITE (MSGTXT,1031) SCVER(2)
         CALL MSGWRT (2)
         CALL TABMRG (DISK, CNO, TYPE, SCVER(1), SCVER(2), EQUKOL,
     *      SUMKOL, TSTKOL, BUFFER, TABUFF, CATBLK, OUTCMP, IRET)
         IF (IRET.NE.0) GO TO 900
         CALL ZPHFIL (TYPE, DISK, CNO, OUTVER, PHNAME, IERR)
         CALL ZDESTR (DISK, PHNAME, IERR)
C                                       Sort to output
         WRITE (MSGTXT,1032) OUTVER
         CALL MSGWRT (2)
         CALL TABSRT (DISK, CNO, TYPE, SCVER(2), OUTVER, KEY(1,3),
     *      KEYSUB, FKEY, TABUFF, CATBLK, IRET)
C                                       empty table
      ELSE IF (INVER.NE.OUTVER) THEN
         CALL ZPHFIL (TYPE, DISK, CNO, OUTVER, PHNAME, IERR)
         CALL ZDESTR (DISK, PHNAME, IERR)
         CALL TABCOP (TYPE, INVER, OUTVER, LUN(1), LUN(2), DISK, DISK,
     *      CNO, CNO, CATBLK, TABUFF, TABUFF(257), IRET)
         END IF
C                                       extension file clean up
C                                       FNDEXT, TABINI called FXHDEX
 900  DO 910 I = 1,KIEXTN
         CALL H2CHR (2, 1, CATH(KHEXT+I-1), CHTMP)
         IF (CHTMP.EQ.TYPE) THEN
            JP = KIVER + I - 1
            IF (CATBLK(JP).GT.MAXVER) THEN
               EMAX = CATBLK(JP)
               GO TO 920
               END IF
            END IF
 910     CONTINUE
      GO TO 999
 920  EMIN = MAXVER + 1
      IF (IRET.EQ.0) EMIN = MAX (EMIN, OUTVER+1)
C                                       delete the extras
      IF (EMIN.LE.EMAX) THEN
         CATBLK(JP) = EMIN - 1
         DO 930 IVER = EMIN,EMAX
            CALL ZPHFIL (TYPE, DISK, CNO, IVER, PHNAME, IERR)
            CALL ZDESTR (DISK, PHNAME, IERR)
            IF (IERR.GT.1) CATBLK(JP) = IVER
 930        CONTINUE
C                                       Update catalog
         CALL CATIO ('UPDT', DISK, CNO, CATBLK, 'REST', TABUFF, IERR)
         END IF
C                                       Delete scratch files
      IF (NSCR.LT.INSCR) THEN
         EMIN = NSCR - INSCR + 1
         CALL FILL (EMIN, 2, DATP)
         CALL COPY (256, CATBLK, CATSAV)
         CALL MAPCLR (EMIN, SCRVOL(INSCR), SCRCNO(INSCR), DATP, TABUFF)
         CALL COPY (256, CATSAV, CATBLK)
         NSCR = INSCR - 1
         END IF
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
      IRET = 8
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('ERROR: NO CX FILES ASSOCIATED WITH IMAGE')
 1010 FORMAT ('ERROR:',I7,' OPENING ',A2,' FILE VERSION',I3)
 1020 FORMAT ('ERROR:',I7,' FINDING NEEDED CX FILE COLUMNS')
 1030 FORMAT ('Start sort to CX file scratch version',I4)
 1031 FORMAT ('Start merge to CX file scratch version',I4)
 1032 FORMAT ('Start sort to CX file output version',I4)
      END
