      SUBROUTINE PPSEL (DISKI, CNOI, DISKO, CNOO, VER, CATIN, CATOUT,
     *   LUNI, LUNO, BIF, EIF, BCHAN, ECHAN, TB, TE, IFQID, ISUB, JSUB,
     *   BUFFER, OBUFF, IRET)
C-----------------------------------------------------------------------
C! Copies and renumbers the IFs and spectral channels in a PP table
C# EXT-appl Calibration
C-----------------------------------------------------------------------
C;  Copyright (C) 2023-2024
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   Copies and renumbers the IFs and channels in an PP table; can also
C   modify the FQ ID.
C   Inputs:
C      DISKI    I        Input volume number
C      CNOI     I        Input catalog number
C      DISKO    I        Output volume number
C      CNOO     I        Output catalog number
C      VER      I        Version to check/modify
C      CATIN    I(256)   Input catalog header
C      CATOUT   I(256)   Output catalog header
C      LUNI     I        LUN to use
C      LUNO     I        LUN to use
C      BIF      I        Start IF number
C      EIF      I        End IF number
C      BCHAN    I        First channel
C      ECHAN    I        Last channel
C      TB       D        Beginning time in days
C      TE       D        Ending time in days
C      IFQID    I        FQ ID to select (output FQID will be 1)
C                           if <= 0 then output FQ ID unchanged.
C      ISUB     I        Selected subarray (= 0 any)
C      JSUB     I        Output subarray number (< 0 => NO CHANGE)
C   Input/Output:
C      BUFFER   I(512)   Work buffer
C      OBUFF    I(512)   Work buffer
C   Output:
C      IRET            I       Error, 0 => OK
C-----------------------------------------------------------------------
      INTEGER   DISKI, CNOI, DISKO, CNOO, VER, CATIN(256), CATOUT(256),
     *   LUNI, LUNO, BIF, EIF, BCHAN, ECHAN, IFQID, ISUB, JSUB,
     *   BUFFER(*), OBUFF(*), IRET
      DOUBLE PRECISION TB, TE
C
      INTEGER   MAXPPC
      PARAMETER (MAXPPC = 5)
C
      INCLUDE 'INCS:PUVD.INC'
      DOUBLE PRECISION PHASES(MAXCIF), ERRORS(MAXCIF)
      REAL      TIME
      INTEGER   IPPRNO, PPKOLS(MAXPPC), PPNUMV(MAXPPC), OKOLS(MAXPPC),
     *   ONUMV(MAXPPC), NPPROW, OPPRNO, SUBA, FREQID, IFA, IFB, CHA,
     *   CHB, NEWIF, NEWFRQ, JIF, JCHAN, INX, LNX, I, J, K, FOPEN,
     *   NUMFRQ, NUMIF, OVER, PPOL
      LOGICAL   REFMT
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
C-----------------------------------------------------------------------
      FOPEN = 1
C                                       Open PP file
      CALL PPINI ('READ', BUFFER, DISKI, CNOI, VER, CATIN, LUNI, IPPRNO,
     *   PPKOLS, PPNUMV, NUMIF, NUMFRQ, JIF, JCHAN, PPOL, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPEN INPUT TABLE'
         GO TO 990
         END IF
      FOPEN = 1
C                                       freq. [IFREQA,IFREQB]
      REFMT = .FALSE.
C                                       New PP table will cover
C                                       IF range [IFA,IFB].
      IFA = MAX (BIF, 1)
      IFA = MAX (IFA, JIF)
      IFB = MIN (NUMIF+JIF-1, EIF)
      NEWIF = IFB - IFA + 1
      IF (NEWIF.LE.0) THEN
         NEWIF = NUMIF
         IFA = JIF
         IFB = IFA + NUMIF - 1
         END IF
      CHA = MAX (1, BCHAN)
      CHA = MAX (CHA, JCHAN)
      CHB = MIN (NUMFRQ+JCHAN-1, ECHAN)
      NEWFRQ = CHB - CHA + 1
C                                       # rows in old table
      NPPROW = BUFFER(5)
C                                       Open up new PP table
      OVER = VER
      CALL PPINI ('WRIT', OBUFF, DISKO, CNOO, OVER, CATOUT, LUNO,
     *   OPPRNO, OKOLS, ONUMV, NEWIF, NEWFRQ, IFA-BIF+1,
     *   CHA-BCHAN+1, PPOL, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPEN OUTPUT TABLE'
         GO TO 990
         END IF
      FOPEN = 2
C                                       Loop and copy
      DO 300 I = 1,NPPROW
         CALL TABPP ('READ', BUFFER, IPPRNO, PPKOLS, PPNUMV, TIME,
     *      SUBA, FREQID, PHASES, ERRORS, IRET)
C                                       Check return code
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READ INPUT TABLE'
            GO TO 990
            END IF
C                                       Is this FQ ID selected ?
         IF ((IFQID.GT.0) .AND. (FREQID.GT.0) .AND. (IFQID.NE.FREQID))
     *      IRET = -10
         IF ((SUBA.GT.0) .AND. (ISUB.GT.0) .AND. (ISUB.NE.SUBA))
     *      IRET = -10
         IF ((I.GT.1) .AND. ((TIME.LT.TB) .OR. (TIME.GT.TE))) IRET = -10
C
         IF ((IRET.LT.-3) .OR. (NEWFRQ.LE.0)) THEN
            REFMT = .TRUE.
C                                       Copy this record
         ELSE
            DO 30 J = IFA,IFB
               INX = (J - IFA) * NEWFRQ
               LNX = (J - JIF) * NUMFRQ + (CHA - JCHAN)
               IF (INX.NE.LNX) REFMT = .TRUE.
C                                       Renumber IFs/FREQ's
               DO 20 K = 1,NEWFRQ
                  INX = INX + 1
                  LNX = LNX + 1
                  PHASES(INX) = PHASES(LNX)
                  ERRORS(INX) = ERRORS(LNX)
 20               CONTINUE
 30            CONTINUE
C                                       Set output FQ ID
            IF (IFQID.GT.0) FREQID = 1
            IF (JSUB.GE.0) SUBA = JSUB
C                                       Write output record.
            CALL TABPP ('WRIT', OBUFF, OPPRNO, OKOLS, ONUMV,
     *         TIME, SUBA, FREQID, PHASES, ERRORS, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'WRITE OUTPUT TABLE'
               GO TO 990
               END IF
            END IF
 300     CONTINUE
C                                       Close both tables
      IF ((MSGSUP.LT.31990) .OR. (MSGSUP.GE.32000)) THEN
         IF (REFMT) THEN
            WRITE (MSGTXT,1300) 'Reformatted PP', DISKI, CNOI, VER,
     *         DISKO, CNOO, OVER
         ELSE
            WRITE (MSGTXT,1300) 'Copied PP', DISKI, CNOI, VER, DISKO,
     *         CNOO, OVER
            END IF
         CALL MSGWRT (3)
         END IF
      IRET = MAX (0, IRET)
      GO TO 995
C                                       Error
 990  CALL MSGWRT (6)
C                                       close
 995  IF (FOPEN.GT.0) CALL TABIO ('CLOS', 0, IPPRNO, BUFFER, BUFFER, I)
      IF (FOPEN.EQ.2) CALL TABIO ('CLOS', 0, OPPRNO, OBUFF, OBUFF, J)
      IF (IRET.EQ.0) IRET = MAX (I, J)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('PPSEL: ERROR ',I3,1X,A)
 1300 FORMAT (A,' file from vol/cno/vers',I3,I5,I4,' to',I3,I5,I4)
      END
