LOCAL INCLUDE 'LISUN.INC'
      INCLUDE 'INCS:PUVD.INC'
      CHARACTER NAMEIN*12, CLAIN*6, XSOUR(30)*16, XCALCO*4, LPNAME*48,
     *   OULINE*132, TITL1*132, TITL2*132, SCRTCH*132
      HOLLERITH XNAMEI(3), XCLAIN(2), XSOURC(4,30), XXCALC, XLPNAM(12)
      DOUBLE PRECISION  FREQIF(MAXIF), BFREQ
      REAL      XSIN, XDISIN, XTIME(8), XBAND, XFREQ, XFQID, DOCRT,
     *   XBADD(10)
      LOGICAL   ISINGL, VERBOS
      INTEGER   DISKIN, SEQIN, CNOIN, BUFFER(512), LUNP, FINDP, NACROS,
     *   IPCNT, PAGE, IXINC, NCOUNT, NSUB, PRTM
C
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XSOURC, XXCALC,
     *   XTIME, XBAND, XFREQ, XFQID, DOCRT, XLPNAM, XBADD
      COMMON /CHPARM/ NAMEIN, CLAIN, XSOUR, XCALCO, LPNAME, OULINE,
     *   TITL1, TITL2, SCRTCH
      COMMON /INFOLS/ FREQIF, BFREQ, ISINGL, VERBOS, DISKIN, SEQIN,
     *   CNOIN, BUFFER, NACROS, IPCNT, PAGE, LUNP, FINDP, IXINC, NCOUNT,
     *   NSUB, PRTM
LOCAL END
LOCAL INCLUDE 'LISUN.BUF'
      REAL   XXBUFF(10000)
      COMMON /BUFFRS/ XXBUFF
LOCAL END
      PROGRAM LISUN
C-----------------------------------------------------------------------
C! LISUN prints uv data scan info with Sun angle; lists antennas
C# Calibration UV VLA VLB
C-----------------------------------------------------------------------
C;  Copyright (C) 2023, 2025
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 LISUN prints data from uv data files in a variety of forms.
C   Inputs:
C      AIPS Adverb   Prg. Name          Description
C      INNAME         NAME          File name to be listed.
C      INCLASS        CLASS         File class to be listed.
C      INSEQ          SEQ           File sequence number.
C      INDISK         DISK          Disk volumn on which file resides.
C      SOURCES        XSOUR(4,30)   Sources selected
C      CALCODE        XCALCO        Calibrator source code
C      TIMERANG       XTIME(8)      Timerange
C      DOCRT          DOCRT         > 0 => use CRT, else line printer
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET, IERR, CATSAV(256)
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'LISUN.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DSOU.INC'
      INCLUDE 'INCS:DANS.INC'
      DATA PRGM /'LISUN '/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL LISUNI (PRGM, IRET)
      IF (IRET.NE.0) GO TO 990
      CALL COPY (256, CATBLK, CATSAV)
C                                       now actually print
      CALL COPY (256, CATSAV, CATBLK)
      CALL SCANUV (IRET)
C                                       Close printer
      IF (IPCNT.GE.0) CALL LPCLOS (LUNP, FINDP, IPCNT, IERR)
      GO TO 990
C                                       Close down files, etc.
 990  IRET = MAX (0, IRET)
      CALL DIE (IRET, BUFFER)
C
 999  STOP
      END
      SUBROUTINE LISUNI (PRGN, JERR)
C-----------------------------------------------------------------------
C   LISUNI gets input parameters for LISUN
C   Inputs:
C      PRGN    C*6       Program name (2 chars/word)
C   Output:
C      JERR    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/ output file catalog header
C   See prologue comments in LISUN for more details.
C-----------------------------------------------------------------------
      CHARACTER PRGN*6
      INTEGER   JERR
C
      CHARACTER STAT*4, STATUS*4, UTYPE*2
      INTEGER   IROUND, NPARM, IERR, I, LUN, NIF, IIVER, MXIF
      REAL      CATR(256)
      LOGICAL   F, TABLE, EXIST, FITASC, MATCH
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   ISBAND(MAXIF)
      DOUBLE PRECISION    FOFF(MAXIF)
      REAL      FINC(MAXIF)
      CHARACTER BNDCOD(MAXIF)*8
      INCLUDE 'LISUN.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DUVH.INC'
C      INCLUDE 'INCS:DANT.INC'
      EQUIVALENCE (CATR,CATBLK)
      DATA F /.FALSE./
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      CALL SELINI
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      JERR = 0
      NCOUNT = 0
C                                       Get input parameters.
      NPARM = 162
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, BUFFER, IERR)
      IF ((IERR.NE.0) .OR. (NPOPS.GT.NINTRN) .OR. (ISBTCH.EQ.32000))
     *   DOCRT = MIN (-1.0, DOCRT)
      CALL H2CHR (48, 1, XLPNAM, LPNAME)
      IF (DOCRT.GT.0.0) RQUICK = .FALSE.
      IF (RQUICK) RQUICK = LPNAME.NE.' '
      IF (IERR.NE.0) THEN
         RQUICK = .TRUE.
         JERR = 8
         IF (IERR.EQ.1) GO TO 999
            WRITE (MSGTXT,1000) IERR, 'OBTAINING INPUT PARAMETERS'
            CALL MSGWRT (8)
         END IF
C                                       Restart AIPS
      IF (RQUICK) CALL RELPOP (JERR, BUFFER, IERR)
      IF (JERR.NE.0) GO TO 999
      JERR = 5
C                                       Hollerith -> char.
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      CALL H2CHR (4, 1, XXCALC, XCALCO)
C                                       Calcode abreviations
      IF (XCALCO(1:2).EQ.'CA') XCALCO = '*   '
      IF (XCALCO(1:1).EQ.'-')  XCALCO = '-CAL'
      SELCOD = XCALCO
      DO 25 I = 1,30
         CALL H2CHR (16, 1, XSOURC(1,I), XSOUR(I))
 25      CONTINUE
C                                       Crunch input parameters.
      SEQIN = IROUND (XSIN)
      DISKIN = IROUND (XDISIN)
C                                       Get CATBLK.
      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
      STATUS = 'REST'
      STATUS = 'READ'
      CALL CATIO ('READ', DISKIN, CNOIN, CATBLK, STATUS, BUFFER, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READING DATA HEADER'
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = CNOIN
      FRW(NCFILE) = 0
C                                       Get uv header info.
      CALL UVPGET (JERR)
      IF (JERR.NE.0) GO TO 999
      BFREQ = FREQ
      CALL FNDEXT ('AN', CATBLK, NSUB)
C                                       Put selection criteria into
C                                       correct common.
      UNAME = NAMEIN
      UCLAS = CLAIN
      UDISK = DISKIN
      USEQ = SEQIN
      DO 70 I = 1,30
         SOURCS(I) = XSOUR(I)
 70      CONTINUE
      CALL RCOPY (8, XTIME, TIMRNG)
      DO 80 I = 1,10
         IBAD(I) = IROUND (XBADD(I))
 80      CONTINUE
      TSTART = ((TIMRNG(4)/60. + TIMRNG(3))/60. + TIMRNG(2))/24. +
     *   TIMRNG(1)
      TEND = ((TIMRNG(8)/60. + TIMRNG(7))/60. + TIMRNG(6))/24. +
     *   TIMRNG(5)
      IF (TEND.LE.TSTART) THEN
         TSTART = -1.0
         TEND = 1000.
         END IF
      JERR = 0
C                                       Freq id
      IF (XBAND.GT.0.0) SELBAN = XBAND
      IF (XFREQ.GT.0.0) SELFRQ = XFREQ
      FRQSEL = IROUND (XFQID)
      LUN = 28
      FRQSEL = MAX (1, FRQSEL)
      CALL FQMATC (DISKIN, CNOIN, CATBLK, LUN, SELBAN, SELFRQ, MATCH,
     *   FRQSEL, JERR)
      IF (.NOT.MATCH) THEN
         WRITE (MSGTXT,1070)
         JERR = 1
         GO TO 990
         END IF
      IF (JERR.GT.0) GO TO 999
      CALL MULSDB (CATBLK, ISINGL)
C                                       Get IF freq offset.
      LUN = 28
      IIVER = 1
      CALL CHNDAT ('READ', BUFFER, DISKIN, CNOIN, IIVER, CATBLK, LUN,
     *   NIF, FOFF, ISBAND, FINC, BNDCOD, FRQSEL, JERR)
      IF (JERR.GT.0) GO TO 999
      MXIF = MAXIF
      DO 100 I = 1, MXIF
         FREQIF(I) = FOFF(I)
 100     CONTINUE
C                                       See if a single source file.
      CALL MULSDB (CATBLK, ISINGL)
      IF (ISINGL) THEN
         CALL ISTAB ('SU', DISKIN, CNOIN, 1, LUN, BUFFER, TABLE, EXIST,
     *      FITASC, IERR)
         ISINGL = EXIST .AND. (IERR.EQ.0) .AND. TABLE
         END IF
      ISINGL = .NOT.ISINGL
      IF (ISINGL) THEN
         NSOUWD = 0
      ELSE
         CALL FNDSOU (DISKIN, CNOIN, SOURCS, BUFFER, NSOUWD, DOSWNT,
     *      SOUWAN, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'FINDING SOURCE LIST'
            GO TO 990
            END IF
         END IF
C                                       Init printer
      PAGE = 0
      IPCNT = 980
      TITL1 = ' '
      TITL2 = ' '
      OULINE = ' '
C                                       Open output device
      IF (LPNAME.EQ.' ') DOCRT = MAX (-1.0, DOCRT)
      CALL LPOPEN (LPNAME, DOCRT, LUNP, FINDP, NACROS, BUFFER, JERR)
      IF (JERR.NE.0) THEN
         WRITE (MSGTXT,1080) JERR
         JERR = 1
         GO TO 990
      END IF
      IF (DOCRT.GT.0) THEN
         PRTM = ABS(CRTMAX)
      ELSE IF (DOCRT.GT.-2.5) THEN
         PRTM = PRTMAX
      ELSE
         PRTM = 100000
         END IF
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('LISUNI: ERROR',I3,' ON',A)
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
     *   I3,' USID=',I5)
 1070 FORMAT ('NO MATCH TO SELBAND/SELFREQ ADVERBS - CHECK INPUTS')
 1080 FORMAT ('LISUNI: ERROR ',I3,' OPENING OUTPUT ''PRINT'' DEVICE')
      END
      SUBROUTINE SCANUV (IRET)
C-----------------------------------------------------------------------
C   Gives column listing of the index table and source info.
C   Output:
C      IRET   I    Return code, 0=OK, else failed
C-----------------------------------------------------------------------
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   MAXSOU
      PARAMETER (MAXSOU=10000)
      CHARACTER  CCODE*1, VELTYP*8, VELDEF*8, SUNAME*16, CALCOD*4,
     *   CH1*1, CH2*1, OBSDAT*8
      INTEGER   IRET, TIME(8), QUAL, NXSOUR, NXSUB, INXLUN, ISLUN, I, J,
     *   HMRA(2), DMDEC(2), SUKOLS(MAXSUC), SUNUMV(MAXSUC), IDSOU, IERR,
     *   NNIF, NSOURC, NDXRNO, SURNO, LOOP, NXVS, NXVE, MXSOU, IIVER,
     *   FQID, FQSIDE(MAXIF), NMFQIF, NUMFQE, NXFQI, NXVER, NLOOP,
     *   SUFQID, MAXSUB, DROUND, ISEP, OBSDAY(6), LONG(2), LAT(2)
      LOGICAL   FQEXIS, TABLE, FITASC, SAMEFQ, ISNX, ISSU
      REAL      T1, T2, NXTIME, NXDTIM, SECRA, SECDEC, FQTBW(MAXIF),
     *   FQCHBW(MAXIF), SLONG, SLAT
      DOUBLE PRECISION    BANDW, RAEPO, DECEPO, EPOCH, RAAPP, SFREQ,
     *   SLSRV, SRF, DECAPP, PMRA, PMDEC, FQFRQ(MAXIF), RAOBS, DECOBS,
     *   XRA(MAXSOU+1), XDEC(MAXSOU+1), SSEP
      INTEGER   XQUAL(MAXSOU+1), XSCNT(MAXSOU+1), KSID(MAXIF), KQUAL
      CHARACTER SXNAME(MAXSOU+1)*16, XCODE(MAXSOU+1)*4, BNDCOD(MAXIF)*8
      REAL      FLUX(4,MAXIF), FINC(MAXIF), CATR(256)
      DOUBLE PRECISION    LSRVEL(MAXIF), FREQO(MAXIF), RESTFQ(MAXIF),
     *   FOFF(MAXIF), CATD(128), REFF, FREQAS(MAXIF), VELOCS(MAXIF),
     *   FQREST(MAXIF)
      HOLLERITH CATH(256)
      INCLUDE 'LISUN.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DANS.INC'
      EQUIVALENCE (CATD, CATH, CATR, CATBLK)
      DATA MXSOU /MAXSOU/
      DATA ISLUN, INXLUN /27,28/
C-----------------------------------------------------------------------
C                                       Do NX, SU tables exist?
      CALL ISTAB ('NX', DISKIN, CNOIN, 1, INXLUN, BLBUFF, TABLE, ISNX,
     *   FITASC, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1001) IRET, 'NX'
         GO TO 990
         END IF
      IF (.NOT.ISNX) THEN
         MSGTXT = 'NX TABLE MISSING, SCAN OUTPUT WILL OMIT'
         CALL MSGWRT (6)
         END IF
      CALL ISTAB ('SU', DISKIN, CNOIN, 1, INXLUN, BLBUFF, TABLE, ISSU,
     *   FITASC, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1001) IRET, 'SU'
         GO TO 990
         END IF
      IF (.NOT.ISSU) THEN
         MSGTXT = 'NO SOURCE TABLE, SCAN OUTPUT WILL OMIT'
         CALL MSGWRT (6)
         END IF
C
      FREQ = BFREQ * 1.0D-9
      MAXSUB = 1
C                                       Initialize source info
      I = MXSOU + 1
      DO 10 LOOP = 1,I
         XSCNT(LOOP) = 0
         XQUAL(LOOP) = 0
         XCODE(LOOP) = 'HELP'
         SXNAME(LOOP) = 'Not in SU table'
 10      CONTINUE
      IF (NSOUWD.GT.0) THEN
         IF (DOSWNT) THEN
            CALL FILL (I, -999, XQUAL)
            DO 11 LOOP = 1,NSOUWD
               I = SOUWAN(LOOP)
               XQUAL(I) = 0
 11            CONTINUE
         ELSE
            DO 12 LOOP = 1,NSOUWD
               I = SOUWAN(LOOP)
               XQUAL(I) = -1
 12            CONTINUE
            END IF
         END IF
      SXNAME(I) = 'Too many sources'
      XSCNT(I) = -1
      EPOCH = CATR(KREPO)
      CALL H2CHR (8, 1, CATH(KHDOB), OBSDAT)
      READ (OBSDAT,1012) OBSDAY(1), OBSDAY(2), OBSDAY(3)
C                                       Get source info
      IF (ISSU) THEN
         CALL SOUINI ('READ', BLBUFF, DISKIN, CNOIN, 1, CATBLK, ISLUN,
     *      NUMIF, VELTYP, VELDEF, SUFQID, SURNO, SUKOLS, SUNUMV, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'OPENING SU TABLE'
            GO TO 990
            END IF
         SUFQID = MAX (1, SUFQID)
         NSOURC = BLBUFF(5)
         DO 30 LOOP = 1,NSOURC
            SURNO = LOOP
            CALL TABSOU ('READ', BLBUFF, SURNO, SUKOLS, SUNUMV, IDSOU,
     *         SUNAME, QUAL, CALCOD, FLUX, FREQO, BANDW, RAEPO, DECEPO,
     *         EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL, RESTFQ,
     *         PMRA, PMDEC, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READING SU TABLE'
               GO TO 990
               END IF
            IF ((IDSOU.GT.0) .AND. (IDSOU.LE.MXSOU) .AND.
     *         (XQUAL(IDSOU).GE.0)) THEN
               SXNAME(IDSOU) = SUNAME
               XCODE(IDSOU) = CALCOD
               XQUAL(IDSOU) = QUAL
               XRA(IDSOU) = RAAPP
               XDEC(IDSOU) = DECAPP
               IF ((XRA(IDSOU).EQ.0.0D0) .AND. (XDEC(IDSOU).EQ.0.0D0))
     *            THEN
                  XRA(IDSOU) = RAEPO
                  XDEC(IDSOU) = DECEPO
                  END IF
               END IF
 30         CONTINUE
      ELSE
         SAMEFQ = .TRUE.
         NSOURC = 1
         XCODE(1) = ' '
         XQUAL(1) = 0
         CALL H2CHR (8, 1, CATH(KHOBJ), SXNAME(1))
         SUFQID = 1
         IF (CATBLK(KIALT).NE.0) THEN
            I = CATBLK(KIALT)/256 + 1
            VELTYP = 'RADIO'
            IF (I.EQ.1) VELTYP = 'OPTICAL'
            I = CATBLK(KIALT) - (I-1) * 256
            VELDEF = 'LSR'
            IF (I.EQ.2) VELDEF = 'BARYCENTR'
            IF (I.EQ.3) VELDEF = 'TOPOCENTR'
         ELSE
            VELTYP = ' '
            VELDEF = ' '
            END IF
         END IF
C                                       Initialize index table
      IF (ISNX) THEN
         NXVER = 1
         CALL NDXINI ('READ', NXBUFF, DISKIN, CNOIN, NXVER, CATBLK,
     *      INXLUN, NDXRNO, NXKOLS, NXNUMV, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'OPENING INDEX TABLE'
            GO TO 990
            END IF
         END IF
C                                       Initialize FQ table
      IQLUN = 44
      NXVER = 1
      CALL ISTAB ('FQ', DISKIN, CNOIN, NXVER, IQLUN, FQBUFF, TABLE,
     *   FQEXIS, FITASC, IRET)
      IF (FQEXIS) THEN
         CALL FQINI ('READ', FQBUFF, DISKIN, CNOIN, NXVER, CATBLK,
     *      IQLUN, IFQRNO, FQKOLS, FQNUMV, NMFQIF, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'OPENING FQ TABLE'
            GO TO 990
            END IF
         NUMFQE = FQBUFF(5)
         END IF
C                                       Names for labels
C                                       first page & page titles
      WRITE (OULINE,1030) NAMEIN, CLAIN, SEQIN, DISKIN, NLUSER
      CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, OULINE,
     *   IPCNT, PAGE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 950
      TITL1 = OULINE
      WRITE (OULINE,1031) FREQ, NCOR, NVIS
      CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, OULINE,
     *   IPCNT, PAGE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 950
      IF (DOCRT.GT.-2.5) THEN
         OULINE = 'Scan summary listing'
         CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, OULINE,
     *      IPCNT, PAGE, SCRTCH, IERR)
         IF (IERR.NE.0) GO TO 950
         OULINE = ' '
         CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, OULINE,
     *      IPCNT, PAGE, SCRTCH, IERR)
         IF (IERR.NE.0) GO TO 950
         END IF
      WRITE (TITL2,1035)
      CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, TITL2,
     *   IPCNT, PAGE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 950
C                                       Get number of index records
      IF (ISNX) THEN
         NINDEX = NXBUFF(5)
C                                       Loop thru index table
         DO 50 LOOP = 1,NINDEX
C                                       Read index table
            NDXRNO = LOOP
            CALL TABNDX ('READ', NXBUFF, NDXRNO, NXKOLS, NXNUMV, NXTIME,
     *         NXDTIM, NXSOUR, NXSUB, NXVS, NXVE, NXFQI, IRET)
            IF (IRET.GT.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READING INDEX TABLE'
               GO TO 990
               END IF
            MAXSUB = MAX (MAXSUB, NXSUB)
C                                       Convert time
            T1 = NXTIME - 0.5 * NXDTIM
            T2 = NXTIME + 0.5 * NXDTIM
            IF ((T2.LT.TSTART) .OR. (T1.GT.TEND)) GO TO 45
            IF (XQUAL(NXSOUR).EQ.-999) GO TO 45
C                                       To Days Hours Minutes Secs
            READ (OBSDAT,1012) OBSDAY(1), OBSDAY(2), OBSDAY(3)
            CALL TODHMS (NXTIME, TIME(1))
            CALL COPY (3, TIME(2), OBSDAY(4))
            OBSDAY(3) = OBSDAY(3) + TIME(1)
            CALL SUNANG (OBSDAY, XRA(NXSOUR), XDEC(NXSOUR), SSEP)
            ISEP = DROUND (SSEP)
            CALL TODHMS (T1, TIME(1))
            CALL TODHMS (T2, TIME(5))
C                                       Print line
            IF ((NXSOUR.LT.1) .OR. (NXSOUR.GT.MXSOU)) NXSOUR = MXSOU + 1
C                                       If calc code OK
            CCODE = XCODE(NXSOUR)(1:1)
            IF ((XCALCO(:1).EQ.' ') .OR. (CCODE.EQ.XCALCO(:1)) .OR.
     *         ((XCALCO(:1).EQ.'*') .AND. (CCODE.NE.' ')) .OR.
     *         ((XCALCO(:1).EQ.'-') .AND. (CCODE.EQ.' '))) THEN
               WRITE (OULINE,1040) LOOP, SXNAME(NXSOUR), XCODE(NXSOUR),
     *            TIME, NXVS, NXVE, ISEP
               CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2,
     *            OULINE, IPCNT, PAGE, SCRTCH, IERR)
               IF (IERR.NE.0) GO TO 950
               END IF
C                                       Sum visibilities
 45         J = NXVE - NXVS + 1
            XSCNT(NXSOUR) = XSCNT(NXSOUR) + J
 50         CONTINUE
C                                       Close  INDEX table
         CALL TABIO ('CLOS', 0, NDXRNO, NXBUFF, NXBUFF, IERR)
         END IF
C-----------------------------------------------------------------------
C                                       Source summary
      OULINE = ' '
      TITL2 = ' '
C                                       if page half full, new page
      IF ((ISSU) .AND. (IPCNT.GT.PRTM/2)) IPCNT = 980
      IF (DOCRT.GT.-2.5) THEN
         CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, OULINE,
     *      IPCNT, PAGE, SCRTCH, IERR)
         IF (IERR.NE.0) GO TO 950
         END IF
      WRITE (TITL2,1051) EPOCH, EPOCH
      IF (DOCRT.GT.-2.5) THEN
         OULINE = 'Source summary'
         CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2,
     *      OULINE, IPCNT, PAGE, SCRTCH, IERR)
         IF (IERR.NE.0) GO TO 950
         END IF
C                                       Velocity type, defination
      OULINE = ' '
      CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, OULINE,
     *   IPCNT, PAGE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 950
      WRITE (OULINE,1060) VELTYP, VELDEF
      CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, OULINE,
     *   IPCNT, PAGE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 950
      IF (DOCRT.GT.-2.5) THEN
         IF (MAXSUB.GT.1) THEN
            WRITE (OULINE,1061) MAXSUB
            CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2,
     *         OULINE, IPCNT, PAGE, SCRTCH, IERR)
            IF (IERR.NE.0) GO TO 950
            END IF
         OULINE = ' '
         CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, OULINE,
     *      IPCNT, PAGE, SCRTCH, IERR)
         IF (IERR.NE.0) GO TO 950
         END IF
      CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, TITL2,
     *   IPCNT, PAGE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 950
C                                       Loop over source table
      IF (ISSU) THEN
C                                       Position, flux
         DO 110 LOOP = 1,NSOURC
            SURNO = LOOP
            CALL TABSOU ('READ', BLBUFF, SURNO, SUKOLS, SUNUMV, IDSOU,
     *         SUNAME, QUAL, CALCOD, FLUX, FREQO, BANDW, RAEPO, DECEPO,
     *         EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL, RESTFQ,
     *         PMRA, PMDEC, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READING SOURCE TABLE'
               GO TO 990
               END IF
            KQUAL = QUAL
C                                       for all IFs
            DO 105 I = 1,NUMIF
C                                       Calc freq, velocity and rest fq
               SFREQ = FREQ + FREQO(I) * 1.0D-9
               SLSRV = LSRVEL(I) * 1.0D-3
               SRF = RESTFQ(I) * 1.0D-9
C                                       store on first source
               IF (LOOP.EQ.1) THEN
                  FREQAS(I) = SFREQ
                  VELOCS(I) = SLSRV
                  FQREST(I) = SRF
                  SAMEFQ    = .TRUE.
C                                       check on rest of sources
               ELSE
                  IF ((FREQAS(I).NE.SFREQ) .OR. (VELOCS(I).NE.SLSRV)
     *               .OR.(FQREST(I).NE.SRF)) SAMEFQ = .FALSE.
                  END IF
C                                       end for all IFs loop
 105           CONTINUE
C                                       Convert RA, dec
            CALL COORDD (1, RAEPO, CH1, HMRA, SECRA)
            CALL COORDD (2, DECEPO, CH2, DMDEC, SECDEC)
            NXSOUR = IDSOU
            IF ((NXSOUR.LT.1) .OR. (NXSOUR.GT.MXSOU)) NXSOUR = MXSOU + 1
            IF (XQUAL(NXSOUR).EQ.-999) GO TO 110
C                                       If calc code OK
            CCODE = XCODE(NXSOUR)(1:1)
            IF ((XCALCO(:1).EQ.' ') .OR. (CCODE.EQ.XCALCO(:1)) .OR.
     *         ((XCALCO(:1).EQ.'*') .AND. (CCODE.NE.' ')) .OR.
     *         ((XCALCO(1:1).EQ.'-') .AND. (CCODE.EQ.' '))) THEN
C                                       Write row
               WRITE (OULINE,1110) IDSOU, SUNAME, KQUAL, CALCOD, CH1,
     *            HMRA, SECRA, CH2, DMDEC, SECDEC, XSCNT(NXSOUR)
               IF (OULINE(43:43).EQ.' ') OULINE(43:43) = '0'
               IF (OULINE(58:58).EQ.' ') OULINE(58:58) = '0'
               CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2,
     *            OULINE, IPCNT, PAGE, SCRTCH, IERR)
               IF (IERR.NE.0) GO TO 950
               END IF
 110        CONTINUE
      ELSE
         CALL AXEFND (2, 'RA', CATBLK(KIDIM), CATH(KHCTP), I, IERR)
         RAEPO = CATD(KDCRV+I)
         CALL AXEFND (3, 'DEC', CATBLK(KIDIM), CATH(KHCTP), I, IERR)
         DECEPO = CATD(KDCRV+I)
         CALL COORDD (1, RAEPO, CH1, HMRA, SECRA)
         CALL COORDD (2, DECEPO, CH2, DMDEC, SECDEC)
         WRITE (OULINE,1110) 1, SXNAME(1), XQUAL(1), XCODE(1), CH1,
     *      HMRA, SECRA, CH2, DMDEC, SECDEC, XSCNT(1)
         IF (OULINE(43:43).EQ.' ') OULINE(43:43) = '0'
         IF (OULINE(58:58).EQ.' ') OULINE(58:58) = '0'
         CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2,
     *      OULINE, IPCNT, PAGE, SCRTCH, IERR)
         IF (IERR.NE.0) GO TO 950
         END IF
C-----------------------------------------------------------------------
C                                       Only once if FQ same for all
      OULINE = ' '
      TITL2 = ' '
C                                       if page half full, new page
      IF ((ISSU) .AND. (IPCNT.GT.PRTM/2)) IPCNT = 980
      IF (DOCRT.GT.-2.5) THEN
         CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, OULINE,
     *      IPCNT, PAGE, SCRTCH, IERR)
         IF (IERR.NE.0) GO TO 950
         END IF
      WRITE (TITL2,1050)
      CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, TITL2,
     *   IPCNT, PAGE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 950
C                                       Loop over source table
      IF (ISSU) THEN
C                                       flux
         DO 130 LOOP = 1,NSOURC
            SURNO = LOOP
            CALL TABSOU ('READ', BLBUFF, SURNO, SUKOLS, SUNUMV, IDSOU,
     *         SUNAME, QUAL, CALCOD, FLUX, FREQO, BANDW, RAEPO, DECEPO,
     *         EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL, RESTFQ,
     *         PMRA, PMDEC, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READING SOURCE TABLE'
               GO TO 990
               END IF
            KQUAL = QUAL
C                                       for all IFs
            DO 115 I = 1,NUMIF
C                                       Calc freq, velocity and rest fq
               SFREQ = FREQ + FREQO(I) * 1.0D-9
               SLSRV = LSRVEL(I) * 1.0D-3
               SRF = RESTFQ(I) * 1.0D-9
C                                       store on first source
               IF (LOOP.EQ.1) THEN
                  FREQAS(I) = SFREQ
                  VELOCS(I) = SLSRV
                  FQREST(I) = SRF
                  SAMEFQ    = .TRUE.
C                                       check on rest of sources
               ELSE
                  IF ((FREQAS(I).NE.SFREQ) .OR. (VELOCS(I).NE.SLSRV)
     *               .OR.(FQREST(I).NE.SRF)) SAMEFQ = .FALSE.
                  END IF
C                                       end for all IFs loop
 115           CONTINUE
C                                       Convert RA, dec
            CALL COORDD (1, RAEPO, CH1, HMRA, SECRA)
            CALL COORDD (2, DECEPO, CH2, DMDEC, SECDEC)
            NXSOUR = IDSOU
            IF ((NXSOUR.LT.1) .OR. (NXSOUR.GT.MXSOU)) NXSOUR = MXSOU + 1
            IF (XQUAL(NXSOUR).EQ.-999) GO TO 130
C                                       If calc code OK
            CCODE = XCODE(NXSOUR)(1:1)
            IF ((XCALCO(:1).EQ.' ') .OR. (CCODE.EQ.XCALCO(:1)) .OR.
     *         ((XCALCO(:1).EQ.'*') .AND. (CCODE.NE.' ')) .OR.
     *         ((XCALCO(1:1).EQ.'-') .AND. (CCODE.EQ.' '))) THEN
C                                       Write row
               WRITE (OULINE,1111) IDSOU, SUNAME, KQUAL, CALCOD,
     *            FLUX(1,1), FLUX(2,1), FLUX(3,1), FLUX(4,1),
     *            XSCNT(NXSOUR)
               CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2,
     *            OULINE, IPCNT, PAGE, SCRTCH, IERR)
               IF (IERR.NE.0) GO TO 950
C                                       Other IF fluxes
               IF (NUMIF.GT.1) THEN
                  DO 120 I = 2,NUMIF
                     IF ((FLUX(1,I).GT.0.0) .OR. (DOCRT.GT.-2.5)) THEN
                        WRITE (OULINE,1112) I, FLUX(1,I), FLUX(2,I),
     *                     FLUX(3,I), FLUX(4,I)
                        CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1,
     *                     TITL2, OULINE, IPCNT, PAGE, SCRTCH, IERR)
                        IF (IERR.NE.0) GO TO 950
                        END IF
 120                 CONTINUE
                  END IF
               END IF
 130        CONTINUE
         END IF
C                                       Get IF frequency info
      IF (.NOT.FQEXIS) THEN
         IIVER = 1
         CALL CHNDAT ('READ', NXBUFF, DISKIN, CNOIN, IIVER, CATBLK,
     *      INXLUN, NNIF, FOFF, KSID, FINC, BNDCOD, FRQSEL, IRET)
      ELSE
         CALL TABFQ ('READ', FQBUFF, SUFQID, FQKOLS, FQNUMV, NMFQIF,
     *      FQID, FOFF, FQCHBW, FQTBW, FQSIDE, BNDCOD, IRET)
         END IF
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'READ IF FREQ INFO'
         GO TO 990
         END IF
      IF (DOCRT.GT.-2.5) THEN
         OULINE = ' '
         CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, OULINE,
     *      IPCNT, PAGE, SCRTCH, IERR)
         IF (IERR.NE.0) GO TO 950
         END IF
      WRITE (TITL2,1130)
      CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, TITL2,
     *    IPCNT, PAGE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 950
      NLOOP = NSOURC
C                                       Frequency, velocity, rest freq.
      IF (SAMEFQ) NLOOP = 1
      IF (ISSU) THEN
         DO 150 LOOP = 1,NLOOP
            SURNO = LOOP
            CALL TABSOU ('READ', BLBUFF, SURNO, SUKOLS, SUNUMV, IDSOU,
     *         SUNAME, QUAL, CALCOD, FLUX, FREQO, BANDW, RAEPO, DECEPO,
     *         EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL, RESTFQ,
     *         PMRA, PMDEC, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READING SOURCE TABLE'
               GO TO 990
               END IF
            KQUAL = QUAL
            SFREQ = FREQ + (FOFF(1) + FREQO(1)) * 1.0D-9
            SLSRV = LSRVEL(1) * 1.0D-3
            SRF = RESTFQ(1) * 1.0D-9
C                                       If FQ info same for all sources
            IF (SAMEFQ) SUNAME = 'All Sources     '
C                                       If calc code OK
            CCODE = XCODE(IDSOU)(1:1)
            IF ((XCALCO(:1).EQ.' ') .OR. (CCODE.EQ.XCALCO(:1)) .OR.
     *         ((XCALCO(:1).EQ.'*') .AND. (CCODE.NE.' ')) .OR. (SAMEFQ)
     *         .OR. ((XCALCO(1:1).EQ.'-') .AND. (CCODE.EQ.' '))) THEN
               WRITE (OULINE,1131) IDSOU, SUNAME, SFREQ, SLSRV, SRF
               CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2,
     *            OULINE, IPCNT, PAGE, SCRTCH, IERR)
               IF (IERR.NE.0) GO TO 950
C                                       Rest of IF loop
               IF (NUMIF.GT.1) THEN
                  DO 140 I = 2,NUMIF
                     SFREQ = FREQ + (FOFF(I) + FREQO(I)) * 1.0D-9
                     SLSRV = LSRVEL(I) * 1.0D-3
                     SRF = RESTFQ(I) * 1.0D-9
                     WRITE (OULINE,1132) I, SFREQ, SLSRV, SRF
                     CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1,
     *                  TITL2, OULINE, IPCNT, PAGE, SCRTCH, IERR)
                     IF (IERR.NE.0) GO TO 950
 140                 CONTINUE
                  END IF
               END IF
 150        CONTINUE
C                                       Close source table
         CALL TABIO ('CLOS', 0, SURNO, BLBUFF, BLBUFF, IERR)
C                                       single source
      ELSE
         I = CATBLK(KIALT) / 256 + 1
         J = CATBLK(KIALT) - (I-1) * 256
         IF ((I.GE.1) .AND. (I.LE.2) .AND. (J.GE.1) .AND. (J.LE.3)) THEN
            SRF = CATD(KDRST) * 1.0D-9
            SLSRV = CATD(KDARV) * 1.0D-3
            SFREQ = CATD(KDCRV+JLOCF) * 1.0D-9
            WRITE (OULINE,1131) 1, SXNAME(1), SFREQ, SLSRV, SRF
            CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2,
     *         OULINE, IPCNT, PAGE, SCRTCH, IERR)
            IF (IERR.NE.0) GO TO 950
            END IF
         END IF
C                                       FQ table stuff
C                                       New page
      IF (FQEXIS) THEN
C                                       if not enough room, new page
         IF ((IPCNT+(NUMFQE*NMFQIF)+3).GT.PRTM) IPCNT = 980
         OULINE = ' '
         TITL2 = ' '
         IF (DOCRT.GT.-2.5) THEN
            CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2,
     *         OULINE, IPCNT, PAGE, SCRTCH, IERR)
            IF (IERR.NE.0) GO TO 950
C                                       FQ summary
            REFF = CATR(KRCRP+JLOCF)
            WRITE (OULINE,1150) REFF
            CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2,
     *         OULINE, IPCNT, PAGE, SCRTCH, IERR)
            IF (IERR.NE.0) GO TO 950
            END IF
C                                       List the FQ entries
         OULINE = ' '
         CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, OULINE,
     *      IPCNT, PAGE, SCRTCH, IERR)
         IF (IERR.NE.0) GO TO 950
         WRITE (TITL2,1151)
         CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, TITL2,
     *      IPCNT, PAGE, SCRTCH, IERR)
         IF (IERR.NE.0) GO TO 950
         REFF = CATD(KDCRV+JLOCF)
         DO 170 LOOP = 1, NUMFQE
            CALL TABFQ ('READ', FQBUFF, IFQRNO, FQKOLS, FQNUMV, NMFQIF,
     *         FQID, FQFRQ, FQCHBW, FQTBW, FQSIDE, BNDCOD, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READING FQ TABLE'
               GO TO 990
               END IF
            DO 160 I = 1,NMFQIF
               FQFRQ(I) = (FQFRQ(I)+REFF) * 1.0D-9
               FQTBW(I) = FQTBW(I) * 1.0E-3
               FQCHBW(I) = FQCHBW(I) * 1.0E-3
               IF (I.EQ.1) THEN
                  WRITE (OULINE,1152) FQID, I, FQFRQ(I), FQTBW(I),
     *               FQCHBW(I), FQSIDE(I), BNDCOD(I)
               ELSE
                  WRITE (OULINE,1153) I, FQFRQ(I), FQTBW(I), FQCHBW(I),
     *               FQSIDE(I), BNDCOD(I)
                  END IF
               CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2,
     *            OULINE, IPCNT, PAGE, SCRTCH, IERR)
               IF (IERR.NE.0) GO TO 950
 160           CONTINUE
 170        CONTINUE
         CALL TABFQ ('CLOS', FQBUFF, IFQRNO, FQKOLS, FQNUMV, NMFQIF,
     *      FQID, FQFRQ, FQCHBW, FQTBW, FQSIDE, BNDCOD, IRET)
         END IF
C                                       get full antenna info
      DO 200 SUBARR = 1,NSUB
         CALL GETANT (DISKIN, CNOIN, SUBARR, CATBLK, BUFFER, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'OPENING ANTENNA FILE'
            GO TO 990
            END IF
C                                       if not enough room, new page
         IF (IPCNT+NSTNS+4.GT.PRTM) IPCNT = 980
         OULINE = ' '
         TITL2 = ' '
         CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, OULINE,
     *      IPCNT, PAGE, SCRTCH, IERR)
         IF (IERR.NE.0) GO TO 950
         WRITE (OULINE,1170) SUBARR
         CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, OULINE,
     *      IPCNT, PAGE, SCRTCH, IERR)
         IF (IERR.NE.0) GO TO 950
         WRITE (OULINE,1175)
         CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2, OULINE,
     *      IPCNT, PAGE, SCRTCH, IERR)
         IF (IERR.NE.0) GO TO 950
         DO 190 LOOP = 1,NSTNS
            CALL T2DMS (STNLON(LOOP), 2, LONG, SLONG, CH1)
            CALL T2DMS (STNLAT(LOOP), 2, LAT, SLAT, CH2)
            WRITE (OULINE,1180) TELNO(LOOP), STNNAM(LOOP), STNX(LOOP),
     *         STNY(LOOP), STNZ(LOOP), CH1, LONG, SLONG, CH2, LAT, SLAT
            IF (OULINE(58:58).EQ.' ') OULINE(58:58) = '0'
            IF (OULINE(71:71).EQ.' ') OULINE(71:71) = '0'
            CALL PRTLIN (LUNP, FINDP, DOCRT, NACROS, TITL1, TITL2,
     *         OULINE, IPCNT, PAGE, SCRTCH, IERR)
            IF (IERR.NE.0) GO TO 950
 190        CONTINUE
 200     CONTINUE
      IRET = 0
      GO TO 999
C                                       Close files.
 950  IF (IERR.GT.0) THEN
         WRITE (MSGTXT,1950) IERR
         CALL MSGWRT (8)
         IRET = 1
      ELSE
         IRET = -1
         END IF
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SCANUV: ERROR',I3,' ON ',A)
 1001 FORMAT ('SCANUV: ERROR ',I3,' CHECKING ',A2,' TABLE')
 1012 FORMAT (I4,2I2)
 1030 FORMAT ('File = ',A12,'.',A6,'.',I4,' Vol =',I2,'  Userid =',I5)
 1031 FORMAT ('Freq =',F13.9,' GHz   Ncor =',I3,'   No. vis =',I10)
 1035 FORMAT ('Scan  Source',10X,'Calc',10X,'Time range',12X,
     *   'Start - end vis   Sun')
C 1035 FORMAT ('Scan      Source      Qual  Calcode Sub',9X,'Timerange',
C     *   10X,'FrqID   START VIS  END VIS')
 1040 FORMAT (I4,2X,A16,2X,A2,I4,'/',I2.2,2(':',I2.2),' -',I3,'/',I2.2,
     *   2(':',I2.2),2I10,I6)
C 1040 FORMAT (I4,1X,A16,':',I5.4,2X,A4,2X,I4,I3,'/',I2.2,2(':',I2.2),
C     *   ' - ',I3,'/',I2.2,2(':',I2.2),2X,I4,I8, 3X, I8)
 1050 FORMAT ('  ID Source',11X,' Qual Calcode ',
     *   '  IFlux   QFlux   UFlux   VFlux   No. vis')
 1051 FORMAT ('  ID Source',12X,'Qual Calcode RA(',F6.1,')     Dec(',
     *   F6.1,')    No. vis')
 1060 FORMAT ('Velocity type = ''',A8,'''    Definition = ''',A8,'''')
 1061 FORMAT ('WARNING: File contains',I4,' subarrays - vis.',
     *   ' counts may not be accurate')
 1110 FORMAT (I4,1X,A16,':',I5.4,3X,A4,1X,A1,2(I2.2,':'),F7.4,1X,A1,
     *   2(I2.2,':'),F6.3,I10)
 1111 FORMAT (I4,1X,A16,':',I5.4,3X,A4,1X,4F8.3,I10)
 1112 FORMAT (13X,'IF(',I2,')',16X,4F8.3)
 1130 FORMAT ('  ID Source',12X,'Freq(GHz) Velocity(Km/s)',
     *   ' Rest freq (GHz)')
 1131 FORMAT (I4,1X,A16,2X,F9.4,F15.4,F16.4)
 1132 FORMAT (5X,'IF(',I3,')',11X,F9.4,F15.4,F16.4)
 1150 FORMAT ('Frequency Table summary uses reference channel',F9.2)
 1151 FORMAT ('FQID IF#      Freq(GHz)      BW(kHz)   Ch.Sep(kHz)',
     *   '  Sideband  Bandcode')
 1152 FORMAT (I4,2X,I2,2X,F15.8,2X,F11.4,2X,F10.4,5X,I2,5X,A)
 1153 FORMAT (6X,I2,2X,F15.8,2X,F11.4,2X,F10.4,5X,I2,5X,A)
 1170 FORMAT (15X,'**********',4X,'Subarray',I4,4X,'**********')
 1175 FORMAT ('Ant Station',9X,'Bx',10X,'By',10X,'Bz',4X,'E Longitude',
     *   4X,'Latitude')
 1180 FORMAT (I3,1X,A8,3F12.2,1X,A1,I3.3,':',I2.2,':',F5.2,1X,A1,I2.2,
     *   ':',I2.2,':',F5.2)
 1950 FORMAT ('SCANUV: ERROR',I5,' DOING I/O TO TERMINAL')
      END
      SUBROUTINE SUNANG (OBSDAY, RA0, DEC0, SEPN)
C-----------------------------------------------------------------------
C   compute Sun angle to source
C   Inputes:
C      OBSDAY   I(6)   Date of observation: YYY, MM, DD, HH, MM, SS
C      RA0      D      Right Ascension
C      DEC0     D      Declination
C   Output
C      SEPN     D      Separation in degrees
C-----------------------------------------------------------------------
      INTEGER   OBSDAY(6)
      DOUBLE PRECISION RA0, DEC0, SEPN
C
      INCLUDE 'INCS:PSTD.INC'
      DOUBLE PRECISION SUNRA, SUNDEC, SINDEC, COSDEC, SINSUN,
     *   COSSUN, SRA
C-----------------------------------------------------------------------
      SINDEC = SIN (DEC0*DG2RAD)
      COSDEC = COS (DEC0*DG2RAD)
      SRA = RA0 * DG2RAD
      CALL SUNPOS (OBSDAY, SUNRA, SUNDEC)
      SINSUN = SIN (SUNDEC)
      COSSUN = COS (SUNDEC)
      SEPN = SINSUN * SINDEC + COSSUN * COSDEC * COS(SUNRA - SRA)
      IF (SEPN.GT.1.0D0) THEN
         SEPN = 0.0D0
      ELSE
         SEPN = RAD2DG * ACOS (SEPN)
         END IF
C
 999  RETURN
      END
      SUBROUTINE SUNPOS (OBSDAY, SUNRA, SUNDEC)
C-----------------------------------------------------------------------
C   Routine to find sun position.  this is crude, and only accurate to
C   some 10's of arcsec, but should be good enough for what we need
C   here.  I used the algorithm from Meeus, chapter 24, pp151-153.
C   Inputs:
C      OBSDAY   I(6)   Date,time: YYYY, MM, DD, HH, MM, SS
C   Outputs:
C      SUNRA    D      Sun RA in radians
C      SUNDEC   D      Sun Dec in radians
C-----------------------------------------------------------------------
      DOUBLE PRECISION SUNRA, SUNDEC
      INTEGER   OBSDAY(6)

      DOUBLE PRECISION JD, T, L0, M, E, C, SUNLON, V, R, OMEGA,
     *   LAMBDA, SL2000, EPS, EPS0
      INCLUDE 'INCS:PSTD.INC'
C-----------------------------------------------------------------------
      CALL DAT2JD (OBSDAY, JD)
C                                       eqn 24.1
      T = (JD - 2451545.0D0) / 36525.0D0
C                                       eqn 24.2
      L0 = 2.8046645D2 + 3.600076983D4 * T + 3.032D-4 * T * T
 10   IF (L0.LT.0.0D0) THEN
         L0 = L0 + 360.0D0
         GO TO 10
         END IF
 20   IF (L0.GT.360.0D0) THEN
         L0 = L0 - 360.0D0
         GO TO 20
         END IF
C                                       eqn 24.3
      M = 3.575291D2 + 3.59990503D4 * T - 1.559D-4 * T * T -
     *    4.8D-7 * T * T * T
 30   IF (M.LT.0.0D0) THEN
         M = M + 360.0D0
         GO TO 30
         END IF
 40   IF (M.GT.360.0D0) THEN
         M = M - 360.0D0
         GO TO 40
         END IF
C                                       eqn 24.4
      E = 1.6708617D-2 - 4.2037D-5 * T - 1.236D-7 * T * T
      M = M * PI / 180.0D0
      C = SIN (M) * (1.9146D0 - 4.871D-3 * T - 1.4D-5 * T * T) +
     *    SIN (2.0D0*M) * (1.9993D-2 - 1.01D-4 * T) +
     *    SIN (3.0D0*M) * 2.9D-4
      SUNLON = L0 + C
      V = M + C * PI / 180.0D0
C                                       eqn 24.5
      R = 1.000001018 * (1 - E * E) / (1 + E * COS (V))
      OMEGA = 1.2504D2 - 1.934136D3 * T
C                                       we want apparent positions,
C                                       though the difference should be
C                                       small...
C     LAMBDA = SUNLON - 5.69D-3 - 4.78D-3 * SIN (OMEGA * PI / 180.0D0)
      SL2000 = SUNLON - 1.397D-2 * (OBSDAY(1) - 2000.0D0)
      LAMBDA = SL2000 - 5.69D-3 - 4.78D-3 * SIN (OMEGA * PI / 180.0D0)
      EPS0 = 23.0D0 + 26.0D0 / 60.0D0 +
     *   (21.448D0 - 46.815D0 * T - 5.9D-4 * T * T +
     *   1.813D-3 * T * T * T) / 3600.0D0
      EPS = EPS0 + 2.56D-3 * COS (OMEGA * DG2RAD)
      EPS = EPS * DG2RAD
      LAMBDA = LAMBDA * DG2RAD
C                                       eqn 24.6
      SUNRA = ATAN2 (COS (EPS) * SIN (LAMBDA), COS (LAMBDA))
      IF (SUNRA.LT.0.0) SUNRA = SUNRA + 2.0D0 * PI
C                                       eqn 24.7
      SUNDEC = DASIN (SIN (EPS) * SIN (LAMBDA))
C
 999  RETURN
      END
      SUBROUTINE T2DMS (COORDI, NDIG, COORD, RCOORD, SIGN)
C-----------------------------------------------------------------------
C   Convert from coordinate (deg) to Degrees Minutes Seconds format
C   Input:
C      COORDI   D       Input: coordinate in radians
C      NDIG     I       Number digits in seconds display
C   Output:
C      COORD    I*(2)   Output Time in Degrees Minutes
C      RCOORD   R       Seconds
C      SIGN     C*1     sign
C-----------------------------------------------------------------------
      DOUBLE PRECISION COORDI
      REAL      RCOORD
      INTEGER   NDIG, COORD(2)
      CHARACTER SIGN*1
C
      DOUBLE PRECISION T
      INTEGER  I, J
      INCLUDE 'INCS:PSTD.INC'
C-----------------------------------------------------------------------
      T = COORDI * RAD2DG
      SIGN = ' '
      IF (COORDI.LT.0.0) THEN
         T = -T
         SIGN = '-'
         END IF
C
      COORD(1) = T
      T = (T - COORD(1)) * 60.0D0
      COORD(2) = T
      T = (T - COORD(2)) * 60.0D0
      RCOORD   = T
      J = 10 ** NDIG
      J = MAX (1, J)
      I = J*T + 0.5
C                                       Now Remove 60 seconds
      IF (I.GE.J*60) THEN
         RCOORD = RCOORD - 60.0
         COORD(2) = COORD(2) + 1
         END IF
C                                       Now Remove 60 minutes
      IF (COORD(2).GE.60) THEN
         COORD(2) = COORD(1) - 60
         COORD(1) = COORD(1) + 1
         END IF
C
 999  RETURN
      END
