LOCAL INCLUDE 'SPRMS.INC'
C                                       Local include for SPRMS
      INCLUDE 'INCS:ZPBUFSZ.INC'
      INCLUDE 'INCS:PUVD.INC'
      HOLLERITH XNAMEI(3), XCLAIN(2), XSOUR(4,30), XCALC(1), XXSTOK(1),
     *   XOPTYP(1)
      REAL      XSIN, XDISIN, XQUAL, XTIME(8), XBAND, XFREQ, XFQID,
     *   XANT(50), XBASE(50), XUVRA(2), XSUBA, XBIF, XEIF, XBCHAN,
     *   XECHAN, XDOCAL, XGUSE, XDOPOL, XPDVER, XBLVER, XFLAG, XDOBND,
     *   XBPVER, XSMOTH(3), DOWGT, SOLINT, XPIXR(2), APARM(10), FACTOR,
     *   XDOTV, XGRCHN, XLABEL, BADD(10)
      REAL      SCRBUF(512), CATOR(256)
      HOLLERITH CATOH(256)
      INTEGER   SEQIN, DISKIN, JBUFSZ, ILOCWT, CATOLD(256), INCSI,
     *   INCFI, INCIFI, OLDCNO, IXANT(50), IXBAS(50), NXANT, NXBAS,
     *   NSAMP, GRCHAN, NPARM, IOPT, NVAL, SCRTCH(256)
      LOGICAL   DESEL
      DOUBLE PRECISION CATOD(128)
      CHARACTER NAMEIN*12, CLAIN*6, OPTYPE*4, LTITLE*80
      EQUIVALENCE (CATOD, CATOH, CATOR, CATOLD)
      DOUBLE PRECISION SR(MAXCIF), SI(MAXCIF), SA(MAXCIF), SW(MAXCIF),
     *   SSR(MAXCIF), SSI(MAXCIF), SSA(MAXCIF)
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XSOUR, XQUAL, XCALC,
     *   XXSTOK, XTIME, XBAND, XFREQ, XFQID, XANT, XBASE, XUVRA, XSUBA,
     *   XBIF, XEIF, XBCHAN, XECHAN, XDOCAL, XGUSE, XDOPOL, XPDVER,
     *   XBLVER, XFLAG, XDOBND, XBPVER, XSMOTH, XOPTYP, DOWGT, SOLINT,
     *   XPIXR, APARM, FACTOR, XDOTV, XGRCHN, XLABEL, BADD
      COMMON /SPRMSS/ CATOLD, SEQIN, DISKIN, ILOCWT, INCSI, INCFI,
     *   INCIFI, OLDCNO, IXANT, IXBAS, NXANT, NXBAS,
     *   DESEL, NSAMP, GRCHAN, NPARM, IOPT, NVAL
      COMMON /CHARPM/ LTITLE, NAMEIN, CLAIN, OPTYPE
      COMMON /BUFRS/ SCRBUF, SCRTCH, JBUFSZ
      COMMON /SPDATA/ SR, SI, SA, SW, SSR, SSI, SSA
C                                       End local include for SPRMS
LOCAL END
      PROGRAM SPRMS
C-----------------------------------------------------------------------
C! Plots statistics of selected uv data
C# UV UV-util Calibration Plot
C-----------------------------------------------------------------------
C;  Copyright (C) 2020-2022
C;  Associated Universities, Inc. Washington DC, USA.
C;
C;  This program is free software; you can redistribute it and/or
C;  modify it under the terms of the GNU General Public License as
C;  published by the Free Software Foundation; either version 2 of
C;  the License, or (at your option) any later version.
C;
C;  This program is distributed in the hope that it will be useful,
C;  but WITHOUT ANY WARRANTY; without even the implied warranty of
C;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C;  GNU General Public License for more details.
C;
C;  You should have received a copy of the GNU General Public
C;  License along with this program; if not, write to the Free
C;  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge,
C;  MA 02139, USA.
C;
C;  Correspondence concerning AIPS should be addressed as follows:
C;         Internet email: aipsmail@nrao.edu.
C;         Postal address: AIPS Project Office
C;                         National Radio Astronomy Observatory
C;                         520 Edgemont Road
C;                         Charlottesville, VA 22903-2475 USA
C-----------------------------------------------------------------------
C   SPRMS plots statistics from a sample of uv data
C   Inputs:
C      AIPS adverb  Prg. name.          Description.
C      INNAME         NAMEIN        Name of input UV data.
C      INCLASS        CLAIN         Class of input UV data.
C      INSEQ          SEQIN         Seq. of input UV data.
C      INDISK         DISKIN        Disk number of input VU data.
C   full set of calibration adverbs
C      OPTYPE         OPTYPE        Type of data to process
C      SOLINT         SOLINT        Averaging time (min)
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET
      INCLUDE 'SPRMS.INC'
      REAL      PV(MAXCIF), PS(MAXCIF)
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DSEL.INC'
      DATA PRGM /'SPRMS '/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL SPRMSI (PRGM, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       read data
      CALL SPRMSR ( IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Average into plot buffers
      CALL SPRMSA (PV, PS, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Plot mean, std spectra
      CALL SPRMSP (1, PV, IRET)
      IF (IRET.EQ.0) CALL SPRMSP (2, PS, IRET)
C                                       Close down files, etc.
 990  CALL DIE (IRET, SCRTCH)
C
 999  STOP
      END
      SUBROUTINE SPRMSI (PRGN, JERR)
C-----------------------------------------------------------------------
C   SPRMSI gets input parameters for SPRMS
C   Inputs:
C      PRGN    C*6  Program name
C   Output:
C      JERR    I    Error code: 0 => ok
C                                5 => catalog troubles
C                                8 => can't start
C   Output in common:
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   Commons: /INPARM/ all input adverbs in order given by INPUTS
C                     file
C            /MAPHDR/ output file catalog header
C-----------------------------------------------------------------------
      INTEGER   JERR
      CHARACTER PRGN*6
C
      CHARACTER STAT*4, PTYPE*2
      INTEGER   IROUND, IERR, INCX, I, NFREQ, LUN
      LOGICAL   MATCH
      REAL      CATR(256), RPARM(20)
      HOLLERITH CATH(256)
      DOUBLE PRECISION CATD(128)
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'SPRMS.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      EQUIVALENCE (CATBLK, CATR, CATH, CATD)
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      CALL SELINI
      JBUFSZ = UVBFSS * 2
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      JERR = 0
C                                       Get input parameters.
      NPARM = 288
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, SCRTCH, 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, SCRTCH, 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 (4, 1, XCALC, SELCOD)
      CALL H2CHR (4, 1, XXSTOK, STOKES)
      DO 5 I = 1,10
         IBAD(I) = IROUND (BADD(I))
 5       CONTINUE
      DO 10 I = 1,30
         CALL H2CHR (16, 1, XSOUR(1,I), SOURCS(I))
 10      CONTINUE
      SELQUA = IROUND (XQUAL)
      SEQIN = IROUND (XSIN)
      DISKIN = IROUND (XDISIN)
      CALL H2CHR (4, 1, XOPTYP, OPTYPE)
      IF (ABS(FACTOR).LE.0.01) THEN
         IF (FACTOR.GE.0.0) FACTOR = 1.0
         IF (FACTOR.LT.0.0) FACTOR = -1.0
         END IF
C                                       Info for UVGET:
C                                       Put selection criteria into
C                                       correct common.
      UNAME = NAMEIN
      UCLAS = CLAIN
      UDISK = DISKIN
      USEQ = SEQIN
      DOCAL = XDOCAL.GT.0.0
      DOWTCL = DOCAL .AND. (XDOCAL.LE.99.0)
      IF (OPTYPE.EQ.'AUTO') THEN
         DOACOR = .TRUE.
         DOXCOR = .FALSE.
         OPTYPE = 'AMP'
         END IF
C                                       Set time range.
      CALL RCOPY (8, XTIME, TIMRNG)
      IF ((TIMRNG(1)+TIMRNG(2)+TIMRNG(3)+TIMRNG(4)) .EQ.0.0)
     *   TIMRNG(1)=-1.0E6
      IF ((TIMRNG(5)+TIMRNG(6)+TIMRNG(7)+TIMRNG(8)) .EQ.0.0)
     *   TIMRNG(5)=1.0E6
      TSTART = TIMRNG(1) + TIMRNG(2) / 24. + TIMRNG(3) / (24. * 60.) +
     *   TIMRNG(4) / (24. * 60. * 60.)
      TEND = TIMRNG(5) + TIMRNG(6) / 24. + TIMRNG(7) / (24. * 60.) +
     *   TIMRNG(8) / (24. * 60. * 60.)
      UVRNG(1) = XUVRA(1)
      UVRNG(2) = XUVRA(2)
      DOPOL = IROUND(XDOPOL)
      IF (XDOPOL.GT.0.0) DOPOL = MAX (1, DOPOL)
      PDVER = IROUND (XPDVER)
      DOAPPL = .FALSE.
      SUBARR = IROUND (XSUBA)
      IF (SUBARR.LT.0) SUBARR = 0
      FGVER = IROUND (XFLAG)
      DOBAND = IROUND (XDOBND)
      BPVER = IROUND (XBPVER)
      CALL RCOPY (3, XSMOTH, SMOOTH)
      CLVER = IROUND (XGUSE)
      CLUSE = IROUND (XGUSE)
      BLVER = IROUND (XBLVER)
      GRCHAN = XGRCHN + 0.1
C                                       Get CATBLK from old file.
      OLDCNO = 1
      PTYPE = 'UV'
      CALL CATDIR ('SRCH', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN,
     *   PTYPE, NLUSER, STAT, SCRTCH, 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', SCRTCH, 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                                       Get uv header info.
      CALL UVPGET (JERR)
      IF (JERR.NE.0) GO TO 999
C                                       Test OPTYPE, STOKES
      IF ((OPTYPE.NE.'AMP') .AND. (OPTYPE.NE.'PHAS') .AND.
     *   (OPTYPE.NE.'REAL') .AND. (OPTYPE.NE.'IMAG') .AND.
     *   (OPTYPE.NE.'SAMP')) THEN
         OPTYPE = 'AMP'
         MSGTXT = 'SETTING OPTYPE TO AMP'
         CALL MSGWRT (6)
         END IF
      IOPT = 1
      IF (OPTYPE.EQ.'REAL') IOPT = 2
      IF (OPTYPE.EQ.'IMAG') IOPT = 3
      IF (OPTYPE.EQ.'PHAS') IOPT = 4
      IF (OPTYPE.EQ.'SAMP') IOPT = 5
      IF (STOKES.EQ.' ') STOKES = 'I'
      IF ((STOKES.EQ.'I') .OR. (STOKES.EQ.'Q') .OR. (STOKES.EQ.'U') .OR.
     *   (STOKES.EQ.'V')) GO TO 20
      IF (CATD(KDCRV+JLOCS).LE.-5.0) THEN
         IF ((STOKES.EQ.'VV') .OR. (STOKES.EQ.'HH') .OR.
     *      (STOKES.EQ.'VH') .OR. (STOKES.EQ.'HV')) GO TO 20
      ELSE IF (CATD(KDCRV+JLOCS).LE.-1.0) THEN
         IF ((STOKES.EQ.'RR') .OR. (STOKES.EQ.'LL') .OR.
     *      (STOKES.EQ.'RL') .OR. (STOKES.EQ.'LR')) GO TO 20
         END IF
      MSGTXT = 'ONLY ONE POLARIZATION ALLOWED: NOT ' // STOKES
      JERR = 10
      GO TO 990

C                                       Channel selection?
 20   IF (JLOCIF.LT.0) THEN
         BIF = 1
         EIF = 1
      ELSE
         BIF = IROUND (XBIF)
         EIF = IROUND (XEIF)
         BIF = MIN (MAX (1, BIF), CATBLK(KINAX+JLOCIF))
         IF (EIF.LT.BIF) EIF = CATBLK(KINAX+JLOCIF)
         END IF
      NFREQ = CATBLK(KINAX+JLOCF)
      BCHAN = IROUND (XBCHAN)
      ECHAN = IROUND (XECHAN)
      IF ((BCHAN.LE.0) .OR. (BCHAN.GT.NFREQ)) BCHAN = 1
      IF ((ECHAN.LE.0) .OR. (ECHAN.GT.NFREQ)) ECHAN = NFREQ
      IF (BCHAN.GT.ECHAN) THEN
         MSGTXT = 'INVALID BCHAN AND ECHAN'
         CALL MSGWRT (6)
         JERR = 1
         GO TO 990
         END IF
C                                       Freq id
      IF (XBAND.GT.0.0) SELBAN = XBAND
      IF (XFREQ.GT.0.0) SELFRQ = XFREQ
      FRQSEL = IROUND (XFQID)
      IF (FRQSEL.EQ.0) FRQSEL = -1
      LUN = 28
      CALL FQMATC (DISKIN, OLDCNO, CATBLK, LUN, SELBAN, SELFRQ, MATCH,
     *   FRQSEL, JERR)
      IF (.NOT.MATCH) THEN
         MSGTXT = 'NO MATCH TO SELBAND/SELFREQ ADVERBS - CHECK INPUTS'
         JERR = 1
         GO TO 990
         END IF
      IF (JERR.GT.0) GO TO 999
C                                       Find baselines to copy
      CALL SETANT (50, XANT, XBASE, NXANT, NXBAS, IXANT, IXBAS, DESEL)
C                                       now using cal system -
C                                       UVGET makes header
      CALL UVGET ('INIT', RPARM, SCRBUF, JERR)
      IF (JERR.NE.0) THEN
         WRITE (MSGTXT,1035) JERR
         GO TO 990
         END IF
      CALL UVGET ('CLOS', RPARM, SCRBUF, IERR)
C                                       Save input file info
      INCX = CATBLK(KINAX)
      INCSI = INCS / INCX
      INCFI = INCF / INCX
      INCIFI = INCIF / INCX
C                                        Fill defaults for plots
      CALL RCOPY (8, TIMRNG, XTIME)
      CALL RCOPY (2, UVRNG, XUVRA)
      XBCHAN = BCHAN
      XECHAN = ECHAN
      XBIF = BIF
      XEIF = EIF
C                                        Put input file in READ
      PTYPE = 'UV'
      CALL CATDIR ('CSTA', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN,
     *   PTYPE, NLUSER, 'READ', SCRTCH, IERR)
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = OLDCNO
      FRW(NCFILE) = 0
      JERR = 0
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SPRMSI: ERROR',I3,' OBTAINING INPUT PARAMETERS')
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
     *   I3,' USID=',I5)
 1035 FORMAT ('SPRMSI: UVGET INIT ERROR',I3,' CHECK ADVERBS')
 1040 FORMAT ('ERROR',I3,' COPYING CATBLK ')
      END
      SUBROUTINE SPRMSR (IRET)
C-----------------------------------------------------------------------
C   SPRMSR reads the uv data and prepares a list of values with time
C   averaging (one or multiple times)
C   Input in common:
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   Output:
C      IRET    I      Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INTEGER   IA1, IA2, ICODE
      LOGICAL   REQBAS
      INCLUDE 'SPRMS.INC'
      REAL      BASEN, VIS(UVBFSS), RPARM(20), LTIME, TIME, RR(MAXCIF),
     *   RI(MAXCIF), RW(MAXCIF)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
C-----------------------------------------------------------------------
C                                       Open and init for read
      CALL UVGET ('INIT', RPARM, VIS, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET
         GO TO 990
         END IF
      CALL UVPGET (IRET)
      IF (SOLINT.LE.0.0) SOLINT = 0.007
      SOLINT = SOLINT / (60.0 * 24.0)
      LTIME = -100.
      IF (DOWGT.GT.0.0) ICODE = 1
      NSAMP = 0
C                                       Loop
C                                       Read vis. record.
 100  CALL UVGET ('READ', RPARM, VIS, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1100) IRET
         GO TO 990
C                                       Loop over buffer
      ELSE IF (IRET.EQ.0) THEN
         IF (ILOCB.GE.0) THEN
            BASEN = RPARM(1+ILOCB)
            IA1 = BASEN / 256. + 0.1
            IA2 = BASEN - IA1*256. + 0.1
         ELSE
            IA1 = RPARM(1+ILOCA1) + 0.1
            IA2 = RPARM(1+ILOCA2) + 0.1
            END IF
         IF (.NOT.REQBAS (IA1, IA2, DESEL, IXANT, NXANT, IXBAS, NXBAS))
     *      GO TO 100
         TIME = RPARM(1+ILOCT)
         IF (DOWGT.GT.0.0) THEN
            CALL SPRMSG (ICODE, VIS, RR, RI, RW)
            NSAMP = NSAMP + 1
         ELSE
            IF (TIME.GT.LTIME+SOLINT) THEN
               ICODE = 2
               LTIME = TIME
            ELSE
               ICODE = 3
               END IF
C                                       call user routine
            CALL SPRMSG (ICODE, VIS, RR, RI, RW)
            NSAMP = NSAMP + 1
            END IF
C                                       Read next buffer.
         GO TO 100
         END IF
C                                       Final value
      ICODE = 2
      IF (DOWGT.LE.0.0) CALL SPRMSG (ICODE, VIS, RR, RI, RW)
C                                       Close files
      CALL UVGET ('CLOS', RPARM, VIS, IRET)
C                                       close NX table
      IRET = 0
      IF (NSAMP.LE.0) THEN
         IRET = 10
         MSGTXT = 'NO DATA SAMPLES FOUND'
         GO TO 990
         END IF
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SPRMSR: ERROR',I3,' OPEN/INIT INPUT VIS FILE')
 1100 FORMAT ('SPRMSR: ERROR',I3,' READING VIS FILE')
      END
      SUBROUTINE SPRMSG (ICODE, VIS, RR, RI, RW)
C-----------------------------------------------------------------------
C   Finds the requested value from the current data
C   Inputs:
C      ICODE    I       1: VIS straight to global summers
c                       2: Average RR/RI -> new sum in RR/RI
c                       3: sum into RR/RI
C      VIS     R(3,*)   Visibilities in order real, imaginary, weight
C   Inputs from COMMON:
C      CATBLK   I(256)  Catalog header record. See Going Aips for
C                       details.
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      DOWGT    R       > 0 do not average the output
C   In/out:
C      RR       R(*)    Local sum value real part
C      RI       R(*)    Local sum value imag part
C      RW       R(*)    Local sum weights
C-----------------------------------------------------------------------
      INTEGER   ICODE
      REAL      VIS(3,*), RR(*), RI(*), RW(*)
C
      INTEGER   JIF, JF, JS, NIF, NF, NS, INDEXI, I
      REAL      VR, VI, VW, VA
      INCLUDE 'SPRMS.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
C-----------------------------------------------------------------------
C                                       pointers to traverse the data
      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)
      NVAL = NS * NIF * NF
C                                       straight to global
      IF (ICODE.EQ.1) THEN
         I = 0
         DO 40 JIF = 1,NIF
            DO 30 JF = 1,NF
               DO 20 JS = 1,NS
                  I = I + 1
                  INDEXI = (JIF-1) * INCIFI + (JF-1) * INCFI +
     *               (JS-1) * INCSI + 1
                  VR = VIS(1,INDEXI)
                  VI = VIS(2,INDEXI)
                  VW = VIS(3,INDEXI)
                  VA = SQRT (VR*VR + VI*VI)
                  IF (VW.GT.0.0) THEN
                     SR(I) = SR(I) + VW * VR
                     SI(I) = SI(I) + VW * VI
                     SA(I) = SA(I) + VW * VA
                     SSR(I) = SSR(I) + VW * VR * VR
                     SSI(I) = SSI(I) + VW * VI * VI
                     SSA(I) = SSA(I) + VW * VA * VA
                     SW(I) = SW(I) + VW
                     END IF
 20               CONTINUE
 30            CONTINUE
 40         CONTINUE
C                                       avg to global, start new
      ELSE IF (ICODE.EQ.2) THEN
         DO 100 I = 1,NVAL
            VW = RW(I)
            IF (VW.GT.0.0) THEN
               VR = RR(I) / VW
               VI = RI(I) / VW
               VA = SQRT (VR*VR + VI*VI)
               VW = 1.0
               SR(I) = SR(I) + VR
               SI(I) = SI(I) + VI
               SA(I) = SA(I) + VA
               SSR(I) = SSR(I) + VR * VR
               SSI(I) = SSI(I) + VI * VI
               SSA(I) = SSA(I) + VA * VA
               SW(I) = SW(I) + 1.0
               END IF
 100        CONTINUE
         I = 0
         DO 140 JIF = 1,NIF
            DO 130 JF = 1,NF
               DO 120 JS = 1,NS
                  I = I + 1
                  INDEXI = (JIF-1) * INCIFI + (JF-1) * INCFI +
     *               (JS-1) * INCSI + 1
                  VR = VIS(1,INDEXI)
                  VI = VIS(2,INDEXI)
                  VW = VIS(3,INDEXI)
                  IF (VW.GT.0.0) THEN
                     RR(I) = VW * VR
                     RI(I) = VW * VI
                     RW(I) = VW
                  ELSE
                     RR(I) = 0.0
                     RI(I) = 0.0
                     RW(I) = 0.0
                     END IF
 120              CONTINUE
 130           CONTINUE
 140        CONTINUE
C                                       sum into local only
      ELSE IF (ICODE.EQ.3) THEN
         I = 0
         DO 240 JIF = 1,NIF
            DO 230 JF = 1,NF
               DO 220 JS = 1,NS
                  I = I + 1
                  INDEXI = (JIF-1) * INCIFI + (JF-1) * INCFI +
     *               (JS-1) * INCSI + 1
                  VR = VIS(1,INDEXI)
                  VI = VIS(2,INDEXI)
                  VW = VIS(3,INDEXI)
                  IF (VW.GT.0.0) THEN
                     RR(I) = RR(I) + VW * VR
                     RI(I) = RI(I) + VW * VI
                     RW(I) = RW(I) + VW
                     END IF
 220              CONTINUE
 230           CONTINUE
 240        CONTINUE
         END IF
C
 999  RETURN
      END
      SUBROUTINE SPRMSA (PV, PS, IRET)
C-----------------------------------------------------------------------
C   SPRMSA averages the desired type
C   Outputs:
C      PV   R(*)   Spectrum of desired type
C      Ps   R(*)   Spectrum of std of desired type
C-----------------------------------------------------------------------
      INTEGER   IRET
      REAL      PV(*), PS(*)
C
      INCLUDE 'SPRMS.INC'
      INTEGER   I, J
      DOUBLE PRECISION VR, VI, UR, UI, VA
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:PSTD.INC'
C-----------------------------------------------------------------------
      J = 0
C                                       vector amplitude
      IF (IOPT.EQ.1) THEN
         DO 110 I = 1,NVAL
            IF (SW(I).LE.0.0) THEN
               PV(I) = FBLANK
               PS(I) = FBLANK
            ELSE
               J = J + 1
               VR = SR(I) / SW(I)
               VI = SI(I) / SW(I)
               PV(I) = SQRT (VR*VR + VI*VI)
               UR = SSR(I) / SW(I) - VR * VR
               UI = SSI(I) / SW(I) - VI * VI
               UR = MAX (0.0, UR)
               UI = MAX (0.0, UI)
               IF (PV(I).LE.0.0) THEN
                  PS(I) = FBLANK
               ELSE
                  PS(I) = SQRT (VR*VR*UR + VI*VI*UI) / PV(I)
                  END IF
               END IF
 110        CONTINUE
C                                       real part
      ELSE IF (IOPT.EQ.2) THEN
         DO 120 I = 1,NVAL
            IF (SW(I).LE.0.0) THEN
               PV(I) = FBLANK
               PS(I) = FBLANK
            ELSE
               J = J + 1
               VR = SR(I) / SW(I)
               PV(I) = vr
               UR = SSR(I) / SW(I) - VR * VR
               UR = SQRT (MAX (0.0, UR))
               PS(I) = UR
               END IF
 120        CONTINUE
C                                       imaginary part
      ELSE IF (IOPT.EQ.3) THEN
         DO 130 I = 1,NVAL
            IF (SW(I).LE.0.0) THEN
               PV(I) = FBLANK
               PS(I) = FBLANK
            ELSE
               J = J + 1
               VI = SI(I) / SW(I)
               PV(I) = VI
               UI = SSI(I) / SW(I) - VI * VI
               UI = SQRT (MAX (0.0, UI))
               PS(I) = UI
               END IF
 130        CONTINUE
C                                       vector phase
      ELSE IF (IOPT.EQ.4) THEN
         DO 140 I = 1,NVAL
            PV(I) = FBLANK
            PS(I) = FBLANK
            IF (SW(I).GT.0.0) THEN
               VR = SR(I) / SW(I)
               VI = SI(I) / SW(I)
               VA = VR*VR + VI*VI
               IF (VA.GT.0.0) THEN
                  J = J + 1
                  PV(I) = RAD2DG * ATAN2 (VI, VR)
                  UR = SSR(I) / SW(I) - VR * VR
                  UI = SSI(I) / SW(I) - VI * VI
                  UR = MAX (0.0, UR)
                  UI = MAX (0.0, UI)
                  PS(I) = RAD2DG * SQRT (VR*VR*UI + VI*VI*UR) / VA
                  END IF
               END IF
 140        CONTINUE
C                                       scalar amplitude
      ELSE IF (IOPT.EQ.5) THEN
         DO 150 I = 1,NVAL
            IF (SW(I).LE.0.0) THEN
               PV(I) = FBLANK
               PS(I) = FBLANK
            ELSE
               J = J + 1
               VR = SA(I) / SW(I)
               PV(I) = VR
               UR = SSA(I) / SW(I) - VR * VR
               UR = SQRT (MAX (0.0, UR))
               PS(I) = UR
               END IF
 150        CONTINUE
         END IF
      IF (J.LE.0) THEN
         MSGTXT = 'SPRMSA: NO POINTS FOUND'
         CALL MSGWRT (8)
         IRET = 10
      ELSE
         IRET = 0
         END IF
C
 999  RETURN
      END
      SUBROUTINE SPRMSP (ITYPE, SP, IRET)
C-----------------------------------------------------------------------
C    SPRMSP plots the the mean and std spectra
C    Inputs:
C       ITYPE    I       1 mean, 2 std
C       STOKES   C*(*)   Stokes string
C       SP       R(*)    spectrum to plot
C    Outputs:
C       IRET     I       > 0 => plot failure
C-----------------------------------------------------------------------
      INTEGER   ITYPE, IRET
      REAL      SP(*)
C
      INCLUDE 'SPRMS.INC'
      INTEGER   I, PLUN, IOBLK(256), IVER, TVCHN, TVCORN(4), IDEPTH(5),
     *   J, LTYPE, LABEL, PIND, IROUND, NC, NI, CATSAV(256), JC, JI
      LOGICAL   DOTV, GOOD
      CHARACTER PFILE*48, CHT12*12, CHT6*6, CHTY*2, PTYPE(5)*20
      REAL      YMAX, YMIN, BLC(2), TRC(2), CH(4), X, FAC, XYRATO, DX,
     *   DY, XMIN, XMAX, LOCRAN(2), XYRAT, Y
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DSEL.INC'
      INCLUDE 'INCS:DTVC.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DGPH.INC'
      INCLUDE 'INCS:DDCH.INC'
      DATA TVCHN, TVCORN, IDEPTH /1, 4*0, 5*1/
      DATA PTYPE /'Amplitude (Jy)', 'Real part (Jy)', 'Imaginary (Jy)',
     *   'Phase (degrees)', 'Scalar amp (Jy)'/
C-----------------------------------------------------------------------
      DOTV = XDOTV.GT.0.0
C                                       Y scale
      YMAX = -1.E10
      YMIN = -YMAX
      NC = (ECHAN - BCHAN + 1)
      NI = (EIF - BIF + 1)
      JC = NC * NI
      DO 10 I = 1,JC
         IF (SP(I).NE.FBLANK) THEN
            YMIN = MIN (YMIN, SP(I))
            YMAX = MAX (YMAX, SP(I))
            END IF
 10      CONTINUE
      IF (ITYPE.EQ.1) THEN
         IF (XPIXR(2).GT.XPIXR(1)) THEN
            YMAX = XPIXR(2)
            YMIN = XPIXR(1)
            END IF
      ELSE IF (ITYPE.EQ.2) THEN
         IF (APARM(2).GT.APARM(1)) THEN
            YMAX = APARM(2)
            YMIN = APARM(1)
            END IF
         END IF
      IF (ITYPE.EQ.1) THEN
         XPIXR(2) = YMAX + 0.04 * (YMAX - YMIN)
         XPIXR(1) = YMIN - 0.04 * (YMAX - YMIN)
         YMAX = XPIXR(2)
         YMIN = XPIXR(1)
      ELSE
         APARM(2) = YMAX + 0.04 * (YMAX - YMIN)
         APARM(1) = YMIN - 0.04 * (YMAX - YMIN)
         YMAX = APARM(2)
         YMIN = APARM(1)
         END IF
      XMIN = 0.0
      XMAX = (NC + 1) * NI
C                                       Add plot file to the image
C                                       catalog header.
      IF (.NOT.DOTV) THEN
         CHT12 = ' '
         CHT6 = ' '
         CHTY = ' '
         IVER = 0
         IF (ITYPE.EQ.1) THEN
            CALL CATDIR ('CSTA', DISKIN, OLDCNO, CHT12, CHT6, 0, CHTY,
     *         0, 'CLRD', IOBLK, IRET)
            IF (IRET.EQ.0) CALL CATDIR ('CSTA', DISKIN, OLDCNO, CHT12,
     *         CHT6, 0, CHTY, 0, 'WRIT', IOBLK, IRET)
            FRW(NCFILE) = 1
            END IF
         CALL MADDEX ('PL', DISKIN, OLDCNO, CATOLD, IOBLK, .TRUE.,
     *      'WRIT', IVER, IRET)
         IF (IRET.NE.0) THEN
            MSGTXT = 'PLHGM: ERROR UPDATING CATALOGUE HEADER.'
            CALL MSGWRT (8)
            GO TO 999
            END IF
         END IF
C                                       Open the PLot file.
      CALL ZPHFIL ('PL', DISKIN, OLDCNO, IVER, PFILE, IRET)
      APARM(10) = ITYPE
      SOLINT = SOLINT * 24.0 * 60.0
      CALL GINIT (DISKIN, OLDCNO, PFILE, 0, 68, NPARM, XNAMEI, DOTV,
     *   TVCHN, GRCHAN, TVCORN, CATOLD, IOBLK, PLUN, PIND, IRET)
      IF (IRET.NE.0) THEN
         MSGTXT = 'PLHGM: ERROR OPENING PLOT FILE FOR THE HISTOGRAM.'
         CALL MSGWRT (8)
         IF (.NOT.DOTV) CALL DELEXT ('PL', DISKIN, OLDCNO, 'WRIT',
     *      CATOLD, IOBLK, IVER, I)
         GO TO 999
         END IF
      SOLINT = SOLINT / (24.0 * 60.0)
C                                       Set character offsets.
      LABEL = IROUND (XLABEL)
      LTYPE = MOD (ABS (LABEL), 100)
      LOCRAN(2) = YMAX
      LOCRAN(1) = YMIN
      CALL GTICNT (LABEL, LOCRAN, I)
      CALL RFILL (4, 0.5, CH)
      IF (LTYPE.EQ.2) CH(1) = 3.5
      IF (LTYPE.GT.2) CH(1) = I + 4.0
      IF (LTYPE.GT.1) CH(2) = 2.0
      IF (LTYPE.GT.2) CH(2) = CH(2) + 1.333
      IF ((LTYPE.GT.1) .AND. (LTYPE.LT.7)) THEN
         CH(2) = CH(2) + 1.333
         CH(4) = 2.0
         IF (LABEL.GT.0) CH(4) = CH(4) + 1.333
         END IF
C                                       Set BLC, TRC, XYRATO.
      BLC(1) = XMIN
      TRC(1) = XMAX
      BLC(2) = YMIN
      TRC(2) = YMAX
      IF (DOTV) THEN
         DX = WINDTV(3) - WINDTV(1) + 1 - CSIZTV(1) * (CH(1) + CH(3))
         DY = WINDTV(4) - WINDTV(2) + 1 - CSIZTV(2) * (CH(2) + CH(4))
         XYRATO = 1.0
         IF (DY.GT.0.0) XYRATO = DX / DY
      ELSE
         XYRATO = 1.0
         END IF
      XYRAT = (TRC(1) - BLC(1)) / (TRC(2) - BLC(2))
C                                       Kludge to keep XYRATO in bounds
C                                       to prevent overflow in GINITL.
      FAC = 1.0
      IF (XYRAT.GT.3.0) THEN
         DO 15 I = 1,10000
            IF (XYRAT.LT.2.0) GO TO 20
            FAC = FAC / 2.
            XYRAT = XYRAT / 2.
 15      CONTINUE
      ELSE IF (XYRAT.LT.0.333) THEN
         DO 16 I = 1,10000
            IF (XYRAT.GT.0.50) GO TO 20
            FAC = FAC * 2.
            XYRAT = XYRAT * 2.
 16         CONTINUE
         END IF
C
 20   TRC(2) = TRC(2) / FAC
      BLC(2) = BLC(2) / FAC
      XYRAT = XYRATO / XYRAT
C                                       Initialize for line drawing
      CALL GINITL (BLC, TRC, XYRAT, CH, IDEPTH, IOBLK, IRET)
      IF (IRET.NE.0) THEN
         MSGTXT = 'DRWHGM: ERROR INITIALIZING FOR LINE DRAWING.'
         GO TO 950
         END IF
      CALL GLTYPE (1, IOBLK, IRET)
      IF (IRET.NE.0) GO TO 920
C                                       Draw borders.
      CALL GPOS (BLC(1), BLC(2), IOBLK, IRET)
      IF (IRET.NE.0) GO TO 910
      CALL GVEC (TRC(1), BLC(2), IOBLK, IRET)
      IF (IRET.NE.0) GO TO 920
      CALL GVEC (TRC(1), TRC(2), IOBLK, IRET)
      IF (IRET.NE.0) GO TO 920
      CALL GVEC (BLC(1), TRC(2), IOBLK, IRET)
      IF (IRET.NE.0) GO TO 920
      CALL GVEC (BLC(1), BLC(2), IOBLK, IRET)
      IF (IRET.NE.0) GO TO 920
C                                       dividers
      DO 25 I = 1,NI-1
         X = I * (NC + 1.0)
         CALL GPOS (X, TRC(2), IOBLK, IRET)
         IF (IRET.NE.0) GO TO 999
         CALL GVEC (X, BLC(2), IOBLK, IRET)
         IF (IRET.NE.0) GO TO 999
 25      CONTINUE
C                                       Labeling.
      CALL COPY (256, CATBLK, CATSAV)
      CALL COPY (256, CATOLD, CATBLK)
      CALL RMSLAB (ITYPE, PTYPE(IOPT), STOKES, BLC, TRC, FAC, NC, NI,
     *   BCHAN, BIF, IVER, LABEL, IOBLK, IRET)
      IF (IRET.NE.0) GO TO 999
C                                       Draw the data
      CALL GLTYPE (2, IOBLK, IRET)
      IF (IRET.NE.0) GO TO 920
      I = 0
      J = 0
      DX = 0.5 * ABS(FACTOR)
      DY = 0.5 * (TRC(2) - BLC(2)) / ((NC + 1.0)* NI) * ABS(FACTOR)
      CALL GPOS (X, 1.0, IOBLK, IRET)
      IF (IRET.NE.0) GO TO 910
      DO 50 JI = 1,NI
         DO 40 JC = 1,NC
            I = I + 1
            X = I
            J = J + 1
            IF (SP(J).NE.FBLANK) THEN
               Y = (SP(J) - YMIN) / (YMAX - YMIN) * (TRC(2)-BLC(2)) +
     *            BLC(2)
               IF ((Y.GT.BLC(2)) .AND. (Y.LT.TRC(2))) THEN
                  CALL GPOS (X-DX, Y+DY, IOBLK, IRET)
                  IF (IRET.NE.0) GO TO 910
                  CALL GVEC (X+DX, Y-DY, IOBLK, IRET)
                  IF (IRET.NE.0) GO TO 920
                  CALL GPOS (X+DX, Y+DY, IOBLK, IRET)
                  IF (IRET.NE.0) GO TO 910
                  CALL GVEC (X-DX, Y-DY, IOBLK, IRET)
                  IF (IRET.NE.0) GO TO 920
                  END IF
               END IF
  40        CONTINUE
         I = I + 1
  50     CONTINUE
      IF (FACTOR.LT.0.0) THEN
         CALL GLTYPE (4, IOBLK, IRET)
         IF (IRET.NE.0) GO TO 920
         I = 0
         J = 0
         DO 70 JI = 1,NI
            GOOD = .FALSE.
            DO 60 JC = 1,NC
               I = I + 1
               X = I
               J = J + 1
               IF (SP(J).NE.FBLANK) THEN
                  Y = (SP(J) - YMIN) / (YMAX - YMIN) * (TRC(2)-BLC(2)) +
     *               BLC(2)
                  IF ((Y.GT.BLC(2)) .AND. (Y.LT.TRC(2))) THEN
                     IF (GOOD) THEN
                        CALL GVEC (X, Y, IOBLK, IRET)
                        IF (IRET.NE.0) GO TO 920
                     ELSE
                        CALL GPOS (X, Y, IOBLK, IRET)
                        IF (IRET.NE.0) GO TO 910
                        END IF
                     GOOD = .TRUE.
                  ELSE
                     GOOD = .FALSE.
                     END IF
               ELSE
                  GOOD = .FALSE.
                  END IF
  60           CONTINUE
            I = I + 1
  70        CONTINUE
         END IF
      GPHPAG = ITYPE.EQ.1
      CALL GFINIS (IOBLK, IRET)
      IF (IRET.NE.0) GO TO 950
      CALL COPY (256, CATBLK, CATOLD)
      CALL COPY (256, CATSAV, CATBLK)
      GO TO 999
C                                       Error return from GPOS.
 910  MSGTXT = 'SPRMSP: PLOT ERROR OCCURRED WHILE MOVING TO A POINT.'
      GO TO 940
C                                       Error return from GVEC.
 920  MSGTXT = 'SPRMSP: PLOT ERROR OCCURRED WHILE DRAWING A LINE.'
 940  CALL MSGWRT (8)
 950  WRITE (MSGTXT,1950) IVER
      CALL MSGWRT (8)
C                                       Destroy the PLot file on error.
      IF (.NOT.DOTV) THEN
         CALL ZCLOSE (PLUN, PIND, I)
         CALL ZDESTR (DISKIN, PFILE, I)
         CALL DELEXT ('PL', DISKIN, OLDCNO, 'WRIT', CATOLD, IOBLK,
     *      IVER, I)
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1950 FORMAT ('DESTROY PLOT VERSION',I4,' DUE TO ERRORS')
      END
      SUBROUTINE RMSLAB (ITY, UNITS, CSTOK, BLC, TRC, FAC, NC, NI,
     *   LBCHAN, LBIF, IVER, LABEL, BUFF1, IRET)
C-----------------------------------------------------------------------
C   Write labeling for SPRMS plots
C   Inputs:
C      ITY     I        Plot type: 1 for mean, 2 std
C      UNITS   C*(*)    vertical axis label
C      CSTOK   C*(*)    vertical axis label
C      BLC     R(2)     bottom left corner of plot.
C      TRC     R(2)     top right hand corner of plot.
C      FAC     R        FAC*XYRATO = real XYRATIO.
C      IVER    I        plot file version number
C      LABEL   I        labeling type
C   In/out:
C      BUFF1   I(256)   I/O buffer for plot file.
C   Output:
C      IRET    I        error code returned from GVEC.
C-----------------------------------------------------------------------
      REAL      BLC(2), TRC(2), FAC
      INTEGER   ITY, NC, NI, LBCHAN, LBIF, IVER, LABEL, BUFF1(256), IRET
      CHARACTER UNITS*(*), CSTOK*(*)
C
      CHARACTER PREFIX(2)*5, TIME*8, DATE*12, CTEMP*8, NAMSTR*18,
     *   MSGBUF*80
      LOGICAL   PFLAG
      REAL      XINTER(24), DCX, DCY, DIST, ODIST, TICSCL, XVAL, YTICEL,
     *   YTICER, YPOS, TICLEN, XINT, X, FREQ, DCXM, XDIST, DTRC, DBLC,
     *   DEG, DU, DL
      INTEGER   INOINT, INCHAR, I, IXO, NXFR, NAX, INC, IANGL,
     *   IT(3), ID(3), ICPNT, ITMP, LTYPE, LECHAN
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      DATA TICSCL /70.0/
      DATA XINTER /.001, .002, .005, .01, .02, .05, .1, .2, .5,
     *   1., 2., 5., 10., 20., 50., 100., 200., 500.,
     *   1000., 2000., 5000., 10000., 20000., 50000./
C-----------------------------------------------------------------------
      LTYPE = MOD (ABS(LABEL), 100)
      IF (LTYPE.LE.1) GO TO 999
      LECHAN = LBCHAN + NC - 1
C                                       Tic positions.
      TICLEN = (TRC(1) - BLC(1)) / TICSCL
      YTICEL = BLC(1) + TICLEN
      YTICER = TRC(1) - TICLEN
C                                       Find vertical interval value.
      DIST = FAC * (TRC(2) - BLC(2))
      ODIST = DIST
      CALL METSCL (LABEL, DIST, PREFIX(2), PFLAG)
      IF (PFLAG) GO TO 110
      XDIST = DIST / ODIST
      DTRC = FAC * XDIST * TRC(2)
      DBLC = FAC * XDIST * BLC(2)
      XINT = 8.0
      DO 20 I = 1,24
         DEG = XINTER(I)
         DU = AINT (DTRC / DEG) * DEG
         IF (DU.GT.DTRC) DU = DU - DEG
         DL = AINT (DBLC / DEG) * DEG
         IF (DL.LT.DBLC) DL = DL + DEG
         INOINT = (DU - DL) / DEG + 1.001
         IF (INOINT.LE.XINT) GO TO 30
 20      CONTINUE
      GO TO 110
C                                       Interval and no of inter found.
 30   XINT = DEG
      INOINT = INOINT + 2
      ODIST = XDIST * FAC * BLC(2)
      XVAL = AINT (ODIST/XINT) * XINT
      IF (XVAL.GE.ODIST) XVAL = XVAL - XINT
      IXO = I
      DCXM = -0.5
C                                       Loop for all tics.
      DO 100 I = 1,INOINT
         XVAL = XVAL + XINT
         YPOS = XVAL / FAC / XDIST
         IF (YPOS.GT.TRC(2)) GO TO 110
C                                       right hand tic.
         CALL GPOS (TRC(1), YPOS, BUFF1, IRET)
         IF (IRET.NE.0) GO TO 999
         CALL GVEC (YTICER, YPOS, BUFF1, IRET)
         IF (IRET.NE.0) GO TO 999
C                                       Left hand tic.
         CALL GPOS (YTICEL, YPOS, BUFF1, IRET)
         IF (IRET.NE.0) GO TO 999
         CALL GVEC (BLC(1), YPOS, BUFF1, IRET)
         IF (IRET.NE.0) GO TO 999
C                                       Write value.
         IF (LTYPE.GT.2) THEN
            WRITE (MSGBUF,1030) XVAL
            CALL CHTRIM (MSGBUF, 14, MSGBUF, INCHAR)
            IF (IXO.GT.3) INCHAR = INCHAR - 1
            IF (IXO.GT.6) INCHAR = INCHAR - 1
            IF (IXO.GT.9) INCHAR = INCHAR - 2
            DCX = - INCHAR - 1.0
            DCY = -0.5
            DCXM = MIN (DCXM, DCX)
            CALL GCHAR (INCHAR, 0, DCX, DCY, MSGBUF, BUFF1, IRET)
            IF (IRET.NE.0) GO TO 999
            END IF
 100     CONTINUE
C                                       RMS
 110  DCX = DCXM - 2.0
      YPOS = (TRC(2) + BLC(2)) / 2.0
      CALL GPOS (BLC(1), YPOS, BUFF1, IRET)
      IF (IRET.NE.0) GO TO 999
      IF (ITY.EQ.1) THEN
         MSGBUF = PREFIX(2) // ' Mean'
      ELSE IF (ITY.EQ.2) THEN
         MSGBUF = PREFIX(2) // ' std'
         END IF
      CALL CHTRIM (MSGBUF, 80, MSGBUF, INCHAR)
      MSGBUF(INCHAR+2:) = UNITS
      CALL CHTRIM (MSGBUF, 80, MSGBUF, INCHAR)
      DCY = INCHAR / 2.0 - 1.0
      CALL GCHAR (INCHAR, 1, DCX, DCY, MSGBUF, BUFF1, IRET)
      IF (IRET.NE.0) GO TO 999
C                                       Nchan, BIF, EIF
      IF (LTYPE.LT.7) THEN
         MSGBUF = 'IF'
         DCY = -2.833 - 1.333
         IF (LTYPE.EQ.2) DCY = -2.833
         XDIST = (TRC(1) - BLC(1)) / NI
         DO 120 I = 1,NI
            ITMP = LBIF + I - 1
            IF ((I.EQ.1) .OR. (NI.LE.4)) THEN
               IF (ITMP.LT.10) THEN
                  WRITE (MSGBUF(4:),1110) ITMP
               ELSE
                  WRITE (MSGBUF(4:),1111) ITMP
                  END IF
            ELSE
               IF (ITMP.LT.10) THEN
                  WRITE (MSGBUF(1:),1110) ITMP
               ELSE
                  WRITE (MSGBUF(1:),1111) ITMP
                  END IF
               END IF
            CALL REFRMT (MSGBUF, '_', INCHAR)
            X = (I - 0.5) * XDIST
            CALL GPOS (X, BLC(2), BUFF1, IRET)
            IF (IRET.NE.0) GO TO 999
            DCX = -INCHAR/2.0
            CALL GCHAR (INCHAR, 0, DCX, DCY, MSGBUF, BUFF1, IRET)
            IF (IRET.NE.0) GO TO 999
 120        CONTINUE
         END IF
C                                       Determine label range
      CALL PINLAB (BLC, TRC, LBCHAN, LECHAN, NI, LABEL, BUFF1, IRET)
      IF (IRET.NE.0) GO TO 999
C                                       Label with prefix
      DCY = -1.5
      IF (LTYPE.GT.2) DCY = -2.833
      X = (TRC(1) + BLC(1)) / 2.0
      CALL GPOS (X, BLC(2), BUFF1, IRET)
      IF (IRET.NE.0) GO TO 999
      MSGBUF = 'Spectral channels'
      CALL CHTRIM (MSGBUF, 17, MSGBUF, INCHAR)
      DCX = 0.5 - INCHAR / 2.0
      CALL GCHAR (INCHAR, 0, DCX, DCY, MSGBUF, BUFF1, IRET)
      IF (IRET.NE.0) GO TO 999
      IF (LTYPE.GE.7) GO TO 999
C                                       which axis is which?
      NXFR = 0
      NAX = CATBLK(KIDIM)
      INC = 2
      DO 200 I = 1,NAX
         ICPNT = KHCTP+(I-1)*INC
         CALL H2CHR (8, 1, CATH(ICPNT), CTEMP)
         IF (CTEMP(1:4).EQ.'FREQ') NXFR  = I
 200     CONTINUE
C                                       Source name, stokes, freq.
      CALL GPOS (BLC(1), TRC(2), BUFF1, IRET)
      IF (IRET.NE.0) GO TO 999
      DCX = 0.0
      DCY = 0.5
      IANGL = 0
      CALL H2CHR (8, 1, CATH(KHOBJ), CTEMP)
      FREQ = 0.0
      IF (NXFR.GT.2) FREQ = CATD(KDCRV+NXFR-1)
      FREQ = FREQ / 1.E6
      IF (NXFR.GT.2) WRITE (MSGBUF,1200) CTEMP, CSTOK, FREQ
      IF (NXFR.LE.2) WRITE (MSGBUF,1200) CTEMP, CSTOK
      CALL REFRMT (MSGBUF, '_', INCHAR)
C                                       image name
      INCHAR = INCHAR + 1
      IF (INCHAR.GT.1) THEN
         MSGBUF(INCHAR:INCHAR+2) = '  _'
         INCHAR = INCHAR + 3
         END IF
      CALL H2CHR (12, KHIMNO, CATH(KHIMN), NAMSTR(1:12))
      CALL H2CHR (6, KHIMCO, CATH(KHIMC), NAMSTR(13:18))
      CALL NAMEST (NAMSTR, CATBLK(KIIMS), MSGBUF(INCHAR:), ITMP)
      CALL REFRMT (MSGBUF, '_', INCHAR)
      CALL GCHAR (INCHAR, 0, DCX, DCY, MSGBUF, BUFF1, IRET)
      IF (IRET.NE.0) GO TO 999
C                                       time/date, version
      IF (LABEL.GT.0) THEN
         CALL GPOS (BLC(1), TRC(2), BUFF1, IRET)
         IF (IRET.NE.0) GO TO 999
         CALL ZDATE (ID)
         CALL ZTIME (IT)
         CALL TIMDAT (IT, ID, TIME, DATE)
         WRITE (MSGBUF,1210) IVER, DATE, TIME
         CALL REFRMT (MSGBUF, '_', INCHAR)
         DCY = DCY + 1.333
         CALL GCHAR (INCHAR, 0, DCX, DCY, MSGBUF, BUFF1, IRET)
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1030 FORMAT (F14.3)
 1110 FORMAT (I1)
 1111 FORMAT (I2)
 1200 FORMAT (A,'  _',A4,'_ ',F10.3,' MHz')
 1210 FORMAT ('Plot file version',I4,'__created ',A,A)
      END
      SUBROUTINE PINLAB (BLC, TRC, BC, EC, NG, ILTYPE, BUFFER, IERR)
C-----------------------------------------------------------------------
C   To do X axis where we have multiple sub panels with integer counts
C   Inputs:
C      BLC      R(2)    X, Y pixels to form bottom left hand corner
C      TRC      R(2)    X, Y pixels to form the top right hand corner
C      BC       I       Begin count
C      EC       I       End count
C      NG       I       Number of such groups
C      ILTYPE   I       label type: 1 none, 2 no ticks, 3 RA/DEC
C                          4 center relative
C   In/out:
C      BUFFER   I(256)  the updated graphics output buffer.
C      IERR     I       error indicator: 0 = No error.
C-----------------------------------------------------------------------
      REAL      BLC(2), TRC(2)
      INTEGER   BC, EC, NG, ILTYPE, BUFFER(256), IERR
C
      INTEGER   NINTER
      PARAMETER (NINTER=15)
C
      INTEGER   INCHAR, LTYPE, I, XINTER(NINTER), XINT, DIST, NOINT,
     *   NINT, IG, XVAL, DEG, DU, DL
      REAL      DCX, DCY, XL, XI, XPOS
      CHARACTER SPRTXT*8
      INCLUDE 'INCS:DMSG.INC'
      DATA XINTER /1, 2, 5, 10, 20, 50, 100, 200, 500, 1000,
     *   2000, 5000, 10000, 20000, 50000/
C-----------------------------------------------------------------------
      LTYPE = MOD (ABS (ILTYPE), 100)
      IF (LTYPE.EQ.1) GO TO 999
C                                       tick marks
      XINT = 32 / NG
      XINT = MAX (3, MIN (16, XINT))
      DIST = EC - BC + 2
      DO 20 I = 1,NINTER
         DEG = XINTER(I)
         DU = (EC / DEG) * DEG
         IF (DU.GT.EC) DU = DU - DEG
         DL = (BC / DEG) * DEG
         IF (DL.LT.BC) DL = DL + DEG
         NOINT = (DU - DL) / DEG + 1
         IF (NOINT.LE.XINT) GO TO 30
 20      CONTINUE
      MSGTXT = 'PINLAB: TICK MARK ALGORITHM FAILED'
      CALL MSGWRT (6)
      IERR = 0
      GO TO 999
C                                       plot tick marks
 30   XINT = DEG
      NINT = (NOINT * NG) / 16
      NINT = MAX (1, MIN (NINT, NOINT))
      NOINT = NOINT + 2
      DCX = -0.5
      XL = DIST * NG + 1
      XL = (TRC(1) - BLC(1)) / XL
      XI = (TRC(2) - BLC(2)) / 25.
      DCY = -1.5
      DO 50 IG = 1,NG
         XVAL = (BC / XINT) * XINT
         IF (XVAL.EQ.BC) XVAL = XVAL - XINT
         DO 40 I = 1,NOINT
            XVAL = XVAL + XINT
            IF ((XVAL.GE.BC) .AND. (XVAL.LE.EC)) THEN
               XPOS = (XVAL-BC+1 + (IG-1)*DIST) + BLC(1)
               CALL GPOS (XPOS, TRC(2), BUFFER, IERR)
               IF (IERR.NE.0) GO TO 999
               CALL GVEC (XPOS, TRC(2)-XI, BUFFER, IERR)
               IF (IERR.NE.0) GO TO 999
               CALL GPOS (XPOS, BLC(2)+XI, BUFFER, IERR)
               IF (IERR.NE.0) GO TO 999
               CALL GVEC (XPOS, BLC(2), BUFFER, IERR)
               IF (IERR.NE.0) GO TO 999
               IF ((LTYPE.GT.2) .AND. (MOD(I,NINT).EQ.0)) THEN
                  WRITE (SPRTXT,1030) XVAL
                  CALL CHTRIM (SPRTXT, 6, SPRTXT, INCHAR)
                  DCX = 0.5 - INCHAR
                  CALL GCHAR (INCHAR, 0, DCX, DCY, SPRTXT, BUFFER, IERR)
                  IF (IERR.NE.0) GO TO 999
                  END IF
               END IF
 40         CONTINUE
 50      CONTINUE
C
 999  RETURN
C-----------------------------------------------------------------------
 1030 FORMAT (I6)
      END
