LOCAL INCLUDE 'PPAPP.INC'
      INCLUDE 'INCS:PUVD.INC'
C
      CHARACTER NAMEIN*12, CLAIN*6, NAMIN2*12, CLAIN2*6
      HOLLERITH XNAMEI(3), XCLAIN(2), XNAME2(3), XCLAI2(2)
      REAL      XSIN, XDISIN, XSIN2, XDISI2, XFQID, XSUBA, XINVER,
     *   XBPVER, XPDVER
      INTEGER   DISKIN, SEQIN, CNOIN, DISKI2, SEQIN2, CNOIN2,
     *   BUFFER(512), SUBARR, FRQSEL, BCHAN, BIF, INVERS, BPVER, PDVER,
     *   BPVOUT, PDVOUT, CPVER, CPVOUT, PPOL
C
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XNAME2, XCLAI2,
     *   XSIN2, XDISI2, XFQID, XSUBA, XINVER, XBPVER, XPDVER
      COMMON /CHPARM/ NAMEIN, CLAIN, NAMIN2, CLAIN2
      COMMON /INFOLS/ DISKIN, SEQIN, CNOIN, DISKI2, SEQIN2, CNOIN2,
     *   BUFFER, SUBARR, FRQSEL, BCHAN, BIF, INVERS, BPVER, PDVER,
     *   BPVOUT, PDVOUT, CPVER, CPVOUT, PPOL
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
LOCAL END
      PROGRAM PPAPP
C-----------------------------------------------------------------------
C! PPAPP applies the Right - Left polarization phase difference
C# Calibration UV VLA VLB polarization
C-----------------------------------------------------------------------
C;  Copyright (C) 2019, 2021-2022, 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   Task PPAPP applies the R-L phase difference spectrum to a 2nd UV
C   data set's BP table
C   Inputs:
C      AIPS Adverb   Prg. Name          Description
C      INNAME         NAME          File name to be corrected
C      INCLASS        CLASS         File class to be corrected
C      INSEQ          SEQ           File sequence number.
C      INDISK         DISK          Disk volume on which file resides.
C      IN2NAME        NAME          File name with PP table.
C      IN2CLASS       CLASS         File class
C      IN2SEQ         SEQ           File sequence number.
C      IN2DISK        DISK          Disk volume on which file resides.
C      FREQID         FRQSEL        Frequency ID number
C      SUBARRAY       SUBARR        Subarray
C      INVERS         INVERS        PP version
C      BPVER                        BP table to correct
C-----------------------------------------------------------------------
      INCLUDE 'PPAPP.INC'
      CHARACTER PRGM*6
      INTEGER   IRET, NCH, NIF
      DOUBLE PRECISION PHASES(MAXCIF)
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      DATA PRGM /'PPAPP '/
C-----------------------------------------------------------------------
C                                       Get input parameters
C                                       get correction
      CALL PPAPIN (PRGM, NCH, NIF, PHASES, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       apply correction
      CALL PPAPPL (NCH, NIF, PHASES, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       History file ??
      CALL PPAPHI (NCH, NIF)
C                                       Close down files, etc.
 990  CALL DIE (IRET, BUFFER)
C
 999  STOP
      END
      SUBROUTINE PPAPIN (PRGN, NCH, NIF, PHASES, IRET)
C-----------------------------------------------------------------------
C   RLDIN gets input parameters for PPAPP
C   Inputs:
C      PRGN    C*6       Program name (2 chars/word)
C   Output:
C      NCH     I         Number channels in phases
C      NIF     I         Number IFs in phases
C      PHASES  D(*)      Phase correction in degrees
C      IRET    I         Error code: 0 => ok
C                           5 => catalog troubles
C                           8 => can't start
C   Commons:
C      /INPARM/ all input adverbs in order given by INPUTS file
C      /MAPHDR/ INNAME file catalog header to be corrected
C   See prologue comments in PPAPP for more details.
C-----------------------------------------------------------------------
      CHARACTER PRGN*6
      INTEGER   NCH, NIF, IRET
      DOUBLE PRECISION PHASES(*)
C
      CHARACTER STAT*4, STATUS*4, UTYPE*2
      INTEGER   IROUND, NPARM, IERR
      LOGICAL   F
      INCLUDE 'PPAPP.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      DATA F /.FALSE./
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      IRET = 0
C                                       Get input parameters.
      NPARM = 19
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, BUFFER, IERR)
      IF (IERR.NE.0) THEN
         RQUICK = .FALSE.
         IRET = 8
         IF (IERR.EQ.1) GO TO 999
            WRITE (MSGTXT,1000) IERR
            CALL MSGWRT (8)
         END IF
C                                       Restart AIPS
      IF (RQUICK) CALL RELPOP (IRET, BUFFER, IERR)
      IF (IRET.NE.0) GO TO 999
C                                       Hollerith -> char.
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      CALL H2CHR (12, 1, XNAME2, NAMIN2)
      CALL H2CHR (6, 1, XCLAI2, CLAIN2)
C                                       Crunch input parameters.
      SEQIN = IROUND (XSIN)
      DISKIN = IROUND (XDISIN)
      SEQIN2 = IROUND (XSIN2)
      DISKI2 = IROUND (XDISI2)
      INVERS = IROUND (XINVER)
      BPVER = IROUND (XBPVER)
      PDVER = IROUND (XPDVER)
      FRQSEL = IROUND (XFQID)
      SUBARR = IROUND (XSUBA)
      SUBARR = MAX (1, SUBARR)
      FRQSEL = MAX (1, FRQSEL)
C                                       Get CATBLK of PP file
      CNOIN2 = 1
      UTYPE = 'UV'
      CALL CATDIR ('SRCH', DISKI2, CNOIN2, NAMIN2, CLAIN2, SEQIN2,
     *   UTYPE, NLUSER, STAT, BUFFER, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1030) IERR, NAMIN2, CLAIN2, SEQIN2, DISKI2,
     *      NLUSER
         GO TO 990
         END IF
      STATUS = 'REST'
      CALL CATIO ('READ', DISKI2, CNOIN2, CATBLK, STATUS, BUFFER, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READING HEADER 2'
         GO TO 990
         END IF
C                                       Get uv header info.
      CALL UVPGET (IRET)
      IF (IRET.NE.0) GO TO 999
C                                       get the correction
      CALL PPAPPG (NCH, NIF, PHASES, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'GETTING PP DATA'
         GO TO 990
         END IF
C                                       Get CATBLK file to correct.
      CNOIN = 1
      UTYPE = 'UV'
      CALL CATDIR ('SRCH', DISKIN, CNOIN, NAMEIN, CLAIN, SEQIN, UTYPE,
     *   NLUSER, STAT, BUFFER, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1030) IERR, NAMEIN, CLAIN, SEQIN, DISKIN,
     *      NLUSER
         GO TO 990
         END IF
C                                       writing the bP file
      STATUS = 'WRIT'
      CALL CATIO ('READ', DISKIN, CNOIN, CATBLK, STATUS, BUFFER, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READING HEADER FILE TO CORRECT'
         GO TO 990
         END IF
C                                       Mark in CFILES
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = CNOIN
      FRW(NCFILE) = 1
C                                       Mark 2nd in CFILES
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKI2
      FCNO(NCFILE) = CNOIN2
      FRW(NCFILE) = 0
C                                       Get uv header info.
      CALL UVPGET (IRET)
      IF (IRET.NE.0) GO TO 999
C                                       check polarization
      IF (PPOL.EQ.1) THEN
         IF ((ICOR0.GE.-4) .AND. (ICOR0.LE.-1)) GO TO 999
         MSGTXT = 'PP FILE POLARIZATION DOES NOT MATCH'
         IRET = 11
      ELSE IF (PPOL.EQ.2) THEN
         IF ((ICOR0.GE.-8) .AND. (ICOR0.LE.-5)) GO TO 999
         MSGTXT = 'PP FILE POLARIZATION DOES NOT MATCH'
         IRET = 11
      ELSE
         MSGTXT = 'PP FILE POLARIZATION UNKNOWN, CONTINUING'
         CALL MSGWRT (6)
         GO TO 999
         END IF
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('PPAPIN: ERROR',I3,' ON ',A)
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
     *   I3,' USID=',I5)
      END
      SUBROUTINE PPAPPG (NCH, NIF, PHASES, IRET)
C-----------------------------------------------------------------------
C   PPAPG finds the correction data from file 2
C   spectrum
C   Output:
C      NCH      I      Number channels in PHASES
C      NIF      I      Number IFs in PHASES
C      PHASES   d(*)   Phase corrections in degrees
C      IRET
C-----------------------------------------------------------------------
      INTEGER   NCH, NIF, IRET
      DOUBLE PRECISION PHASES(*)
C
      INCLUDE 'PPAPP.INC'
      INTEGER   VER, LUN, LUNTMP, PPBUFF(512), IPPRNO, PPKOLS(5),
     *   PPNUMV(5), IROW, SUBAPP, FRQAPP
      REAL      TIME
      DOUBLE PRECISION ERRORS(MAXCIF)
      INCLUDE 'INCS:DUVH.INC'
C-----------------------------------------------------------------------
      VER = INVERS
      LUN = LUNTMP(1)
      CALL PPINI ('READ', PPBUFF, DISKI2, CNOIN2, VER, CATBLK, LUN,
     *   IPPRNO, PPKOLS, PPNUMV, NIF, NCH, BIF, BCHAN, PPOL, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING PHASE DIFF TABLE'
         GO TO 990
         END IF
      INVERS = VER
      IPPRNO = 1
      CALL TABPP ('READ', PPBUFF, IPPRNO, PPKOLS, PPNUMV, TIME, SUBAPP,
     *   FRQAPP, PHASES, ERRORS, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1000) IRET, 'READING PHASE DIFFERENCE TABLE'
         GO TO 990
         END IF
C                                       Data selection
      IF ((SUBAPP.GT.0) .AND. (SUBARR.GT.0) .AND. (SUBARR.NE.SUBAPP))
     *   GO TO 110
      IF ((FRQAPP.GT.0) .AND. (FRQSEL.GT.0) .AND. (FRQSEL.NE.FRQAPP))
     *   GO TO 110
C                                       subarray and freqid match
      IF (IRET.EQ.0) GO TO 200
 110  IRET = 10
      MSGTXT = 'MATCHING PP DATA NOT FOUND'
      GO TO 990
C                                       success
 200  CALL TABPP ('CLOS', PPBUFF, IPPRNO, PPKOLS, PPNUMV, TIME, SUBAPP,
     *   FRQAPP, PHASES, ERRORS, IROW)
      IRET = 0
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('PPFILE: ERROR',I4,' ON ',A)
      END
      SUBROUTINE PPAPPL (NCH, NIF, PHASES, IRET)
C-----------------------------------------------------------------------
C   PPAPPL applies the phases found from IN2NAME to a BP table belonging
C   to INNAME.
C   Inputs
C      NCH      I      Number spectral channels
C      NIF      I      Number ifs in PHASES
C      PHASES   D(*)   Phase corrections to apply (deg)
C   Output
C      IRET     I      Error code
C-----------------------------------------------------------------------
      INTEGER   NCH, NIF, IRET
      DOUBLE PRECISION PHASES(NCH,NIF)
C
      INCLUDE 'PPAPP.INC'
      INTEGER   NUMTA, LUN1, LUN2, TABUF1(512), TABUF2(512), IBPRNO,
     *   BPKOLS(MAXBPC), BPNUMV(MAXBPC), NUMANT, NUMPOL, NUMIF, NUMFRQ,
     *   LCHAN, NUMSHF, NREC, IREC, SOURID, SUBA, ANT, FREQID, LI, LC,
     *   REFANT(2), CPNUMV(6), CPKOLS(6), ICPRNO, PDKOLS(9), PDNUMV(9),
     *   IPDRNO, JNX, VER, PDKOLO(9), PDNUMO(9)
      DOUBLE PRECISION TIME, CHSHFT(MAXIF)
      REAL      CF, SF, LOWSHF, DELSHF, INTERV, BANDW, WEIGHT(2*MAXIF),
     *   BNDPAS(2,MAXCIF), XT, YT, VFLUX(4,MAXCIF), PHDIFF(MAXCIF)
      CHARACTER LBPTYP*8, SOURSE*16, POLTYP*8
      INCLUDE 'INCS:PSTD.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DANS.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DDCH.INC'
      EQUIVALENCE (BNDPAS, VFLUX)
      DATA LUN1, LUN2 /79, 78/
C-----------------------------------------------------------------------
      CALL FNDEXT ('BP', CATBLK, NUMTA)
      IF ((BPVER.LE.0) .OR. (BPVER.GT.NUMTA)) BPVER = NUMTA
      BPVOUT = NUMTA + 1
C                                       modify existing BP table
      IF (BPVER.GT.0) THEN
         MSGTXT = 'Updating existing BP table, writing new one'
         CALL MSGWRT (5)
         CALL BPINI ('READ', TABUF2, DISKIN, CNOIN, BPVER, CATBLK, LUN2,
     *      IBPRNO, BPKOLS, BPNUMV, NUMANT, NUMPOL, NUMIF, NUMFRQ,
     *      LCHAN, NUMSHF, LOWSHF, DELSHF, LBPTYP, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'OPEN OLD BP TABLE'
            GO TO 990
            END IF
         CALL BPINI ('WRIT', TABUF1, DISKIN, CNOIN, BPVOUT, CATBLK,
     *      LUN1, IBPRNO, BPKOLS, BPNUMV, NUMANT, NUMPOL, NUMIF,
     *      NUMFRQ, LCHAN, NUMSHF, LOWSHF, DELSHF, LBPTYP, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'OPEN OLD BP TABLE'
            GO TO 990
            END IF
         NREC = TABUF2(5)
         DO 50 IREC = 1,NREC
            IBPRNO = IREC
            CALL TABBP ('READ', TABUF2, IBPRNO, BPKOLS, BPNUMV, NUMIF,
     *         NUMFRQ, NUMPOL, TIME, INTERV, SOURID, SUBA, ANT, BANDW,
     *         CHSHFT, FREQID, REFANT, WEIGHT, BNDPAS, IRET)
            IF (IRET.GT.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READ OLD BP TABLE'
               GO TO 990
               END IF
            IF (((SUBA.LE.0) .OR. (SUBARR.LE.0) .OR. (SUBA.EQ.SUBARR))
     *         .AND. ((FREQID.LE.0) .OR. (FRQSEL.LE.0) .OR.
     *         (FREQID.EQ.FRQSEL)) .AND. (IRET.GT.-2)) THEN
               DO 30 LI = 1,NIF
                  JNX = (LI + BIF - 2) * NUMFRQ + BCHAN + NUMFRQ*NUMIF
                  DO 20 LC = 1,NCH
                     XT = BNDPAS(1,JNX)
                     YT = BNDPAS(2,JNX)
                     IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK) .AND.
     *                  (PHASES(LC,LI).NE.DBLANK)) THEN
                        CF = COS (PHASES(LC,LI)*DG2RAD)
                        SF = SIN (PHASES(LC,LI)*DG2RAD)
                        BNDPAS(1,JNX) = XT*CF - YT*SF
                        BNDPAS(2,JNX) = XT*SF + YT*CF
                        END IF
                     JNX = JNX + 1
 20                  CONTINUE
 30               CONTINUE
               END IF
            IBPRNO = IREC
            CALL TABBP ('WRIT', TABUF1, IBPRNO, BPKOLS, BPNUMV, NUMIF,
     *         NUMFRQ, NUMPOL, TIME, INTERV, SOURID, SUBA, ANT, BANDW,
     *         CHSHFT, FREQID, REFANT, WEIGHT, BNDPAS, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'WRITE NEW BP TABLE'
               GO TO 990
               END IF
 50         CONTINUE
         CALL TABIO ('CLOS', 0, IBPRNO, TABUF2, TABUF2, LI)
         CALL TABIO ('CLOS', 0, IBPRNO, TABUF1, TABUF1, LI)
         WRITE (MSGTXT,1050) 'BP', BPVER, BPVOUT
         CALL MSGWRT (5)
C                                       complain there is none
      ELSE
         MSGTXT = 'NO BP TABLE TO BE CORRECTED'
         CALL MSGWRT (8)
         END IF
C                                       CP file if any
      CALL FNDEXT ('PD', CATBLK, NUMTA)
      IF ((PDVER.LE.0) .OR. (PDVER.GT.NUMTA)) PDVER = NUMTA
      PDVOUT = NUMTA + 1
      CALL FNDEXT ('CP', CATBLK, NUMTA)
      CPVER = MAX (1, MIN (NUMTA, PDVER)) + 1
 200  CPVER = CPVER - 1
      IF (VER.GT.0) THEN
         CALL CPINI ('READ', TABUF2, DISKIN, CNOIN, CPVER, CATBLK, LUN2,
     *      ICPRNO, CPKOLS, CPNUMV, NUMIF, NUMFRQ, FREQID, IRET)
         IF (((FREQID.GT.0) .AND.(FRQSEL.GT.0) .AND. (FRQSEL.NE.FREQID))
     *      .OR. (IRET.NE.0)) THEN
            CALL TABIO ('CLOS', 0, ICPRNO, TABUF2, TABUF2, LI)
            GO TO 200
            END IF
         MSGTXT = 'Updating existing CP table, writing new one'
         CALL MSGWRT (5)
         CPVOUT = NUMTA + 1
         CALL CPINI ('WRIT', TABUF1, DISKIN, CNOIN, CPVOUT, CATBLK,
     *      LUN1, ICPRNO, CPKOLS, CPNUMV, NUMIF, NUMFRQ, FREQID, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'OPEN NEW CP TABLE'
            GO TO 990
            END IF
         NREC = TABUF2(5)
         DO 250 IREC = 1,NREC
            ICPRNO = IREC
            CALL TABCP ('READ', TABUF2, ICPRNO, CPKOLS, CPNUMV, NUMIF,
     *         NUMFRQ, SOURSE, SOURID, VFLUX, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READ OLD CP TABLE'
               GO TO 990
               END IF
            DO 230 LI = 1,NIF
               JNX = (LI + BIF - 2) * NUMFRQ + BCHAN
               DO 220 LC = 1,NCH
                  IF (PHASES(LC,LI).NE.DBLANK) THEN
                     CF = COS (PHASES(LC,LI)*DG2RAD)
                     SF = SIN (PHASES(LC,LI)*DG2RAD)
                     XT = VFLUX(2,JNX)
                     YT = VFLUX(3,JNX)
                     VFLUX(2,JNX) = XT*CF - YT*SF
                     VFLUX(3,JNX) = XT*SF + YT*CF
                     END IF
                  JNX = JNX + 1
 220              CONTINUE
 230           CONTINUE
            ICPRNO = IREC
            CALL TABCP ('WRIT', TABUF1, ICPRNO, CPKOLS, CPNUMV, NUMIF,
     *         NUMFRQ, SOURSE, SOURID, VFLUX, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'WRITE NEW CP TABLE'
               GO TO 990
               END IF
 250        CONTINUE
         CALL TABIO ('CLOS', 0, ICPRNO, TABUF2, TABUF2, LI)
         CALL TABIO ('CLOS', 0, ICPRNO, TABUF1, TABUF1, LI)
         WRITE (MSGTXT,1050) 'CP', CPVER, CPVOUT
         CALL MSGWRT (5)
         END IF
C                                       PD update
      CALL FNDEXT ('PD', CATBLK, NUMTA)
      IF (NUMTA.LE.0) GO TO 999
      MSGTXT = 'Updating existing PD table, writing new one'
      CALL MSGWRT (5)
      IF ((PDVER.LT.1) .OR. (PDVER.GT.NUMTA)) PDVER = NUMTA
      CALL PDINI ('READ', TABUF2, DISKIN, CNOIN, PDVER, CATBLK, LUN2,
     *   IPDRNO, PDKOLS, PDNUMV, NUMANT, NUMPOL, NUMIF, NUMFRQ,
     *   POLTYP, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPEN OLD PD TABLE FOR READ'
         GO TO 990
         END IF
      PDVOUT = NUMTA + 1
      CALL PDINI ('WRIT', TABUF1, DISKIN, CNOIN, PDVOUT, CATBLK, LUN1,
     *   IPDRNO, PDKOLO, PDNUMO, NUMANT, NUMPOL, NUMIF, NUMFRQ,
     *   POLTYP, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'RE-OPEN OLD PD TABLE FOR WRITE'
         GO TO 990
         END IF
      NREC = TABUF2(5)
      DO 360 IREC = 1,NREC
         IPDRNO = IREC
         CALL TABPD ('READ', TABUF2, IPDRNO, PDKOLS, PDNUMV, NUMIF,
     *      NUMFRQ, NUMPOL, ANT, SUBA, FREQID, REFANT, PHDIFF, BNDPAS,
     *      IRET)
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READ PD TABLE'
            GO TO 990
            END IF
         IF (((SUBA.LE.0) .OR. (SUBARR.LE.0) .OR. (SUBA.EQ.SUBARR))
     *      .AND. (IRET.GT.-3)) THEN
C                                       Just add to phase difference
            IF (POLTYP.EQ.'ORI-ELP') THEN
               DO 320 LI = 1,NIF
                  JNX = (LI + BIF - 2) * NUMFRQ + BCHAN
                  DO 310 LC = 1,NCH
                     IF (PHASES(LC,LI).NE.DBLANK) PHDIFF(JNX) =
     *                  PHDIFF(JNX) + PHASES(LC,LI) * DG2RAD
                     JNX = JNX + 1
 310                 CONTINUE
 320              CONTINUE
C                                       correct D terms
            ELSE
               DO 350 LI = 1,NIF
                  JNX = (LI + BIF - 2) * NUMFRQ + BCHAN
                  DO 330 LC = 1,NCH
                     XT = BNDPAS(1,JNX)
                     YT = BNDPAS(2,JNX)
                     IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK) .AND.
     *                  (PHASES(LC,LI).NE.DBLANK)) THEN
                        CF = COS (PHASES(LC,LI)*DG2RAD)
                        SF = SIN (PHASES(LC,LI)*DG2RAD)
                        BNDPAS(1,JNX) = XT*CF - YT*SF
                        BNDPAS(2,JNX) = XT*SF + YT*CF
                        END IF
                     JNX = JNX + 1
 330                 CONTINUE
C                                       2nd polarization opposite
                  JNX = (LI + BIF - 2) * NUMFRQ + BCHAN +
     *               NUMFRQ * NUMIF
                  DO 340 LC = 1,NCH
                     XT = BNDPAS(1,JNX)
                     YT = BNDPAS(2,JNX)
                     IF ((XT.NE.FBLANK) .AND. (YT.NE.FBLANK) .AND.
     *                  (PHASES(LC,LI).NE.DBLANK)) THEN
                        CF = COS (PHASES(LC,LI)*DG2RAD)
                        SF = SIN (PHASES(LC,LI)*DG2RAD)
                        BNDPAS(1,JNX) = XT*CF + YT*SF
                        BNDPAS(2,JNX) = YT*CF - XT*SF
                        END IF
                     JNX = JNX + 1
 340                 CONTINUE
 350              CONTINUE
               END IF
            END IF
         IPDRNO = IREC
         CALL TABPD ('WRIT', TABUF1, IPDRNO, PDKOLO, PDNUMO, NUMIF,
     *      NUMFRQ, NUMPOL, ANT, SUBA, FREQID, REFANT, PHDIFF, BNDPAS,
     *      IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'RE-WRITE PD TABLE'
            GO TO 990
            END IF
 360     CONTINUE
      CALL TABIO ('CLOS', 0, IPDRNO, TABUF1, TABUF1, LI)
      CALL TABIO ('CLOS', 0, IPDRNO, TABUF2, TABUF2, LI)
      WRITE (MSGTXT,1050) 'PD', PDVER, PDVOUT
      CALL MSGWRT (5)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('PPAPPL: ERROR',I4,' ON ',A)
 1050 FORMAT ('Updated ',A,' version',I4, ' to new version',I4)
      END
      SUBROUTINE PPAPHI (NCH, NIF)
C-----------------------------------------------------------------------
C   writes HI records when solution is appled to data
C-----------------------------------------------------------------------
      INTEGER   NCH, NIF
C
      INCLUDE 'PPAPP.INC'
      INTEGER   LUN, LUNTMP, TIME(3), DATE(3), IERR, BUFF2(256)
      CHARACTER CTIME(2)*12, HILINE*72
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
C                                       Write History.
      LUN = LUNTMP (1)
      CALL HIINIT (3)
C                                       Open old history
      CALL HIOPEN (LUN, DISKIN, CNOIN, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 200
C                                       Task message
      CALL ZDATE (DATE)
      CALL ZTIME (TIME)
      CALL TIMDAT (TIME, DATE, CTIME(2), CTIME)
      WRITE (HILINE,1000) TSKNAM, RLSNAM, CTIME
      CALL HIADD (LUN, HILINE, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 200
C                                       file with PP table
      CALL HENCO2 (TSKNAM, NAMIN2, CLAIN2, SEQIN2, DISKI2, LUN, BUFF2,
     *   IERR)
      IF (IERR.NE.0) GO TO 200
      WRITE (HILINE,1010) TSKNAM, FRQSEL
      CALL HIADD (LUN, HILINE, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 200
      WRITE (HILINE,1011) TSKNAM, SUBARR
      CALL HIADD (LUN, HILINE, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 200
      WRITE (HILINE,1012) TSKNAM, INVERS
      CALL HIADD (LUN, HILINE, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 200
      WRITE (HILINE,1013) TSKNAM, BIF, NIF
      CALL HIADD (LUN, HILINE, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 200
      WRITE (HILINE,1014) TSKNAM, BCHAN, NCH
      CALL HIADD (LUN, HILINE, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 200
      WRITE (HILINE,1015) TSKNAM, 'BP', BPVER, 'BP'
      CALL HIADD (LUN, HILINE, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 200
      WRITE (HILINE,1016) TSKNAM, 'BP', BPVOUT, 'BP'
      CALL HIADD (LUN, HILINE, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 200
      IF ((PDVER.GT.0) .AND. (PDVOUT.GT.0)) THEN
         WRITE (HILINE,1015) TSKNAM, 'PD', PDVER, 'PD'
         CALL HIADD (LUN, HILINE, BUFF2, IERR)
         IF (IERR.NE.0) GO TO 200
         WRITE (HILINE,1016) TSKNAM, 'PD', PDVOUT, 'PD'
         CALL HIADD (LUN, HILINE, BUFF2, IERR)
         IF (IERR.NE.0) GO TO 200
         END IF
      IF ((CPVER.GT.0) .AND. (CPVOUT.GT.0)) THEN
         WRITE (HILINE,1015) TSKNAM, 'CP', CPVER, 'CP'
         CALL HIADD (LUN, HILINE, BUFF2, IERR)
         IF (IERR.NE.0) GO TO 200
         WRITE (HILINE,1016) TSKNAM, 'CP', CPVOUT, 'CP'
         CALL HIADD (LUN, HILINE, BUFF2, IERR)
         IF (IERR.NE.0) GO TO 200
         END IF
C                                       Close HI file
 200  CALL HICLOS (LUN, .TRUE., BUFF2, IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT (A6,'RELEASE =''',A7,' ''  /********* Start ',
     *   A12,2X,A8)
 1010 FORMAT (A6,'FREQID   =',I4,'   / Frequency ID number')
 1011 FORMAT (A6,'SUBARRAY =',I4,'   /Subarray number')
 1012 FORMAT (A6,'INVERS   =',I4,'   / PP file version')
 1013 FORMAT (A6,'BIF =',I3,' NIF =',I3,'  /PP file begin, # IFs')
 1014 FORMAT (A6,'BCHAN=',I5,' NCHAN =',I5,
     *   '  /PP file spectral channels')
 1015 FORMAT (A6,A2,'VER    =',I4,'   / ',A2,' table corrected')
 1016 FORMAT (A6,A2,'VOUT   =',I4,'   / ',A2,' new table')
      END
