LOCAL INCLUDE 'UVFXT.INC'
C                                       Local include for UVFXT
      INCLUDE 'INCS:ZPBUFSZ.INC'
      HOLLERITH XNAMEI(3), XCLAIN(2), XNAME2(3), XCLAS2(2),
     *   XNAMOU(3), XCLAOU(2)
      REAL      XSIN, XDISIN, XS2, XDISK2, XSOUT, XDISO, APARM(10),
     *   BPARM(10), BOX(4,10), BUFF1(UVBFSS), BUFF2(UVBFSS)
      INTEGER   SEQIN, SEQ2, SEQOUT, DISKIN, DISK2, DISKO, NUMHIS,
     *   JBUFSZ, ILOCWT, CATOLD(256), INCSI, INCFI, INCIFI, INCSO,
     *   INCFO, INCIFO, LRECI, LRECO, NRPRMI, NRPRMO
      LOGICAL   ISCOMP
      CHARACTER NAMEIN*12, CLAIN*6, NAME2*12, CLAS2*6,
     *   NAMOUT*12, CLAOUT*6, HISCRD(10)*64
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XNAME2, XCLAS2,
     *   XS2, XDISK2, XNAMOU, XCLAOU, XSOUT, XDISO, APARM, BPARM, BOX,
     *   SEQIN, SEQ2, SEQOUT, DISKIN, DISK2, DISKO, NUMHIS,
     *   ILOCWT, CATOLD, INCSI, INCFI, INCIFI, INCSO, INCFO, INCIFO,
     *   LRECI, LRECO, NRPRMI, NRPRMO, ISCOMP
      COMMON /CHARPM/ NAMEIN, CLAIN, NAME2, CLAS2, NAMOUT, CLAOUT,
     *   HISCRD
      COMMON /BUFRS/ BUFF1, BUFF2, JBUFSZ
C                                       End local include for UVFXT
LOCAL END
C=====================================================================72
      PROGRAM UVFXT
C     =============
C
C To correct GMRT visibilites with timestamps near the beginning of the
C integration period, instead of middle. For example, for 16.33 s
C integrations, move timestamps on all uv data points forward by 7.17 s,
C (i.e. to centre of 16.33 s from the centre of the initial 2 s
C integration), and rotate u,v,w coordinates forward.
C
C   APARM(1) time to advance (s)
C   APARM(2) number of u,v,w to print out for diagnostics
C
C Dave Green (dag@mrao.cam.ac.uk) -- MRAO -- 2006 June 2nd
C-----------------------------------------------------------------------
C Adapted from FUDGE.FOR, the AIPS template for reading in, modifying,
C and writing out a UV dataset.
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER  IRET
      INCLUDE 'UVFXT.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DCAT.INC'
C
      DATA PRGM /'UVFXT '/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL FUDGIN (PRGM, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Call routine that sends data
C                                       to the user routine.
      CALL SENDUV (IRET)
      IF (IRET.NE.0) GO TO 990
      CALL FUGHIS
C                                       Close down files, etc.
 990  CALL DIE (IRET, BUFF1)
C
 999  STOP
      END
C=====================================================================72
      SUBROUTINE FUDGIN (PRGN, JERR)
C     ==============================
      INTEGER   JERR
      CHARACTER PRGN*6
C
      CHARACTER  STAT*4, BLANK*6, PTYPE*2
      INTEGER   OLDCNO, IROUND, NPARM, IERR, INCX
      LOGICAL   T, F
      INCLUDE 'UVFXT.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DUVH.INC'
      DATA BLANK  /'      '/
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (T)
      CALL VHDRIN
      JBUFSZ = UVBFSS * 2
      NUMHIS = 0
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      JERR = 0
C                                       Get input parameters.
      NPARM = 81
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         RQUICK = .TRUE.
         JERR = 8
         IF (IERR.EQ.1) GO TO 999
            WRITE (MSGTXT,1000) IERR
            CALL MSGWRT (8)
         END IF
C                                       Restart AIPS
      IF (RQUICK) CALL RELPOP (JERR, BUFF1, IERR)
      IF (JERR.NE.0) GO TO 999
      JERR = 5
C                                       Crunch input parameters.
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      CALL H2CHR (12, 1, XNAME2, NAME2)
      CALL H2CHR (6, 1, XCLAS2, CLAS2)
      CALL H2CHR (12, 1, XNAMOU, NAMOUT)
      CALL H2CHR (6, 1, XCLAOU, CLAOUT)
      SEQIN = IROUND (XSIN)
      SEQOUT = IROUND (XSOUT)
      SEQ2 = IROUND (XS2)
      DISKIN = IROUND (XDISIN)
      DISK2 = IROUND (XDISK2)
      DISKO = IROUND (XDISO)
C
C                                       Get CATBLK from old file.
      OLDCNO = 1
      PTYPE = 'UV'
      CALL CATDIR ('SRCH', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN,
     *   PTYPE, NLUSER, STAT, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1030) IERR, NAMEIN, CLAIN, SEQIN, DISKIN,
     *      NLUSER
         GO TO 990
         END IF
      CALL CATIO ('READ', DISKIN, OLDCNO, CATBLK, 'REST', BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1040) IERR
         GO TO 990
         END IF
C                                       Save input CATBLK
      CALL COPY (256, CATBLK, CATOLD)
C                                       Compressed data?
      ISCOMP = CATBLK(KINAX).EQ.1
      IF (ISCOMP) THEN
C                                       Find weight and scale.
         CALL AXEFND (8, 'WEIGHT  ', CATBLK(KIPCN), CATH(KHPTP), ILOCWT,
     *      JERR)
         IF (JERR.NE.0) THEN
            MSGTXT = 'ERROR FINDING WEIGHT FOR COMPRESSED DATA'
            JERR = 9
            GO TO 990
            END IF
         END IF
C                                       Get uv header info.
      CALL UVPGET (JERR)
      IF (JERR.NE.0) GO TO 999
C                                       Save input file info
      INCX = CATBLK(KINAX)
      LRECI = LREC
      NRPRMI = NRPARM
      INCSI = INCS / INCX
      INCFI = INCF / INCX
      INCIFI = INCIF / INCX
C                                       Put new values in CATBLK.
      CALL MAKOUT (NAMEIN, CLAIN, SEQIN, BLANK, NAMOUT, CLAOUT, SEQOUT)
      CALL CHR2H (12, NAMOUT, KHIMNO, CATH(KHIMN))
      CALL CHR2H (6, CLAOUT, KHIMCO, CATH(KHIMC))
      CATBLK(KIIMS) = SEQOUT
C                                       Create output file.
      CCNO = 1
      FRW(NCFILE+1) = 3
      JERR = 4
      CALL UVCREA (DISKO, CCNO, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         IF (IERR.NE.2) THEN
            WRITE (MSGTXT,1050) IERR
            GO TO 990
            END IF
C                                       Only overwrite Input file
C                                       no destroy existing otherwise
         IF ((CCNO.NE.OLDCNO) .OR. (DISKO.NE.DISKIN)) THEN
            WRITE (MSGTXT,1060)
            GO TO 990
            END IF
C                                       Recover existing CATBLK
         FRW(NCFILE+1) = 2
         CALL CATIO ('READ', DISKO, CCNO, CATBLK, 'WRIT', BUFF1, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1065) IERR
            CALL MSGWRT (6)
            END IF
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKO
      FCNO(NCFILE) = CCNO
      FRW(NCFILE) = FRW(NCFILE) - 1
C                                       Save output file info
      CALL UVPGET (JERR)
      IF (JERR.NE.0) GO TO 999
      INCX = CATBLK(KINAX)
      LRECO = LREC
      NRPRMO = NRPARM
      INCSO = INCS / INCX
      INCFO = INCF / INCX
      INCIFO = INCIF / INCX
C                                        Put input file in READ
      PTYPE = 'UV'
      CALL CATDIR ('CSTA', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN,
     *   PTYPE, NLUSER, 'READ', BUFF1, IERR)
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = OLDCNO
      FRW(NCFILE) = 0
      JERR = 0
      SEQOUT = CATBLK(KIIMS)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('FUDGIN: ERROR',I3,' OBTAINING INPUT PARAMETERS')
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
     *   I3,' USID=',I5)
 1040 FORMAT ('ERROR',I3,' COPYING CATBLK ')
 1050 FORMAT ('ERROR',I3,' CREATING OUTPUT FILE')
 1060 FORMAT ('MAY OVERWRITE INPUT FILE ONLY.  QUITTING')
 1065 FORMAT ('FUDGIN: ERROR',I3,' UPDATING NEW CATBLK')
      END
C=====================================================================72
      SUBROUTINE SENDUV (IRET)
C     ========================
      INTEGER   IRET
C
      CHARACTER OFILE*48, IFILE*48
      INTEGER   INIO, IPTRI, IPTRO, LUNI, LUNO, INDI, INDO, ILENBU,
     *   KBIND, NIOUT, NIOLIM, IBIND, I, IA1, IA2, INCX, BO, VO,
     *   NUMVIS, XCOUNT, NCORI, NCORO, NCOPY
      LOGICAL   T, F
      INCLUDE 'UVFXT.INC'
      REAL      DUM, BASEN, CBUFF(UVBFSS), RESULT(UVBFSS)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA LUNI, LUNO /16, 17/
      DATA VO, BO /0, 1/
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
C                                       Dimension of complex axis
      INCX = CATBLK(KINAX)
      IF (ISCOMP) INCX = 3
C                                       Number of visibilities in input
C                                       and output files.
      NCORI = (LRECI - NRPRMI) / CATOLD(KINAX)
      NCORO = (LRECO - NRPRMO) / CATBLK(KINAX)
      NCOPY = LRECO - NRPRMO
C                                       Open and init for read
C                                       visibility file
      CALL ZPHFIL ('UV', DISKIN, FCNO(NCFILE), 1, IFILE, IRET)
      CALL ZOPEN (LUNI, INDI, DISKIN, IFILE, T, F, F, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1000) IRET
         GO TO 990
         END IF
C                                       Open vis file for write
      CALL ZPHFIL ('UV', DISKO, CCNO, 1, OFILE, IRET)
      CALL ZOPEN (LUNO, INDO, DISKO, OFILE, T, F, F, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1010) IRET
         GO TO 990
         END IF
C                                       Init vis file for write
      ILENBU = 0
      CALL UVINIT ('WRIT', LUNO, INDO, NVIS, VO, LRECO, ILENBU, JBUFSZ,
     *   BUFF2, BO, KBIND, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1020) IRET
         GO TO 990
         END IF
      IPTRO = KBIND
      NIOUT = 0
      NIOLIM = ILENBU
C                                       Init vis file for read.
      ILENBU = 0
      CALL UVINIT ('READ', LUNI, INDI, NVIS, VO, LRECI, ILENBU, JBUFSZ,
     *   BUFF1, BO, IBIND, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1030) IRET
         GO TO 990
         END IF
      NUMVIS = 0
      XCOUNT = 0
C                                       Loop
 100  CONTINUE
C                                       Read vis. record.
         CALL UVDISK ('READ', LUNI, INDI, BUFF1, INIO, IBIND, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1100) IRET
            GO TO 990
            END IF
         IPTRI = IBIND
C                                       Out of data?
         IF (INIO.LE.0) GO TO 200
C                                       Loop over buffer
         DO 190 I = 1,INIO
            BASEN = BUFF1(IPTRI+ILOCB)
            IA1 = BASEN / 256. + 0.1
            IA2 = BASEN - IA1*256. + 0.1
            NUMVIS = NUMVIS + 1
C                                      Call user routine.
            IF (ISCOMP) THEN
C                                       Compressed data.
               CALL ZUVXPN (NCORI, BUFF1(IPTRI+NRPRMI),
     *            BUFF1(IPTRI+ILOCWT), CBUFF)
               CALL DIDDLE (NUMVIS, BUFF1(IPTRI+ILOCU),
     *            BUFF1(IPTRI+ILOCV), BUFF1(IPTRI+ILOCW),
     *            BUFF1(IPTRI+ILOCT), IA1, IA2, CBUFF, BUFF1(IPTRI),
     *            INCX, RESULT, IRET)
            ELSE
C                                       Un compressed data
            CALL DIDDLE (NUMVIS, BUFF1(IPTRI+ILOCU),
     *         BUFF1(IPTRI+ILOCV), BUFF1(IPTRI+ILOCW),
     *         BUFF1(IPTRI+ILOCT), IA1, IA2, BUFF1(IPTRI+NRPRMI),
     *         BUFF1(IPTRI), INCX, RESULT, IRET)
            END IF
C                                       Branch on his return
            IF (IRET) 140, 130, 120
C                                       Error (fatal)
 120           WRITE (MSGTXT,1120) IRET
               GO TO 990
C                                       Copy to output.
 130        CONTINUE
               XCOUNT = XCOUNT + 1.0D0
               CALL RCOPY (NRPRMO, BUFF1(IPTRI), BUFF2(IPTRO))
               IF (ISCOMP) THEN
C                                       Compressed
                  CALL ZUVPAK (NCORO, RESULT, BUFF2(IPTRO+ILOCWT),
     *               BUFF2(IPTRO+NRPRMO))
               ELSE
                  CALL RCOPY (NCOPY, RESULT, BUFF2(IPTRO+NRPRMO))
                  END IF
               IPTRO = IPTRO + LRECO
               NIOUT = NIOUT + 1
C                                       OK, but no output please
 140        IPTRI = IPTRI + LRECI
C                                       Write vis record.
         IF (NIOUT.LT.NIOLIM) GO TO 190
            CALL UVDISK ('WRIT', LUNO, INDO, BUFF2, NIOLIM, KBIND, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1150) IRET
               GO TO 990
               END IF
            IPTRO = KBIND
            NIOUT = 0
 190        CONTINUE
C                                       Read next buffer.
         GO TO 100
C                                       Final call to DIDDLE.
 200     NUMVIS = -1
         CALL DIDDLE (NUMVIS, DUM, DUM, DUM, DUM, IA1, IA2, BUFF1,
     *      BUFF1, INCX, RESULT, IRET)
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1120) IRET
            GO TO 990
            END IF
C                                       Finish write
      NIOUT = - NIOUT
      CALL UVDISK ('FLSH', LUNO, INDO, BUFF2, NIOUT, KBIND, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1150) IRET
         GO TO 990
         END IF
C                                       Compress output file.
      NVIS = XCOUNT
      CALL UCMPRS (NVIS, DISKO, CCNO, LUNO, CATBLK, IRET)
C                                       Close files
      CALL ZCLOSE (LUNI, INDI, IRET)
      CALL ZCLOSE (LUNO, INDO, IRET)
      IRET = 0
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SENDUV: ERROR',I3,' OPEN-FOR-READ VIS FILE')
 1010 FORMAT ('SENDUV: ERROR',I3,' OPEN-FOR-WRITE VIS FILE')
 1020 FORMAT ('SENDUV: ERROR',I3,' INIT-FOR-WRITE VIS FILE')
 1030 FORMAT ('SENDUV: ERROR',I3,' INIT-FOR-READ VIS FILE')
 1100 FORMAT ('SENDUV: ERROR',I3,' READING VIS FILE')
 1120 FORMAT ('SENDUV: DIDDLE ERROR',I3)
 1150 FORMAT ('SENDUV: ERROR',I3,' WRITING VIS FILE')
      END
C=====================================================================72
      SUBROUTINE FUGHIS
C     =================
C FUGHIS copies and updates history file.  It also copies any tables.
C
      CHARACTER NOTTYP*2, HILINE*72, LABEL*8
      INTEGER   LUN1, LUN2, IERR, I, NONOT
      LOGICAL   T, F
      INCLUDE 'UVFXT.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHIS.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA LUN1, LUN2 /27,28/
      DATA T, F /.TRUE.,.FALSE./
      DATA NONOT, NOTTYP /0, '  '/
C-----------------------------------------------------------------------
C                                       Write History.
      CALL HIINIT (3)
C                                       Copy/open history file.
      CALL HISCOP (LUN1, LUN2, DISKIN, DISKO, FCNO(NCFILE),
     *   FCNO(NCFILE-1), CATBLK, BUFF1, BUFF2, IERR)
      IF (IERR.GT.2) THEN
         WRITE (MSGTXT,1000) IERR
         CALL MSGWRT (6)
         GO TO 200
         END IF
C                                       New history
      CALL HENCO1 (TSKNAM, NAMEIN, CLAIN, SEQIN, DISKIN, LUN2, BUFF2,
     *   IERR)
      IF (IERR.NE.0) GO TO 200
      CALL HENCOO (TSKNAM, NAMOUT, CLAOUT, SEQOUT, DISKO, LUN2, BUFF2,
     *   IERR)
      IF (IERR.NE.0) GO TO 200
C                                      Add any other history.
      IF (NUMHIS.LE.0) GO TO 200
         WRITE (LABEL,1010) TSKNAM
         DO 50 I = 1,NUMHIS
            HILINE = LABEL // HISCRD(I)
            CALL HIADD (LUN2, HILINE, BUFF2, IERR)
            IF (IERR.NE.0) GO TO 200
 50         CONTINUE
C                                       Close HI file
 200   CALL HICLOS (LUN2, T, BUFF2, IERR)
C                                        Copy tables
      CALL ALLTAB (NONOT, NOTTYP, LUN1, LUN2, DISKIN, DISKO,
     *   FCNO(2), FCNO(1), CATBLK, BUFF1, BUFF2, IERR)
      IF (IERR.GT.2) THEN
         WRITE (MSGTXT,1200)
         CALL MSGWRT (6)
         END IF
C                                        Update CATBLK.
      CALL CATIO ('UPDT', DISKO, FCNO(NCFILE-1), CATBLK, 'REST',
     *   BUFF1, IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('FUGHIS: ERROR',I3,' COPY/OPEN HISTORY FILE')
 1010 FORMAT (A6,' /')
 1200 FORMAT ('FUGHIS: ERROR COPYING TABLES')
      END
C=====================================================================72
      SUBROUTINE DIDDLE (NUMVIS, U, V, W, T, IA1, IA2, VIS, RPARM,
     *   INCX, RESULT, IRET)
C-----------------------------------------------------------------------
C   This allows the user to modify a UV data base.  Visibilities are
C   sent one at a time and when returned are written on the output file
C   if so specified.
C
C   Up to 10 history entries can be written by using WRITE to
C   record up to 64 characters per entry into array HISCRD.  Format:
C          WRITE (HISCRD(entry #),format) history information
C   The history is written after the last call to DIDDLE.
C
C   Messages can be written to the monitor/logfile by WRITEing
C   the message (up to 80 char) into array MSGTXT in COMMON /MSGCOM/
C   and then issuing a call:
C            CALL MSGWRT (priority #)
C
C   Unit 1 is the line printer
C
C   If IRET > 0, then the output file will be destroyed iff
C   it was created in the current execution.
C
C   If the size of the vis record is to be changed, appropriate
C   modifications should be made to CATBLK in FUDGIN before the call
C   to UVCREA.  Pointers and increments are passed in the common to
C   interprete the structure of the input and output data records.
C   See the precursor comments for UVPGET for a description.
C
C   After all data has been processed a final call will be made to
C   DIDDLE with NUMVIS = -1.  This is to allow for the completion of
C   pending operations, i.e. preparation of HIstory cards.
C
C   LUN's 16 and 17 are open and not available to DIDDLE.
C
C   The current contents of CATBLK will be written back to the
C   catalog after the last call to DIDDLE.
C
C   Inputs:
C      NUMVIS  I    Visibility number, -1 => final call, no data
C                   passed but allows any operations to be completed.
C      U       R    U in wavelengths
C      V       R    V in wavelengths
C      W       R    W in wavelengths
C      T       R    Time in days since 0 IAT on the first day for
C                   which there is data, the julian day corresponding
C                   to this day can be obtained in D   form by:
C                   CALL JULDAY (CATH(KHDOB),XDAY) where XDAY will
C                   be the Julian day number.
C      IA1     I    First antenna number
C      IA2     I    Second antenna number
C      RPARM   R(*) Random parameter array which includes U,V,W etc
C                   but also any other random parameters.
C      VIS     R(INCX,*)  Visibilities in order real, imaginary, weight
C                   (Jy, Jy, unitless).  Weight <= 0 => flagged.
C                   NOTE: INCX may be any value .GE. 2
C   Inputs from COMMON:
C      NAME2      C*12    Name of the aux. file
C      CLAS2      C*6     Class of the aux. file.
C      SEQ2       I       Sequence number of the aux. file.
C      DISK2      I       Volumn number of the aux. file.
C      APARM(10)  R(10)   User array.
C      BPARM(10)  R(10)   User array.
C      BOX(4,10)  R(4,10) User array.
C      RA         D       Right ascension (1950) of phase center. (deg)
C      DEC        D       Declination (1950) of phase center. (deg)
C      FREQ       D       Frequency of observation (Hz)
C      NRPARM     I       # random parameters.
C      NCOR       I       # correlators
C      CATBLK     I(256)  Catalog header record. See Going Aips for
C                         details.
C      LRECI      I    Input file record length
C      NRPRMI     I    Input number of random parameters.
C      INCSI      I    Input Stokes' increment in vis.
C      INCFI      I    Input frequency increment in vis.
C      INCIFI     I    Input IF increment in vis.
C      LRECO      I    Output file record length
C      NRPRMO     I    Output number of random parameters.
C      INCSO      I    Output Stokes' increment in vis.
C      INCFO      I    Output frequency increment in vis.
C      INCIFO     I    Output IF increment in vis.
C   Output:
C      U          R    U in wavelengths
C      V          R    V in wavelengths
C      W          R    W in wavelengths
C      T          R    Time in same units as input.
C      RPARM      R    Modified random parameter array.
C      RESULT  R(INCX,*) Output visibilities selected in frequency.
C      IRET       I    Return code  -1 => don't write
C                                    0 => OK
C                                   >0 => error, terminate.
C
C   Output in COMMON:
C      NUMHIS    I         # history entries (max. 10)
C      HISCRD    C(NUMHIS) History records
C      CATBLK    I         Catalog header block
C-----------------------------------------------------------------------
      INTEGER   NUMVIS, IA1, IA2, INCX, IRET
      REAL      U, V, W, T, VIS(INCX,*), RPARM(*), RESULT(INCX,*)
C
      INTEGER   JIF, JF, JS, NIF, NF, NS, INDEXO, INDEXI, I
      REAL      WFAC
      INCLUDE 'UVFXT.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
C-----------------------------------------------------------------------
C (DAG) added for correction of T,U,V,W...
C
      INTEGER J,K,N,M
      REAL   OLDT
      DOUBLE PRECISION INUV(3),OUTUV(3)
      DOUBLE PRECISION XYZ2U(3,3),UVW2X(3,3),ROTZ(3,3),ZROT
      DOUBLE PRECISION ONE(3,3),TWO(3,3)
      DOUBLE PRECISION RRA,RDEC,D2RAD
      PARAMETER (D2RAD=1.745329251994329576923691D-2)
C-----------------------------------------------------------------------
      IRET = 0
      IF (NUMVIS.GT.0) THEN
C
         NS = 1
         NIF = 1
         NF = 1
         IF (JLOCS.GE.0) NS = CATBLK(KINAX+JLOCS)
         IF (JLOCIF.GE.0) NIF = CATBLK(KINAX+JLOCIF)
         IF (JLOCF.GE.0) NF = CATBLK(KINAX+JLOCF)
         WFAC = 1.0
         IF (APARM(1).NE.0.0) WFAC = 1.0 / (APARM(1) * APARM(1))
C----------------------------------------------------------------
C (DAG) add APARM(1) to input T...
C       and rotate U,V,W by APARM(1) s...
C----------------------------------------------------------------
C
C Calculate U,V,W to X,Y,Z and X,Y,Z to U,V,W matrices (using reference
C epoch RA and DEC, converted deg to rad; this is not strictly correct
C due to precession)
C
         RRA=RA*D2RAD
         RDEC=DEC*D2RAD
C
         UVW2X(1,1)=-SIN(RRA)
         UVW2X(1,2)=-COS(RRA)*SIN(RDEC)
         UVW2X(1,3)=+COS(RRA)*COS(RDEC)
         UVW2X(2,1)=+COS(RRA)
         UVW2X(2,2)=-SIN(RRA)*SIN(RDEC)
         UVW2X(2,3)=+SIN(RRA)*COS(RDEC)
         UVW2X(3,1)=0.0D0
         UVW2X(3,2)=+COS(RDEC)
         UVW2X(3,3)=+SIN(RDEC)
C
         XYZ2U(1,1)=-SIN(RRA)
         XYZ2U(1,2)=+COS(RRA)
         XYZ2U(1,3)=0.0D0
         XYZ2U(2,1)=-COS(RRA)*SIN(RDEC)
         XYZ2U(2,2)=-SIN(RRA)*SIN(RDEC)
         XYZ2U(2,3)=+COS(RDEC)
         XYZ2U(3,1)=+COS(RRA)*COS(RDEC)
         XYZ2U(3,2)=+SIN(RRA)*COS(RDEC)
         XYZ2U(3,3)=+SIN(RDEC)
C
C Rotation about Z axis...
C
         ZROT=(APARM(1)*15.0D0/3600.0D0)*D2RAD
         ROTZ(1,1)=+COS(ZROT)
         ROTZ(1,2)=-SIN(ZROT)
         ROTZ(1,3)=0.0D0
         ROTZ(2,1)=+SIN(ZROT)
         ROTZ(2,2)=+COS(ZROT)
         ROTZ(3,3)=0.0D0
         ROTZ(3,1)=0.0D0
         ROTZ(3,2)=0.0D0
         ROTZ(3,3)=1.0D0
C
         IF(NUMVIS.EQ.1)THEN
           WRITE(MSGTXT,1001)RA,DEC
           CALL MSGWRT(8)
           WRITE(MSGTXT,1002)ZROT/D2RAD
           CALL MSGWRT(8)
           WRITE(MSGTXT,1003)
           CALL MSGWRT(8)
           WRITE(MSGTXT,1004)(ROTZ(1,I),I=1,3)
           CALL MSGWRT(8)
           WRITE(MSGTXT,1005)(ROTZ(2,I),I=1,3)
           CALL MSGWRT(8)
           WRITE(MSGTXT,1006)(ROTZ(3,I),I=1,3)
           CALL MSGWRT(8)
         ENDIF
C
C Calculate final matrix...
C
         DO 103 I=1,3
           DO 102 J=1,3
             ONE(I,J)=0.0D0
             DO 101 K=1,3
               ONE(I,J)=ONE(I,J)+ROTZ(I,K)*UVW2X(K,J)
  101        CONTINUE
  102      CONTINUE
  103    CONTINUE
C
         DO 113 I=1,3
           DO 112 J=1,3
             TWO(I,J)=0.0D0
             DO 111 K=1,3
               TWO(I,J)=TWO(I,J)+XYZ2U(I,K)*ONE(K,J)
  111        CONTINUE
  112      CONTINUE
  113    CONTINUE
C
         IF(NUMVIS.EQ.1)THEN
           WRITE(MSGTXT,1007)
           CALL MSGWRT(8)
           WRITE(MSGTXT,1004)(TWO(1,I),I=1,3)
           CALL MSGWRT(8)
           WRITE(MSGTXT,1005)(TWO(2,I),I=1,3)
           CALL MSGWRT(8)
           WRITE(MSGTXT,1006)(TWO(3,I),I=1,3)
           CALL MSGWRT(8)
         ENDIF
C
C Convert U,V,W...
C
         INUV(1)=U
         INUV(2)=V
         INUV(3)=W
C
         DO 122 N=1,3
           OUTUV(N)=0.0D0
           DO 121 M=1,3
             OUTUV(N)=OUTUV(N)+TWO(N,M)*INUV(M)
  121      CONTINUE
  122    CONTINUE
C
         U=OUTUV(1)
         V=OUTUV(2)
         W=OUTUV(3)
C
C Adjust T...
C
         OLDT=T
         T=T+APARM(1)/86400.0D0
C
         IF(NUMVIS.LT.APARM(2))THEN
           WRITE(MSGTXT,1008)OLDT,T
           CALL MSGWRT(8)
           WRITE(MSGTXT,1009)INUV
           CALL MSGWRT(8)
           WRITE(MSGTXT,1010)OUTUV
           CALL MSGWRT(8)
         ENDIF
C
C----------------------------------------------------------------
         DO 40 JIF = 1,NIF
            DO 30 JF = 1,NF
               DO 20 JS = 1,NS
                  INDEXI = (JIF-1) * INCIFI + (JF-1) * INCFI +
     *               (JS-1) * INCSI + 1
                  INDEXO = (JIF-1) * INCIFO + (JF-1) * INCFO +
     *               (JS-1) * INCSO + 1
                      DO 10 I = 1,INCX
C----------------------------------------------------------------
C (DAG) simply copy visibility data...
C
                        RESULT(I,INDEXO)=VIS(I,INDEXI)
C----------------------------------------------------------------
 10                  CONTINUE
 20               CONTINUE
 30            CONTINUE
 40         CONTINUE
C                                       last call - no vis
      ELSE
C
C (DAG): write time correction to history file...
C
         NUMHIS = 1
         WRITE (HISCRD(1),1100) TSKNAM, APARM(1)
C
C
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
C   FORMAT STATEMENTS GO HERE

 1001 FORMAT ('RA, DEC used........: ',2F16.10)
 1002 FORMAT ('Rotation angle (deg): ',F10.8)
 1003 FORMAT ('Rotation matrix:')
 1004 FORMAT (3X,F12.9,2(2X,1PE10.3))
 1005 FORMAT (3X,2X,1PE10.3,0PF12.9,2X,1PE10.3)
 1006 FORMAT (3X,2(2X,1PE10.3),0PF12.9)
 1007 FORMAT ('Final matrix:')
 1008 FORMAT ('Time (old,new)......: ',2F10.8)
 1009 FORMAT ('  old U,V,W: ',3F11.4)
 1010 FORMAT ('  new U,V,W: ',3F11.4)
C
 1100 FORMAT (A6,'APARM(1) =',F9.4,'  / time correction (s) for U,V,W')
      END
C=====================================================================72
