LOCAL INCLUDE 'INPUT.INC'
C                                       Declarations for inputs
      INTEGER   NPARMS
C                                       NPARMS=no. adverbs passed.
      PARAMETER (NPARMS=10)
      INTEGER   AVTYPE(NPARMS), AVDIM(2,NPARMS)
      CHARACTER AVNAME(NPARMS)*8
LOCAL END
LOCAL INCLUDE 'INPUTDATA.INC'
C                                       DATA statments defining input
C                                       parameters.
      INCLUDE 'INCS:PAOOF.INC'
C                                       Adverb names
C                     1         2          3        4         5
      DATA AVNAME /'INNAME', 'INCLASS', 'INSEQ', 'INDISK', 'INVERS',
C           6           7         8         9         10
     *   'OUTVERS',  'BCOUNT' ,'ECOUNT', 'RADIUS', 'CUTOFF'/
C                                       Adverb data types (PAOOF.INC)
C                    1       2       3       4       5       6
      DATA AVTYPE /OOACAR, OOACAR, OOAINT, OOAINT, OOAINT,
C          6       7       8       9      10
     *   OOAINT, OOAINT, OOAINT, OOARE, OOARE/
C                                       Adverb dimensions (as 2D)
C                   1    2    3    4    5
      DATA AVDIM /12,1, 6,1, 1,1, 1,1, 1,1,
C         6    7    8    9    10
     *   1,1, 1,1, 1,1, 1,1, 1,1/
LOCAL END
LOCAL INCLUDE 'GFORT'
      INTEGER   IDUM(4)
      LOGICAL   LDUM(4)
      REAL      RDUM(4)
      DOUBLE PRECISION DDUM(2)
      EQUIVALENCE (DDUM, RDUM, LDUM, IDUM)
      COMMON /CCSELG/ DDUM
LOCAL END
      PROGRAM CCSEL
C-----------------------------------------------------------------------
C! Select signifigant CC components.
C# Utility OOP
C-----------------------------------------------------------------------
C;  Copyright (C) 1995, 2009-2010, 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   Paraform AIPS OOP task processing a table.
C-----------------------------------------------------------------------
      CHARACTER PRGM*6, INTAB*32, OUTTAB*32
      INTEGER   IRET, BUFF1(256)
      DATA PRGM /'CCSEL '/
C-----------------------------------------------------------------------
C                                       Startup
      CALL CSELIN (PRGM, INTAB, OUTTAB, IRET)
C                                       Process table
      IF (IRET.EQ.0) CALL CSELAB (INTAB, OUTTAB, IRET)
C                                       History
      IF (IRET.EQ.0) CALL CSELHI (OUTTAB)
C                                       Close down files, etc.
      CALL DIE (IRET, BUFF1)
C
 999  STOP
      END
      SUBROUTINE CSELIN (PRGN, INTAB, OUTTAB, IRET)
C-----------------------------------------------------------------------
C   CSELIN gets input parameters for CCSEL and creates the input and
C   output objects
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 file
C-----------------------------------------------------------------------
      INTEGER   IRET
      CHARACTER PRGN*6, INTAB*32, OUTTAB*32
C
      INTEGER   NKEY1, NKEY2
C                                       NKEY1=no. adverbs to copy to
C                                       INTAB
      PARAMETER (NKEY1=9)
C                                       NKEY2=no. adverbs to copy to
C                                       OUTTAB
      PARAMETER (NKEY2=5)
      INTEGER   DIM(3)
      CHARACTER INK1(NKEY1)*8, OUTK1(NKEY1)*32, INK2(NKEY2)*8,
     *   OUTK2(NKEY2)*32
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'GFORT'
      INCLUDE 'INPUT.INC'
      INCLUDE 'INPUTDATA.INC'
C                                       Adverbs to copy to INTAB
C                   1         2          3        4         5
      DATA INK1 /'INNAME', 'INCLASS', 'INSEQ', 'INDISK', 'INVERS',
C           6         7         8         9
     *   'BCOUNT', 'ECOUNT', 'RADIUS', 'CUTOFF'/
C                                       May rename adverbs to INTAB
C                    1       2        3        4       5
      DATA OUTK1 /'NAME', 'CLASS', 'IMSEQ', 'DISK', 'VER',
C           6         7         8         9
     *   'BCOUNT', 'ECOUNT', 'RADIUS', 'CUTOFF'/
C                                       Adverbs to copy to OUTTAB
C                   1         2          3        4         5
      DATA INK2 /'INNAME', 'INCLASS', 'INSEQ', 'INDISK', 'OUTVERS'/
C                                       May rename adverbs to OUTTAB
C                    1       2        3        4       5
      DATA OUTK2 /'NAME', 'CLASS', 'IMSEQ', 'DISK', 'VER'/
C-----------------------------------------------------------------------
C                                       Startup,  returns "Input" object
C                                       containing POPS adverbs
      CALL AV2INP (PRGN, NPARMS, AVNAME, AVTYPE, AVDIM, 'Input', IRET)
      IF (IRET.NE.0) GO TO 999
C                                       Create input object
      INTAB = 'Input table'
      CALL CREATE (INTAB, 'TABLE', IRET)
      IF (IRET.NE.0) GO TO 999
C                                       Copy adverbs to object
      CALL IN2OBJ ('Input', NKEY1, INK1, OUTK1, INTAB, IRET)
      IF (IRET.NE.0) GO TO 999
C                                       Table type
      DIM(1) = 2
      DIM(2) = 1
      DIM(3) = 0
      CALL OPUT (INTAB, 'TBLTYPE', OOACAR, DIM, IDUM, 'CC', IRET)
      IF (IRET.NE.0) GO TO 999
C                                       Create Output Object
      OUTTAB = 'Output table'
      CALL CREATE (OUTTAB, 'TABLE', IRET)
      IF (IRET.NE.0) GO TO 999
C                                       Copy adverbs to object
      CALL IN2OBJ ('Input', NKEY2, INK2, OUTK2, OUTTAB, IRET)
      IF (IRET.NE.0) GO TO 999
C                                       Table type
      CALL OPUT (OUTTAB, 'TBLTYPE', OOACAR, DIM, IDUM, 'CC', IRET)
      IF (IRET.NE.0) GO TO 999
C
 999  RETURN
      END
      SUBROUTINE CSELAB (INTAB, OUTTAB, IERR)
C-----------------------------------------------------------------------
C   Sum and select components.
C   Inputs:
C      INTAB   C*   Name of input table object.
C      OUTTAB  C*   Name of output table object.
C   Output:
C      IERR    I    Error code: 0 => ok
C-----------------------------------------------------------------------
      CHARACTER INTAB*(*), OUTTAB*(*)
      INTEGER   IERR
C
C
      INTEGER   MAXCC
C                                       MAXCC = max. no. CC entries.
      PARAMETER (MAXCC = 1000000)
      INTEGER   IROW, OROW, NROW, BC, EC, TYPE, DIM(3), NCC, I, J,
     *   CCROW, CCNCOL, CCTYPE(MAXCC), OVER
      REAL      XPOS(MAXCC), YPOS(MAXCC), ZPOS(MAXCC), FLUX(MAXCC),
     *   SFLUX(MAXCC), PARMS(3,MAXCC), RADIUS, CUTOFF, MXDIS, SUM, DIS,
     *   SUMI, SUMO
      LOGICAL   DOMAGN
      CHARACTER CDUMMY*1
      INCLUDE 'GFORT'
      INCLUDE 'INCS:PAOOF.INC'
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
C                                       Create output table
C                                       This copies header stuff
C                                       including any keywords.
      CALL COPHED (INTAB, OUTTAB, IERR)
      IF (IERR.NE.0) GO TO 999
C                                       Open input table
      CALL OCCINI (INTAB, 'READ', CCROW, CCNCOL, IERR)
      IF (IERR.NE.0) GO TO 999
C                                       Get number of entries
      CALL OGET (INTAB, 'NROW', TYPE, DIM, IDUM, CDUMMY, IERR)
      NROW = IDUM(1)
      IF (IERR.NE.0) GO TO 999
C                                       Get range of rows.
      CALL OGET (INTAB, 'BCOUNT', TYPE, DIM, IDUM, CDUMMY, IERR)
      BC = IDUM(1)
      IF (IERR.NE.0) GO TO 999
      BC = MIN (MAX (BC, 1), NROW)
      CALL OGET (INTAB, 'ECOUNT', TYPE, DIM, IDUM, CDUMMY, IERR)
      EC = IDUM(1)
      IF (IERR.NE.0) GO TO 999
      IF (EC.LE.0) EC = NROW
C                                       Check array sizes
      IF ((EC-BC+1) .GT. MAXCC) THEN
         WRITE (MSGTXT,1000) EC-BC+1, MAXCC
         CALL MSGWRT (8)
         IERR = 5
         GO TO 999
         END IF
C                                       Filtering parameters
      CALL OGET (INTAB, 'RADIUS', TYPE, DIM, IDUM, CDUMMY, IERR)
      RADIUS = RDUM(1)
      IF (IERR.NE.0) GO TO 999
      CALL OGET (INTAB, 'CUTOFF', TYPE, DIM, IDUM, CDUMMY, IERR)
      CUTOFF = RDUM(1)
      IF (IERR.NE.0) GO TO 999
C                                       Filter by magnitude?
      DOMAGN = CUTOFF.LT.0.0
      CUTOFF = ABS (CUTOFF)
C                                       Read table to internal arrays.
      NCC = 0
      SUMI = 0.0
      DO 100 IROW = BC,EC
         NCC = NCC + 1
         CALL CCTGET (INTAB, IROW, CCNCOL, XPOS(NCC), YPOS(NCC),
     *      ZPOS(NCC), FLUX(NCC), CCTYPE(NCC), PARMS(1,NCC), IERR)
         IF (IERR.GT.0) GO TO 999
C                                       Flagged?
         IF (IERR.LT.0) NCC = NCC - 1
         IF (IERR.EQ.0) SUMI = SUMI + FLUX(NCC)
 100     CONTINUE
C                                       Close Input
      CALL OCLOSE (INTAB, IERR)
      IF (IERR.NE.0) GO TO 999
C                                       Sum fluxes within RADIUS
      MXDIS = (RADIUS / 3600.0) ** 2
      DO 400 I = 1,NCC
         SUM = 0.0
         DO 300 J = 1,NCC
            DIS = (XPOS(I)-XPOS(J)) ** 2 + (YPOS(I)-YPOS(J)) ** 2
            IF (DIS.LE.MXDIS) SUM = SUM + FLUX(J)
 300        CONTINUE
         IF (DOMAGN) SUM = ABS (SUM)
         SFLUX(I) = SUM
 400     CONTINUE
C                                       Open output table
      CALL OCCINI (OUTTAB, 'WRIT', CCROW, CCNCOL, IERR)
      IF (IERR.NE.0) GO TO 999
C                                       Write selected components
      OROW = 0
      SUMO = 0.0
      DO 500 IROW = 1,NCC
         IF (SFLUX(IROW).GT.CUTOFF) THEN
            OROW = OROW + 1
            CALL CCTPUT (OUTTAB, OROW, CCNCOL, XPOS(IROW), YPOS(IROW),
     *         ZPOS(IROW), FLUX(IROW), CCTYPE(IROW), PARMS(1,IROW),
     *         IERR)
            IF (IERR.GT.0) GO TO 999
            SUMO = SUMO + FLUX(IROW)
            END IF
 500     CONTINUE
C                                       Update number of rows
      DIM(1) = 1
      DIM(2) = 1
      DIM(3) = 0
      IDUM(1) = OROW
      CALL OPUT (OUTTAB, 'NROW', OOAINT, DIM, IDUM, CDUMMY, IERR)
      IF (IERR.NE.0) GO TO 999
      CALL OGET (OUTTAB, 'VER', TYPE, DIM, IDUM, CDUMMY, IERR)
      OVER = IDUM(1)
      IF (IERR.NE.0) GO TO 999
      WRITE (MSGTXT,1500) NCC, OROW, OVER
      CALL MSGWRT (4)
      WRITE (MSGTXT,1505) SUMI, SUMO
      CALL MSGWRT (4)
C                                       Close output
      CALL OCLOSE (OUTTAB, IERR)
      IF (IERR.NE.0) GO TO 999
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('TOO MANY COMPONENTS FOR INTERNAL ARRAYS:',I8,'>',I8)
 1500 FORMAT ('Read',I10,' comps, wrote',I10,' to version',I5)
 1505 FORMAT ('Read',F11.5,' Jy, wrote',F11.5)
      END
      SUBROUTINE CSELHI (OUTTAB)
C-----------------------------------------------------------------------
C   Routine to write history file to output table object.  This assumes
C   that a previous history exists and merely adds the information from
C   the current task.
C   Inputs:
C      OUTTAB  C*?  Output table object
C-----------------------------------------------------------------------
      CHARACTER OUTTAB*(*)
C
      INTEGER   NADV
      PARAMETER (NADV=9)
      CHARACTER LIST(NADV)*8
      INTEGER   IERR
      INCLUDE 'INCS:DMSG.INC'
C                                       Adverbs to copy to history
      DATA LIST /'INNAME', 'INCLASS', 'INSEQ', 'INVERS',
     *   'OUTVERS',  'BCOUNT' ,'ECOUNT', 'RADIUS', 'CUTOFF'/
C-----------------------------------------------------------------------
C                                       Add task label to history
      CALL OHTIME (OUTTAB, IERR)
      IF (IERR.NE.0) GO TO 990
C                                       Copy adverb values.
      CALL OHLIST ('Input', LIST, NADV, OUTTAB, IERR)
      IF (IERR.NE.0) GO TO 990
      GO TO 999
C                                       Error
 990  MSGTXT = 'ERROR WRITING HISTORY FOR ' // OUTTAB
      CALL MSGWRT (4)
 999  RETURN
      END
      SUBROUTINE CCTGET (NAME, ROW, NC, X, Y, Z, FLUX, CCTYPE, PARMS,
     *   IERR)
C-----------------------------------------------------------------------
C   Get row from CC (CLEAN component) table object.
C   This assumes the structure of the CC table
C   Inputs:
C      NAME    C*?  CC table object name.
C      ROW     I    Row number
C   Output:
C      X       R    X coordinate
C      Y       R    Y coordinate
C      FLUX    R    Component flux density.
C      IERR    I    Return error code, 0=>OK
C-----------------------------------------------------------------------
      CHARACTER NAME*(*)
      INTEGER   ROW, NC, CCTYPE, IERR
      REAL      X, Y, Z, FLUX, PARMS(3)
C
      INTEGER   CCRNO
C-----------------------------------------------------------------------
C                                       Read
      CCRNO = ROW
      CALL OTABCC (NAME, 'READ', CCRNO, NC, X, Y, Z, FLUX, CCTYPE,
     *   PARMS, IERR)
C
 999  RETURN
      END
      SUBROUTINE CCTPUT (NAME, ROW, NC, X, Y, Z, FLUX, CCTYPE, PARMS,
     *   IERR)
C-----------------------------------------------------------------------
C   Write row to CC (CLEAN component) table object.
C   This assumes the structure of the CC table
C   Inputs:
C      NAME    C*?  CC table object name.
C      ROW     I    Row number
C      X       R    X coordinate
C      Y       R    Y coordinate
C   Output:
C      IERR    I    Return error code, 0=>OK
C-----------------------------------------------------------------------
      CHARACTER NAME*(*)
      INTEGER   ROW, NC, CCTYPE, IERR
      REAL      X, Y, Z, FLUX, PARMS(3)
C
      INTEGER   CCRNO
C-----------------------------------------------------------------------
C                                       Write
      CCRNO = ROW
      CALL OTABCC (NAME, 'WRIT', CCRNO, NC, X, Y, Z, FLUX, CCTYPE,
     *   PARMS, IERR)
C
 999  RETURN
      END
