LOCAL INCLUDE 'DT2PD.INC'
C                                       Local include for TAPPE
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   SEQI, OUTVER, CNOI, DISKI, MAXVER, NROW, NIF, NCH, NANT
      HOLLERITH XNAMEI(3), XCLASI(2), XINFIL(12)
      CHARACTER NAMEI*12, CLASSI*6, TTYPE*2, INFILE*48
      REAL      XSEQI, XDISKI, XFQID, XSUBA, BADD(10)
      COMMON /INPARM/ XNAMEI, XCLASI, XSEQI, XDISKI, XFQID, XSUBA,
     *   XINFIL, BADD
      COMMON /OTHER/ SEQI, OUTVER, CNOI, DISKI, MAXVER, NROW, NIF, NCH,
     *   NANT
      COMMON /CHRCOM/ NAMEI, CLASSI, TTYPE, INFILE
LOCAL END
      PROGRAM DT2PD
C-----------------------------------------------------------------------
C! Converts D term text file to PD extension table
C# EXT-util
C-----------------------------------------------------------------------
C;  Copyright (C) 2021-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   Task DT2PD converts D term text file to PD table
C   Inputs:
C      AIPS Adverb   Prg. Name          Description
C      INNAME         NAMEI         File name.
C      INCLASS        CLASI         File class.
C      INSEQ          SEQI          File sequence number.
C      INDISK         DISKI         Disk volume on which file resides.
C      OUTVER         OUTVER        Input file input version number
C      FREQID         FRQSEL        FQ ID number     0 -> 1
C      SUBARRAY       ISUBA         Subarray number  0 -> 1
C      INFILE         INFILE        text file
C      BADDISK        IBADD(10)     Disks to avoid for scratch.
C-----------------------------------------------------------------------
      INCLUDE 'INCS:ZPBUFSZ.INC'
      INTEGER   IRET, SCRBUF(512)
      LONGINT   PDTERM
      REAL      DTERMS(2)
      INCLUDE 'DT2PD.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
C-----------------------------------------------------------------------
C                                       Set file info
      CALL DT2PDI (SCRBUF, PDTERM, DTERMS, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Do operation
      CALL DT2PDD (NIF, NCH, NANT, DTERMS(1+PDTERM), IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Write end message
 990  CALL DIE (IRET, SCRBUF)
C
 999  STOP
      END
      SUBROUTINE DT2PDI (SCRBUF, PDTERM, DTERMS, IRET)
C-----------------------------------------------------------------------
C   DT2PDI performs initialization for DT2PD and reads the D term text
C   file
C   Output:
C      SCRBUF   I(*)     Scratch
C      IRET     I        Error code: 0 -> okay
C-----------------------------------------------------------------------
      INTEGER   IRET, SCRBUF(*)
      LONGINT   PDTERM
      REAL      DTERMS(*)
C
      CHARACTER PRGM*6, PTYPE*2, STAT*4
      INTEGER   NPARM, IROUND, I, NWORDS
      INCLUDE 'DT2PD.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DANS.INC'
      DATA PRGM /'DT2PD'/
C-----------------------------------------------------------------------
C                                       Init I/O, parameters
      NPARM = 31
      CALL SETUP (PRGM, NPARM, XNAMEI, SCRBUF, IRET)
      IF (IRET.NE.0) GO TO 990
      SEQI = IROUND (XSEQI)
      DISKI = IROUND (XDISKI)
      SUBARR = XSUBA + 0.1
      FRQSEL = XFQID + 0.1
      IF (SUBARR.LE.0) SUBARR = 1
      IF (FRQSEL.LE.0) FRQSEL = 1
      CALL H2CHR (12, 1, XNAMEI, NAMEI)
      CALL H2CHR (6, 1, XCLASI, CLASSI)
      CALL H2CHR (48, 1, XINFIL, INFILE)
      TTYPE = 'PD'
C                                       Open file and get CATBLK.
C                                       Get CATBLK from old file.
      CNOI = 1
      PTYPE = '  '
      CALL CATDIR ('SRCH', DISKI, CNOI, NAMEI, CLASSI, SEQI, PTYPE,
     *   NLUSER, STAT, SCRBUF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1005) IRET, NAMEI, CLASSI, SEQI, DISKI, NLUSER
         GO TO 990
         END IF
      CALL CATIO ('READ', DISKI, CNOI, CATBLK, 'REST', SCRBUF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1010) IRET
         GO TO 990
         END IF
C                                       BADDISK
      DO 10 I = 1,10
         IBAD(I) = IROUND (BADD(I))
 10      CONTINUE
C                                       find version numbers
      CALL FXHDEX (CATBLK)
      CALL FNDEXT (TTYPE, CATBLK, MAXVER)
      OUTVER = MAXVER + 1
      CALL UVPGET (IRET)
      IF (IRET.NE.0) THEN
         MSGTXT = 'ERROR GETTING HEADER PARAMETERS'
         GO TO 990
         END IF
C                                       get Dterms
      CALL COPY (256, CATBLK, CATUV)
      IUDISK = DISKI
      IUCNO = CNOI
      CALL GETANT (IUDISK, IUCNO, SUBARR, CATUV, SCRBUF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'READ ANTNENNA INFORMATION'
         GO TO 990
         END IF
      NCH = CATBLK(KINAX+JLOCF)
      NIF = 1
      IF (JLOCIF.GE.0) NIF = CATBLK(KINAX+JLOCIF)
      NANT = NSTNS
      NWORDS = 2 * NCH * NIF * 2 * NANT + 2048
      NWORDS = (NWORDS - 1) / 1024 + 1
      CALL ZMEMRY ('GET ', 'DT2PD', NWORDS, DTERMS, PDTERM, IRET)
      IF (IRET.NE.0) THEN
         MSGTXT = 'FAILED TO GET REQUESTED MEMORY FOR PD FILE'
         GO TO 990
         END IF
      KLOCFY = JLOCF
      CALL GDTERM (NIF, NCH, NANT, INFILE, DTERMS(1+PDTERM), IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'GETTING D TERMS FROM TEXT FILE'
         GO TO 990
         END IF
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('DT2PDI: ERROR',I4,' ON ',A)
 1005 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
     *   I3,' USID=',I5)
 1010 FORMAT ('ERROR',I3,' READ HEADER, SETTING STATUS')
      END
      SUBROUTINE DT2PDD (NI, NF, NA, DTERMS, IRET)
C-----------------------------------------------------------------------
C   DT2PDD writes the PD table
C   Input:
C      NIF      I      Number IFs
C      NCH      I      Number spectral channels
C      NANT     I      Number antennas
C      DTERMS   R(*)   Dterms (2,nch,nif,2,nant)
C   Output:
C      IRET     I      Error code - 0 okay
C-----------------------------------------------------------------------
      INTEGER   NI, NF, NA, IRET
      REAL      DTERMS (2,NF,NI,2,*)
C
      INTEGER   MAXPDC
      PARAMETER (MAXPDC = 9)
      INCLUDE 'INCS:PUVD.INC'
C
      INCLUDE 'DT2PD.INC'
      INTEGER   PDBUFF(512), LUN, IPDRNO, PDKOLS(MAXPDC),
     *   PDNUMV(MAXPDC), ISUB, IFQ, REFA, IROW, NUMP
      REAL      PHDIFF(MAXCIF)
      CHARACTER POLTYP*8
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DSEL.INC'
C-----------------------------------------------------------------------
C                                       open PD table
      LUN = 32
      NUMP = 2
      POLTYP = 'APPROX'
      CALL PDINI ('WRIT', PDBUFF, DISKI, CNOI, OUTVER, CATBLK, LUN,
     *   IPDRNO, PDKOLS, PDNUMV, NANT, NUMP, NIF, NCH, POLTYP, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CREATING, OPENING PD TABLE'
         GO TO 980
         END IF
      ISUB = 0
      IFQ = 0
      REFA = 0
      CALL RFILL (MAXCIF, 0.0, PHDIFF)
C                                       write PD table
      DO 100 IROW = 1,NANT
         IPDRNO = IROW
         CALL TABPD ('WRIT', PDBUFF, IPDRNO, PDKOLS, PDNUMV, NIF,
     *      NCH, NUMP, IROW, ISUB, IFQ, REFA, PHDIFF,
     *      DTERMS(1,1,1,1,IROW), IRET)
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITE PD TABLE'
            GO TO 980
            END IF
 100     CONTINUE
C                                       done!
      CALL TABPD ('CLOS', PDBUFF, IPDRNO, PDKOLS, PDNUMV, NIF,
     *   NCH, NUMP, NANT, ISUB, IFQ, REFA, PHDIFF, DTERMS, IRET)
      IRET = 0
      GO TO 999
C
 980  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('DT2PDD: ERROR',I4,' ON ',A)
      END
