      SUBROUTINE ALGSTB (APCORE, IFIELD, SCRGRD, DISKI, CNOSCI, DISKO,
     *   CNOSCO, CHANEL, NCHAN, CATR, JBUFSZ, BUFF1, BUFF2, BUFF3, IRET)
C-----------------------------------------------------------------------
C! Interpolates model visibility from a grid and subtracts from uv data.
C# UV Modeling AP-appl
C-----------------------------------------------------------------------
C;  Copyright (C) 1995, 1997, 1999-2001, 2003, 2006, 2008-2010, 2012,
C;  Copyright (C) 2014-2015, 2018-2019, 2022-2023
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   ALGSTB interpolates model visibility data from a grid and subtracts
C   it from the observed visibilities.  UV data may be in any sort order
C   If AP memory is large enough to hold all gridded model, ALGSTB runs
C   much faster.
C   Inputs:
C      IFIELD   I       Field number.
C      SCRGRD   I       /CFILES/ file number for grid file.
C      DISKI    I       Input file disk number for catalogd files,
C                       .LE. 0 => /CFILES/ scratch file.
C      CNOSCI   I       Input file catalog slot number or /CFILES/
C                       scratch file number.
C      DISKO    I       Output file disk number for catalogd files,
C                       .LE. 0 => /CFILES/ scratch file.
C      CNOSCO   I       Output file catalog slot number or /CFILES/
C                       scratch file number.
C      CHANEL   I       First channel number.
C      NCHAN    I       Number of channels to process.
C      CATR     R(256)  UV data catalog header record.
C      JBUFSZ   I       Size in bytes of buffers. Dimension of
C                       BUFF1,2,3  must be at least 4096 words.
C   Inputs: from commons
C      LREC     I       length in words of vis record.
C      NVIS     I       number of vis records
C      FREQG    D(*)    Frequencies of IF and channels in same order
C                       as occurs in the data.
C      FACGRD   R(2)    (1) Value to multiply Clean fluxes
C                       (2) > 0 normal, 0 model with flagging,
C                           < 0 model weights all -> 1.0
C   Output:
C      BUFF1    R(*)    Working buffer
C      BUFF2    R(*)    Working buffer
C      BUFF3    R(*)    Working buffer
C      IRET     I       Return code, 0 => ok, otherwise not.
C   The AP grid file must contain the gridded UV model for this pass.
C   The UV points are read in and the model is subtracted from them.
C-----------------------------------------------------------------------
      DOUBLE PRECISION APCORE(*)
      INTEGER   IFIELD, SCRGRD, DISKI, CNOSCI, DISKO, CNOSCO, CHANEL,
     *   NCHAN, JBUFSZ, IRET
      REAL       BUFF1(*), BUFF2(*), BUFF3(*)
C
      INTEGER   CJTBSZ, MINT, TPBFMX
C                                       CJTBSZ = conj. table size
C                                       MINT   = Interpol. support size.
C                                       TPBFMX = Temp Buffer size
      PARAMETER (CJTBSZ=4000, MINT=11, TPBFMX=20000)
      INTEGER   VISRED, NIOUT, IDISK, ICNOSC, INDS(3), NX, NY, ILENBU,
     *   IUMIN, IUMAX, USTOP, USTRT, IU, U, IVIS, ICONJ, I, NIO, LENBU,
     *   FLIST(22), CNJPTR(CJTBSZ), M, MO2, LOCHAN, NCHGRD, MSGINC,
     *   NROGRD, MXROGD, KAP, CX, VIS, UV, LLREC, MM, WORK, INDEX, LROW,
     *   FLAG, VISOFF, NS, APSIZE, MAXREC, CNT, IFACT, ITEMP1, ITEMP2,
     *   INPTR, OUTPTR, JNPTR, KNPTR, LNPTR, NPOINT, JNCS, EXCESS,
     *   LOGRID, JNCF, LRPARM, ROWSIZ, IDATA, MAXU, RPASS, NRPASS,
     *   NROWS, NXO2, EROW, ERRCNT, IXTEMP(3), MSGSAV, HIC, LOC, J, K,
     *   IUFMAX, IULO, IUHI, LSTRT, LSTOP, NROW, END1, LUMAX, LUMIN,
     *   NEED, UCOUNT, UTARG, II, JJ, KK
      LOGICAL   ALLROW, ONCE, DOROT, DOFLAG
      REAL      XTEMP(7), FACT2(4), CATR(256), ZSCLV, ZSCLW, ZSCLU,
     *   SCALU, SCALV, FFRAC, FRSTU, UUMAX, VVMAX, UIN, VIN, UMIN, UMAX,
     *   TEMPBF(TPBFMX), UUU, UMAT(3,3), PMAT(3,3), DDX(3),
     *   RMAT(3,3), DMAT(3,3), RULO, RUHI, UVWS(3,TPBFMX), RXTEMP(3)
      DOUBLE PRECISION GFACT, MAXFRQ, XRA, XDEC, MINFRQ, MXFACT, MNFACT
      CHARACTER CSTOK*1
      EQUIVALENCE (IXTEMP, RXTEMP)
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DGDS.INC'
      INCLUDE 'INCS:DMPR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DSCD.INC'
      INCLUDE 'INCS:DAPM.INC'
      SAVE ONCE, ERRCNT
      DATA ONCE /.FALSE./, ERRCNT /0/
C-----------------------------------------------------------------------
      IRET = 0
      DOFLAG = ERRCNT.EQ.0
C                                       Rotate?
      DOROT = (ABS (SSROT).GT.1.0E-10) .OR. (ABS (CCROT-1.0).GT.1.0E-4)
      APSIZE = PSAPNW * 1024
      NX = ABS (FLDSZ(1,IFIELD) * OSFX) + 0.1
      NY = ABS (FLDSZ(2,IFIELD) * OSFY) + 0.1
      ZSCLU = SCLUG(IFIELD) * OSFX
      ZSCLV = SCLVG(IFIELD) * OSFY
      ZSCLW = SCLWG(IFIELD)
      NXO2 = NX / 2
C                                       Set AP Pointers; IFACT=cellsiz
      IFACT = 2
      LROW = NY
      ROWSIZ = IFACT * LROW
C                                       Set up for APIO
      CALL FILL (22, 0, FLIST)
      FLIST(1) = LUNS(4)
      FLIST(2) = SCRGRD
      FLIST(5) = ROWSIZ
      FLIST(6) = NXO2 + 1
      FLIST(9) = 1
      FLIST(11) = FLIST(5)
      FLIST(12) = 1
      FLIST(13) = JBUFSZ
C                                       Get un-compressed UV increments
      IF (DATDIV) CALL PRMUPD
      IF (COMPDT) THEN
         ITEMP1 = LREC
         ITEMP2 = NRPARM
         LREC = SCLREC
         NRPARM = SCRPRM
         END IF
C                                       Correlator scaling table.
      MSGSAV = MSGSUP
      MSGSUP = 31900
      CALL GETCTL (CATR, FACT2, IRET)
      MSGSUP = MSGSAV
      IF (IRET.NE.0) GO TO 999
      CSTOK = MSGTXT(1:1)
      NS = NSTOK
      CALL UVINCS (INCS, INCF, INCIF, NRPARM, LREC, JNCS, JNCF,
     *   LRPARM, LLREC)
C                                       Set I/O visibility count
      ILENBU = ((MIN(JBUFSZ,TPBFMX*2) - 2 * NBPS) / 2) / LLREC - 2
      ILENBU = MAX (ILENBU, 1)
      LENBU  = ILENBU
      IDISK = DISKI
      ICNOSC = CNOSCI
C                                       Grab ap
      M = MINT
      MAXREC = 256
      NEED = MAXREC*(LLREC+4) + 200*M + 30 + NCHAN + (NXO2+M)*ROWSIZ
      NEED = NEED / 1024 + 2
      CALL QINIT (APCORE, NEED, 0, KAP)
      IF ((KAP.EQ.0) .OR. (PSAPNW.EQ.0)) THEN
         IRET = 8
         MSGTXT = 'ALGSTB UNABLE TO GET DESIRED MEMORY'
         CALL MSGWRT (8)
         GO TO 999
         END IF
      APSIZE = 1024 * PSAPNW
C                                       Calc extra ap for interp func
      MAXREC = MIN (2048, (APSIZE/30)/(LLREC+4)) + 5
      MAXREC = MAX (15, MAXREC)
      EXCESS = APSIZE - MAXREC*(LLREC+4) - 200*MINT - 30 - NCHAN
C                                       How big can interp func be?
      M = EXCESS / (ROWSIZ + 200)
C                                       M between mint/2 and mint
      M = MAX (MINT/2, MIN (M, MINT))
C                                       M must be odd, round down
      M = (2 * ((M-1)/2)) + 1
      MO2 = M / 2
C                                       Extra ap goes to extra rows
      EXCESS = APSIZE - MAXREC*(LLREC+4) - 200*M - 30 - NCHAN
      MXROGD = (EXCESS/ROWSIZ) - 1
      IF (MXROGD.LT.M) THEN
         IRET = 8
         MSGTXT = 'ALGSTB UNABLE TO GET ENOUGH MEMORY'
         CALL MSGWRT (8)
         GO TO 999
         END IF
C                                       Grid no more than all rows
      MXROGD = MIN (MXROGD, NXO2+M)
C                                       Set ap pointers
      LOGRID = APSIZE - ((MXROGD+1) * ROWSIZ) - 1
      CX = LOGRID - (200 * (M+1)) - 1
      MM = M
      FLAG = 1
      IF ((KSTOK.EQ.3) .AND. (ICOR0.LE.0)) FLAG = -1
C                                       model only
      IF (FACGRD(2).LE.0.0) THEN
         UUU = 0.0
         FACT2(1) = FACT2(1) * FACGRD(1)
         FACT2(2) = FACT2(2) * FACGRD(1)
         FACT2(3) = FACT2(3) * FACGRD(1)
         FACT2(4) = FACT2(4) * FACGRD(1)
C                                       Scale FACT2 by -FACGRD
C                                       data - model
      ELSE
         UUU = 1.0
         FACT2(1) = -FACT2(1) * FACGRD(1)
         FACT2(2) = -FACT2(2) * FACGRD(1)
         FACT2(3) = -FACT2(3) * FACGRD(1)
         FACT2(4) = -FACT2(4) * FACGRD(1)
         END IF
C                                       If fft scale by 0.5
      IF (DOFFT) THEN
         FACT2(1) = FACT2(1) * 0.5
         FACT2(2) = FACT2(2) * 0.5
         FACT2(3) = FACT2(3) * 0.5
         FACT2(4) = FACT2(4) * 0.5
         END IF
C                                       Prepare for bs loop
      DDX(1) = DXCG(IFIELD)
      DDX(2) = DYCG(IFIELD)
      DDX(3) = DZCG(IFIELD)
      CALL XYSHFT (RA, DEC, XSHIFT(IFIELD), YSHIFT(IFIELD), MAPROT,
     *   XRA, XDEC)
      IF (DO3DIM) THEN
         CALL PRJMAT (RA, DEC, UVROT, XRA, XDEC, MAPROT, UMAT, PMAT)
         CALL RFILL (9, 0.0, RMAT)
         CALL RFILL (9, 0.0, DMAT)
         RMAT(1,1) = CCROT
         RMAT(1,2) = SSROT
         RMAT(2,1) = -SSROT
         RMAT(2,2) = CCROT
         RMAT(3,3) = 1
         DO 20 I = 1,3
            DO 15 J = 1,3
               DO 10 K = 1,3
                  DMAT(I,J) = DMAT(I,J) + PMAT(I,K) * RMAT(K,J)
 10               CONTINUE
 15            CONTINUE
 20         CONTINUE
         CALL PRJMUL (2, DDX, DMAT, DDX)
      ELSE
         CALL P2DMAT (RA, DEC, UVROT, XRA, XDEC, MAPROT, UMAT, PMAT)
         END IF
C                                       self defense
      DO 30 I = 1,3
         DO 25 J = 1,3
            IF (UMATS(I,J,1).NE.0.0) GO TO 35
 25         CONTINUE
 30      CONTINUE
      MSGTXT = 'ALGSTB: ROTATION MATRIX UMATS IS 0, FIELD 1'
      CALL MSGWRT (6)
      MSGTXT = 'ALGSTB: THIS IS A SERIOUS ERROR SINCE MFIELD > 1'
      IF (MFIELD.GT.1) CALL MSGWRT (7)
      CALL RCOPY (9, UMAT, UMATS)
C                                       Get maximum u
 35   CALL UVPROT ('READ', IDISK, ICNOSC, LUNS(2), INDS(2), MFIELD,
     *   UMATS, CCROT, SSROT, NVIS, LREC, ILENBU, JBUFSZ, BUFF1, NIO,
     *   INPTR, FRSTU, DISKO, CNOSCO, IRET)
      IF (IRET.NE.0) GO TO 999
      CALL ZCLOSE (LUNS(2), INDS(2), IRET)
C                                       Find Max Frequency
      MAXFRQ = FREQG(CHANEL)
      MINFRQ = FREQG(CHANEL)
      DO 40 I = 2,NCHAN
         BUFF3(I-1) = 0.0
         IF (FREQG(CHANEL+I-1).GT.0.0D0) THEN
            MAXFRQ = MAX (MAXFRQ, FREQG(CHANEL+I-1))
            MINFRQ = MIN (MINFRQ, FREQG(CHANEL+I-1))
            BUFF3(I-1) = FREQG(CHANEL+I-1)/FREQG(CHANEL+I-2) - 1.0D0
            END IF
 40      CONTINUE
C                                       Scale by Max Freq. to cells
      MAXU   = ABS (FRSTU * MAXFRQ / FREQ * ZSCLU) + 0.99
C                                       Limit u to max that will fit
      MAXU   = MIN (MAXU, NXO2)
C                                       Calc number needed
      NROGRD = MAXU + M
C                                       Do all rows fit in ap?
      ALLROW = MXROGD.GE.NROGRD
C                                       Number of rows in a pass
      NROWS  = MIN (NROGRD, MXROGD)
C                                       If all rows fit, 1 pass
      IF (ALLROW) THEN
         NRPASS = 1
         WRITE (MSGTXT,1040) NROWS, MXROGD
C                                       Else, how many row passes?
      ELSE
         NRPASS = (MAXU + 1)/(NROWS - M + 1)
         IF (NRPASS*(NROWS-M+1).LT.(MAXU+1)) NRPASS = NRPASS + 1
         WRITE (MSGTXT,1041) NROWS, NROGRD
         END IF
      IF (.NOT.ONCE) CALL MSGWRT (2)
      VISRED = 0
      LOCHAN = 1
      NCHGRD = NCHAN
      LOC = CHANEL + LOCHAN - 1
      HIC = LOC + NCHGRD - 1
      IF (MFIELD.LE.1) THEN
         WRITE (MSGTXT,1045) CSTOK, LOC, HIC
      ELSE
         WRITE (MSGTXT,1046) IFIELD, CSTOK, LOC, HIC
         END IF
      CALL MSGWRT (2)
C                                       Determine where data starts.
      FLIST(10) = MIN (MAXU+MO2+1, NXO2+1)
C                                       Get frequency scaling factors.
      FFRAC = (MINFRQ / FREQ) - 1.0D0
      GFACT = 1.0D0 / ((1.0D0 + FFRAC) * ZSCLU)
      MNFACT = ZSCLU * MINFRQ / FREQ
      MXFACT = ZSCLU * MAXFRQ / FREQ
      FFRAC = (MAXFRQ / FREQ) - 1.0D0
      SCALU = FFRAC * ZSCLU + ZSCLU
      SCALV = FFRAC * ZSCLV + ZSCLV
C                                       Set limits on u,v - do not get
C                                       Within mint/2+1 of edge.
      UUMAX = ABS (((NX/2) - (MINT/2+1)) / SCALU)
      VVMAX = ABS (((NY/2) - (MINT/2+1)) / SCALV)
C                                       Setup ap griding constants
      FFRAC = (FREQG(LOCHAN+CHANEL-1) / FREQ) - 1.0D0
      XTEMP(1) = (ZSCLU + FFRAC * ZSCLU)
      XTEMP(2) = (ZSCLV + FFRAC * ZSCLV)
      XTEMP(3) = DDX(1) / ZSCLU
      XTEMP(4) = DDX(2) / ZSCLV
      XTEMP(5) = DDX(3) + DDX(3)*FFRAC
      XTEMP(6) = 0.0
      XTEMP(7) = 0.0
      IXTEMP(1) = 0
      IXTEMP(2) = LOGRID
      IXTEMP(3) = CX
      CALL QPUT (APCORE, XTEMP, 0, 7, 2)
      CALL QPUT (APCORE, RXTEMP, 7, 3, 1)
C                                       Correlator scaling table.
      CALL QPUT (APCORE, FACT2, 16, NS, 2)
      RXTEMP(1) = 1.0
      CALL QPUT (APCORE, RXTEMP, 15, 1, 2)
C                                       Frequency scaling table.
      BUFF3(NCHGRD) = 0.0
      CALL QPUT (APCORE, BUFF3, 20, NCHGRD, 2)
C                                       Set interpolation tables
      CALL INTPFN (APCORE, CX, M, BUFF3, JBUFSZ, IRET)
      IF (IRET.NE.0) GO TO 999
C                                       Save space for 4 word work array.
      MAXREC = (CX - 20 - NS - NCHGRD) / (LLREC+4) - 5
C                                       No more recs than conj table.
      IF (MAXREC.GT.CJTBSZ) MAXREC = CJTBSZ
C                                       More ap pointers.
      WORK = 20 + NCHGRD
      UV = WORK + 4 + (MAXREC * 4)
C                                       Correction for stokes.
      VISOFF = LRPARM + ((CHANEL-1) + (LOCHAN-1))*JNCF + (VOFF / INCS) *
     *   JNCS
      VIS = UV + VISOFF
C                                       Set location of data inp ap
      IDATA = UV
      IUMAX = MAXU
      RPASS = 0
      LUMAX = 10 * MAXU
      LUMIN = LUMAX + 1
C                                       Row pass loop point
 50   RPASS = RPASS + 1
         IUMIN = MAX (IUMAX - (NROWS-M), 0)
         IUFMAX = -1000
         LSTRT = USTRT
         LSTOP = USTOP
C                                       Load ALL rows
         USTRT = MAX (IUMIN - MO2, 0)
         USTOP = MIN (IUMAX+MO2, NXO2)
C                                       move ones previously loaded
         IF ((RPASS.GT.1) .AND. (USTOP.GE.LSTRT)) THEN
C                                       wait for AP to FINISH
            CALL QWAIT
C                                       must move from top to bottom
            NROW = USTOP - LSTRT + 1
            DO 60 I = 1,NROW
               END1 = LOGRID + ((NROW-I)*ROWSIZ)
               EROW = LOGRID + ((USTOP-(IUMIN-MO2))*ROWSIZ)
               CALL QVMOV (APCORE, END1, 1, EROW, 1, ROWSIZ)
               CALL QWAIT
               USTOP = USTOP - 1
 60            CONTINUE
C                                       clear rest for gridding
            CALL QVCLR (APCORE, LOGRID, 1, EROW-LOGRID)
            CALL QWAIT
            END IF
C                                       Load grided uv values in ap
         CALL APLOAD (APCORE, USTRT, USTOP, IUMIN-MO2, ROWSIZ, LOGRID,
     *      APSIZE, FLIST, BUFF2, IRET)
         IF (IRET.NE.0) GO TO 999
C                                       When near end of rows
         IF (IUMIN.EQ.0) THEN
            DO 90 IU = 1, MO2
C                                       Convert to decreasing u
               U = MO2 - IU + 1
C                                       U=0 at lrow/2
C                                       U<0 rows from complex cong u>0
C                                       Index points to end of u row
               INDEX = LOGRID + ((U+MO2+1)*ROWSIZ) - IFACT
C                                       Erow points to start of -u row
               EROW  = LOGRID + ((MO2-U)*ROWSIZ)
               CALL QCVCON (APCORE, INDEX, -IFACT, EROW+IFACT, IFACT,
     *            LROW-1)
C                                       Index points to start same u row
               INDEX = INDEX - ROWSIZ + IFACT
C                                       Conjugate a single pixel
               CALL QCVCON (APCORE, INDEX, IFACT, EROW, IFACT, 1)
 90            CONTINUE
            END IF
C                                       Set min and max this pass
         UMAX = (IUMAX + 0.5) * GFACT
         UMIN = (IUMIN - 0.5) * GFACT
         OUTPTR = 1
         INPTR  = 1
         ILENBU = MIN (LENBU, MAXREC)
C                                       Set output file name.
         CALL UVPREP ('WRIT', DISKO, CNOSCO, LUNS(3), INDS(3), NVIS,
     *      LREC, ILENBU, JBUFSZ, BUFF3, NIOUT, OUTPTR, FRSTU, IRET)
         IF (IRET.NE.0) GO TO 999
         NIOUT = ILENBU
         ILENBU = MIN (LENBU, MAXREC)
C                                       Prepare to read through data
         CALL UVPREP ('READ', IDISK, ICNOSC, LUNS(2), INDS(2), NVIS,
     *      LREC, ILENBU, JBUFSZ, BUFF1, NIO, INPTR, FRSTU, IRET)
         IF (IRET.NE.0) GO TO 999
C                                       Reset input to output file.
         IDISK = DISKO
         ICNOSC = CNOSCO
C                                       Count points this pass
         NPOINT = 0
         UCOUNT = NIO
         UTARG = 1
C                                       Loop forever, read all uvdata
 100     CONTINUE
            IF (UCOUNT.GT.UTARG) THEN
               WRITE (MSGTXT,1100) UTARG
               CALL MSGWRT (2)
               UTARG = UTARG + 200000
               END IF
C                                       Rotate, save init u,v,w
            JNPTR = INPTR
            DO 110 I =1,NIO
               UVWS(1,I) = BUFF1(JNPTR+ILOCU)
               UVWS(2,I) = BUFF1(JNPTR+ILOCU+1)
               UVWS(3,I) = BUFF1(JNPTR+ILOCU+2)
               CALL PRJMUL (1, BUFF1(JNPTR+ILOCU), UMAT,
     *            BUFF1(JNPTR+ILOCU))
               JNPTR = JNPTR + LREC
 110           CONTINUE
C                                       Start read from beginning of uvs
            JNPTR = INPTR
C                                       Put uvdata back at beginning
            KNPTR = INPTR
C                                       Use start of output buffer
            LNPTR = OUTPTR
C                                       Count points this buffer
            CNT = 0
C                                       Do all points in buffer
            DO 200 IVIS = 1,NIO
C                                       Input u, v values
               UIN = ABS (BUFF1(JNPTR+ILOCU))
               VIN = ABS (BUFF1(JNPTR+ILOCV))
               IULO = MNFACT * UIN + 0.5
               IUHI = MXFACT * UIN + 0.5
               RULO = MNFACT * UIN
               RUHI = MXFACT * UIN
C                                       uv outside range.
               IF ((UIN.GT.UUMAX) .OR. (VIN.GT.VVMAX)) THEN
                  CALL UVLIMT (0.0, 1.0E20, UUMAX, VVMAX, IVIS,
     *               UIN, VIN, ERRCNT)
C                                       Reset u to within range
                  UIN = MAXU * GFACT
                  UIN = MIN (UUMAX, UIN) * 0.99
C                                       Put location back in buffer
                  BUFF1(JNPTR+ILOCU) = UIN
                  BUFF1(JNPTR+ILOCV) = 0.0
C                                       Zero data
                  CALL RFILL (LREC-VISOFF, 0.0, BUFF1(JNPTR+VISOFF))
C                                       Zero data leave weights
               ELSE IF (UUU.EQ.0.0) THEN
                  KK = JNPTR + VISOFF - 1
                  JJ = LREC - VISOFF
C                                       compressed
                  IF (LREC.LT.LLREC) THEN
                     CALL RFILL (LREC-NRPARM, 0.0, BUFF1(JNPTR+NRPARM))
                  ELSE
                     DO 120 II = 1,JJ,3
                        BUFF1(KK+II) = 0.0
                        BUFF1(KK+II+1) = 0.0
                        IF (FACGRD(2).LT.0.0) BUFF1(KK+II+2) = 1.0
 120                    CONTINUE
                     END IF
                  END IF
C                                       If datum on current rows
C              IF (UIN.GT.UMIN .AND. (UIN.LE.UMAX.OR.RPASS.EQ.1)) THEN
               IF (((IUHI.LE.IUMAX) .OR. (RPASS.EQ.1)) .AND.
     *            (IULO.GE.IUMIN) .AND. ((RPASS.EQ.1) .OR.
     *            (IUHI.GT.LUMAX) .OR. (IULO.LT.LUMIN))) THEN
C                                       Keep count of number to process
                  CNT = CNT + 1
C                                       Store output point location
                  CNJPTR(CNT) = LNPTR
C                                       If u neg. then flip
                  IF (BUFF1(JNPTR+ILOCU).LT.0.0) THEN
C                                       Enter in cnjptr table.
                     CNJPTR(CNT) = -LNPTR
C                                       Flip u, v, w, conjugate data.
                     CALL UVCONJ (VISOFF, JNCF, NCHGRD, NSTOK,
     *                  JNCS, BUFF1(JNPTR))
C                                       End if u < 0, conjugate
                     END IF
C                                       If more than 1 pass
                  IF (.NOT.ALLROW) THEN
C                                       Put data in buff for processing
                     CALL COPY (LREC, BUFF1(JNPTR), BUFF1(KNPTR))
C                                       Update output pointer
                     KNPTR = KNPTR + LREC
                     END IF
C                                       Else not in current rows
               ELSE
                  IF (IULO.LT.IUMIN) IUFMAX = MAX (IUFMAX, IUHI)
C                                       Put in output buffer
                  CALL COPY (LREC, BUFF1(JNPTR), BUFF3(LNPTR))
C                                       End if on current rows
                  END IF
C                                       Set new input and output pos
               JNPTR = JNPTR + LREC
               LNPTR = LNPTR + LREC
C                                       End for all vis recs read
 200           CONTINUE
C                                       Keep track of total
            VISRED = VISRED + CNT
C                                       Count points in range each pass
            NPOINT = NPOINT + CNT
C                                       If points were found
            IF (CNT.GT.0) THEN
C                                       Wait for ap, then load into ap
               CALL QWR
C                                       Uncompress Vis and put in AP
               CALL BUFPUT (APCORE, CNT, NRPARM, LREC, LLREC, IDATA,
     *            BUFF1(INPTR), TEMPBF(1))
C                                       Low row to ap
               IXTEMP(1) = IUMIN
               IXTEMP(2) = LOGRID
               CALL QPUT (APCORE, RXTEMP, 7, 3, 1)
               CALL QWAIT
               CALL QUVIN (APCORE, UV, VIS, WORK, LLREC, MM, LROW, NS,
     *            JNCS, NCHGRD, JNCF, CNT, FLAG)
               CALL QWR
C                                       Read out interpolated data
C                                       If all data in ap
               IF (ALLROW) THEN
C                                       Get UVs from AP (maybe pack UV)
                  CALL BUFGET (APCORE, CNT, NRPARM, LREC, LLREC, IDATA,
     *               BUFF3(OUTPTR), TEMPBF(1))
C                                       Else get some data
               ELSE
C                                       Get UVs from AP (maybe pack UV)
                  CALL BUFGET (APCORE, CNT, NRPARM, LREC, LLREC, IDATA,
     *               BUFF1(INPTR), TEMPBF(1))
                  JNPTR = INPTR
C                                       For all points
                  DO 400 I = 1,CNT
C                                       Get output location of data
                     LNPTR = ABS(CNJPTR(I))
C                                       Move from input to output
                     CALL COPY (LREC, BUFF1(JNPTR), BUFF3(LNPTR))
C                                       Start location of next vis rec.
                     JNPTR = JNPTR + LREC
 400                 CONTINUE
C                                       End if not all in ap
                  END IF
C                                       For all points, conjugate
               DO 500 ICONJ = 1, CNT
C                                       If point was conjugated
                  IF (CNJPTR(ICONJ).LT.0) THEN
C                                       Get position
                     LNPTR = -CNJPTR(ICONJ)
C                                       Flip u, v, w, conjugate data.
                     CALL UVCONJ (VISOFF, JNCF, NCHGRD, NSTOK, JNCS,
     *                  BUFF3(LNPTR))
                     END IF
 500              CONTINUE
C                                       End if points this pass
               END IF
C                                       restore u,v,w
            JNPTR = OUTPTR
            DO 520 I = 1,NIO
               BUFF3(JNPTR+ILOCU) = UVWS(1,I)
               BUFF3(JNPTR+ILOCU+1) = UVWS(2,I)
               BUFF3(JNPTR+ILOCU+2) = UVWS(3,I)
               JNPTR = JNPTR + LREC
 520           CONTINUE
C                                       Write all nio points read
            NIOUT = NIO
C                                       Write data to disk
            CALL UVDISK ('WRIT', LUNS(3), INDS(3), BUFF3, NIOUT,
     *         OUTPTR, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1200) IRET
               GO TO 995
               END IF
C                                       Read a new uvdata buffer
            CALL UVDISK ('READ', LUNS(2), INDS(2), BUFF1, NIO, INPTR,
     *         IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1300) IRET
               GO TO 995
               END IF
            UCOUNT = UCOUNT + NIO
C                                       If more data, loop
            IF (NIO.GT.0) GO TO 100
C                                       Jump here on end uv data
C                                       Write Diag messages ONLY once
C                                       Print only 10 Messages
         IF (.NOT.ONCE) THEN
            WRITE(MSGTXT,1104,ERR=680) RPASS, IUMAX, IUMIN, NPOINT
            MSGINC = (NRPASS/10) + 1
 680        IF (((RPASS/MSGINC)*MSGINC).EQ.RPASS) CALL MSGWRT (2)
            END IF
C                                       Finish write.
         NIOUT = 0
         CALL UVDISK ('FLSH', LUNS(3), INDS(3), BUFF3, NIOUT, OUTPTR,
     *      IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1500) IRET, I
            GO TO 995
            END IF
C                                       Close files
         CALL ZCLOSE (LUNS(2), INDS(2), IRET)
         CALL ZCLOSE (LUNS(3), INDS(3), IRET)
         LUMIN = IUMIN
         LUMAX = IUMAX
C                                       end of rows loop: do more?
         IF (IUFMAX.GT.0) THEN
            IUMAX = IUFMAX
            GO TO 50
            END IF
C                                       Check that written all data read
      IF (NVIS.NE.VISRED) THEN
         WRITE (MSGTXT,1600) NVIS, VISRED
         CALL MSGWRT (8)
         END IF
      IF ((DOFLAG) .AND. (ERRCNT.GT.0)) THEN
         MSGTXT = '**************************************************'
     *     // '*****'
         CALL MSGWRT (8)
         WRITE (MSGTXT,1601) ERRCNT
         CALL MSGWRT (8)
         MSGTXT = '**************************************************'
     *     // '*****'
         CALL MSGWRT (8)
         END IF
C                                       re-set pointers to beginning
C                                       of the grid file.
      CALL APIO (APCORE, 'INIT', FLIST, LOGRID, BUFF2, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1400) IRET
         GO TO 995
         END IF
C                                       Give up AP.
      CALL QRLSE
C                                       write diag messages once only
C                                       DEBUG
C     ONCE = .TRUE.
C                                       Close grid file.
      CALL APIO (APCORE, 'CLOS', FLIST, LOGRID, BUFF2, IRET)
      IF (COMPDT) THEN
         LREC = ITEMP1
         NRPARM = ITEMP2
         END IF
      GO TO 999
C                                       Error
 995  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1040 FORMAT ('ALGSTB: All ',I5,' Rows In AP (Max  ',I5,')')
 1041 FORMAT ('ALGSTB: Only',I5,' Rows In AP (Need ',I5,')')
 1045 FORMAT ('ALGSTB: ',A1,'pol gridded model subtraction, chans',I5,
     *   ' through',I5)
 1046 FORMAT ('ALGSTB field',I5,1X,A1,'pol gridded model subtraction',
     *   ' chns',I5,'-',I5)
 1100 FORMAT ('ALGSTB: at visibility number',I12)
 1104 FORMAT ('ALGSTB: Pass',I4,';',I5,'-',I4,' Cells, with',I9,
     *        ' Pts')
 1200 FORMAT ('ALGSTB: WRITE ERROR IN VISIBILITY FILE, IER=',I6)
 1300 FORMAT ('ALGSTB: READ  ERROR IN VISIBILITY FILE, IER=',I6)
 1400 FORMAT ('ALGSTB: TROUBLE INIT GRID FILE, IER=',I5)
 1500 FORMAT ('ALGSTB: ERROR',I5,' READING GRID ROW ',I5)
 1600 FORMAT ('ALGSTB: WARNING! Misplaced Data, NVIS = ',I8,
     *   ' WRITTEN =',I8)
 1601 FORMAT ('ALGSTB:',I10,' POINTS FLAGGED FOR BEING OFF THE GRID')
      END
