LOCAL INCLUDE 'XG2XG.INC'
      HOLLERITH XINAM1(3), XINCL1(2), XINEXT(1)
      REAL      XINSEQ, XINDSK, XINVER, XNGAUS
      COMMON /INPARM/ XINAM1, XINCL1, XINSEQ, XINDSK, XINVER, XNGAUS,
     *   XINEXT
      INTEGER   INSEQ, INDISK, INCNO, INVER, NGAUSS, OUVER, MGAUSS,
     *   SCRTCH(256)
      CHARACTER INAME*12, INCLS*6, INEXT*2
      COMMON /XGPRMS/ SCRTCH, INSEQ, INDISK, INCNO, INVER, NGAUSS,
     *   MGAUSS, OUVER
      COMMON /CHPRMS/ INAME, INCLS, INEXT
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
LOCAL END
LOCAL INCLUDE 'XGTABLE.INC'
      INTEGER   MAXGAU, MAXP
      PARAMETER (MAXGAU=32)
      PARAMETER (MAXP=2+3*MAXGAU)
C
      INTEGER   XGBUFI(512), XGBUFO(512), XGKOLS(12), XGNUMV(12),
     *   XGKOLO(12), XGNUMO(12)
      REAL      RESULI(2*MAXP), RESULO(2*MAXP)
      COMMON /XGTABP/ XGBUFI, XGBUFO, XGKOLS, XGNUMV, XGKOLO, XGNUMO,
     *   RESULI, RESULO
LOCAL END
      PROGRAM XG2XG
C-----------------------------------------------------------------------
C! Task to copy one XG table to a new one with changed NGAUSS
C# Plot-util EXT-util
C-----------------------------------------------------------------------
C;  Copyright (C) 2025
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   XG2XG copy data to new VG file
C   Inputs:   (from AIPS)
C      INNAME     H(3)   name of primary file.Ipol
C      INCLASS    H(2)   class of primary file.Ipol
C      INSEQ      R      sequence number of primary file. Ipol
C      INDISK     R      disk volume number. 0 means try all.Ipol
C      INVERS     R      version number of XG file, 0 means latest
C      NGAUSS     R      Number Gaussians in output file
C-----------------------------------------------------------------------
      INTEGER   IRET
      CHARACTER PRGNAM*6
      INCLUDE 'XG2XG.INC'
      INCLUDE 'XGTABLE.INC'
      DATA PRGNAM /'XG2XG'/
C-----------------------------------------------------------------------
C                                       Init
      CALL XG2XGI (PRGNAM, IRET)
C                                       Do the copy
      IF (IRET.EQ.0) THEN
         IF (INEXT.EQ.'ZE') THEN
            CALL XG2XGZ (IRET)
         ELSE
            CALL XG2XGX (IRET)
            END IF
         END IF
C                                       history
      IF (IRET.EQ.0) CALL XG2XGH
C
      CALL DIE (IRET, SCRTCH)
C
 999  STOP
      END
      SUBROUTINE XG2XGI (PRGNAM, IRET)
C-----------------------------------------------------------------------
C   Inits this task
C   Input:
C      PRGNAM   C*6   Task name
C   Outputs:
C      IRET     I     Error code: 0 okay
C-----------------------------------------------------------------------
      CHARACTER PRGNAM*(*)
      INTEGER   IRET
C
      INTEGER   I, IROUND, NPARMS
      CHARACTER MTYPE*2, STAT*4
      INCLUDE 'XG2XG.INC'
      INCLUDE 'XGTABLE.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DGPH.INC'
      INCLUDE 'INCS:DFIL.INC'
C-----------------------------------------------------------------------
C                                       Initialize the IO parameters.
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      NSCR = 0
      NCFILE = 0
C                                       Get input values from AIPS.
      NPARMS = 10
      CALL GTPARM (PRGNAM, NPARMS, RQUICK, XINAM1, SCRTCH, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET
         CALL MSGWRT (8)
         END IF
      IF (RQUICK) CALL RELPOP (IRET, SCRTCH, I)
      IF (IRET.NE.0) GO TO 999
C                                       Hollerith -> char.
      CALL H2CHR (12, 1, XINAM1, INAME)
      CALL H2CHR (6, 1, XINCL1, INCLS)
      CALL H2CHR (2, 1, XINEXT, INEXT)
      INSEQ = IROUND (XINSEQ)
      INDISK = IROUND (XINDSK)
      INVER = IROUND (XINVER)
      NGAUSS = XNGAUS
C                                       IPOL
      INCNO = 1
      MTYPE = 'MA'
      CALL CATDIR ('SRCH', INDISK, INCNO, INAME, INCLS, INSEQ,
     *   MTYPE, NLUSER, STAT, SCRTCH, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1030) IRET, INAME, INCLS, INSEQ, INDISK,
     *      NLUSER
         GO TO 990
         END IF
C                                       Read CATBLK and mark 'READ'.
      STAT = 'WRIT'
      CALL CATIO ('READ', INDiSK, INCNO, CATBLK, STAT, SCRTCH, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'READING IPOL HEADER'
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = INDiSK
      FCNO(NCFILE) = INCNO
      FRW(NCFILE) = 1
C                                       Find table version
      IF (INEXT.NE.'ZE') INEXT = 'XG'
      CALL FNDEXT (INEXT, CATBLK, I)
      IF ((INVER.LE.0) .OR. (INVER.GT.I)) INVER = I
      OUVER = I + 1
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('XG2XGI ERROR',I4,' ON ',A)
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I3,' DISK=',
     *   I2,' USID=',I5)
      END
      SUBROUTINE XG2XGX (IRET)
C-----------------------------------------------------------------------
C   Copies XG to new XG
C   Outputs
C      IRET   I   Error code
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'XG2XG.INC'
      INCLUDE 'XGTABLE.INC'
      INTEGER   IROW, NVI, NVO, LUNI, LUNTMP, LUNO, IXGRNO, IYINC, CMAX,
     *   IZINC, IBLC(2), ITRC(2), ABSORB, NC, NROW, YZPIX(2), NGA, I, K,
     *   PDONE, NP
      REAL      VCLIP, REFINC, REFPIX, VPEAK, XGRMS
      LOGICAL   CHECK
      DOUBLE PRECISION REFVAL, VOFF
      CHARACTER REFTYP*8
C-----------------------------------------------------------------------
      LUNI = LUNTMP (1)
      CALL XGINI ('READ', XGBUFI, INDISK, INCNO, INVER, CATBLK, LUNI,
     *   IXGRNO, XGKOLS, XGNUMV, MGAUSS, IBLC, ITRC, IYINC, IZINC,
     *   VCLIP, VOFF, PDONE, REFVAL, REFPIX, REFINC, REFTYP, ABSORB,
     *   IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING REQUESTED XG TABLE'
         GO TO 990
         END IF
      LUNO = LUNTMP (1)
      NGAUSS = MAX (1, MIN (MAXGAU, NGAUSS))
      CALL XGINI ('WRIT', XGBUFO, INDISK, INCNO, OUVER, CATBLK, LUNO,
     *   IXGRNO, XGKOLO, XGNUMO, NGAUSS, IBLC, ITRC, IYINC, IZINC,
     *   VCLIP, VOFF, PDONE, REFVAL, REFPIX, REFINC, REFTYP, ABSORB,
     *   IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING OUTPUT XG TABLE'
         GO TO 990
         END IF
      WRITE (MSGTXT,1010) INVER, MGAUSS
      CALL MSGWRT (2)
      WRITE (MSGTXT,1011) OUVER, NGAUSS
      CALL MSGWRT (2)
      CHECK = NGAUSS.LT.MGAUSS
      NP = 0
      NVI = 2 + 3*MGAUSS + 1
      NVO = 2 + 3*NGAUSS + 1
      NC = MIN (NVI, NVO) - 1
      NROW = XGBUFI(5)
      CALL FILL (2*MAXP, FBLANK, RESULO)
      DO 100 IROW = 1,NROW
         IXGRNO = IROW
         CALL TABXG ('READ', XGBUFI, IXGRNO, XGKOLS, XGNUMV, YZPIX, NGA,
     *      VPEAK, XGRMS, RESULI, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READING INPUT XG TABLE'
            GO TO 990
            END IF
         IF (CHECK) THEN
            CMAX = 0
            K = 2 + 3*MGAUSS
            DO 50 I = 1,K
               IF ((RESULI(I).NE.0.0) .AND. (RESULI(I).NE.FBLANK))
     *            CMAX = I
               IF ((RESULI(I+K).NE.0.0) .AND. (RESULI(I+K).NE.FBLANK))
     *            CMAX = I
 50         CONTINUE
            CMAX = CMAX / 3
            IF (CMAX.GT.NGAUSS) THEN
               WRITE (MSGTXT,1050) YZPIX, CMAX-NGAUSS
               IF (NP.LT.30) CALL MSGWRT (6)
               NP = NP + 1
               END IF
            END IF
C                                       copy fit results
         CALL RCOPY (NC, RESULI(1), RESULO(1))
C                                       copy errors
         CALL RCOPY (NC, RESULI(NVI), RESULO(NVO))
C                                       write output
         IXGRNO = IROW
         CALL TABXG ('WRIT', XGBUFO, IXGRNO, XGKOLO, XGNUMO, YZPIX, NGA,
     *      VPEAK, XGRMS, RESULO, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING OUTPUT XG TABLE'
            GO TO 990
            END IF
 100     CONTINUE
C                                       close down
      CALL TABXG ('CLOS', XGBUFO, IXGRNO, XGKOLO, XGNUMO, YZPIX, NGA,
     *   VPEAK, XGRMS, RESULO, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CLOSING OUTPUT XG TABLE'
         GO TO 990
         END IF
      CALL TABXG ('CLOS', XGBUFI, IXGRNO, XGKOLS, XGNUMV, YZPIX, NGA,
     *   VPEAK, XGRMS, RESULI, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CLOSING INPUT XG TABLE'
         GO TO 990
         END IF
      IF (NP.GT.30) THEN
         WRITE (MSGTXT,1100) NP-30
         CALL MSGWRT (6)
         END IF
      GO TO 999
C
 990  CALL MSGWRT(8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('XG2XGX ERROR',I4,' ON ',A)
 1010 FORMAT ('Reading XG table version',I4,' with',I3,' Gaussians')
 1011 FORMAT ('Writing XG table version',I4,' with',I3,' Gaussians')
 1050 FORMAT ('Image pixel',2I6,' loses',I3,' components')
 1100 FORMAT ('And',I7,' more messages about loss')
      END
      SUBROUTINE XG2XGZ (IRET)
C-----------------------------------------------------------------------
C   Copies ZE to new ZE
C   Outputs
C      IRET   I   Error code
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'XG2XG.INC'
      INCLUDE 'XGTABLE.INC'
      INTEGER   IROW, NVI, NVO, LUNI, LUNTMP, LUNO, IXGRNO, IBLC(2), I,
     *   ITRC(2), ABSORB, NC, NROW, YZPIX(2), NGA, PDONE, NGI, NGO, NG,
     *   CMAX, K, NP
      REAL      VCLIP, REFINC, REFPIX, VPEAK, XGRMS, XGAUSI(3*MAXGAU),
     *   XGAUSO(3*MAXGAU), XGAUSB(2)
      DOUBLE PRECISION REFVAL
      CHARACTER REFTYP*8
      LOGICAL   CHECK
C-----------------------------------------------------------------------
      LUNI = LUNTMP (1)
      CALL ZEINI ('READ', XGBUFI, INDISK, INCNO, INVER, CATBLK, LUNI,
     *   IXGRNO, XGKOLS, XGNUMV, IBLC, ITRC, MGAUSS, VCLIP, PDONE,
     *   REFVAL, REFPIX, REFINC, REFTYP, ABSORB, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING REQUESTED ZE TABLE'
         GO TO 990
         END IF
      LUNO = LUNTMP (1)
      NGAUSS = MAX (1, MIN (MAXGAU, NGAUSS))
      CALL ZEINI ('WRIT', XGBUFO, INDISK, INCNO, OUVER, CATBLK, LUNO,
     *   IXGRNO, XGKOLO, XGNUMO, IBLC, ITRC, NGAUSS, VCLIP, PDONE,
     *   REFVAL, REFPIX, REFINC, REFTYP, ABSORB, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING OUTPUT XG TABLE'
         GO TO 990
         END IF
      WRITE (MSGTXT,1010) INVER, MGAUSS
      CALL MSGWRT (2)
      WRITE (MSGTXT,1011) OUVER, NGAUSS
      CALL MSGWRT (2)
      CHECK = NGAUSS.LT.MGAUSS
      NP = 0
      NVI = 1 + MGAUSS + 1
      NVO = 1 + NGAUSS + 1
      NC = MIN (NVI, NVO) - 1
      NGI = 3 * MGAUSS
      NGO = 3 * NGAUSS
      NG = MIN (NGO, NGI)
      NROW = XGBUFI(5)
      CALL FILL (2*MAXP, FBLANK, RESULO)
      CALL FILL (3*MAXGAU, FBLANK, XGAUSO)
      DO 100 IROW = 1,NROW
         IXGRNO = IROW
         CALL TABZE ('READ', XGBUFI, IXGRNO, XGKOLS, XGNUMV, YZPIX,
     *      VPEAK, XGRMS, RESULI, NGA, XGAUSI, XGAUSB, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READING INPUT ZE TABLE'
            GO TO 990
            END IF
         IF (CHECK) THEN
            CMAX = 0
            K = 1 + MGAUSS
            DO 50 I = 1,K
               IF ((RESULI(I).NE.0.0) .AND. (RESULI(I).NE.FBLANK))
     *            CMAX = I
               IF ((RESULI(I+K).NE.0.0) .AND. (RESULI(I+K).NE.FBLANK))
     *            CMAX = I
 50            CONTINUE
            CMAX = CMAX - 1
            IF (CMAX.GT.NGAUSS) THEN
               WRITE (MSGTXT,1050) YZPIX, CMAX-NGAUSS
               IF (NP.LT.30) CALL MSGWRT (6)
               NP = NP + 1
               END IF
            END IF
C                                       copy fit results
         CALL RCOPY (NC, RESULI(1), RESULO(1))
C                                       copy errors
         CALL RCOPY (NC, RESULI(NVI), RESULO(NVO))
C                                       copy Gaussian model
         CALL RCOPY (NG, XGAUSI, XGAUSO)
C                                       write output
         IXGRNO = IROW
         CALL TABZE ('WRIT', XGBUFO, IXGRNO, XGKOLO, XGNUMO, YZPIX,
     *      VPEAK, XGRMS, RESULO, NGA, XGAUSO, XGAUSB, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING OUTPUT ZE TABLE'
            GO TO 990
            END IF
 100     CONTINUE
C                                       close down
      CALL TABZE ('CLOS', XGBUFO, IXGRNO, XGKOLO, XGNUMO, YZPIX,
     *   VPEAK, XGRMS, RESULO, NGA, XGAUSO, XGAUSB, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CLOSING OUTPUT ZE TABLE'
         GO TO 990
         END IF
      CALL TABZE ('CLOS', XGBUFI, IXGRNO, XGKOLS, XGNUMV, YZPIX,
     *   VPEAK, XGRMS, RESULI, NGA, XGAUSI, XGAUSB, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CLOSING INPUT ZE TABLE'
         GO TO 990
         END IF
      IF (NP.GT.30) THEN
         WRITE (MSGTXT,1100) NP-30
         CALL MSGWRT (6)
         END IF
      GO TO 999
C
 990  CALL MSGWRT(8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('XG2XGZ ERROR',I4,' ON ',A)
 1010 FORMAT ('Reading ZE table version',I4,' with',I3,' Gaussians')
 1011 FORMAT ('Writing ZE table version',I4,' with',I3,' Gaussians')
 1050 FORMAT ('Image pixel',2I6,' loses',I3,' components')
 1100 FORMAT ('And',I7,' more messages about loss')
      END
      SUBROUTINE XG2XGH
C-----------------------------------------------------------------------
C   Adds a few lines to the history
C-----------------------------------------------------------------------
C
      INCLUDE 'XG2XG.INC'
      INTEGER   HLUN, DATE(3), TIME(3), IERR
      CHARACTER HILINE*72, TTIME(2)*12
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHIS.INC'
      DATA HLUN /28/
C-----------------------------------------------------------------------
      CALL HIINIT (3)
      CALL HIOPEN (HLUN, INDISK, INCNO, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 100
      CALL ZDATE (DATE)
      CALL ZTIME (TIME)
      CALL TIMDAT (TIME, DATE, TTIME(2), TTIME)
      WRITE (HILINE,1000) TSKNAM, RLSNAM, TTIME
      CALL HIADD (HLUN, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 100
      WRITE (HILINE,1010) TSKNAM, INVER, INEXT
      CALL HIADD (HLUN, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 100
      WRITE (HILINE,1011) TSKNAM, MGAUSS, INEXT
      CALL HIADD (HLUN, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 100
      WRITE (HILINE,1012) TSKNAM, OUVER, INEXT
      CALL HIADD (HLUN, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 100
      WRITE (HILINE,1013) TSKNAM, NGAUSS, INEXT
      CALL HIADD (HLUN, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 100
      WRITE (HILINE,1014) TSKNAM, INEXT, INEXT
      CALL HIADD (HLUN, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 100
C
 100  IF (IERR.NE.0) THEN
         MSGTXT = 'ERROR WRITING NISTORY FILE'
         CALL MSGWRT (6)
         END IF
      CALL HICLOS (HLUN, .TRUE., SCRTCH, IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT (A6,'RELEASE =''',A7,'''   /****** Start ',
     *   A12,2X,A8)
 1010 FORMAT (A6,'INVERS  =',I5,'   / input ',A,' table version')
 1011 FORMAT (A6,'INGAUSS =',I5,'   / input ',A,' table # Gaussians')
 1012 FORMAT (A6,'OUTVERS =',I5,'   / output ',A,' table version')
 1013 FORMAT (A6,'NGAUSS  =',I5,'   / output ',A,' table # Gaussians')
 1014 FORMAT (A6,'INEXT   =''',A,'''    / output ',A,
     *   ' table # Gaussians')
      END
