LOCAL INCLUDE 'XMBUFRS'
      INCLUDE 'INCS:PMAD.INC'
      REAL      BUFF1(MABFSS), BUFF2(MABFSS)
      INTEGER   IBUFF1(MABFSS), IBUFF2(MABFSS), SCRTCH(512)
      EQUIVALENCE (IBUFF1, BUFF1), (IBUFF2, BUFF2)
      COMMON /BUFRS/ BUFF1, BUFF2, SCRTCH
LOCAL END
LOCAL INCLUDE 'TVSPX.INC'
      INTEGER   MAXLIS, MAXFQ
      PARAMETER (MAXLIS=1000)
      PARAMETER (MAXFQ=16384)
C
      INCLUDE 'XMBUFRS'
      CHARACTER NAMEIN*12, CLAIN*6, NAMOUT*12, OPTYPE*4, FUNCTY(7)*2,
     *   CUNITS(7)*8
      HOLLERITH XNAMEI(3), XCLAIN(2), XNAMOU(3), XOPTYP, CATOH(256)
      REAL      XSEQIN, XDISKI, XSEQO, XDISKO, BLC(7), TRC(7),
     *   FCUT, REFREQ, PBPARM(7), DPARM(10), CPARM(10), BADD(10)
      DOUBLE PRECISION CATOD(128), FV, RV, DV, RA0, DE0, XFREQ(MAXFQ),
     *   DEFREQ
      REAL      CATOR(256), PMIN(7), PMAX(7), FI, RI, DI, FR, RR, DR,
     *   MROT, ROBUST(4,7)
      INTEGER   CATOLD(256), SEQIN, SEQOUT, DISKIN, DISKO, NEWCNO,
     *   OLDCNO, JBUFSZ, FAX, RAX, DAX, NGOOD, PIXLIS(2,MAXLIS), NLIST,
     *   SUBWIN(4), SVZOOM(3)
      COMMON /INPARM/ XNAMEI, XCLAIN, XSEQIN, XDISKI, XNAMOU, XSEQO,
     *   XDISKO, BLC, TRC, FCUT, REFREQ, XOPTYP, PBPARM, DPARM, CPARM,
     *   BADD
      COMMON /CHPARM/ NAMEIN, CLAIN, NAMOUT, OPTYPE, FUNCTY, CUNITS
      COMMON /PARMS/ CATOLD, FV, RV, DV, RA0, DE0, XFREQ, DEFREQ, PMAX,
     *   PMIN, SEQIN, SEQOUT, DISKIN, DISKO, NEWCNO, OLDCNO, JBUFSZ, FI,
     *   RI, DI, FR, RR, DR, FAX, RAX, DAX, MROT, NGOOD, PIXLIS, NLIST,
     *   SUBWIN, ROBUST, SVZOOM
      EQUIVALENCE (CATOLD, CATOR, CATOH, CATOD)
LOCAL END
LOCAL INCLUDE 'TVSPX.TV'
      INTEGER   IGR1, IGR2, IGR3, IGR4, IGR5, IGR7, TTYLUN, TTYIND,
     *   IPL(2)
      LOGICAL   LABWED
      REAL      PLTMIN, PLTMAX
      INCLUDE 'INCS:DTVC.INC'
      COMMON /TVSPIX/ IGR1, IGR2, IGR3, IGR4, IGR5, IGR7, TTYLUN,
     *   TTYIND, LABWED, PLTMIN, PLTMAX, IPL
LOCAL END
      PROGRAM TVSPX
C-----------------------------------------------------------------------
C! TVSPX fits 1-D spectral indexes
C# Map-util Spectral
C-----------------------------------------------------------------------
C;  Copyright (C) 2024-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   TVSPX fits 1-dimensional spectral inices to rows of an image.  It
C   fits and then allows TV interaction to blank bad values
C   Inputs:
C      AIPS adverb  Prg. name.          Description.
C      INNAME         NAMEIN        Name of input image.
C      INCLASS        CLAIN         Class of input image.
C      INSEQ          SEQIN         Seq. of input image.
C      INDISK         DISKIN        Disk number of input image.
C      OUTNAME        NAMOUT        Name of the output image
C                                   Default output is input image.
C      OUTSEQ         SEQOUT        Seq. number of output image.
C      OUTDISK        DISKO         Disk number of the output image.
C      BLC(7)         BLC           Bottom left corner of subimage
C                                   of input image.
C      TRC(7)         TRC           Top right corner of subimage.
C      FLUX           FCUT          Flux cutoff: use only data >
C                                   FLUX.
C      OPTYPE         XOPTYP        '': Blank illegal velocities;
C      BADD(10)       IBAD          Disk numbers to avoid.
C   Programmer Eric W. Greisen  2005
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET, NX, NY, NZ, ITYP
      LOGICAL   ABLANK
      REAL      IMAGE(2), ANSW(2)
      LONGINT   PIMAGE, PANSW
      INCLUDE 'TVSPX.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA PRGM /'TVSPX'/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL SPIXIN (PRGM, NX, NY, NZ, ITYP, IMAGE, PIMAGE, ANSW, PANSW,
     *   IRET)
C                                       Call routine that sends data
C                                       to the user routine.
      IF (IRET.EQ.0) CALL SPIXDO (ABLANK, NX, NY, NZ, ITYP,
     *   IMAGE(1+PIMAGE), ANSW(1+PANSW), IRET)
      IF (IRET.EQ.0) CALL SPIXTV (ABLANK, NX, NY, NZ, ITYP,
     *   IMAGE(1+PIMAGE), ANSW(1+PANSW), IRET)
      IF (IRET.EQ.0) CALL SPIXOU (ABLANK, NX, NY, ITYP, ANSW(1+PANSW),
     *   IRET)
C                                       Close down files, etc.
      CALL DIE (IRET, SCRTCH)
C
 999  STOP
      END
      SUBROUTINE SPIXIN (PRGN, NX, NY, NZ, ITYP, IMAGE, PIMAGE, ANSW,
     *   PANSW, IRET)
C-----------------------------------------------------------------------
C   SPIXIN gets input parameters for TVSPX.
C   Inputs:
C      PRGN     C*6    Program name (2 chars/word)
C      IMAGE    R(*)   buffer for image
C      ANSW     R(*)   buffer for answers
C   Output:
C      NX       I      # X pixels
C      NY       I      # Y pixels
C      NZ       I      # spectral pixels
C      ITYP     I      # output parameters
C      PIMAGE   L      pointer for image
C      PANSW    L      pointer for answ
C      IRET     I      Error code: 0 => ok
C                                4 => user routine detected error.
C                                5 => catalog troubles
C                                8 => can't start
C                               <0 => failed to get all frequencies
C      /MAPHDR/ output file catalog header
C-----------------------------------------------------------------------
      CHARACTER PRGN(6)
      REAL      IMAGE(*), ANSW(*)
      LONGINT   PIMAGE, PANSW
      INTEGER   NX, NY, NZ, ITYP, IRET
C
      CHARACTER STAT*4, OTYPE*8, CLAOUT*6, SEQTYP(7)*8, CTEMP*8,
     *   MTYPE*2, C1TYP*8
      INTEGER   IPT, I, IERR, NPARM, IROUND, IG, INC, NAX, J, need
      DOUBLE PRECISION C1CRV
      REAL      CONST, C1CRP, C1CIC, C1CRT
      INCLUDE 'TVSPX.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:PSTD.INC'
      DATA SEQTYP /'SP CNT', 'B TEMP', 'D BT', 'SPIX','D SPIX',
     *   'SPCU', 'D SPCU'/
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      JBUFSZ = 2 * MABFSS
      IRET = 0
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
C                                       Get input parameters.
C                                       Fixed PPM 1996.09.30: was 38
      NPARM = 66
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, SCRTCH, IERR)
      RQUICK = .FALSE.
      IF (IERR.NE.0) THEN
         RQUICK = .TRUE.
         IRET = 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 (IRET, SCRTCH, IERR)
      IF (IRET.NE.0) GO TO 999
      IRET = 5
C                                       Crunch input parameters.
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      CALL H2CHR (12, 1, XNAMOU, NAMOUT)
      CALL H2CHR (12, 1, XOPTYP, OPTYPE)
      SEQIN = IROUND (XSEQIN)
      SEQOUT = IROUND (XSEQO)
      DISKIN = IROUND (XDISKI)
      DISKO = IROUND (XDISKO)
      DO 20 I = 1,10
         IBAD(I) = IROUND (BADD(I))
 20      CONTINUE
C                                       Get CATBLK from old file.
      OLDCNO = 1
      MTYPE = 'MA'
      CALL CATDIR ('SRCH', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN, MTYPE,
     *   NLUSER, STAT, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1030) IERR, NAMEIN, CLAIN, SEQIN, DISKIN,
     *      NLUSER
         GO TO 990
         END IF
C                                       Read CATBLK and mark 'READ'.
      CALL CATIO ('READ', DISKIN, OLDCNO, CATOLD, 'READ', SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'COPYING CATBLK'
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = OLDCNO
      FRW(NCFILE) = 0
C                                       Copy old CATBLK to new.
      CALL COPY (256, CATOLD, CATBLK)
C                                       Put new values in CATBLK.
      CALL MAKOUT (NAMEIN, CLAIN, SEQIN, '      ', NAMOUT, CLAOUT,
     *   SEQOUT)
      CALL CHR2H (12, NAMOUT, KHIMNO, CATH(KHIMN))
      CATBLK(KIIMS) = SEQOUT
C                                       Set defaults on BLC,TRC
      CALL WINDOW (CATOLD(KIDIM), CATOLD(KINAX), BLC, TRC, IERR)
      IF (IERR.NE.0) GO TO 999
      NZ = TRC(1) - BLC(1) + 1.01
      NX = TRC(2) - BLC(2) + 1.01
      NY = TRC(3) - BLC(3) + 1.01
C                                       allocate memory
      NEED = (NX * NY * NZ - 1) / 1024 + 5
      CALL ZMEMRY ('GET ', TSKNAM, NEED, IMAGE, PIMAGE, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'GETTING MEMORY FOR IMAGE'
         GO TO 990
         END IF
      ITYP = 5
      IF (OPTYPE.EQ.'CURV') ITYP = 7
      NEED = (ITYP * NX * NY - 1) / 1024 + 5
      CALL ZMEMRY ('GET ', TSKNAM, NEED, ANSW, PANSW, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'GETTING MEMORY FOR ANSWERS'
         GO TO 990
         END IF
      NEED = NEED * 1024
      CALL RFILL (NEED, 0.0, ANSW(1+PANSW))
C                                       Get user modification to CATBLK
      IRET = 4
      CALL SPIHED (IRET)
      IF (IRET.NE.0) GO TO 999
      NEWCNO = 0
C                                       Make names, classes, disks OK.
      CALL H2CHR (12, KHIMNO, CATH(KHIMN), NAMOUT)
      CONST = -1.E15
      CALL RFILL (7, CONST, PMAX)
      CONST = -CONST
      CALL RFILL (7, CONST, PMIN)
C                                       PBCORR parameters
      FAX = 0
      RAX = 0
      DAX = 0
      NAX = CATOLD(KIDIM)
      DO 100 I = 1,NAX
         CALL H2CHR (8, 1, CATOH(KHCTP+2*(I-1)), OTYPE)
         IF (OTYPE(:4).EQ.'FREQ') THEN
            FAX = I
            J = I
            FV = CATOD(KDCRV+I-1)
            FI = CATOR(KRCIC+I-1)
            FR = CATOR(KRCRP+I-1)
         ELSE IF (OTYPE(:8).EQ.'SEQ.NUM.') THEN
            FAX = I
         ELSE IF (OTYPE(:8).EQ.'FQID') THEN
            FAX = I
         ELSE IF ((OTYPE(:2).EQ.'RA') .OR. (OTYPE(2:4).EQ.'LON')) THEN
            RAX = I
            RV = CATOD(KDCRV+I-1) * DG2RAD
            RI = CATOR(KRCIC+I-1) * DG2RAD
            RR = CATOR(KRCRP+I-1)
         ELSE IF ((OTYPE(:3).EQ.'DEC') .OR. (OTYPE(2:4).EQ.'LAT')) THEN
            DAX = I
            DV = CATOD(KDCRV+I-1) * DG2RAD
            DI = CATOR(KRCIC+I-1) * DG2RAD
            DR = CATOR(KRCRP+I-1)
            MROT = CATOR(KRCRT+I-1) * DG2RAD
            END IF
 100     CONTINUE
      IF ((PBPARM(1).GT.0.0) .AND. (DAX*RAX*FAX.LE.0)) THEN
         MSGTXT = 'FREQ/RA/DEC AXIS NOT FOUND: PBPARM TURNED OFF'
         CALL MSGWRT (7)
         PBPARM(1) = 0.0
         END IF
      RA0 = CATOD(KDORA) * DG2RAD
      DE0 = CATOD(KDODE) * DG2RAD
      IF ((RA0.EQ.0.0D0) .AND. (DE0.EQ.0.0D0)) THEN
         RA0 = RV
         DE0 = DV
         END IF
C                                       reference freq
      IF (FAX.LE.0) THEN
         IF (REFREQ.LE.0.0) REFREQ = 1.0
      ELSE IF (REFREQ.LT.0.0) THEN
         REFREQ = FV / 1.D9
      ELSE IF (REFREQ.EQ.0.0) THEN
         REFREQ = 1.0
         END IF
      DEFREQ = REFREQ * 1.D9
C                                       create output files in advance
C                                       Basic output header
      NAX = CATBLK(KIDIM) - 1
      J = J - 1
      INC = 2
C                                       save averaged axis for what??
      C1CRP = (CATR(KRCRP) - 1.5) / CATBLK(KINAX) + 0.5
      C1CIC = CATR(KRCIC) * CATBLK(KINAX)
      C1CRT = CATR(KRCRT)
      C1CRV = CATD(KDCRV)
      CALL H2CHR (8, 1, CATH(KHCTP), C1TYP)
      IF (C1TYP.EQ.'FREQ') J = NAX + 1
C                                       move other axes down
      DO 60 I = 1,NAX
         CATBLK(KINAX+I-1) = CATBLK(KINAX+I)
         CATR(KRCRP+I-1) = CATR(KRCRP+I)
         CATR(KRCRT+I-1) = CATR(KRCRT+I)
         CATR(KRCIC+I-1) = CATR(KRCIC+I)
         CATD(KDCRV+I-1) = CATD(KDCRV+I)
         IPT = KHCTP+I*INC
         CALL H2CHR (8, 1, CATH(IPT), CTEMP)
         IPT = KHCTP+(I-1)*INC
         CALL CHR2H (8, CTEMP, 1, CATH(IPT))
 60      CONTINUE
      CATR(KRCRP+NAX) = 1.0
      CATR(KRCRT+NAX) = 0.0
      CATR(KRCIC+NAX) = 1.0
      CATD(KDCRV+NAX) = C1CRV
      IPT = KHCTP + NAX*INC
      CALL CHR2H (8, C1TYP, 1, CATH(IPT))
      DO 65 I = NAX,6
         CATBLK(KINAX+I) = 1
 65      CONTINUE
      CATD(KDCRV+J-1) = DEFREQ
C                                       creates
      CALL H2CHR (8, 1, CATOH(KHBUN), CTEMP)
      CUNITS(2) = CTEMP
      CUNITS(3) = CTEMP
      CUNITS(1) = 'SP COUNT'
      CUNITS(4) = 'SP INDEX'
      CUNITS(6) = 'CSPINDEX'
      CUNITS(5) = 'SP INDEX'
      CUNITS(7) = 'CSPINDEX'
      DO 90 IG = 1,ITYP
         CALL CHR2H (6, SEQTYP(IG), KHIMCO, CATH(KHIMC))
         CALL CHR2H (8, CUNITS(IG), 1, CATH(KHBUN))
C                                       Create
         DISKO = XDISKO + 0.01
         NEWCNO = 1
         CALL MCREAT (DISKO, NEWCNO, SCRTCH, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1075) IERR, SEQTYP(IG)
            GO TO 990
            END IF
C                                       Record the creation
         NCFILE = NCFILE + 1
         FVOL(NCFILE) = DISKO
         FCNO(NCFILE) = NEWCNO
         FRW(NCFILE) = 2
         SEQOUT = CATBLK(KIIMS)
C                                       copy most keywords
         CALL KEYPCP (DISKIN, OLDCNO, DISKO, NEWCNO, 0, ' ', IERR)
 90      CONTINUE
      IRET = 0
C                                       get frequencies
      NAX = CATOLD(KINAX)
      IF (NAX.GT.MAXFQ) THEN
         MSGTXT = 'I CAN ONLY HANDLE 16384 FREQUENCIES'
         IERR = 10
         GO TO 990
         END IF
      CALL H2CHR (8, 1, CATOH(KHCTP), OTYPE)
      IF (OTYPE(:4).EQ.'FREQ') THEN
         DO 110 I = 1,MIN(NAX,MAXFQ)
            XFREQ(I) = FV + FI * (I - FR)
            XFREQ(I) = LOG10 (XFREQ(I)/DEFREQ)
 110        CONTINUE
      ELSE IF (OTYPE.EQ.'SEQ.NUM.') THEN
         CALL HIGET (DISKIN, OLDCNO, NAX, DEFREQ, XFREQ, IRET)
      ELSE
         C1CRV = CATOD(KDCRV)
         C1CRP = CATOR(KRCRP)
         C1CIC = CATOR(KRCIC)
         CALL FQGET (DISKIN, OLDCNO, NAX, FV, C1CRV, C1CRP, C1CIC,
     *      CATOLD, DEFREQ, XFREQ, IRET)
         END IF
C                                       correct XFREQ for BLC(1)
      IPT = BLC(1) + 0.1
      IF (IPT.GT.1) THEN
         IPT = IPT - 1
         IG = TRC(1) - BLC(1) + 1.01
         DO 120 I = 1,IG
            XFREQ(I) = XFREQ(I+IPT)
 120        CONTINUE
         END IF
C                                       set DPARM defaults
      IF (DPARM(1).LT.0.0) DPARM(1) = 0
      IF (DPARM(2).EQ.0.0) DPARM(2) = -1.E8
      IF (DPARM(3).EQ.0.0) DPARM(3) = 1.E8
      IF (DPARM(4).LT.0.0) DPARM(4) = 0
      IF (DPARM(5).EQ.0.0) DPARM(5) = 1.E8
      IF (DPARM(6).LT.0.0) DPARM(6) = 0
      IF (DPARM(7).EQ.0.0) DPARM(7) = 1.E8
      IF (DPARM(8).EQ.0.0) DPARM(8) = -1.E8
      IF (DPARM(9).EQ.0.0) DPARM(9) = 1.E8
      DPARM(10) = 0.0
      IF (CPARM(1).LE.0.0) CPARM(1) = 1.E8
      IF (CPARM(2).LE.0.0) CPARM(2) = 1.E8
      IF (CPARM(3).LE.0.0) CPARM(3) = 1.E8
      NGOOD = 0
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SPIXIN: ERROR',I3,' ON ',A)
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I3,' DISK=',
     *   I2,' USID=',I5)
 1075 FORMAT ('ERROR',I5,' CREATING FILE TYPE ',A6)
      END
      SUBROUTINE FQGET (DISK, CNO, NF, FV, CV, CP, CI, CATBLK, DEFREQ,
     *   XFREQ, IRET)
C-----------------------------------------------------------------------
C   Gets the frequencies from the FQ table
C   Inputs:
C      DISK     I        disk
C      CNO      I        calatog number
C      NF       I        Number of frequencies
C      FV       D        Header ref frequency
C      CV       D        FQID axis ref value
C      CP       D        FQID axis ref pixel
C      CI       D        FQID axis increment
C      CATBLK   I(256)   old image header
C      DEFREQ   D        ref freq
C   Outputs:
C      XFREQ    D(*)     LOG10(freq/FV)
C      IERR     I        Error code
C-----------------------------------------------------------------------
      INTEGER   DISK, CNO, NF, CATBLK(*), IRET
      DOUBLE PRECISION FV, CV, DEFREQ, XFREQ(*)
      REAL      CP, CI
C
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   BUFFER(512), VER, LUN, IFQRNO, FQKOLS(MAXFQC),
     *   FQNUMV(MAXFQC), NUMIF, FQID, IFSIDE, IREC, NREC, I, MF
      DOUBLE PRECISION IFFREQ
      REAL      IFCHW, IFTBW
      CHARACTER BNDCOD*8
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
C                                       open
      VER = 1
      LUN = 20
      NUMIF = 1
      CALL FQINI ('READ', BUFFER, DISK, CNO, VER, CATBLK, LUN, IFQRNO,
     *   FQKOLS, FQNUMV, NUMIF, IRET)
      IF (IRET.NE.0) GO TO 999
      NREC = BUFFER(5)
C                                       read
      DO 10 IREC = 1,NREC
         CALL TABFQ ('READ', BUFFER, IFQRNO, FQKOLS, FQNUMV, NUMIF,
     *      FQID, IFFREQ, IFCHW, IFTBW, IFSIDE, BNDCOD, IRET)
         IF (IRET.NE.0) GO TO 20
         I = (FQID - CV) / CI + CP + 0.5
         IF ((I.GE.1) .AND. (I.LE.NF)) XFREQ(I) = IFFREQ + FV
 10      CONTINUE
 20   CALL TABFQ ('CLOS', BUFFER, IFQRNO, FQKOLS, FQNUMV, NUMIF,
     *   FQID, IFFREQ, IFCHW, IFTBW, IFSIDE, BNDCOD, IREC)
C                                       test
      MF = NF
      DO 30 I = 1,NF
         IF (XFREQ(I).GT.0.0D0) THEN
            MF = MF - 1
            XFREQ(I) = LOG10 (XFREQ(I)/DEFREQ)
            END IF
 30      CONTINUE
      IF (IRET.LE.0) IRET = -MF
      IF (MF.GT.0) THEN
         WRITE (MSGTXT,1030) MF
         CALL MSGWRT (7)
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1030 FORMAT ('WARNING:',I3,' FREQUENCY PLANES NOT FOUND IN FQ FILE')
      END
      SUBROUTINE HIGET (DISK, CNO, NF, DEFREQ, XFREQ, IRET)
C-----------------------------------------------------------------------
C   HIGET tries to get the frequencies from the history file
C   Inputs:
C      DISK    I      Disk number
C      CNO     I      Catalog number
C      NF      I      Number of frequencies
C   Output
C      XFREQ   D(*)   Frequencies
C      IRET    I      Error code
C-----------------------------------------------------------------------
      INTEGER   DISK, CNO, NF, IRET
      DOUBLE PRECISION DEFREQ, XFREQ(*)
C
      INTEGER   IHLUN, NREC, IHPTR, HIBUFF(256), IBLK, ICARD, IP, MF,
     *   ICUR, IHIND, II
      CHARACTER LINE*72, CTYP*8
      DOUBLE PRECISION X
      REAL      HRBUFF(256)
      EQUIVALENCE (HIBUFF, HRBUFF)
      INCLUDE 'INCS:DHIS.INC'
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
      MF = 0
      CALL DFILL (NF, 0.0D0, XFREQ)
C                                       open history file
      IHLUN = 27
C                                       Open history file.
      CALL HIINIT (3)
      CALL HIOPEN (IHLUN, DISK, CNO, HIBUFF, IRET)
      IF (IRET.NE.0) GO TO 999
      CALL HILOCT ('SRCH', IHLUN, IHPTR, IRET)
      IF (IRET.NE.0) GO TO 100
C                                       Determine no. of hist. recs.
      NREC = HITAB(IHPTR+2)
      IHIND = HITAB(IHPTR+1)
      IBLK = 0
      ICARD = NHILPR
      DO 20 ICUR = 1,NREC
C                                       Read next buffer.
         ICARD = ICARD + 1
         IF (ICARD.GT.NHILPR) THEN
            IBLK = IBLK + 1
            ICARD = 1
            CALL ZFIO ('READ', IHLUN, IHIND, IBLK, HIBUFF, IRET)
            IF (IRET.NE.0) GO TO 100
            END IF
C                                       desired task?
         II = (ICARD-1) * NHIWPL + 5
         CALL H2CHR (72, 1, HRBUFF(II), LINE)
         IF (LINE(:12).EQ.'MCUBE COORD=') THEN
            READ (LINE,1000) X, CTYP, IP
C                                       test
            IF ((CTYP(:4).EQ.'FREQ') .AND. (IP.GT.0) .AND. (IP.LE.NF))
     *         THEN
               XFREQ(IP) = X
               MF = MF + 1
               WRITE (MSGTXT,1001) CTYP, X, IP
               CALL MSGWRT (3)
            ELSE
               WRITE (MSGTXT,1010) X, CTYP, IP
               CALL MSGWRT (7)
               END IF
            END IF
 20      CONTINUE
C                                       Close history file.
 100  CALL HICLOS (IHLUN, .FALSE., HIBUFF, II)
C                                       fill it all in??
      MF = NF
      DO 110 II = 1,NF
         IF (XFREQ(II).GT.0.0D0) THEN
            MF = MF - 1
            XFREQ(II) = LOG10 (XFREQ(II)/DEFREQ)
            END IF
 110     CONTINUE
      IF (IRET.LE.0) IRET = -MF
      IF (MF.GT.0) THEN
         WRITE (MSGTXT,1110) MF
         CALL MSGWRT (7)
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT (12X,E13.5,5X,13X,A8,11X,I5)
 1001 FORMAT ('Found in MCUBE history ',A8,' F=',1PE13.5,' plane',I5)
 1010 FORMAT ('Coordinate mismatch',1PE13.5,' ''',A8,''' plane',I5)
 1110 FORMAT ('WARNING:',I3,
     *   ' FREQUENCY PLANES NOT FOUND IN HISTORY FILE')
      END
      SUBROUTINE SPIXDO (TBLNKD, NX, NY, NZ, ITYP, IMAGE, ANSW, IRET)
C-----------------------------------------------------------------------
C   SPIXDO sends image one row at a time to the moment fitting
C   routine and then saves the answers
C   Inputs
C      NX       I      # X pixels
C      NY       I      # Y pixels
C      NZ       I      # spectral channels
C      ITYP     I      # answers (5 or 7)
C   Output:
C      IMAGE    R(*)   Input data image
C      ANSW     R(*)   Answer images
C      TBLNKD   L      Answers contain blanked pixels?
C      IRET     I      Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      LOGICAL   TBLNKD
      INTEGER   NX, NY, NZ, ITYP, IRET
      REAL      IMAGE(NZ,NX,NY), ANSW(NX,NY,ITYP)
C
      CHARACTER IFILE*48
      INTEGER   IROUND, LUNI, NYI, NXI, WINI(4), BOI, LIM2, LIM3, LIM4,
     *   LIM5, LIM6, LIM7, I1, I2, I3, I4, I5, I6, I7, IPOS(7), CORN(7),
     *   BOTEMP, IBIND, INDI, LIM1, JBUFS3
      LOGICAL   T, F
      INCLUDE 'TVSPX.INC'
      REAL      ANSWER(7)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA LUNI /16/
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
      JBUFS3 = 2 * MABFSS
C                                       Open and init for read
      CALL ZPHFIL ('MA', DISKIN, OLDCNO, 1, IFILE, IRET)
      CALL ZOPEN (LUNI, INDI, DISKIN, IFILE, T, F, T, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING INPUT IMAGE'
         GO TO 990
         END IF
C                                       Setup for I/O
C                                       remember names switched
      NXI = CATOLD(KINAX)
      NYI = CATOLD(KINAX+1)
      WINI(1) = IROUND (BLC(1))
      WINI(2) = IROUND (BLC(2))
      WINI(3) = IROUND (TRC(1))
      WINI(4) = IROUND (TRC(2))
C                                       Setup for looping
      LIM1 = TRC(1) - BLC(1) + 1.01
      LIM2 = TRC(2) - BLC(2) + 1.01
      LIM3 = TRC(3) - BLC(3) + 1.01
      LIM4 = TRC(4) - BLC(4) + 1.01
      LIM5 = TRC(5) - BLC(5) + 1.01
      LIM6 = TRC(6) - BLC(6) + 1.01
      LIM7 = TRC(7) - BLC(7) + 1.01
      CORN(7) = 1
      TBLNKD = .FALSE.
      IF (LIM4+LIM5+LIM6+LIM7.GT.4) THEN
         MSGTXT = 'IMAGE HAS TOO MANY REAL AXES'
         IRET = 10
         GO TO 990
         END IF
C                                       Loop
      DO 700 I7 = 1,LIM7
         IPOS(7) = BLC(7) + I7 - 0.9
         CORN(7) = I7
         DO 600 I6 = 1,LIM6
            IPOS(6) = BLC(6) + I6 - 0.9
            CORN(6) = I6
            DO 500 I5 = 1,LIM5
               IPOS(5) = BLC(5) + I5 - 0.9
               CORN(5) = I5
               DO 400 I4 = 1,LIM4
                  IPOS(4) = BLC(4) + I4 - 0.9
                  CORN(4) = I4
                  DO 300 I3 = 1,LIM3
                     IPOS(3) = BLC(3) + I3 - 0.9
                     CORN(3) = I3
C                                       Init. files, first input.
         CALL COMOFF (CATOLD(KIDIM), CATOLD(KINAX), IPOS(3), BOTEMP,
     *      IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'SET I/O OFFSET'
            GO TO 990
            END IF
         BOI = BOTEMP + 1
         CALL MINIT ('READ', LUNI, INDI, NXI, NYI, WINI, BUFF1, JBUFSZ,
     *      BOI, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'INIT READ OF IMAGE'
            GO TO 990
            END IF
         DO 250 I2 = 1,LIM2
            IPOS(2) = BLC(2) + I2 - 0.9
            IPOS(1) = IROUND (BLC(1))
C                                       Read.
            CALL MDISK ('READ', LUNI, INDI, BUFF1, IBIND, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READING INPUT IMAGE'
               GO TO 990
               END IF
C                                       Copy to memory
            CALL RCOPY (LIM1, BUFF1(IBIND), IMAGE(1,I2,I3))
C                                       Call DO1SPX
            IF (OPTYPE.NE.'CURV') THEN
               CALL DO1SPX (IPOS, BUFF1(IBIND), ANSWER)
            ELSE
               CALL DO2SPX (IPOS, BUFF1(IBIND), ANSWER)
               END IF
C                                       Check blanking, save answer
            DO 215 I1 = 1,ITYP
               ANSW(I2,I3,I1) = ANSWER(I1)
               IF (ANSW(I2,I3,I1).EQ.FBLANK) TBLNKD = .TRUE.
 215           CONTINUE
 250        CONTINUE
C                                       Flush buffers.
 300                 CONTINUE
 400              CONTINUE
 500           CONTINUE
 600        CONTINUE
 700     CONTINUE
C                                       Close files
      CALL ZCLOSE (LUNI, INDI, IRET)
      IRET = 0
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SPIXDO: ERROR',I3,' ON ',a)
      END
      SUBROUTINE SPIHED (IRET)
C-----------------------------------------------------------------------
C   SPIHED modifies the new image header for the subimaging and for
C   replacing the first axis with Gaussian components.
C   Input:
C      CATBLK(256)    I     Output catalog header, also CATR, CATD,
C                           CATH
C      CATOLD(256)    I     Input catalog header, also CATOR, CATOD,
C                           CATOH
C   Output:
C      CATBLK(256)    I     Modified output catalog header.
C      IRET           I     Return error code, 0=>OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      CHARACTER CHTM12*12
      INCLUDE 'TVSPX.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
C-----------------------------------------------------------------------
      IRET = 0
C                                       Set axes in output CATBLK.
      CALL SUBHDR (BLC, TRC, 1.0, 1.0)
C                                       Check input axes
      CALL H2CHR (8, 1, CATH(KHCTP), CHTM12)
      IF ((CHTM12(:4).NE.'FREQ') .AND. (CHTM12(:8).NE.'SEQ.NUM.') .AND.
     *   (CHTM12(:8).NE.'FQID')) THEN
         MSGTXT = 'FIRST AXIS NOT FREQUENCY, FQID, OR SEQ.NUM.'
         CALL MSGWRT (8)
         IRET = 8
         END IF
C
 999  RETURN
      END
      SUBROUTINE DO1SPX (IPOS, IDATA, RESULT)
C-----------------------------------------------------------------------
C   DO1SPX fits spectral index to a row of an image and returns the
C   answers in RESULT.
C   Inputs:
C      IPOS(7)   I      BLC (input image) of first value in DATA
C      IDATA     R(*)   Input data (floated and scaled)
C   Values from commons:
C      FCUT      R      Flux cutoff
C      FBLANK    R      Value of blanked pixel.
C      CATOLD    I      Input catalog header (also CATOR, CATOD)
C   Output:
C     RESULT(*) R      Output row (count, br, br err, spix sp err,...)
C      IRET      I      Return code   0 => OK
C                               >0 => error, terminate.
C-----------------------------------------------------------------------
      INTEGER   IPOS(7)
      REAL      IDATA(*), RESULT(*)
C
      INTEGER   INPTS, I, IRET
      REAL      LFCUT, V , TMIN, TMAX
      DOUBLE PRECISION X, Y, SXX, SX, SY, SXY, SN, DET, VM, VB, SDD
      LOGICAL   FAIL
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'TVSPX.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DDCH.INC'
C-----------------------------------------------------------------------
C                                       Not last call
      IF (IPOS(1).GE.0) THEN
         LFCUT = FCUT
         LFCUT = MAX (1.E-10, LFCUT)
         INPTS = TRC(1) - BLC(1) + 1.01
         SXX = 0.0
         SX  = 0.0
         SXY = 0.0
         SY  = 0.0
         SN  = 0.0
         TMIN = 1.E8
         TMAX = -TMIN
         DO 20 I = 1,INPTS
            V = IDATA(I)
            IF ((V.GT.0.0) .AND. (V.NE.FBLANK)) THEN
               IF (PBPARM(1).GT.0.0) THEN
                  CALL SPIXPB (I, IPOS, LFCUT, IRET)
                  IF (IRET.NE.0) GO TO 20
                  END IF
               IF (V.GE.LFCUT) THEN
                  TMIN = MIN (TMIN, V)
                  TMAX = MAX (TMAX, V)
                  Y = LOG10 (V)
                  X = XFREQ(I)
                  SX = SX + X
                  SY = SY + Y
                  SXX = SXX + X * X
                  SXY = SXY + X * Y
                  SN = SN + 1.0
                  END IF
               END IF
 20         CONTINUE
         IRET = 0
         DET = SN * SXX - SX * SX
         FAIL = (DET.LE.0.0) .OR. (SN.LE.1.5)
         IF (.NOT.FAIL) THEN
            VB = (SXX * SY - SX * SXY) / DET
            VM = (SN * SXY - SX * SY) / DET
C                                       find overall sigma**2
            SDD = 0.0
            DO 30 I = 1,INPTS
               Y = IDATA(I)
               IF ((Y.GT.0.0) .AND. (Y.NE.FBLANK)) THEN
                  IF (PBPARM(1).GT.0.0) THEN
                     CALL SPIXPB (I, IPOS, LFCUT, IRET)
                     IF (IRET.NE.0) GO TO 30
                     END IF
                  IF (Y.GE.LFCUT) THEN
                     Y = LOG10 (Y)
                     X = XFREQ(I)
                     SDD = SDD + (VM * X + VB - Y)**2
                     END IF
                  END IF
 30            CONTINUE
            IRET = 0
            SDD = SDD / SN
            RESULT(2) = VB
            RESULT(4) = VM
            RESULT(1) = SN
            RESULT(3) = SQRT (SDD * SXX / DET)
            RESULT(5) = SQRT (SN * SDD / DET)
            RESULT(6) = 0.0
            RESULT(7) = 0.0
C                                       but want T not log T
            RESULT(2) = 10.0 ** (RESULT(2))
            RESULT(3) = RESULT(2) * RESULT(3)
C                                       test results
            IF (RESULT(1).LT.DPARM(1)) FAIL = .TRUE.
            IF (RESULT(4).LT.DPARM(2)) FAIL = .TRUE.
            IF (RESULT(4).GT.DPARM(3)) FAIL = .TRUE.
            IF (TMIN.GT.0.0) THEN
               IF (RESULT(2)/TMIN.LT.DPARM(4)) FAIL = .TRUE.
               END IF
            IF (RESULT(2)/TMAX.GT.DPARM(5)) FAIL = .TRUE.
            IF (RESULT(2).LT.DPARM(6)) FAIL = .TRUE.
            IF (RESULT(2).GT.DPARM(7)) FAIL = .TRUE.
            IF (RESULT(3).GT.CPARM(1)) FAIL = .TRUE.
            IF (RESULT(5).GT.CPARM(2)) FAIL = .TRUE.
            IF (FAIL) DPARM(10) = DPARM(10) + 1.0
            END IF
C                                       Max / Min
         IF (.NOT.FAIL) THEN
            NGOOD = NGOOD + 1
            DO 40 I = 1,7
               PMAX(I) = MAX (PMAX(I), RESULT(I))
               PMIN(I) = MIN (PMIN(I), RESULT(I))
 40            CONTINUE
         ELSE
            CALL RFILL (5, FBLANK, RESULT)
            END IF
         END IF
C
 999  RETURN
      END
      SUBROUTINE DO2SPX (IPOS, IDATA, RESULT)
C-----------------------------------------------------------------------
C   DO2SPX fits spectral index plus curvature to a row of an image and
C   returns the answers in RESULT.
C   Inputs:
C      IPOS(7)   I      BLC (input image) of first value in DATA
C      IDATA     R(*)   Input data (floated and scaled)
C   Values from commons:
C      FCUT      R      Flux cutoff
C      FBLANK    R      Value of blanked pixel.
C      CATOLD    I      Input catalog header (also CATOR, CATOD)
C   Output:
C      RESULT(*) R      Output row (count, 4 moments)
C      IRET      I      Return code   0 => OK
C                               >0 => error, terminate.
C-----------------------------------------------------------------------
      INTEGER   IPOS(7)
      REAL      IDATA(*), RESULT(*)
C
      INTEGER   INPTS, I, IRET
      REAL      LFCUT, V, TMAX, TMIN
      DOUBLE PRECISION X, Y, SXXXX, SXXX, SXX, SX, SY, SXY, SXXY, SN,
     *   DET, VM, VB, VC, SDD, AB, AC, AM, BB, BC, BM, CB, CC, CM
      LOGICAL   FAIL
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'TVSPX.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DDCH.INC'
C-----------------------------------------------------------------------
      IRET = 0
C                                       Not last call
      IF (IPOS(1).GE.0) THEN
         LFCUT = FCUT
         LFCUT = MAX (1.E-10, LFCUT)
         INPTS = TRC(1) - BLC(1) + 1.01
         SXXXX = 0.0
         SXXX = 0.0
         SXX = 0.0
         SX = 0.0
         SXXY = 0.0
         SXY = 0.0
         SY = 0.0
         SN = 0.0
         TMIN = 1.E8
         TMAX = -TMIN
         DO 20 I = 1,INPTS
            V = IDATA(I)
            IF ((V.GT.0.0) .AND. (V.NE.FBLANK)) THEN
               IF (PBPARM(1).GT.0.0) THEN
                  CALL SPIXPB (I, IPOS, LFCUT, IRET)
                  IF (IRET.NE.0) GO TO 20
                  END IF
               IF (V.GE.LFCUT) THEN
                  TMIN = MIN (TMIN, V)
                  TMAX = MAX (TMAX, V)
                  Y = LOG10 (V)
                  X = XFREQ(I)
                  SX = SX + X
                  SY = SY + Y
                  SXX   = SXX + X * X
                  SXXXX = SXXXX + X * X * X * X
                  SXXX  = SXXX + X * X * X
                  SXXY = SXXY + X * X * Y
                  SXY = SXY + X * Y
                  SN = SN + 1.0
                  END IF
               END IF
 20         CONTINUE
         IRET = 0
         DET = SN*SXXXX*SXX - SXXXX*SX*SX - SN*SXXX*SXXX +
     *      2.0*SXXX*SXX*SX  - SXX*SXX*SXX
         FAIL = (DET.LE.0.0) .OR. (SN.LE.2.5)
         IF (.NOT.FAIL) THEN
C                                       const (log brightness)
            AB = (SXXX*SX - SXX*SXX) / DET
            BB = (SXXX*SXX - SXXXX*SX) / DET
            CB = (SXXXX*SXX - SXXX*SXXX) / DET
            VB = (SXXY * AB + SXY * BB + SY * CB)
C                                       slope (spectral index)
            AM = (SXX*SX - SN*SXXX) / DET
            BM = (SN*SXXXX - SXX*SXX) / DET
            CM = (SXXX*SXX - SXXXX*SX) / DET
            VM = (SXXY * AM + SXY * BM + SY * CM)
C                                       curvature
            AC = (SN*SXX - SX*SX) / DET
            BC = (SXX*SX - SN*SXXX) / DET
            CC = (SXXX*SX - SXX*SXX) / DET
            VC = (SXXY * AC + SXY * BC + SY * CC)
C                                       find overall sigma**2
            SDD = 0.0
            DO 30 I = 1,INPTS
               Y = IDATA(I)
               IF ((Y.GT.0.0) .AND. (Y.NE.FBLANK)) THEN
                  IF (PBPARM(1).GT.0.0) THEN
                     CALL SPIXPB (I, IPOS, LFCUT, IRET)
                     IF (IRET.NE.0) GO TO 30
                     END IF
                  IF (Y.GE.LFCUT) THEN
                     Y = LOG10 (Y)
                     X = XFREQ(I)
                     SDD = SDD + (VC * X * X + VM * X + VB - Y)**2
                     END IF
                  END IF
 30            CONTINUE
            IRET = 0
            SDD = SDD / SN
            RESULT(2) = VB
            RESULT(4) = VM
            RESULT(1) = SN
            RESULT(6) = VC
C                                       error bars
            X = AB * AB * SXXXX + BB * BB * SXX + CB * CB +
     *         2. * (AB*BB*SXXX + AB*CB*SXX + BB*CB*SX)
            X = ABS (X)
            RESULT(3) = SQRT (SDD * X)
            X = AM * AM * SXXXX + BM * BM * SXX + CM * CM +
     *         2. * (AM*BM*SXXX + AM*CM*SXX + BM*CM*SX)
            X = ABS (X)
            RESULT(5) = SQRT (SDD * X)
            X = AC * AC * SXXXX + BC * BC * SXX + CC * CC +
     *         2. * (AC*BC*SXXX + AC*CC*SXX + BC*CC*SX)
            X = ABS (X)
            RESULT(7) = SQRT (SDD * X)
C                                       but want T not log T
            RESULT(2) = 10.0 ** (RESULT(2))
            RESULT(3) = RESULT(2) * RESULT(3)
C                                       test results
            IF (RESULT(1).LT.DPARM(1)) FAIL = .TRUE.
            IF (RESULT(4).LT.DPARM(2)) FAIL = .TRUE.
            IF (RESULT(4).GT.DPARM(3)) FAIL = .TRUE.
            IF (TMIN.GT.0.0) THEN
               IF (RESULT(2)/TMIN.LT.DPARM(4)) FAIL = .TRUE.
               END IF
            IF (RESULT(2)/TMAX.GT.DPARM(5)) FAIL = .TRUE.
            IF (RESULT(2).LT.DPARM(6)) FAIL = .TRUE.
            IF (RESULT(2).GT.DPARM(7)) FAIL = .TRUE.
            IF (RESULT(6).LT.DPARM(8)) FAIL = .TRUE.
            IF (RESULT(6).GT.DPARM(9)) FAIL = .TRUE.
            IF (RESULT(3).GT.CPARM(1)) FAIL = .TRUE.
            IF (RESULT(5).GT.CPARM(2)) FAIL = .TRUE.
            IF (RESULT(7).GT.CPARM(3)) FAIL = .TRUE.
            IF (FAIL) DPARM(10) = DPARM(10) + 1.0
            END IF
C                                       Max / Min
         IF (.NOT.FAIL) THEN
            NGOOD = NGOOD + 1
            DO 40 I = 1,7
               PMAX(I) = MAX (PMAX(I), RESULT(I))
               PMIN(I) = MIN (PMIN(I), RESULT(I))
 40            CONTINUE
         ELSE
            CALL RFILL (7, FBLANK, RESULT)
            END IF
         END IF
C
 999  RETURN
      END
      SUBROUTINE SPIXPB (IX, IPOS, FCC, IRET)
C-----------------------------------------------------------------------
C   SPIXPB computes the primary beam correction at the current pixel and
C   adjusts FCUT and ICUT for it.
C   Inputs:
C      IX     I      X pixel position
C      IPOS   I(7)   ?,Y,Z,... pixels
C   Output:
C      FCC    R      FCUT adjusted
C      IRET   I      0 - okay, 1 outside the usable beam
C-----------------------------------------------------------------------
      INTEGER   IX, IPOS(*), IRET
      REAL      FCC
C
      INTEGER   LPOS(7), LF, LR, LD, CATSAV(256), LY
      DOUBLE PRECISION DX, DY, DT, X, Y, LAMBDA, ANGLE
      REAL      PBCORF
      CHARACTER ARRAY*8
      LOGICAL   OUTSID
      INCLUDE 'TVSPX.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DLOC.INC'
      INCLUDE 'INCS:PSTD.INC'
      SAVE LF, LR, LD, LY, LAMBDA, ANGLE
      DATA LF, LR, LD, LY /3*0,300000/
C-----------------------------------------------------------------------
      CALL COPY (6, IPOS(2), LPOS(2))
      LPOS(1) = IX
      IRET = 0
      CALL H2CHR (8, 1, CATH(KHTEL), ARRAY)
C                                       init common each plane
      IF (LPOS(2).LT.LY) THEN
        CALL COPY (256, CATBLK, CATSAV)
        LOCNUM = 1
        CALL COPY (256, CATOLD, CATBLK)
        CALL SETLOC (LPOS(3), .FALSE.)
        END IF
      LY = LPOS(2)
C                                       new frequency
      IF (LF.NE.LPOS(1)) THEN
         LF = LPOS(1)
         LAMBDA = XFREQ(LF) + 9.0D0
         LAMBDA = 10.0D0**(LAMBDA)
         LAMBDA = VELITE / LAMBDA
         END IF
C                                       new coordinate
      IF ((LD.NE.LPOS(DAX)) .OR. (LR.NE.LPOS(RAX))) THEN
         DX = (LPOS(RAX) - RR) * RI
         DY = (LPOS(DAX) - DR) * DI
         DT = DX * COS (MROT) - DY * SIN (MROT)
         DY = DY * COS (MROT) + DX * SIN (MROT)
         DX = DT
         CALL NEWPOS (AXFUNC(KLOCL(LOCNUM)+1,LOCNUM), RA0, DE0, DX, DY,
     *      X, Y, IRET)
         IF (IRET.NE.0) THEN
            LD = -10
            GO TO 999
            END IF
         DT = SIN (DE0) * SIN (Y) + COS (DE0) * COS (Y) * COS (RA0-X)
         DT = MIN (1.0D0, DT)
         DT = MAX (-1.0D0, DT)
         ANGLE = RAD2DG * ACOS (DT)
         LD = LPOS(DAX)
         LR = LPOS(RAX)
         END IF
C                                       primary beam
      CALL PBCALC (ANGLE, LAMBDA, ARRAY, PBPARM(2), PBCORF, OUTSID)
      IF ((OUTSID) .OR. (PBCORF.LE.0.0) .OR. (PBCORF.LT.PBPARM(1))) THEN
         IRET = 1
      ELSE
         FCC = FCUT / PBCORF
         END IF
C
 999  RETURN
      END
      SUBROUTINE SPIXTV (TBLNKD, NX, NY, NZ, ITYP, IMAGE, ANSW, IRET)
C-----------------------------------------------------------------------
C   SPIXTV interacts with user and answer images
C   Inputs
C      NX       I      # X pixels
C      NY       I      # Y pixels
C      NZ       I      # spectral channels
C      ITYP     I      # answers (5 or 7)
C      IMAGE    R(*)   Input data image
C      TBLNKD   L      Answers contain blanked pixels?
C   In/output:
C      ANSW     R(*)   Answer images
C   Output:
C      IRET     I      Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      LOGICAL   TBLNKD
      INTEGER   NX, NY, NZ, ITYP, IRET
      REAL      IMAGE(NZ,NX,NY), ANSW(NX,NY,ITYP)
C
      INTEGER   I, J, I1, I2, MTYPE, MCOL, MROWS(2), GRCHS(2), TIMLIM,
     *   CHS, TVBUT, TOPSEP, SIDSEP, NTITL, IPOS(2), CATEMP(256), IC,
     *   ICOLOR, IG, II, IP, JJ, LSTIMG, NLEVS, JTRIM, DOCHAR
      CHARACTER CHOIC1(9)*16, CHOICD(14)*16, CHOICS(40)*16, ROUTIN*6,
     *   IMGTYP(7)*3, ISHELP*6, TITLE(3)*128, MSGBUF*72
      REAL      RANGE(2,3), ERROR(3), SLOPE
      LOGICAL   LEAVE(30), DOIT, IMGOK
      DOUBLE PRECISION XX(2)
      INCLUDE 'TVSPX.INC'
      INCLUDE 'TVSPX.TV'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DTVC.INC'
      DATA CHOIC1 /'EXIT', 'ABORT', ' ', 'SET BRIGHT RANGE',
     *   'SET SPIX RANGE', 'SET CURV RANGE', 'SET MAX ERR BR',
     *   'SET MAX ERR SPIX', 'SET MAX ERR CURV'/
      DATA CHOICD /' ', 'REDO ALL', 'FLAG ALL', ' ', 'ADD TO LIST',
     *   'CLEAR LIST', 'SHOW LIST', 'REDO LIST', 'FLAG LIST', ' ',
     *   'OFF ZOOM', 'OFF TRANSFER', 'RESET WINDOW', 'LABEL WEDGE?'/
      DATA IMGTYP /'NP', 'BR', 'EBR', 'SP', 'ESP', 'CU', 'ECU'/
      DATA LEAVE /.FALSE., 29*.TRUE./
C-----------------------------------------------------------------------
      CALL FILL (3, 0, SVZOOM)
      CALL TVOPEN (SCRTCH, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING TV DISPLAY'
         GO TO 990
         END IF
      CALL YINIT (BUFF1, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'INIT THE TV DISPLAY'
         GO TO 990
         END IF
      LABWED = .FALSE.
      IMGOK = .FALSE.
      SUBWIN(1) = 1
      SUBWIN(2) = 1
      SUBWIN(3) = NX
      SUBWIN(4) = NY
      DOCHAR = SQRT ((MAXXTV(1)/1024.0)*(MAXXTV(2)/1024.0)) + 0.5
      IF (DOCHAR.LE.1) DOCHAR = CSIZTV(1) / 7
      IF (DOCHAR.EQ.1) DOCHAR = 0
C                                       prepare menu
      J = 9
      DO 10 I = 1,9
         CHOICS(I) = CHOIC1(I)
 10      CONTINUE
      IF (ITYP.LT.7) THEN
         CHOICS(6) = CHOIC1(7)
         CHOICS(7) = CHOIC1(8)
         J = 7
         END IF
      DO 15 I = 1,14
         J = J + 1
         CHOICS(J) = CHOICD(I)
 15      CONTINUE
      IF (DOCHAR.GT.0) THEN
         J = J + 1
         CHOICS(J) = 'CHAR MULT'
         END IF
      MROWS(1) = J
      MROWS(2) = ITYP
      DO 20 I = 1,ITYP
         FUNCTY(I) = ' '
         J = J + 1
         CHOICS(J) = 'SHOW IMAGE ' // IMGTYP(I)
 20   CONTINUE
      MTYPE = -1
      MCOL = 2
C                                       turn on graphics
      IGR1 = 1 + NGRAY
      IGR2 = 2 + NGRAY
      IGR3 = 3 + NGRAY
      IGR4 = 4 + NGRAY
      IGR5 = 5 + NGRAY
      IGR7 = 7 + NGRAY
      ROUTIN = 'YSLECT'
      CALL YSLECT ('ONNN', IGR1, 0, IBUFF1, IRET)
      IF (IRET.NE.0) GO TO 980
      CALL YSLECT ('ONNN', IGR2, 0, IBUFF1, IRET)
      IF (IRET.NE.0) GO TO 980
      CALL YSLECT ('ONNN', IGR3, 0, IBUFF1, IRET)
      IF (IRET.NE.0) GO TO 980
      CALL YSLECT ('ONNN', IGR4, 0, IBUFF1, IRET)
      IF (IRET.NE.0) GO TO 980
      CALL RFILL (6, 0.0, RANGE)
      CALL RFILL (3, 0.0, ERROR)
      IF (TTYIND.LE.0) THEN
         TTYLUN = 5
         CALL ZOPEN (TTYLUN, TTYIND, 1, MSGBUF, .FALSE., .TRUE., .TRUE.,
     *      IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'OPEN TTY FOR INPUTS'
            TTYIND = 0
            GO TO 990
            END IF
         END IF
      GRCHS(1) = 2
      GRCHS(2) = 1
      TOPSEP = 3
      SIDSEP = 10
      ISHELP = TSKNAM
      TIMLIM = 0
      NTITL = 3
      IF (ITYP.LT.7) NTITL = 2
C                                       (re)set robust
 30   CONTINUE
      DO 40 I = 1,ITYP
         CALL TVSTAT (' ', NX, NY, ANSW(1,1,I), SUBWIN, ROBUST(1,I))
 40      CONTINUE
C                                       title lines
 50   WRITE (TITLE(1),1050) RANGE(1,1), RANGE(2,1), ERROR(1)
      WRITE (TITLE(2),1051) RANGE(1,2), RANGE(2,2), ERROR(2)
      WRITE (TITLE(3),1052) RANGE(1,3), RANGE(2,3), ERROR(3)
      CALL TVMENU (MTYPE, MCOL, MROWS, GRCHS, TOPSEP, SIDSEP, ISHELP,
     *   CHOICS, TIMLIM, LEAVE, NTITL, TITLE, CHS, TVBUT, IBUFF2, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1000) IRET, 'RETURNED FROM TVMENU'
         GO TO 990
         END IF
C                                       case statement
C                                       exit
      IF (CHOICS(CHS).EQ.'EXIT') THEN
         MSGTXT = 'Bye-bye'
         CALL MSGWRT (2)
         GO TO 990
      ELSE IF (CHOICS(CHS).EQ.'ABORT') THEN
         MSGTXT = 'Bye-bye and delete output files'
         CALL MSGWRT (2)
         IRET = 10
         GO TO 990
C                                       blank
      ELSE IF (CHOICS(CHS).EQ.' ') THEN
C                                       brightness range
      ELSE IF (CHOICS(CHS).EQ.'SET BRIGHT RANGE') THEN
         MSGBUF = 'Enter brightness range, 0 0 for self-scale'
         CALL INQFLN (TTYLUN, MSGBUF, 2, XX, JJ, IRET)
         IF (IRET.EQ.0) THEN
            RANGE(1,1) = XX(1)
            RANGE(2,1) = XX(2)
            END IF
C                                       spectral index range
      ELSE IF (CHOICS(CHS).EQ.'SET SPIX RANGE') THEN
         MSGBUF = 'Enter spectral index range, 0 0 for self-scale'
         CALL INQFLN (TTYLUN, MSGBUF, 2, XX, JJ, IRET)
         IF (IRET.EQ.0) THEN
            RANGE(1,2) = XX(1)
            RANGE(2,2) = XX(2)
            END IF
C                                       curvature range
      ELSE IF (CHOICS(CHS).EQ.'SET CURV RANGE') THEN
         MSGBUF = 'Enter spectral curvature range, 0 0 for self-scale'
         CALL INQFLN (TTYLUN, MSGBUF, 2, XX, JJ, IRET)
         IF (IRET.EQ.0) THEN
            RANGE(1,3) = XX(1)
            RANGE(2,3) = XX(2)
            END IF
C                                       max brightness rms
      ELSE IF (CHOICS(CHS).EQ.'SET MAX ERR BR') THEN
         MSGBUF = 'Enter maximum error in brightness'
         CALL INQFLT (TTYLUN, MSGBUF, 1, XX, IRET)
         IF (IRET.EQ.0) ERROR(1) = XX(1)
C                                       max spectral index rms
      ELSE IF (CHOICS(CHS).EQ.'SET MAX ERR SPIX') THEN
         MSGBUF = 'Enter maximum error in spectral index'
         CALL INQFLT (TTYLUN, MSGBUF, 1, XX, IRET)
         IF (IRET.EQ.0) ERROR(2) = XX(1)
C                                       max curvature rms
      ELSE IF (CHOICS(CHS).EQ.'SET MAX ERR CURV') THEN
         MSGBUF = 'Enter maximum error in spectral curvature'
         CALL INQFLT (TTYLUN, MSGBUF, 1, XX, IRET)
         IF (IRET.EQ.0) ERROR(3) = XX(1)
C                                       redo all
      ELSE IF (CHOICS(CHS).EQ.'REDO ALL') THEN
         DOIT = .FALSE.
         DO 58 IG = 1,3
            IF (ERROR(IG).GT.0.0) DOIT = .TRUE.
            IF (RANGE(1,IG).NE.RANGE(2,IG)) DOIT = .TRUE.
 58         CONTINUE
         IF (.NOT.DOIT) THEN
            MSGTXT = 'Allowed range and/or max error must be set'
            CALL MSGWRT (6)
         ELSE
            CALL YZERO (IGR5, IRET)
            CALL YZERO (1, IRET)
            CALL COPY (256, CATBLK, CATEMP)
            CALL COPY (256, CATOLD, CATBLK)
            CALL UPDALL ('REDO', RANGE, ERROR, NX, NY, NZ, ITYP, IMAGE,
     *         ANSW, IRET)
            CALL COPY (256, CATEMP, CATBLK)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'RE-DOING ALL'
               GO TO 990
               END IF
            GO TO 30
            END IF

C                                       flag all
      ELSE IF (CHOICS(CHS).EQ.'FLAG ALL') THEN
         DOIT = .FALSE.
         DO 59 IG = 1,3
            IF (ERROR(IG).GT.0.0) DOIT = .TRUE.
            IF (RANGE(1,IG).NE.RANGE(2,IG)) DOIT = .TRUE.
 59         CONTINUE
        IF (.NOT.DOIT) THEN
            MSGTXT = 'Allowed range and/or max error must be set'
            CALL MSGWRT (6)
         ELSE
            CALL YZERO (IGR5, IRET)
            CALL YZERO (1, IRET)
            CALL UPDALL ('FLAG', RANGE, ERROR,  NX, NY, NZ, ITYP, IMAGE,
     *         ANSW, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'FLAGGING ALL'
               GO TO 990
               END IF
            GO TO 30
            END IF
C                                       offzoom
      ELSE IF (CHOICS(CHS).EQ.'OFF ZOOM') THEN
         CALL FILL (3, 0, SVZOOM)
         TVZOOM(1) = 0
         TVZOOM(2) = MAXXTV(1) / 2
         TVZOOM(3) = MAXXTV(2) / 2
         CALL YZOOMC (TVZOOM(1), TVZOOM(2), TVZOOM(3), .TRUE., IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'TURNING OFF ZOOM'
            GO TO 990
            END IF
C                                       offtr
      ELSE IF (CHOICS(CHS).EQ.'OFF TRANSFER') THEN
         IC = 2 ** NGRAY - 1
         ICOLOR = 7
         NLEVS = MAXINT + 1
         SLOPE = REAL (LUTOUT) / REAL(MAXINT)
         DO 67 I = 1,NLEVS
            IBUFF1(I) = (I-1) * SLOPE + 0.5
 67         CONTINUE
         CALL YLUT ('WRIT', IC, ICOLOR, .FALSE., IBUFF1, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'TUNING OFF BLACK&WHITE TRANSFER'
            GO TO 990
            END IF
         I = OFMINP + 1
         ICOLOR = 7
         CALL RFILL (I, 0.0, BUFF1)
         NLEVS = LUTOUT + 1
         IF (NLEVS.GT.OFMINP) NLEVS = OFMINP + 1
         SLOPE = 1.0 / (NLEVS-1.0)
         DO 167 I = 1,NLEVS
            BUFF1(I) = (I-1) * SLOPE
 167        CONTINUE
         I = OFMINP + 1
         JJ = NLEVS
         I = I / NLEVS
         DO 267 II = 2,I
            CALL RCOPY (NLEVS, BUFF1, BUFF1(JJ+1))
            JJ = JJ + NLEVS
 267        CONTINUE
         CALL YOFM ('WRIT', ICOLOR, .FALSE., BUFF1, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'TUNING OFF PSEUDO-COLOR'
            GO TO 990
            END IF
C                                       reset window
      ELSE IF (CHOICS(CHS).EQ.'RESET WINDOW') THEN
         SUBWIN(1) = 1
         SUBWIN(2) = 1
         SUBWIN(3) = NX
         SUBWIN(4) = NY
         IP = LSTIMG
         IF (IP.GT.0) CALL SHOIMG (.TRUE., IP, NX, NY, ITYP, IGR5,
     *      ANSW, IRET)
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1000) IRET, 'SHOWING AN IMAGE'
            GO TO 990
         ELSE IF (IRET.LT.0) THEN
            IMGOK = .FALSE.
            IRET = 0
            END IF
C                                       label wedge
      ELSE IF (CHOICS(CHS).EQ.'LABEL WEDGE?') THEN
         LABWED = .NOT.LABWED
         IP = LSTIMG
         IF (IP.GT.0) CALL SHOIMG (.TRUE., IP, NX, NY, ITYP, IGR5,
     *      ANSW, IRET)
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1000) IRET, 'SHOWING AN IMAGE'
            GO TO 990
         ELSE IF (IRET.LT.0) THEN
            IMGOK = .FALSE.
            IRET = 0
            END IF
C                                       add to list
      ELSE IF (CHOICS(CHS).EQ.'ADD TO LIST') THEN
         IF (NLIST.GE.MAXLIS) THEN
            MSGTXT = 'LIST IS FULL'
            CALL MSGWRT (6)
         ELSE
            MSGBUF = 'Enter X and Y pixels to add to list: 2 integers'
            CALL INQINT (TTYLUN, MSGBUF, 2, IPOS, IRET)
            IF (IRET.NE.0) GO TO 50
            IF ((IPOS(1).LE.-1) .AND. (IPOS(1).GE.-NX) .AND.
     *         (IPOS(2).LE.-1) .AND. (IPOS(2).GE.-NY)) THEN
               IPOS(1) = -IPOS(1)
               IPOS(2) = -IPOS(2)
               DO 65 I = 1,NLIST
                  IF ((IPOS(1).EQ.PIXLIS(1,I)) .AND.
     *               (IPOS(2).EQ.PIXLIS(2,I))) GO TO 165
 65               CONTINUE
 165           IF (I.GT.NLIST) THEN
                  WRITE (MSGTXT,1165) IPOS, NX, NY
                  CALL MSGWRT (6)
               ELSE
                  DO 265 I1 = I+1,NLIST
                     PIXLIS(1,I) = PIXLIS(1,I1)
                     PIXLIS(2,I) = PIXLIS(2,I1)
                     I = I + 1
 265                 CONTINUE
                  NLIST = NLIST - 1
                  END IF
            ELSE IF ((IPOS(1).LT.1) .OR. (IPOS(1).GT.NX) .OR.
     *         (IPOS(2).LT.1) .OR. (IPOS(2).GT.NY)) THEN
               WRITE (MSGTXT,1265) IPOS, NX, NY
               CALL MSGWRT (6)
            ELSE
               NLIST = NLIST + 1
               PIXLIS(1,NLIST) = IPOS(1)
               PIXLIS(2,NLIST) = IPOS(2)
               END IF
            END IF
C                                       empty the list
      ELSE IF (CHOICS(CHS).EQ.'CLEAR LIST') THEN
         NLIST = 0
C                                       list list
      ELSE IF (CHOICS(CHS).EQ.'SHOW LIST') THEN
         IF (NLIST.LE.0) THEN
            MSGTXT = 'List is empty'
            CALL MSGWRT (6)
         ELSE
            I1 = 1
 66         I2 = MIN (NLIST, I1+3)
            IF (I2.GE.I1) THEN
               WRITE (MSGTXT,1066) (PIXLIS(1,I), PIXLIS(2,I), I = I1,I2)
               IF (I2-I1.LT.3) THEN
                  J = JTRIM (MSGTXT)
                  IF (MSGTXT(J:J).EQ.'(') MSGTXT(J:) = ' '
                  END IF
               CALL MSGWRT (2)
               I1 = I2 + 1
               GO TO 66
               END IF
            END IF
C                                       redo list
      ELSE IF (CHOICS(CHS).EQ.'REDO LIST') THEN
         IF (NLIST.LE.0) THEN
            MSGTXT = 'List is empty'
            CALL MSGWRT (6)
         ELSE
            CALL YZERO (IGR5, IRET)
            CALL YZERO (1, IRET)
            CALL COPY (256, CATBLK, CATEMP)
            CALL COPY (256, CATOLD, CATBLK)
            CALL UPDLIS ('REDO', NX, NY, NZ, ITYP, IMAGE, ANSW, IRET)
            CALL COPY (256, CATEMP, CATBLK)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'UPDATING FIT OF PIXEL LIST'
               GO TO 990
               END IF
            GO TO 30
            END IF
C                                       flag list
      ELSE IF (CHOICS(CHS).EQ.'FLAG LIST') THEN
         IF (NLIST.LE.0) THEN
            MSGTXT = 'List is empty'
            CALL MSGWRT (6)
         ELSE
            CALL YZERO (IGR5, IRET)
            CALL YZERO (1, IRET)
            CALL UPDLIS ('FLAG', NX, NY, NZ, ITYP, IMAGE, ANSW, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'UPDATING FIT OF PIXEL LIST'
               GO TO 990
               END IF
            GO TO 30
            END IF
C                                       flag list
      ELSE IF (CHOICS(CHS).EQ.'CHAR MULT') THEN
         I = CSIZTV(1) / 7
         WRITE (MSGBUF,1100) I
         CALL INQINT (TTYLUN, MSGBUF, 1, IPOS, IRET)
         IF (IRET.NE.0) GO TO 50
         IF ((IPOS(1).GE.1) .AND. (IPOS(1).LE.5)) THEN
            CALL YCMULT (IPOS(1), IRET)
            CSIZTV(1) = 7 * IPOS(1)
            CSIZTV(2) = 9 * IPOS(1)
            END IF
C                                       display image
      ELSE
         IP = CHS - MROWS(1)
         IF (MCOL.GT.2) IP = IP - MROWS(2)
         CALL SHOIMG (.FALSE., IP, NX, NY, ITYP, IGR5, ANSW, IRET)
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1000) IRET, 'SHOWING AN IMAGE'
            GO TO 990
         ELSE IF (IRET.LT.0) THEN
            IMGOK = .FALSE.
            IRET = 0
         ELSE
            LSTIMG = IP
            END IF
         END IF
      GO TO 50
C                                       TV function failure
 980  WRITE (MSGTXT,1000) IRET, 'TV INIT FUNCTIONS'
C
 990  IF ((IRET.GT.0) .AND. (IRET.NE.99)) CALL MSGWRT (8)
      IF (TTYIND.GT.0) THEN
         CALL ZCLOSE (TTYLUN, TTYIND, J)
         TTYIND = 0
         END IF
      CALL TVCLOS (SCRTCH, J)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SPIXTV ERROR',I4,' ON A',A)
 1050 FORMAT (F9.4,' < BRIGHT <',F10.4,'  ERROR <',F8.4)
 1051 FORMAT (F9.4,' < SPIX   <',F10.4,'  ERROR <',F8.4)
 1052 FORMAT (F9.4,' < CURV   <',F10.4,'  ERROR <',F8.4)
 1165 FORMAT ('POSITION',2I6,' NOT FOUND IN THE PIXEL LIST')
 1265 FORMAT ('POSITION',2I6,' OUTSIDE 1-',I5,' 1-',I5)
 1066 FORMAT (4('(',I5,',',I5,')',3X))
 1100 FORMAT ('Enter character multiplier 1 - 5, current value',I2)
      END
      SUBROUTINE SHOIMG (QUICK, IP, NX, NY, NP, LGR, ANSW, IRET)
C-----------------------------------------------------------------------
C   SHOIMG displays an image plane on the TV screen and allows an
C   interactive transfer function, coloring, CURVALUE, and EXIT.
C   Inputs:
C      QUICK   L      T -> load image and return
C      IP      I      Desired plane
C      NX      I      Number X pixels in image
C      NY      I      Number Y pixels in image
C      NP      I      Number Z pixels in image
C      LGR     I      Graphics plane for labeling
C      ANSW    R(*)   Images of NP parameters
C   Output:
C      IRET    I      Error code
C-----------------------------------------------------------------------
      LOGICAL   QUICK
      INTEGER   IP, NX, NY, NP, LGR, IRET
      REAL      ANSW(NX,NY,*)
C
      INCLUDE 'TVSPX.INC'
      INCLUDE 'TVSPX.TV'
      INTEGER   NOPTS
      PARAMETER (NOPTS=14)
      INCLUDE 'INCS:PMAD.INC'
      INCLUDE 'INCS:PTVC.INC'
C
      INTEGER   IX, IY, TVWIN(4), IWIN(4), NPIX, PLINC, IYTV, HORIZ,
     *   IBUFF(MABFSS), NLEVS, MCOL, NROWS, MTYPE, TIMLIM, TOPSEP, I,
     *   GRCHS(2), TVBUT, CHS, ITR, LUTBUF(TVMLUT), JJ, II, LTY, NW,
     *   EX(5), EY(5), NXFRAM, NYFRAM, CFRAME, TFRAME, PINC, LNX, LNY,
     *   IC(2), NPIXW, WXPOS, JTRIM, JT, MMCOL, POFF, NEDGE, SIDSEP,
     *   MINC, MPIX, JBUFF(MABFSS), JNX, JNY, NBO, MBOX, IGR,
     *   CATSAV(256), ILAB, MROWS(1)
      CHARACTER TRANFN*2, CHOICS(NOPTS+1)*12, ISHELP*8, TITLE*132,
     *   TVALS(7)*16, CHTEMP*8, FUNCS(4)*2, BUNITS*8, BTEMP*8,
     *   TUNITS(7)*8, STRING*128
      REAL      PMN, PMX, RPOS(4), SLOPE, TEMP, BLCO(7), TRCO(7),
     *   OFM(TVMOFM,3), IOFM(TVMOFM,3)
      LOGICAL   LEAVE(NOPTS+1), DOWEDG, DOEDGE
      EQUIVALENCE (NROWS, MROWS)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DTVC.INC'
      INCLUDE 'INCS:DLOC.INC'
      INCLUDE 'INCS:DCAT.INC'
      EQUIVALENCE (IBUFF, BUFF2, LUTBUF), (JBUFF, BUFF1)
      DATA MCOL, MTYPE, TIMLIM, TOPSEP, SIDSEP /1, -1, 0, 3, 10/
      DATA CHOICS /'RETURN', ' ','LOAD AS','SET WINDOW','RESET WINDOW',
     *   'OFF TRANSF', 'OFF COLOR', 'TVTRANSF', 'TVPSEUDO', 'TVPHLAME',
     *   'OFMCOLOR', 'TVZOOM', 'IMSTAT', 'CURVALUE', ' '/
      DATA LEAVE /13*.TRUE., .FALSE.,.TRUE./
      DATA TVALS /'CHANNELS', 'BRIGHTNESS', 'ERR BRIGHT', 'SPEC INDEX',
     *   'ERR SPIX', 'CURVATURE', 'ERR CURV'/
      DATA TUNITS /'PIXELS', 2*'JY/BEAM', 2*'SPECINDX',2*'SPECCURV'/
      DATA FUNCS /'LN', 'SQ', 'LG', 'L2'/
C-----------------------------------------------------------------------
      MMCOL = 1
      LTY = IP
      CALL YWINDO ('READ', WINDTV, IRET)
      NROWS = NOPTS
      IF (SVZOOM(1).NE.0) CALL COPY (3, SVZOOM, TVZOOM)
C                                       find max/min
 10   JNX = SUBWIN(3) - SUBWIN(1)
      JNY = SUBWIN(4) - SUBWIN(2)
      PMN = 1.E15
      PMX = -PMN
      DO 20 IY = SUBWIN(2),SUBWIN(4)
         DO 15 IX = SUBWIN(1),SUBWIN(3)
            IF (ANSW(IX,IY,IP).NE.FBLANK) THEN
               PMN = MIN (PMN, ANSW(IX,IY,IP))
               PMX = MAX (PMX, ANSW(IX,IY,IP))
               END IF
 15         CONTINUE
 20      CONTINUE
      IF (PMX.GE.PMN) THEN
         PLTMIN = PMN
         PLTMAX = PMX
         END IF
C                                       too big for TV?
      NXFRAM = (JNX - 1) / (MAXXTV(1)-33) + 1
      NYFRAM = (JNY - 1) / (MAXXTV(2)-33) + 1
      TFRAME = NXFRAM * NYFRAM
      CFRAME = 0
      PINC = MAX (NXFRAM, NYFRAM)
      LNX = JNX / PINC
      LNY = JNY / PINC
      MINC = 1
      IF (PINC.EQ.1) THEN
         JJ = 256
         IF ((MAXXTV(1).GT.650) .AND. (MAXXTV(2).GT.650)) JJ = 512
         IF ((2*JNX.LE.JJ) .AND. (2*JNY.LE.JJ)) THEN
            MINC = JJ / JNX
            IF (JJ/JNY.LT.MINC) MINC = JJ / JNY
            MINC = MIN (20, MINC)
            LNX = MINC * JNX
            LNY = MINC * JNY
            END IF
         END IF
      IC(1) = SUBWIN(1)
      IC(2) = SUBWIN(2)
C                                       menu list
      IF ((TFRAME.GT.1) .AND. (CHOICS(NROWS).NE.'NEXT WINDOW')) THEN
         NROWS = NROWS + 1
         CHOICS(NROWS) = 'NEXT WINDOW'
         POFF = 0
C                                       menu is on right and left sides
      ELSE IF (MMCOL.LE.2) THEN
         POFF = 0
C                                       offset image from menus
C                                       menu all on left
      ELSE
         NEDGE = (CSIZTV(1) + 1) / 2
         POFF = 2 * (2 + NEDGE + (MMCOL-1)*(1+NEDGE)) + 56 * CSIZTV(1)
         POFF = POFF + 7 + NEDGE
         IF (POFF+LNX.GT.WINDTV(3)-WINDTV(1)) POFF = 0
         END IF
C                                       width of wedge
      NW = MIN (JNY, 16)
C                                       no real image
      IF (PMX.LT.PMN) THEN
         MSGTXT = 'NO VALID PIXELS FOUND'
         IF ((SUBWIN(1).GT.1) .OR. (SUBWIN(2).GT.1) .OR.
     *      (SUBWIN(3).LT.NX) .OR. (SUBWIN(4).LT.NY)) THEN
            MSGTXT = 'NO VALID PIXELS FOUND: TRY DOING A RESET WINDOW'
            END IF
         CALL MSGWRT (7)
         IRET = -1
C                                       okay do it
      ELSE
         TRANFN = FUNCTY(IP)
         ITR = 1
         DO 30 I = 2,4
            IF (TRANFN.EQ.FUNCS(I)) ITR = I
 30         CONTINUE
         ITR = MOD (ITR, 4) + 1
C                                       header adjust
         CALL H2CHR (8, 1, CATOH(KHBUN), BUNITS)
         BTEMP = BUNITS(:4) // '*PIX'
         IF (MOD(IP-1,4).EQ.0) THEN
            CALL CHR2H (8, BUNITS, 1, CATH(KHBUN))
         ELSE IF (MOD(IP-1,4).EQ.3) THEN
            CALL CHR2H (8, BTEMP, 1, CATH(KHBUN))
         ELSE
            CALL CHR2H (8, 'PIXELS  ', 1, CATH(KHBUN))
            END IF
         CATR(KRDMX) = PMX
         CATR(KRDMN) = PMN
         TEMP = 0.005 * (PMX-PMN)
         CATR(IRRAN+1) = PMX + TEMP
         CATR(IRRAN) = PMN - TEMP
         WRITE (MSGTXT,1020) PMN, PMX, TVALS(LTY)
         CALL REFRMT (MSGTXT, '_', I)
         CALL MSGWRT (2)
C                                       window
 50      DOWEDG = .FALSE.
         DOEDGE = (LNX.LT.MAXXTV(1)-2) .AND.
     *      (LNY.LT.MAXXTV(2)-2*CSIZTV(2))
         IF (LNX.LE.MAXXTV(1)) THEN
            IWIN(1) = IC(1)
            IWIN(3) = IC(1) - 1 + (LNX/MINC) * PINC
            TVWIN(1) = (MAXXTV(1) - POFF - LNX) / 2 + POFF
            TVWIN(3) = TVWIN(1) + LNX - 1
            END IF
         IF (LNY.LE.MAXXTV(2)) THEN
            IF (LNY.LE.MAXXTV(2)-24) THEN
               IY = (NW * 2) / 3
               TVWIN(2) = (MAXXTV(2)-IY - LNY) / 2 + 16
               TVWIN(4) = TVWIN(2) + LNY - 1
               DOWEDG = .TRUE.
            ELSE
               TVWIN(2) = (MAXXTV(2) - LNY) / 2
               TVWIN(4) = TVWIN(2) + LNY - 1
               END IF
            IWIN(2) = IC(2)
            IWIN(4) = IC(2) - 1 + (LNY/MINC) * PINC
            END IF
         CALL COPY (4, IWIN, CATBLK(IIWIN))
         CALL COPY (4, TVWIN, CATBLK(IICOR))
C                                       not from disk
         CATBLK(IIVOL) = 0
         CATBLK(IICNO) = 0
         IPL(1) = 1
         IPL(2) = 1
         CALL YHOLD ('ONNN', IRET)
         CALL YZERO (LGR, IRET)
         CALL YZERO (IPL(1), IRET)
         IF (TFRAME.GT.1) THEN
            IF (PINC.EQ.1) THEN
               WRITE (MSGTXT,1050) CFRAME
            ELSE
               WRITE (MSGTXT,1051) PINC
               END IF
            CALL MSGWRT (2)
         ELSE IF (MINC.GT.1) THEN
            WRITE (MSGTXT,1052) MINC
            CALL MSGWRT (2)
            END IF
C                                       return here to reload
 60      CALL CHR2H (2, TRANFN, 1, CATH(IITRA))
         CHOICS(3)(9:10) = FUNCS(ITR)
         FUNCTY(IP) = TRANFN
         CALL YHOLD ('ONNN', IRET)
         CALL YCINIT (IPL(1), SCRTCH)
         CALL YCWRIT (IPL(1), TVWIN, CATBLK, SCRTCH, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITE IMAGE CATALOG'
            GO TO 990
            END IF
         CALL YSLECT ('ONNN', IPL(1), 0, SCRTCH, IRET)
         CALL COPY (256, CATBLK, CATSAV)
C                                       write TV image
         IYTV = TVWIN(2) - 1
         NPIX = (IWIN(3) - IWIN(1)) / PINC + 1
         MPIX = NPIX * MINC
         IF (MPIX.GT.17) THEN
            NPIXW = MPIX
            WXPOS = TVWIN(1)
         ELSE
            NPIXW = 17
            WXPOS = TVWIN(1) - (18-NPIX)/2
            WXPOS = MAX (1, WXPOS)
            END IF
         PLINC = 1
         HORIZ = 0
         DO 70 IY = IWIN(2),IWIN(4),PINC
            IYTV = IYTV + 1
            CALL ISCALE (TRANFN, MAXINT, CATR(IRRAN), NPIX*PINC, PINC,
     *         ANSW(IWIN(1),IY,IP), IBUFF)
            IF (MINC.EQ.1) THEN
               CALL YIMGIO ('WRIT', IPL(1), TVWIN(1), IYTV, HORIZ, NPIX,
     *            IBUFF, IRET)
            ELSE
               DO 64 I = 1,NPIX
                  CALL FILL (MINC, IBUFF(I), JBUFF(MINC*(I-1)+1))
 64               CONTINUE
               IYTV = IYTV - 1
               DO 65 I = 1,MINC
                  IYTV = IYTV + 1
                  IF (IRET.EQ.0) CALL YIMGIO ('WRIT', IPL(1), TVWIN(1),
     *               IYTV, HORIZ, MPIX, JBUFF, IRET)
 65               CONTINUE
               END IF
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'WRITING IMAGE TO TV'
               GO TO 990
               END IF
 70         CONTINUE
         IF (DOWEDG) THEN
            IYTV = TVWIN(2) - (NW+1)/2
            SLOPE = (PMX - PMN) / (NPIXW - 1)
            DO 80 IY = 1,NPIXW
               BUFF1(IY) = (IY - 1.0) * SLOPE + PMN
 80            CONTINUE
            CALL ISCALE (TRANFN, MAXINT, CATR(IRRAN), NPIXW, 1, BUFF1,
     *         IBUFF)
            DO 90 IY = 1,NW
               IYTV = IYTV - 1
               CALL YIMGIO ('WRIT', IPL(1), WXPOS, IYTV, HORIZ, NPIXW,
     *            IBUFF, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1000) IRET, 'WRITING WEDGE TO TV'
                  GO TO 990
                  END IF
 90            CONTINUE
            IF (NGRAPH.GE.4) THEN
               I = NGRAY + NGRAPH
               CALL YZERO (I, IRET)
               IRET = 0
               END IF
            IF ((IYTV.GT.2*CSIZTV(2)) .AND. (LABWED)) THEN
               CATBLK(IICOR) = WXPOS
               CATBLK(IICOR+2) = WXPOS + NPIXW -1
               CATBLK(IICOR+1) = IYTV
               CATBLK(IICOR+3) = IYTV + NW - 1
               CALL COPY (4, CATBLK(IICOR), CATBLK(IIWIN))
               CATR(KRCRP) = (CATBLK(IICOR) + CATBLK(IICOR+2)) / 2.0
               CATD(KDCRV) = (CATR(KRDMX) + CATR(KRDMN)) / 2.0
               CATR(KRCIC) = (CATR(KRDMX) - CATR(KRDMN)) /
     *            (CATBLK(IICOR+2) - CATBLK(IICOR))
               I = 2 * (KICTPN-1)
               CALL RFILL (I, HBLANK, CATH(KHCTP+2))
               CALL CHR2H (8, TUNITS(LTY), 1, CATH(KHCTP))
               CALL CHR2H (4, 'WEBB', 1, CATH(KHCTP+I))
               CATR(KRCIC+1) = 0.0
               CATR(KRCRP+1) = CATBLK(IICOR+1) - 1
               CATD(KDCRV+1) = 0.0
               CALL CHR2H (2, 'WE', KHPTYO, CATH(KHPTY))
               ILAB = 7
               LOCNUM = MAX (1, LOCNUM)
               LABTYP(LOCNUM) = 0
               LGR = 5
               CALL IAXIS1 (SCRTCH, ILAB, LGR, 1, .TRUE., IRET)
               IF (IRET.NE.0) THEN
                  MSGTXT = 'WEDGE LABEL ERROR'
                  CALL MSGWRT (6)
                  IRET = 0
                  END IF
               CALL COPY (256, CATSAV, CATBLK)
               END IF
            END IF
C                                       line around
         IF (DOEDGE) THEN
            EX(1) = TVWIN(1) - 1
            EY(1) = TVWIN(2) - 1
            EX(3) = TVWIN(3) + 1
            EY(3) = TVWIN(4) + 1
            EX(2) = EX(3)
            EY(2) = EY(1)
            EX(4) = EX(1)
            EY(4) = EY(3)
            EX(5) = EX(1)
            EY(5) = EY(1)
            LGR = NGRAY + 5
            CALL YSLECT ('ONNN', LGR, 0, IBUFF, IRET)
            IF (IRET.EQ.0) CALL IMVECT ('ONNN', LGR, 5, EX, EY, IBUFF,
     *         IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'DRAWING EDGE LINE AROUND' //
     *            ' THE IMAGE'
               GO TO 990
               END IF
            WRITE (STRING,1095) (ROBUST(I,IP), I = 1,4)
            CALL REFRMT (STRING, '_', I)
            EY(1) = EY(3) + (CSIZTV(2)+1)/2
            IF (EY(1)+1.5*CSIZTV(2).LT.MAXXTV(2)) THEN
               CALL IMCHAR (LGR, EX(1), EY(1), 0, 0, STRING(:I), IBUFF,
     *            IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1000) IRET, 'SHOWING STATISTICS'
                  GO TO 990
                  END IF
               END IF
            END IF
         IF (QUICK) THEN
            CALL YHOLD ('OFFF', IRET)
            GO TO 999
            END IF
         NLEVS = LUTOUT + 1
         ISHELP = TSKNAM
C                                       simple menu
C                                       menu selection
         IY = IP
         CALL H2CHR (8, 1, CATOH(KHBUN), CHTEMP)
         JT = JTRIM (TVALS(IP))
         TEMP = MAX (ABS(PMN), ABS(PMX))
         IF (TFRAME.GT.1) THEN
            IF ((TEMP.LT.10000.) .AND. (TEMP.GT.0.001)) THEN
               WRITE (TITLE,1090) CFRAME, TVALS(IP)(:JT), PMN, PMX
            ELSE
               WRITE (TITLE,1091) CFRAME, TVALS(IP)(:JT), PMN, PMX
            END IF
         ELSE
            IF ((TEMP.LT.10000.) .AND. (TEMP.GT.0.001)) THEN
               WRITE (TITLE,1092) TVALS(IP)(:JT), PMN, PMX
            ELSE
               WRITE (TITLE,1093) TVALS(IP)(:JT), PMN, PMX
               END IF
            END IF
         CALL REFRMT (TITLE, '_', I)
         GRCHS(1) = 2
         GRCHS(2) = 1
         RPOS(1) = MAXXTV(1) / 2
         RPOS(2) = MAXXTV(2) / 2
 100     CALL TVMENU (MTYPE, MCOL, MROWS, GRCHS, TOPSEP, SIDSEP, ISHELP,
     *      CHOICS, TIMLIM, LEAVE, 1, TITLE, CHS, TVBUT, IBUFF2, IRET)
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1000) IRET, 'RETURNED FROM TVMENU'
            GO TO 990
            END IF
C                                       return to main menu
         IF (CHOICS(CHS).EQ.'RETURN') THEN
            MSGTXT = 'Returning to main menu'
            CALL MSGWRT (2)
            CALL COPY (3, TVZOOM, SVZOOM)
            TVZOOM(1) = 0
            TVZOOM(2) = MAXXTV(1) / 2
            TVZOOM(3) = MAXXTV(2) / 2
            CALL YZOOMC (TVZOOM(1), TVZOOM(2), TVZOOM(3), .TRUE., IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'TURNING OFF ZOOM'
               GO TO 990
               END IF
            GO TO 999
C                                       blank
         ELSE IF (CHOICS(CHS).EQ.' ') THEN
C                                       set window
         ELSE IF (CHOICS(CHS).EQ.'SET WINDOW') THEN
            CALL YCINIT (LGR, IBUFF2)
            NBO = 0
            MBOX = 1
            CALL RCOPY (7, BLC, BLCO)
            CALL RCOPY (7, TRC, TRCO)
            IGR = LGR - NGRAY
            CALL GRBOXS (IGR, MBOX, NBO, BLCO, TRCO, BUFF2, IRET)
            IF (IRET.EQ.0) THEN
               SUBWIN(1) = BLCO(1) + 0.1
               SUBWIN(2) = BLCO(2) + 0.1
               SUBWIN(3) = TRCO(1) + 0.1
               SUBWIN(4) = TRCO(2) + 0.1
               WRITE (MSGTXT,1110) SUBWIN
               CALL MSGWRT (2)
               END IF
            GO TO 10
C                                       reset window
         ELSE IF (CHOICS(CHS).EQ.'RESET WINDOW') THEN
            SUBWIN(1) = 1
            SUBWIN(2) = 1
            SUBWIN(3) = NX
            SUBWIN(4) = NY
            GO TO 10
C                                       change transfer function
         ELSE IF (CHOICS(CHS)(:8).EQ.'LOAD AS ') THEN
            TRANFN = FUNCS(ITR)
            ITR = MOD (ITR, 4) + 1
            GO TO 60
C                                       TV transfer func OFF
         ELSE IF (CHOICS(CHS).EQ.'OFF TRANSF') THEN
            IYTV = MAXINT + 1
            SLOPE = REAL(LUTOUT) / REAL(MAXINT)
            DO 110 I = 1,IYTV
               LUTBUF(I) = (I-1) * SLOPE + 0.5
 110           CONTINUE
            I = 2 ** (IPL(1)-1)
            CALL YLUT ('WRIT', I, 7, .FALSE., LUTBUF, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'RETURNED BY OFF TRANSF'
               GO TO 990
               END IF
C                                       TV color func OFF
         ELSE IF (CHOICS(CHS).EQ.'OFF COLOR') THEN
            I = OFMINP + 1
            CALL RFILL (I, 0.0, BUFf1)
            NLEVS = LUTOUT + 1
            IF (I.LT.NLEVS) NLEVS = I
            SLOPE = 1.0 / (NLEVS-1.0)
            DO 120 I = 1,NLEVS
               BUFF1(I) = (I-1) * SLOPE
 120           CONTINUE
            I = (OFMINP + 1) / NLEVS
            JJ = NLEVS
            DO 130 II = 2,I
               CALL RCOPY (NLEVS, BUFF1, BUFF1(JJ+1))
               JJ = JJ + NLEVS
 130           CONTINUE
            CALL YOFM ('WRIT', 7, .FALSE., BUFF1, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'RETURNED BY OFF COLOR'
               GO TO 990
               END IF
C                                       TV transfer func
         ELSE IF (CHOICS(CHS).EQ.'TVTRANSF') THEN
            I = 2 ** (IPL(1)-1)
            IYTV = 1
            CALL IENHNS (I, 7, IYTV, RPOS, BUFF1, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'RETURNED BY TVTRANSF'
               GO TO 990
               END IF
C                                       TV pseudo colors
         ELSE IF (CHOICS(CHS).EQ.'TVPSEUDO') THEN
            CALL TVPSUD (NLEVS, BUFF1, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'RETURNED BY TVPSEUDO'
               GO TO 990
               END IF
C                                       TV flame colors
         ELSE IF (CHOICS(CHS).EQ.'TVPHLAME') THEN
            CALL TVFLAM (NLEVS, BUFF1, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'RETURNED BY TVPHLAME'
               GO TO 990
               END IF
C                                       TV OFM table colors
         ELSE IF (CHOICS(CHS).EQ.'OFMCOLOR') THEN
            CALL OFMCOL (NLEVS, OFM, IOFM, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'RETURNED BY OFMCOLOR'
               GO TO 990
               END IF
C                                       TV zoom
         ELSE IF (CHOICS(CHS).EQ.'TVZOOM') THEN
            CALL TVZOME (IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'RETURNED BY TVZOOM'
               GO TO 990
               END IF
C                                       Cursor value: local version
         ELSE IF (CHOICS(CHS).EQ.'CURVALUE') THEN
            CALL YSLECT ('OFFF', GRCHS(2)+NGRAY, 0, IBUFF1, IRET)
            CALL TVALUE (GRCHS(1), NX, NY, ANSW(1,1,IP), CUNITS(IP),
     *         NLIST, PIXLIS, IBUFF1, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'RETURNED BY TVALUE'
               GO TO 990
               END IF
C                                       Imstat
         ELSE IF (CHOICS(CHS).EQ.'IMSTAT') THEN
            CALL TVSTAT (TVALS(IP), NX, NY, ANSW(1,1,IP), SUBWIN,
     *         RPOS)
            IF ((SUBWIN(1).EQ.1) .AND. (SUBWIN(2).EQ.1) .AND.
     *         (SUBWIN(3).EQ.NX) .AND. (SUBWIN(4).EQ.NY)) THEN
               CALL RCOPY (4, RPOS, ROBUST(1,IP))
               IF (DOEDGE) THEN
                  WRITE (STRING,1095) (ROBUST(I,IP), I = 1,4)
                  I = JTRIM (STRING)
                  CALL REFRMT (STRING, '_', II)
                  EY(1) = EY(3) + (CSIZTV(2)+1)/2
                  CALL IMCHAR (LGR, EX(1), EY(1), 0, 0, STRING(:I),
     *               IBUFF, IRET)
                  IF (IRET.NE.0) THEN
                     WRITE (MSGTXT,1000) IRET, 'SHOWING STATISTICS'
                     GO TO 990
                     END IF
                  END IF
               END IF
C                                       load next portion
         ELSE IF (CHOICS(CHS).EQ.'NEXT WINDOW') THEN
            CFRAME = CFRAME + 1
            IF (CFRAME.GT.TFRAME) THEN
               CFRAME = 0
               PINC = MAX (NXFRAM, NYFRAM)
               IC(1) = SUBWIN(1)
               IC(2) = SUBWIN(2)
               LNX = JNX / PINC
               LNY = JNY / PINC
            ELSE
               PINC = 1
               IF (NXFRAM.EQ.1) THEN
                  IC(1) = SUBWIN(1)
                  LNX = JNX
               ELSE
                  II = MOD (CFRAME-1, NXFRAM) + 1
                  IC(1) = (II - 1) * (MAXXTV(1) - 3) + SUBWIN(1)
                  IF (IC(1)+MAXXTV(1)-33.GT.NX) IC(1) = JNX - MAXXTV(1)
     *               + 33
                  LNX = MAXXTV(1) - 33
                  END IF
               IF (NYFRAM.EQ.1) THEN
                  IC(2) = SUBWIN(2)
                  LNY = JNY
               ELSE
                  II = (CFRAME-1) / NXFRAM + 1
                  IC(2) = (II - 1) * (MAXXTV(2) - 3) + SUBWIN(2)
                  IF (IC(2)+MAXXTV(2)-33.GT.NY) IC(2) = JNY - MAXXTV(2)
     *               + 33
                  LNY = MAXXTV(2) - 33
                  END IF
               END IF
            GO TO 50
            END IF
         GO TO 100
         END IF
C
 990  IF (IRET.GT.0) CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SHOIMG: ERROR:',I4,' ON ',A)
 1020 FORMAT ('Loading image',F12.5,' to',F12.5,' of ',A)
 1050 FORMAT ('Loading every pixel in subimage',I3)
 1051 FORMAT ('Loading full image with only every',I3,
     *   ' pixels in X and Y')
 1052 FORMAT ('Loading every pixel replicated by',I3)
 1090 FORMAT ('Subim',I3,2X,A,'_',F11.5,' TO',F11.5)
 1091 FORMAT ('Subim',I3,2X,A,'_',1PE11.3,' TO',1PE11.3)
 1092 FORMAT (A,'_',F11.5,' TO',F11.5)
 1093 FORMAT (A,'_',1PE11.3,' TO',1PE11.3)
 1095 FORMAT ('Robust mean, rms',2F10.3,'____Full mean, rms',2F10.3)
 1110 FORMAT ('BLC/TRC=',4I7)
      END
      SUBROUTINE TVALUE (GR, NX, NY, IMAGE, CUNITS, NLIST, PIXLIS,
     *   BUFFER, IRET)
C-----------------------------------------------------------------------
C   TVALUE performs interactive displays of map image values:
C   Special version for XGAUS - allows picking pixels for list
C   Inputs:
C      GR        I        Graphics plane for lettering
C      NX        I        Number X pixels in image
C      NY        I        Number Y pixels in image
C      IMAGE     R(*)     Image values
C   In/out:
C      NLIST     I        Number entries in PIXLIS
C      PIXLIST   I(2,*)   List of pixels
C   Output:
C      BUFFER    I(*)     Scratch buffer
C      IRET      I        Basic TV error code
C-----------------------------------------------------------------------
      INTEGER   GR, NX, NY, NLIST, PIXLIS(2,*), BUFFER(*), IRET
      REAL      IMAGE(NX,NY)
      CHARACTER CUNITS*(*)
C
      CHARACTER STRING*16, PREFIX*5, ITRTYP(8)*2, LMTYPS(2)*2, LMTYPE*2
      INTEGER   MIND, IG, IG1, IG2, ITW(3), NPIX, NROW, MAG, IX0, IY0,
     *   IX, IY, IP, ECOUNT, QUAD, IBUT, ITR, ICMASK, ZAND, ISCX,
     *   ISCY, I, INCNO, INVOL, LDEP(5), ITG1, ITG2, ITEMP, IX1, IY1,
     *   MSGSAV, LBUT
      REAL      PPOS(2), RPOS(2), PIXVAL, CORN(7)
      LOGICAL   T, F, EQUAL, DOIT, FROMTV, BLNKD, NOQUAD
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DTVC.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA ITRTYP /'LN','LG','L2','SQ','NE','NG','N2','NQ'/
      DATA LMTYPS /'WE','ZZ'/
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
      MIND = 0
      QUAD = 0
      FROMTV = .TRUE.
      CALL ZTIME (ITW)
      MSGSAV = MSGSUP
      NOQUAD = .TRUE.
C                                       Turn on graphics
      CALL YHOLD ('ONNN', IRET)
      IG1 = MIN (GR, NGRAPH)
      IF (IG1.LE.0) IG1 = MIN (2, NGRAPH)
      IG2 = 0
      IF (NGRAPH.GE.4) IG2 = NGRAPH
      ITG1 = NGRAY + IG1
      ITG2 = NGRAY + IG2
      CALL YSLECT ('ONNN', ITG1, 0, BUFFER, IRET)
      IF (IRET.NE.0) GO TO 970
      CALL YZERO (ITG1, IRET)
      IF (IRET.NE.0) GO TO 970
      IF (IG2.NE.0) THEN
         CALL YSLECT ('ONNN', ITG2, 0, BUFFER, IRET)
         IF (IRET.NE.0) GO TO 970
         CALL YZERO (ITG2, IRET)
         IF (IRET.NE.0) GO TO 970
         END IF
C                                       Display area: location, size
C                                       Approx corr for zoom
      NPIX = 13 * CSIZTV(1)
      NROW = 4 * CSIZTV(2)
      ISCX = 0
      ISCY = 0
      MAG = 1 + TVZOOM(1)
      IF (MXZOOM.GT.0) MAG = 2 ** TVZOOM(1)
      IX0 = WINDTV(1) - (MAG-1)/2
      IY0 = WINDTV(4) - MAG*NROW + 1 - (MAG-1)/2
      IF (MAG.GT.1) IY0 = IY0 + MAG
      IX0 = (IX0 - TVZOOM(2)) / MAG + TVZOOM(2) - TVSCGX
      IY0 = (IY0 - TVZOOM(3)) / MAG + TVZOOM(3) - TVSCGY
      IF (IX0+NPIX-1.GT.MAXXTV(1)) IX0 = 1
      IF (IY0+NROW-1.GT.MAXXTV(2)) IY0 = MAXXTV(2) - NROW + 1
      IX1 = IX0 + NPIX - 1
      IY1 = IY0 + NROW - 1
      CALL YFILL (ITG1, IX0, IY0, IX1, IY1, 0, BUFFER, IRET)
      IF (IRET.NE.0) GO TO 970
      IF (IG2.GT.0) THEN
         CALL YFILL (ITG2, IX0, IY0, IX1, IY1, 1, BUFFER, IRET)
         IF (IRET.NE.0) GO TO 970
         END IF
      CALL YHOLD ('OFFF', IRET)
C                                       CURVALUE (from disk file)
C                                       no image yet
      RPOS(1) = (CATBLK(IICOR) + CATBLK(IICOR+2)) / 2
      RPOS(2) = (CATBLK(IICOR+1) + CATBLK(IICOR+3)) / 2
      CALL FILL (4, 0, CATBLK(IICOR))
      CATBLK(IICNO) = 0
      LDEP(1) = -10000
      WRITE (MSGTXT,1100)
      CALL MSGWRT (1)
      WRITE (MSGTXT,1101)
      CALL MSGWRT (1)
      WRITE (MSGTXT,1102)
      CALL MSGWRT (1)
C                                       turn on cursor
      IP = 0
      ECOUNT = 0
      IG = IG1 + NGRAY
      PPOS(1) = 0.0
      PPOS(2) = 0.0
      CALL YCURSE ('ONNN', F, F, RPOS, QUAD, IBUT, IRET)
      IF (IRET.NE.0) GO TO 970
C                                       Cursor read loop point
 110  CALL YCURSE ('READ', F, F, RPOS, QUAD, IBUT, IRET)
      IF ((IBUT.GE.4) .OR. (IRET.NE.0)) GO TO 970
      LBUT = IBUT
      CALL DLINTR (RPOS, IBUT, PPOS, ITW, DOIT)
      IF (.NOT.DOIT) GO TO 110
C                                       Find new image catalog block
         QUAD = 0
         CALL YCURSE ('FXIT', F, T, RPOS, QUAD, IBUT, IRET)
         IX = RPOS(1) + 0.51
         IY = RPOS(2) + 0.51
         INCNO = CATBLK(IICNO)
         INVOL = CATBLK(IIVOL)
         IF ((IX.LT.CATBLK(IICOR)) .OR. (IX.GT.CATBLK(IICOR+2)) .OR.
     *      (IY.LT.CATBLK(IICOR+1)) .OR. (IY.GT.CATBLK(IICOR+3))) THEN
            DO 115 IP = 1,NGRAY
               ITEMP = 2 ** (IP - 1)
               IF (ZAND(TVLIMG(QUAD),ITEMP).NE.0) THEN
                  CALL YCREAD (IP, IX, IY, CATBLK, IRET)
                  IF (IRET.EQ.0) GO TO 120
                  IF (IRET.NE.1) GO TO 960
                  END IF
 115           CONTINUE
C                                       No or invalid image here
 116        ECOUNT = ECOUNT + 1
            CALL FILL (4, 0, CATBLK(IICOR))
            CATBLK(IICNO) = 0
            IF (ECOUNT.LT.1) THEN
               WRITE (MSGTXT,1116) IX, IY
               CALL MSGWRT (1)
               END IF
            GO TO 110
C                                       Set up image reads
 120        CALL H2CHR (2, KHPTYO, CATH(KHPTY), LMTYPE)
            IF (LMTYPE.EQ.LMTYPS(2)) GO TO 116
            BLNKD = .FALSE.
C                                       Scaling parms for TV pixvals
            CALL COPY (5, CATBLK(IIDEP), LDEP)
            ICMASK = 2 ** (IP-1)
            ITR = 1
            CALL H2CHR (2, 1, CATH(IITRA), LMTYPE)
            DO 135 I = 1,8
               IF (LMTYPE.EQ.ITRTYP(I)) ITR = I
 135           CONTINUE
            ECOUNT = 0
            END IF
C                                       From TV for wedges
         CALL IMA2MP (RPOS, CORN)
         IX = CORN(1) + 0.51
         IY = CORN(2) + 0.51
         PIXVAL = IMAGE(IX,IY)
         BLNKD = IMAGE(IX,IY).EQ.FBLANK
C                                       Button A or B => add to lists
         IF (LBUT.GT.0) THEN
            NLIST = NLIST + 1
            PIXLIS(1,NLIST) = IX
            PIXLIS(2,NLIST) = IY
            WRITE (MSGTXT,1135) IX, IY
            CALL MSGWRT (2)
            END IF
C                                       Write text to TV
         IF ((IX.LE.9999) .AND. (IY.LE.9999)) THEN
            WRITE (STRING,1170) IX, IY
         ELSE
            WRITE (STRING,1171) IX, IY
            END IF
         IY = IY0 + 3*CSIZTV(2)
         CALL YHOLD ('ONNN', IRET)
         CALL YSLECT ('OFFF', ITG1, 0, BUFFER, IRET)
         IF (IRET.NE.0) GO TO 970
         CALL IMCHAR (IG, IX0, IY, 0, 0, STRING(:13), BUFFER, IRET)
         IF (IRET.NE.0) GO TO 970
         IF (.NOT.BLNKD) THEN
            CALL METSCA (PIXVAL, PREFIX, EQUAL)
            WRITE (STRING,1172) PIXVAL
            IY = IY - 1.5*CSIZTV(2)
            CALL IMCHAR (IG, IX0, IY, 0, 0, STRING(:10), BUFFER, IRET)
            IF (IRET.NE.0) GO TO 970
            STRING = PREFIX
            STRING(6:) = CUNITS
            CALL IMCHAR (IG, IX0, IY0, 0, 0, STRING(:13), BUFFER, IRET)
            IF (IRET.NE.0) GO TO 970
         ELSE
            STRING = 'B  BLANKED'
            IY = IY - 1.5*CSIZTV(2)
            CALL IMCHAR (IG, IX0, IY, 0, 0, STRING(:10), BUFFER, IRET)
            IF (IRET.NE.0) GO TO 970
            STRING = ' '
            CALL IMCHAR (IG, IX0, IY0, 0, 0, STRING(:13), BUFFER, IRET)
            IF (IRET.NE.0) GO TO 970
            END IF
         IF (IG2.GT.0) CALL YFILL (ITG2, IX0, IY0, IX1, IY1, 1,
     *      BUFFER, IRET)
         IF (IRET.NE.0) GO TO 970
         CALL YSLECT ('ONNN', ITG1, 0, BUFFER, IRET)
         IF (IRET.NE.0) GO TO 970
         CALL YHOLD ('OFFF', IRET)
C                                       Button A or B => add to lists
         IF (IBUT.GT.0) THEN
            NLIST = NLIST + 1
            PIXLIS(1,NLIST) = IX
            PIXLIS(2,NLIST) = IY
            END IF
         GO TO 110
C-----------------------------------------------------------------------
C                                       Close downs
C                                       Img Catlg error
 960  WRITE (MSGTXT,1960) IRET
      CALL MSGWRT (6)
      GO TO 975
C                                       TV error possibly
 970  IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1970) IRET
         CALL MSGWRT (6)
         END IF
C                                       Close things
 975  CALL YHOLD ('ONNN', I)
      CALL YCURSE ('OFFF', F, F, RPOS, QUAD, IBUT, I)
      ITEMP = 2 ** NGRAY
      IF ((ISCX.NE.0) .OR. (ISCY.NE.0)) CALL YSCROL (ITEMP, ISCX,
     *   ISCY, F, I)
      CALL YZERO (ITG1, I)
      IF (IG2.NE.0) CALL YZERO (ITG2, I)
C
 999  RETURN
C-----------------------------------------------------------------------
 1100 FORMAT ('Cursor selects which pixel is displayed')
 1101 FORMAT ('Hit button A or B to add the current pixel to list')
 1102 FORMAT ('Hit button C or D to exit')
 1116 FORMAT ('TVALUE: ',2I7,' NOT IN VALID IMAGE')
 1135 FORMAT ('Pixel',I5,',',I5,' added to list')
 1170 FORMAT ('X=',I4,' Y=',I4)
 1171 FORMAT (I6,I7)
 1172 FORMAT ('B=',F8.3)
 1960 FORMAT ('TVALUE: IMAGE CAT FILE IO ERROR',I7)
 1970 FORMAT ('TVALUE: TV ACTION IO ERROR',I7)
      END
      SUBROUTINE TVSTAT (CTYPE, NX, NY, IMAGE, WIN, ROBUST)
C-----------------------------------------------------------------------
C   TVSTAT computes the statistics of an image
C   reports the results
C   Inputs:
C      CTYPE    C*(*)    Image type
C      NX       I        Number X pixels
C      NY       I        Number Y pixels (rows)
C      IMAGE    R(*,*)   Image values
C      WIN      I(4)     window for stat
C   Output
C      ROBUST   R(4)     Robust mean, rms; Full mean, rms
C-----------------------------------------------------------------------
      CHARACTER CTYPE*(*)
      INTEGER   NX, NY, WIN(4)
      REAL      IMAGE(NX,NY), ROBUST(4)
C
      INTEGER   IX, IY, NPASS, SN,
     *   TN, J, JTRIM
      REAL      T, RX, A
      DOUBLE PRECISION RSP, RSM, TT, SS, SQ, RM, RS, TS, TQ
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
C-----------------------------------------------------------------------
C                                       we need to find it
      RSP = 1.D10
      RSM = -1.D10
      RX = 0.0
      DO 60 NPASS = 1,7
         SS = 0.0D0
         SQ = 0.0D0
         SN = 0
         TS = 0.0D0
         TQ = 0.0D0
         TN = 0
         DO 50 IY = WIN(2),WIN(4)
            DO 40 IX = WIN(1),WIN(3)
               T = IMAGE(IX,IY)
               IF (T.NE.FBLANK) THEN
                  RX = MAX (RX, ABS(T))
                  TT = T
                  IF ((TT.LT.RSP) .AND. (TT.GT.RSM)) THEN
                     SS = SS + TT
                     SQ = SQ + TT * TT
                     SN = SN + 1
                     END IF
                  TS = TS + TT
                  TQ = TQ + TT * TT
                  TN = TN + 1
                  END IF
 40            CONTINUE
 50         CONTINUE
         IF (SN.LE.0.0D0) THEN
            RSP = RSP + 3.0D0 * RS
            RSM = RSP - 3.0D0 * RS
         ELSE
            RM = SS / SN
            SQ = SQ / SN
            RS = SQ - RM * RM
            RS = SQRT (MAX (0.0D0, RS))
            RS = MAX (RS, 0.01D0*RM)
            RSP = RM + 3.0D0 * RS
            RSM = RM - 4.0D0 * RS
            END IF
         IF (TN.GT.0) THEN
            TS = TS / TN
            TQ = TQ / TN - TS * TS
            TQ = SQRT (MAX (0.0D0, TQ))
            END IF
 60      CONTINUE
      J = JTRIM (CTYPE)
      IF (J.GT.0) THEN
         WRITE (MSGTXT,1060) CTYPE(:J), RM, RS
         CALL MSGWRT (3)
         WRITE (MSGTXT,1061) CTYPE(:J), TS, TQ
         CALL MSGWRT (3)
         END IF
      ROBUST(1) = RM
      ROBUST(2) = RS
      ROBUST(3) = TS
      ROBUST(4) = TQ
C
 999  RETURN
C-----------------------------------------------------------------------
 1060 FORMAT ('Image ',A,'  robust mean',1PE12.4,'  rms',1PE12.4)
 1061 FORMAT ('Image ',A,'  full   mean',1PE12.4,'  rms',1PE12.4)
      END
      SUBROUTINE UPDALL (OPER, RANGE, ERROR, NX, NY, NZ, ITYP, IMAGE,
     *   ANSW, IRET)
C-----------------------------------------------------------------------
C   UPDALL flags or re-does fitting on all pixels matching test
C   conditions
C   Inputs:
C      OPER     C*4    'REDO', 'FLAG'
C      RANGE    R(2,3)   Min/Max range
C      ERROR    R(3)     Max allowed rms
C      NX       I        # X pixels
C      NY       I        # Y pixels
C      NZ       I        # freq pixels
C      ITYP     I        # parameters (5, 7)
C   In/out:
C      IMAGE    R(*)   Images of data (NX,NY,NZ)
C      ANSW     R(*)     Answers (NX,NY,ITYP)
C   Output:
C      IRET     I      Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      CHARACTER OPER*4
      INTEGER   NX, NY, NZ, ITYP, IRET
      REAL      RANGE(2,3), ERROR(3), IMAGE(NZ,NX,NY), ANSW(NX,NY,ITYP)
C
      INCLUDE 'TVSPX.INC'
      INTEGER   IX, IY, I, J, N
      LOGICAL   DOIT(7), CH, REV(7)
      REAL      RESULT(7)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      DATA REV /7*.FALSE./
C-----------------------------------------------------------------------
      DOIT(2) = RANGE(2,1).GT.RANGE(1,1)
      DOIT(4) = RANGE(2,2).GT.RANGE(1,2)
      DOIT(6) = RANGE(2,3).GT.RANGE(1,3)
      DOIT(3) = ERROR(1).GT.0.0
      DOIT(5) = ERROR(2).GT.0.0
      DOIT(7) = ERROR(3).GT.0.0
      REV(2) = RANGE(2,1).LT.RANGE(1,1)
      REV(4) = RANGE(2,2).LT.RANGE(1,2)
      REV(6) = RANGE(2,3).LT.RANGE(1,3)
      IF (OPER.EQ.'FLAG') THEN
         N = 0
         DO 40 IY = SUBWIN(2),SUBWIN(4)
            DO 30 IX = SUBWIN(1),SUBWIN(3)
               CH = .FALSE.
               DO 10 I = 2,ITYP,2
                  J = I/2
                  IF (ANSW(IX,IY,I).NE.FBLANK) THEN
                     IF ((I.EQ.4) .AND. (ABS(ANSW(IX,IY,I)).LT.0.1))
     *                  THEN
                        MSGTXT = 'WE ARE HERE'
                        END IF
                     IF ((DOIT(I)) .AND. ((ANSW(IX,IY,I).LT.RANGE(1,J))
     *                  .OR. (ANSW(IX,IY,I).GT.RANGE(2,J)))) CH = .TRUE.
                     IF ((DOIT(I+1)).AND.(ANSW(IX,IY,I+1).GT.ERROR(J)))
     *                  CH = .TRUE.
                     IF ((REV(I)) .AND. (ANSW(IX,IY,I).LT.RANGE(1,J))
     *                  .AND. (ANSW(IX,IY,I).GT.RANGE(2,J))) CH = .TRUE.
                     END IF
 10               CONTINUE
               IF (CH) THEN
                  N = N + 1
                  DO 20 I = 1,ITYP
                     ANSW(IX,IY,I) = FBLANK
 20                  CONTINUE
                  END IF
 30            CONTINUE
 40         CONTINUE
      ELSE
         N = 0
         DO 80 IY = SUBWIN(2),SUBWIN(4)
            DO 70 IX = SUBWIN(1),SUBWIN(3)
               CH = .FALSE.
               DO 50 I = 2,ITYP,2
                  J = I/2
                  IF (ANSW(IX,IY,I).NE.FBLANK) THEN
                     IF ((DOIT(I)) .AND. ((ANSW(IX,IY,I).LT.RANGE(1,J))
     *                  .OR. (ANSW(IX,IY,I).GT.RANGE(2,J)))) CH = .TRUE.
                     IF ((DOIT(I+1)).AND.(ANSW(IX,IY,I+1).GT.ERROR(J)))
     *                  CH = .TRUE.
                     IF ((REV(I)) .AND. (ANSW(IX,IY,I).LT.RANGE(1,J))
     *                  .AND. (ANSW(IX,IY,I).GT.RANGE(2,J))) CH = .TRUE.
                     END IF
 50               CONTINUE
               IF (CH) THEN
                  DO 55 J = 1,ITYP
                     RESULT(J) = ANSW(IX,IY,J)
 55                  CONTINUE
                  CALL SPREDO (NZ, ITYP, IX, IY, IMAGE(1,IX,IY), RESULT,
     *                  IRET)
                  IF (IRET.NE.0) THEN
                     WRITE (MSGTXT,1080) OPER, N, 'But skipped some'
                     CALL MSGWRT (4)
                     IRET = 0
                     GO TO 999
                     END IF
                  N = N + 1
                  DO 60 J = 1,ITYP
                     ANSW(IX,IY,J) = RESULT(J)
 60                  CONTINUE
                  END IF
 70            CONTINUE
 80         CONTINUE
         END IF
      WRITE (MSGTXT,1080) OPER, N, ' '
      CALL MSGWRT (4)
      CALL RFILL (6, 0.0, RANGE)
      CALL RFILL (3, 0.0, ERROR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1080 FORMAT ('UPDALL did ',A,' on',I8,' pixels ',A)
      END
      SUBROUTINE UPDLIS (OPER, NX, NY, NZ, ITYP, IMAGE, ANSW, IRET)
C-----------------------------------------------------------------------
C   UPDLIS flags or re-does fitting on a list of pixels
C   Inputs:
C      OPER     C*4    'REDO', 'FLAG'
C      NX       I      # X pixels
C      NY       I      # Y pixels
C      NZ       I      # freq pixels
C      ITYP     I      # parameters (5, 7)
C   In/out:
C      IMAGE    R(*)   Images of data (NX,NY,NZ)
C      ANSW     R(*)   Answers (NX,NY,ITYP)
C   Output:
C      IRET     I      Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      CHARACTER OPER*4
      INTEGER   NX, NY, NZ, ITYP, IRET
      REAL      IMAGE(NZ,NX,NY), ANSW(NX,NY,ITYP)
C
      INCLUDE 'TVSPX.INC'
      INTEGER   I, IX, IY, J, N
      REAL      RESULT(7)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
C-----------------------------------------------------------------------
      IRET = 0
      IF (OPER.EQ.'FLAG') THEN
         DO 20 I = 1,NLIST
            IX = PIXLIS(1,I)
            IY = PIXLIS(2,I)
            DO 10 J = 1,ITYP
               ANSW(IX,IY,J) = FBLANK
 10            CONTINUE
 20         CONTINUE
         N = NLIST
C                                       redo
      ELSE
         N = 0
         DO 50 I = 1,NLIST
            IX = PIXLIS(1,I)
            IY = PIXLIS(2,I)
            DO 35 J = 1,ITYP
               RESULT(J) = ANSW(IX,IY,J)
 35            CONTINUE
            CALL SPREDO (NZ, ITYP, IX, IY, IMAGE(1,IX,IY), RESULT, IRET)
            IF (IRET.NE.0) GO TO 60
            N = N + 1
            DO 40 J = 1,ITYP
               ANSW(IX,IY,J) = RESULT(J)
 40            CONTINUE
 50         CONTINUE
         END IF
 60   WRITE (MSGTXT,1080) OPER, N
      CALL MSGWRT (4)
      IF (N.LT.NLIST) THEN
         IX = 2 * (NLIST - N)
         CALL COPY (IX, PIXLIS(1,N+1), PIXLIS(1,1))
         END IF
      NLIST = NLIST - N
      WRITE (MSGTXT,1081) NLIST
      IF (NLIST.GT.0) CALL MSGWRT (4)
      IRET = 0
C
 999  RETURN
C-----------------------------------------------------------------------
 1080 FORMAT ('UPDLIS did ',A,' on',I5,' pixels')
 1081 FORMAT ('There are',I5,' pixels left in the list')
      END
      SUBROUTINE SPREDO (NZ, ITYP, IX, IY, IMAGE, RESULT, IRET)
C-----------------------------------------------------------------------
C   SPREDO displays a spectrum, allows interaction to fit, flag data
C   returns new values to the answer
C   Inputs
C      NZ      I      # spectral points
C      ITYP    I      # answers (5 or 7)
C      IX      I      X pixel
C      IY      I      Y pixel
C      IMAGE   R(*)   spectrum
C   In/Output:
C      RESULT  R(*)   Initial/New fit parms (or blanked)
C      IRET    I      > 0 => quit was selected
C-----------------------------------------------------------------------
      INTEGER   NZ, ITYP, IX, IY, IRET
      REAL      IMAGE(*), RESULT(*)
C
      INCLUDE 'TVSPX.INC'
      INCLUDE 'TVSPX.TV'
      INTEGER   I, J, MCOL, MROWS(1), TVWIND(4), IDROP(2), LABEL,
     *   IDEPTH(5), TVSIZE(2), IX1, IY1, IX2, IY2, ICHL, ICHB, ICHR,
     *   ICHT, NYA, NXA, IDX, IDY, I4XTRA, NTEXT, MTYPE, TIMLIM, TOPSEP,
     *   SIDSEP, GRCHS(2), CHS, TVBUT, IPOS(7), IROUND, NPIX, NROW, IM,
     *   LXPT(MAXFQ), LYPT(MAXFQ), IR, IP, IBUT, ITW(3), QUAD, LBUT
      CHARACTER CHOICS(10)*12, TEXT(2)*80, MSGBUF*80, ISHELP*8, TITLE*80
      REAL      D, LDATA(16384), LRES(7), LMOD(MAXFQ), VMIN, VMAX, YGAP,
     *   RANGE(2), PBLC(2), PTRC(2), XBLC(7), XTRC(7), FQFINC, CH(4),
     *   XYRATO, X, XX, Y, DY, DX, XFAC, XOFF, RPOS(2), PPOS(2), VX, VY,
     *   XM(2)
      LOGICAL   LEAVE(10), DOIT, T, F
      DOUBLE PRECISION FF, FMIN, FMAX, FFMN, FFMX

      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DLOC.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DTVS.INC'
      DATA CHOICS /'CHAN RANGE', 'RESET CHANS', 'FLAG POINTS',
     *   'UNDO FLAGS', 'NEW FIT', ' ', 'GOOD', 'BAD', ' ', 'QUIT'/
      DATA MCOL, MTYPE, TIMLIM, TOPSEP, SIDSEP /1, -1, 0, 1, 10/
      DATA MROWS /10/
      DATA LRES, IPOS /7*0.0, 7*1/
      DATA IDROP, IDEPTH, LABEL /0,0, 5*1, 3/
      DATA LEAVE /10*.TRUE./
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
      IRET = 0
C                                       make local copies
      IF (NZ.GT.16384) THEN
         MSGTXT = 'SPECTRUM TOO LARGE FOR ME'
         GO TO 980
         END IF
      IRET = 0
      CALL RCOPY (NZ, IMAGE, LDATA)
      CALL RCOPY (ITYP, RESULT, LRES)
      DO 5 I = 1,ITYP
         IF (LRES(I).EQ.FBLANK) THEN
            CALL RCOPY (ITYP, FBLANK, RESULT)
            WRITE (MSGTXT,1010) IX, IY
            CALL MSGWRT (6)
            GO TO 999
            END IF
 5       CONTINUE
C                                       X axis range
      FMIN = 1.D15
      FMAX = -FMIN
      DO 10 I = 1,NZ
         FF = 10.0D0**XFREQ(I)
         FMIN = MIN (FF, FMIN)
         FMAX = MAX (FF, FMAX)
 10      CONTINUE
      DX = 0.05 * (FMAX - FMIN)
      FMIN = (FMIN - DX) * DEFREQ
      FMAX = (FMAX + DX) * DEFREQ
      FFMN = FMIN
      FFMX = FMAX
      CALL RCOPY (7, BLC, XBLC)
      XBLC(2) = XBLC(2) + IX - 1.0
      XBLC(3) = XBLC(3) + IY - 1.0
      CALL RCOPY (7, XBLC, XTRC)
      XTRC(1) = XBLC(1) + NZ - 1
C                                       Compute model, max/min
 20   D = LOG10 (LRES(2))
      VMIN = 1.E15
      VMAX = -VMIN
      DO 30 I = 1,NZ
         LMOD(I) = D + LRES(4)*XFREQ(I) + LRES(6)*(XFREQ(I)**2)
         LMOD(I) = 10.0**LMOD(I)
         VMIN = MIN (VMIN, LMOD(I))
         VMAX = MAX (VMAX, LMOD(I))
         IF (LDATA(I).NE.FBLANK) THEN
            VMIN = MIN (VMIN, LDATA(I))
            VMAX = MAX (VMAX, LDATA(I))
            END IF
 30      CONTINUE
      DY = 0.05 * (VMAX - VMIN)
      VMIN = VMIN - DY
      VMAX = VMAX + DY
      RANGE(1) = VMIN
      RANGE(2) = VMAX
      CALL YWINDO ('READ', TVWIND, IRET)
      IF (IRET.NE.0) THEN
         TVWIND(1) = 1
         TVWIND(2) = 1
         TVWIND(3) = MAXXTV(1)
         TVWIND(4) = MAXXTV(2)
         END IF
      IF (IRET.NE.0) GO TO 970
      CALL YHOLD ('ONNN', IRET)
      CALL YSLECT ('OFFF', 1, 0, SCRTCH, IRET)
      IF (IRET.NE.0) GO TO 970
      DO 35 I = 1,5
         J = I + NGRAY
         CALL YZERO (J, IRET)
         IF (IRET.NE.0) GO TO 970
         CALL YSLECT ('ONNN', J, 0, SCRTCH, IRET)
         IF (IRET.NE.0) GO TO 970
         CALL YCINIT (J, SCRTCH)
 35      CONTINUE
      CATR(IRRAN) = RANGE(1)
      CATR(IRRAN+1) = RANGE(2)
      XFAC = 39999.0 / (CATR(IRRAN+1) - CATR(IRRAN))
      XOFF = 40000.0 - XFAC * CATR(IRRAN+1)
      PBLC(2) = RANGE(1) * XFAC + XOFF
      PTRC(2) = RANGE(2) * XFAC + XOFF
C                                       Label inits
      LOCNUM = 1
      I = NZ * 110
      FQFINC = (FFMX - FFMN) / (I-1)
      CALL SLBINI (IDROP, I, RANGE, PBLC, PTRC, XBLC, XTRC, FFMN,
     *   FQFINC, IDEPTH, LABEL, YGAP, CH, TEXT, NTEXT)
      IF (ITYP.LT.7) THEN
         WRITE (TEXT(2),1035) (LRES(I), I=2,5)
      ELSE
         WRITE (TEXT(2),1036) (LRES(I), I=2,7)
         END IF
      NTEXT = 2
      CH(2) = CH(2) + 1.333
      RANGE(1) = XFAC*RANGE(1) + XOFF
      RANGE(2) = XFAC*RANGE(2) + XOFF
      TVSIZE(1) = TVWIND(3) - TVWIND(1) + 1
      TVSIZE(2) = 0.75 * (TVWIND(4) - TVWIND(2) + 1)
      XYRATO = (PTRC(2) - PBLC(2)) / (PTRC(1) - PBLC(1))
      IX1 = PBLC(1) + .5
      IY1 = PBLC(2) + .5
      IX2 = PTRC(1) + .5
      IY2 = PTRC(2) + .5
      ICHL = CH(1) * CSIZTV(1) + .5
      ICHB = CH(2) * CSIZTV(2) + .5
      ICHR = CH(3) * CSIZTV(1) + .5
      ICHT = CH(4) * CSIZTV(2) + .5
      NYA = TVSIZE(2) - ICHT -ICHB -1
      NXA = TVSIZE(1) - ICHL - ICHR - 1
C                                       compute scaling
      X = IX2
      X = ABS (X - IX1)
      XX = X * XYRATO
      Y = IY2
      Y = ABS (Y - IY1)
      IF ((XX.LE.0.0) .OR. (Y.LE.0.0)) THEN
         MSGTXT = 'SCALING ERROR'
         CALL MSGWRT (8)
         IRET = 1
         GO TO 999
         END IF
      IF ((XX/Y).LE.FLOAT(NXA)/FLOAT(NYA)) THEN
         SCALEY = NYA / Y
         SCALEX = SCALEY * Y / X * FLOAT(TVSIZE(1)) / FLOAT(TVSIZE(2))
      ELSE
         SCALEX = NXA / X
         SCALEY = SCALEX * X / Y
         END IF
C
      NXA = SCALEX * X + ICHL + ICHR
      IF (NXA.GE.TVSIZE(1)) THEN
         SCALEX = SCALEX * (FLOAT(TVSIZE(1)) / (NXA + 5.0))
         SCALEY = SCALEY * (FLOAT(TVSIZE(1)) / (NXA + 5.0))
         NXA = SCALEX * X + ICHL + ICHR
         END IF
      NYA = SCALEY * Y + ICHB + ICHT
      IF (NXA.GE.TVSIZE(1)) THEN
         SCALEX = SCALEX * (FLOAT(TVSIZE(2)) / (NYA + 5.0))
         SCALEY = SCALEY * (FLOAT(TVSIZE(2)) / (NYA + 5.0))
         NXA = SCALEX * X + ICHL + ICHR
         NYA = SCALEY * Y + ICHB + ICHT
         END IF
      RX0 = ICHL + MAX (0, TVSIZE(1)-NXA) / 2 + TVWIND(1)
      RY0 = ICHB + MAX (0, TVSIZE(2)-NYA) / 2 + TVWIND(2)
C                                       Put stuff in image catalog.
      CATBLK(IIWIN  ) = IX1
      CATBLK(IIWIN+1) = IY1
      CATBLK(IIWIN+2) = IX2
      CATBLK(IIWIN+3) = IY2
      CATBLK(IICOR  ) = RX0 + 0.5
      CATBLK(IICOR+1) = RY0 + 0.5
      CATBLK(IICOR+2) = RX0 + X * SCALEX + 0.5
      CATBLK(IICOR+3) = RY0 + Y * SCALEY + 0.5
      CATBLK(IIPLT) = 5
      CATBLK(IIOTH) = LABEL
      CATBLK(IIOTH+1) = IDROP(1)
      CATBLK(IIOTH+2) = IDROP(2)
      I4XTRA = IIOTH + 3
      CATR(I4XTRA  ) = XBLC(1)
      CATR(I4XTRA+1) = XBLC(2)
      CATR(I4XTRA+2) = XTRC(1)
      CATR(I4XTRA+3) = XTRC(2)
C                                       Update image catalog
      CALL YCWRIT (IGR5, CATBLK(IICOR), CATBLK, SCRTCH, IRET)
      IF (IRET.NE.0) THEN
         MSGTXT = 'TV IMAGE CATALOG ERROR'
         CALL MSGWRT (6)
         END IF
C                                       set scale for plot routines
      RX0 = RX0 - PBLC(1) * SCALEX + 0.5
      RY0 = RY0 - PBLC(2) * SCALEY + 0.5
C                                       label the plot
      IGR = IGR5
      CALL TVLAB (PBLC, PTRC, LABEL, YGAP, TEXT, NTEXT, CH, .FALSE.,
     *   IRET)
      IF (IRET.NE.0) GO TO 970
C                                       add pixel coordinates
      DX = PTRC(1)*SCALEX + RX0 - 8.5 * CSIZTV(1)
      DY = PTRC(2)*SCALEY + RY0 - 2.0 * CSIZTV(2)
      IDX = DX + 0.5
      IDY = DY + 0.5
      WRITE (MSGBUF,1060) IX
      CALL IMCHAR (IGR, IDX, IDY, 0, 0, MSGBUF(:7), SCRTCH, IRET)
      IF (IRET.NE.0) GO TO 970
      DY = DY - 1.5 * CSIZTV(2)
      IDY = DY + 0.5
      WRITE (MSGBUF,1061) IY
      CALL IMCHAR (IGR, IDX, IDY, 0, 0, MSGBUF(:7), SCRTCH, IRET)
      IF (IRET.NE.0) GO TO 970
C                                       add pixel coordinates
      DX = 0.02* (PTRC(1) - PBLC(1))
      DY = 0.02* (PTRC(2) - PBLC(2))
      IGR = IGR4
      CALL FILL (NZ, -10000, LXPT)
      CALL FILL (NZ, -10000, LYPT)
      DO 50 I = 1,NZ
         FF = (10.0D0**XFREQ(I)) * DEFREQ
         IF ((LDATA(I).NE.FBLANK) .AND. (FF.GE.FFMN) .AND. (FF.LT.FFMX))
     *      THEN
            X = (FF - FFMN) / (FFMX - FFMN)
            LXPT(I) = X * (CATBLK(IICOR+2) - CATBLK(IICOR)) +
     *         CATBLK(IICOR)
            X = X * (PTRC(1) - PBLC(1)) + PBLC(1)
            Y = (LDATA(I) - VMIN) / (VMAX - VMIN)
            LYPT(I) = Y * (CATBLK(IICOR+3) - CATBLK(IICOR+1)) +
     *         CATBLK(IICOR+1)
            Y = Y * (PTRC(2) - PBLC(2)) + PBLC(2)
            CALL TVVEC (X+DX, Y, 1, IRET)
            IF (IRET.EQ.0) CALL TVVEC (X-DX, Y, 2, IRET)
            IF (IRET.EQ.0) CALL TVVEC (X, Y+DY, 1, IRET)
            IF (IRET.EQ.0) CALL TVVEC (X, Y-DY, 2, IRET)
            IF (IRET.NE.0) GO TO 970
            END IF
 50      CONTINUE
      J = 1
      DO 60 I = 1,NZ
         FF = (10.0D0**XFREQ(I)) * DEFREQ
         IF ((FF.GE.FFMN) .AND. (FF.LE.FFMX)) THEN
            X = (FF - FFMN) / (FFMX - FFMN)
            X = X * (PTRC(1) - PBLC(1)) + PBLC(1)
            Y = (LMOD(I) - VMIN) / (VMAX - VMIN)
            Y = Y * (PTRC(2) - PBLC(2)) + PBLC(2)
            CALL TVVEC (X, Y, J, IRET)
            IF (IRET.NE.0) GO TO 970
            J = 2
            END IF
 60      CONTINUE
      CALL YHOLD ('FFFF', IRET)
      GRCHS(1) = 2
      GRCHS(2) = 1
      RPOS(1) = MAXXTV(1) / 2
      RPOS(2) = MAXXTV(2) / 2
      ISHELP = TSKNAM
      TITLE = ' '
 100  CALL TVMENU (MTYPE, MCOL, MROWS, GRCHS, TOPSEP, SIDSEP, ISHELP,
     *   CHOICS, TIMLIM, LEAVE, 1, TITLE, CHS, TVBUT, IBUFF2, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1000) IRET, 'RETURNED FROM TVMENU'
         GO TO 980
         END IF
C                                       case statement
C                                       exit
      IF (CHOICS(CHS).EQ.'GOOD') THEN
         CALL RCOPY (ITYP, LRES, RESULT)
         GO TO 990
      ELSE IF (CHOICS(CHS).EQ.'BAD') THEN
         CALL RFILL (ITYP, FBLANK, RESULT)
         GO TO 990
      ELSE IF (CHOICS(CHS).EQ.'QUIT') THEN
         IRET = 1
         GO TO 990
      ELSE IF (CHOICS(CHS).EQ.'RESET CHANS') THEN
         FFMN = FMIN
         FFMX = FMAX
         GO TO 20
      ELSE IF (CHOICS(CHS).EQ.'CHAN RANGE') THEN
         CALL YZERO (IGR1, IRET)
         IF (IRET.NE.0) GO TO 970
         CALL YZERO (IGR2, IRET)
         IF (IRET.NE.0) GO TO 970
         NPIX = 16 * CSIZTV(1)
         NROW = 3 * CSIZTV(2)
         IX1 = WINDTV(1)
         IY1 = WINDTV(4) - NROW + 1
         IF (IX1+NPIX-1.GT.MAXXTV(1)) IX1 = 1
         IF (IY1+NROW-1.GT.MAXXTV(2)) IY1 = MAXXTV(2) - NROW + 1
         IX2 = IX1 + NPIX - 1
         IY2 = IY1 + NROW - 1
         CALL YFILL (IGR2, IX1, IY1, IX2, IY2, 0, IBUFF2, IRET)
         IF (IRET.NE.0) GO TO 970
         WRITE (MSGTXT,1090)
         CALL MSGWRT (1)
         WRITE (MSGTXT,1092)
         CALL MSGWRT (1)
         WRITE (MSGTXT,1093)
         CALL MSGWRT (1)
         CALL ZTIME (ITW)
         RPOS(1) = (CATBLK(IICOR) + CATBLK(IICOR+2)) / 2
         RPOS(2) = (CATBLK(IICOR+1) + CATBLK(IICOR+3)) / 2
         CALL YCURSE ('ONNN', F, F, RPOS, QUAD, IBUT, IRET)
         IF (IRET.NE.0) GO TO 970
         XM(1) = FFMN
         XM(2) = FFMX
         IM = 1
 110     IGR = IGR3
         X = (XM(1) - FFMN) / (FFMX - FFMN)
         X = X * (PTRC(1) - PBLC(1)) + PBLC(1)
         CALL TVVEC (X, PBLC(2), 1, IRET)
         IF (IRET.EQ.0) CALL TVVEC (X, PTRC(2), 2, IRET)
         X = (XM(2) - FFMN) / (FFMX - FFMN)
         X = X * (PTRC(1) - PBLC(1)) + PBLC(1)
         CALL TVVEC (X, PBLC(2), 1, IRET)
         IF (IRET.EQ.0) CALL TVVEC (X, PTRC(2), 2, IRET)
C                                       Cursor read loop point
         CALL YCURSE ('READ', F, F, RPOS, QUAD, IBUT, IRET)
         IF (IRET.NE.0) GO TO 970
         CALL DLINTR (RPOS, IBUT, PPOS, ITW, DOIT)
         IF (DOIT) THEN
            LBUT = IBUT
C                                       Display coordinate
            QUAD = 0
            CALL YCURSE ('FXIT', F, T, RPOS, QUAD, IBUT, IRET)
            IF (RPOS(1).LT.CATBLK(IICOR)) RPOS(1) = CATBLK(IICOR)
            IF (RPOS(1).GT.CATBLK(IICOR+2)) RPOS(1) = CATBLK(IICOR+2)
            IF (RPOS(2).LT.CATBLK(IICOR+1)) RPOS(2) = CATBLK(IICOR+1)
            IF (RPOS(2).GT.CATBLK(IICOR+3)) RPOS(2) = CATBLK(IICOR+3)
            VX = (RPOS(1) - CATBLK(IICOR)) * (FFMX - FFMN) /
     *         (CATBLK(IICOR+2)-CATBLK(IICOR)) + FFMN
            VY = (RPOS(2) - CATBLK(IICOR+1)) * (VMAX - VMIN) /
     *         (CATBLK(IICOR+3)-CATBLK(IICOR+1)) + VMIN
            IF (IM.EQ.2) THEN
               VX = MAX (VX, XM(1))
            ELSE
               VX = MIN (VX, XM(2))
               END IF
            RPOS(1) = (VX - FFMN) * (CATBLK(IICOR+2)-CATBLK(IICOR)) /
     *         (FFMX - FFMN) + CATBLK(IICOR)
            WRITE (MSGBUF,1115) VY
            I = IY1 + 1.5*CSIZTV(2)
            CALL IMCHAR (IGR2, IX1, I, 0, 0, MSGBUF(:18), IBUFF2, IRET)
            IF (IRET.NE.0) GO TO 970
            WRITE (MSGBUF,1116) VX
            CALL IMCHAR (IGR2, IX1, IY1, 0, 0, MSGBUF(:14), IBUFF2,
     *         IRET)
            IF (IRET.NE.0) GO TO 970
            X = (XM(1) - FFMN) / (FFMX - FFMN)
            X = X * (PTRC(1) - PBLC(1)) + PBLC(1)
            CALL TVVEC (X, PBLC(2), 1, IRET)
            IF (IRET.EQ.0) CALL TVVEC (X, PTRC(2), 3, IRET)
            X = (XM(2) - FFMN) / (FFMX - FFMN)
            X = X * (PTRC(1) - PBLC(1)) + PBLC(1)
            CALL TVVEC (X, PBLC(2), 1, IRET)
            IF (IRET.EQ.0) CALL TVVEC (X, PTRC(2), 3, IRET)
            XM(IM) = VX
            IF ((LBUT.GT.0) .AND. (LBUT.LE.3)) THEN
               IM = 3 - IM
               IF (IM.EQ.1) THEN
                  WRITE (MSGTXT,1090)
               ELSE
                  WRITE (MSGTXT,1091)
                  END IF
               CALL MSGWRT (1)
               END IF
            END IF
         IF (LBUT.LE.3) GO TO 110
         FFMN = XM(1)
         FFMX = XM(2)
         CALL YZERO (IGR3, IRET)
         IF (IRET.NE.0) GO TO 970
         GO TO 20
C                                       blank
      ELSE IF (CHOICS(CHS).EQ.' ') THEN
C                                       undo flags
      ELSE IF (CHOICS(CHS).EQ.'UNDO FLAGS') THEN
         CALL RCOPY (NZ, IMAGE, LDATA)
         CALL RCOPY (ITYP, RESULT, LRES)
         GO TO 20
      ELSE IF (CHOICS(CHS).EQ.'NEW FIT') THEN
         IPOS(1) = IROUND (BLC(1))
         IPOS(2) = IX
         IPOS(3) = IY
         IF (ITYP.LT.7) THEN
            CALL DO1SPX (IPOS, LDATA, LRES)
         ELSE
            CALL DO2SPX (IPOS, LDATA, LRES)
            END IF
         IF (LRES(2).EQ.FBLANK) THEN
            MSGTXT = '****** FIT FAILED, UNDOING FLAGS ******'
            CALL MSGWRT (6)
            MSGTXT = '*** YOU SHOULD PROBABLY MARK IT BAD ***'
            CALL MSGWRT (6)
            CALL RCOPY (NZ, IMAGE, LDATA)
            CALL RCOPY (ITYP, RESULT, LRES)
            END IF
         GO TO 20
      ELSE IF (CHOICS(CHS).EQ.'FLAG POINTS') THEN
         CALL YZERO (IGR1, IRET)
         IF (IRET.NE.0) GO TO 970
         CALL YZERO (IGR2, IRET)
         IF (IRET.NE.0) GO TO 970
         NPIX = 16 * CSIZTV(1)
         NROW = 3 * CSIZTV(2)
         IX1 = WINDTV(1)
         IY1 = WINDTV(4) - NROW + 1
         IF (IX1+NPIX-1.GT.MAXXTV(1)) IX1 = 1
         IF (IY1+NROW-1.GT.MAXXTV(2)) IY1 = MAXXTV(2) - NROW + 1
         IX2 = IX1 + NPIX - 1
         IY2 = IY1 + NROW - 1
         CALL YFILL (IGR2, IX1, IY1, IX2, IY2, 0, IBUFF2, IRET)
         IF (IRET.NE.0) GO TO 970
         WRITE (MSGTXT,1100)
         CALL MSGWRT (1)
         WRITE (MSGTXT,1101)
         CALL MSGWRT (1)
         WRITE (MSGTXT,1102)
         CALL MSGWRT (1)
         CALL ZTIME (ITW)
         RPOS(1) = (CATBLK(IICOR) + CATBLK(IICOR+2)) / 2
         RPOS(2) = (CATBLK(IICOR+1) + CATBLK(IICOR+3)) / 2
         CALL YCURSE ('ONNN', F, F, RPOS, QUAD, IBUT, IRET)
         IF (IRET.NE.0) GO TO 970
C                                       Cursor read loop point
 115     CALL YCURSE ('READ', F, F, RPOS, QUAD, IBUT, IRET)
         IF (IRET.NE.0) GO TO 970
         IF (IBUT.GE.4) GO TO 100
         CALL DLINTR (RPOS, IBUT, PPOS, ITW, DOIT)
         IF (DOIT) THEN
            LBUT = IBUT
C                                       Find new image catalog block
            QUAD = 0
            CALL YCURSE ('FXIT', F, T, RPOS, QUAD, IBUT, IRET)
            VX = (RPOS(1) - CATBLK(IICOR)) * (FFMX - FFMN) /
     *         (CATBLK(IICOR+2)-CATBLK(IICOR)) + FFMN
            VY = (RPOS(2) - CATBLK(IICOR+1)) * (VMAX - VMIN) /
     *         (CATBLK(IICOR+3)-CATBLK(IICOR+1)) + VMIN
            WRITE (MSGBUF,1115) VY
            I = IY1 + 1.5*CSIZTV(2)
            CALL IMCHAR (IGR2, IX1, I, 0, 0, MSGBUF(:18), IBUFF2, IRET)
            IF (IRET.NE.0) GO TO 970
            WRITE (MSGBUF,1116) VX/1.E9
            CALL IMCHAR (IGR2, IX1, IY1, 0, 0, MSGBUF(:14), IBUFF2,
     *         IRET)
            IF (IRET.NE.0) GO TO 970
            IF (LBUT.GT.0) THEN
               IP = 0
               IR = 100000
               DO 120 I = 1,NZ
                  XX = (RPOS(1)-LXPT(I))**2 + (RPOS(2)-LYPT(I))**2
                  IF (XX.LT.IR) THEN
                     IR = XX + 0.5
                     IP = I
                     END IF
 120              CONTINUE
               IF (IR.LT.100) THEN
                  DX = 0.02* (PTRC(1) - PBLC(1))
                  DY = 0.02* (PTRC(2) - PBLC(2))
                  IGR = IGR3
                  FF = (10.0D0**XFREQ(IP)) * DEFREQ
                  X = (FF - FFMN) / (FFMX - FFMN)
                  X = X * (PTRC(1) - PBLC(1)) + PBLC(1)
                  Y = (LDATA(IP) - VMIN) / (VMAX - VMIN)
                  Y = Y * (PTRC(2) - PBLC(2)) + PBLC(2)
                  CALL TVVEC (X+DX, Y, 1, IRET)
                  IF (IRET.EQ.0) CALL TVVEC (X-DX, Y, 2, IRET)
                  IF (IRET.EQ.0) CALL TVVEC (X, Y+DY, 1, IRET)
                  IF (IRET.EQ.0) CALL TVVEC (X, Y-DY, 2, IRET)
                  IF (IRET.NE.0) GO TO 970
                  LDATA(IP) = FBLANK
                  END IF
               END IF
            END IF
         GO TO 115
         END IF
      GO TO 100
C
 970  WRITE (MSGTXT,1000) IRET, 'TV FUNCTION'
C
 980  CALL MSGWRT (8)
C
 990  CALL YINIT (BUFF1, I)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SPREDO ERROR',I4,' ON ',A)
 1010 FORMAT ('SPREDO: PIXEL IX, IY=',2I6,' ALREADY FAILED')
 1035 FORMAT ('T0=',F8.5,' (',F7.5,') SP=',F7.3,' (',F6.3,')')
 1036 FORMAT ('T0=',F8.5,' (',F7.5,') SP=',F7.3,' (',F6.3,') CU=',F7.3,
     *   ' (',F6.3,')')
 1060 FORMAT ('X=',I5)
 1061 FORMAT ('Y=',I5)
 1090 FORMAT ('Setting lower limit')
 1091 FORMAT ('Setting lower limit')
 1092 FORMAT ('Hit button A or B to switch to other limit')
 1093 FORMAT ('Hit button C or D to exit')
 1100 FORMAT ('Cursor selects which pixel is displayed')
 1101 FORMAT ('Hit button A or B to flag a point')
 1102 FORMAT ('Hit button C or D to exit flagging')
 1115 FORMAT (F10.5,' Jy/beam')
 1116 FORMAT (F10.5,' GHz')
      END
      SUBROUTINE SPIXOU (BLNKD, NX, NY, ITYP, ANSW, IRET)
C-----------------------------------------------------------------------
C   SPIXOU creates and fills (via PSCALE) the individual spix maps.
C   It calls SPIXHI for history info for all images.
C   Inputs
C      BLNKD    L      there are blank pixels
C      NX       I      # X pixels
C      NY       I      # Y pixels
C      ITYP     I      # answers (5 or 7)
C      ANSW     R(*)   Answer images
C   Output:
c      IRET    I      0 => ok,  4 => real trouble.
C------------------------------------------------------------------------
      LOGICAL   BLNKD
      INTEGER   NX, NY, ITYP, IRET
      REAL      ANSW(NX,NY,*)
C
      CHARACTER CLAOUT*6, SEQTYP*6
      INTEGER   NXO, NYO, WINI(4), WINO(4), IERR, IG, IP, NP, IY, IX
      REAL      PMX, PMN
      INCLUDE 'TVSPX.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
C-----------------------------------------------------------------------
      IRET = 0
C                                       loop limits etc.
      WINO(1) = 1
      WINO(2) = 1
      NP = 5
      IF (OPTYPE.EQ.'CURV') NP = 7
C                                       Output spectral index parms
      DO 40 IG = 1,NP
         IP = NCFILE - NP + IG
         NEWCNO = FCNO(IP)
         DISKO = FVOL(IP)
         CALL CATIO ('READ', DISKO, NEWCNO, CATBLK, 'REST', SCRTCH,
     *        IERR)
         IF ((IERR.NE.0) .AND. (IERR.NE.6)) THEN
            WRITE (MSGTXT,1010) IERR, IP
            GO TO 990
            END IF
         CALL H2CHR (6, KHIMCO, CATH(KHIMC), SEQTYP)
         WRITE (MSGTXT,1020) SEQTYP
         CALL MSGWRT (1)
         SEQOUT = CATBLK(KIIMS)
         CALL H2CHR (12, KHIMNO, CATH(KHIMNO), NAMOUT)
         CALL H2CHR (6, KHIMCO, CATH(KHIMC), CLAOUT)
         NXO = CATBLK(KINAX)
         NYO = CATBLK(KINAX+1)
         WINI(4) = NXO
         WINO(3) = NXO
         WINO(4) = NYO
         PMX = -1.E15
         PMN = -PMX
         DO 20 IY = 1,NY
            DO 15 IX = 1,IX
               IF (ANSW(IX,IY,IG).NE.FBLANK) THEN
                  PMX = MAX (PMX, ANSW(IX,IY,IG))
                  PMN = MIN (PMN, ANSW(IX,IY,IG))
               ELSE
                  BLNKD = .TRUE.
                  END IF
 15            CONTINUE
 20         CONTINUE
C                                       Fill image
         CALL PSCALE (NEWCNO, DISKO, WINO, JBUFSZ, NX, ANSW(1,1,IG),
     *        PMX, PMN, BLNKD, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1021) IERR, SEQTYP
            GO TO 990
            END IF
C                                       History, close
         CALL SPIXHI (IP, CLAOUT)
 40      CONTINUE
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
      IRET = 4
C
 999  RETURN
C-----------------------------------------------------------------------
 1010 FORMAT ('SPIXOU ERROR',I5,' RECOVERING HEADER NUMBER',I5)
 1020 FORMAT ('Begin writing file of type ',A6)
 1021 FORMAT ('ERROR',I5,' MOVING DATA TO FILE TYPE ',A6)
      END
      SUBROUTINE PSCALE (NEWCNO, DISKO, WINO, JBUFSZ, NX, ANSW, PMAX,
     *   PMIN, BLNKD, IERR)
C-----------------------------------------------------------------------
C   PSCALE copies an in memory image to output file
C   Inputs:
C      NEWCNO   I      Output catalog number
C      DISKO    I      Output disk number
C      WINO     I(4)   Output Window
C      JBUFSZ   I      Buffer size in bytes
C      NX       I      # points on 1st axis
C      ANSW     R(*)   image
C      PMAX     R(*)   Max values by columns
C      PMIN     R(*)   Min values by columns
C      BLNKD    L      Image is blanked
C   Output:
C      IERR     I      0 -> ok, else IO error
C      CATBLK in common: change max/min and scaling and blanking
C      Buffers in common
C-----------------------------------------------------------------------
      INTEGER   NEWCNO, DISKO, WINO(4), JBUFSZ, NX, IERR
      REAL      ANSW(NX,*), PMAX, PMIN
      LOGICAL   BLNKD
C
      CHARACTER PHNAME*48
      INTEGER   NXO, L3, L4, L5, L6, L7, I3, I4, I5, I6, I7, LUNO, INDO,
     *   IPOS(8), BOTEMP, OBIND, JERR
      LOGICAL   T
      INCLUDE 'XMBUFRS'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA LUNO /17/
      DATA T /.TRUE./
C-----------------------------------------------------------------------
C                                       Set maxima, clear blanking
      CATR(KRDMX) = PMAX
      CATR(KRDMN) = PMIN
      CATR(KRBLK) = 0.0
      IF (BLNKD) CATR(KRBLK) = FBLANK
C                                       loop limits
      L3 = CATBLK(KINAX+1)
      L4 = CATBLK(KINAX+2)
      L5 = CATBLK(KINAX+3)
      L6 = CATBLK(KINAX+4)
      L7 = CATBLK(KINAX+5)
      NXO = WINO(3)
      CALL ZPHFIL ('MA', DISKO, NEWCNO, 1, PHNAME, IERR)
      CALL ZOPEN (LUNO, INDO, DISKO, PHNAME, T, T, T, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'OPEN OUTPUT FILE'
         CALL MSGWRT (8)
         GO TO 999
         END IF
C                                       loop
      DO 700 I7 = 1,L7
         IPOS(7) = I7
         DO 600 I6 = 1,L6
            IPOS(6) = I6
            DO 500 I5 = 1,L5
               IPOS(5) = I5
               DO 400 I4 = 1,L4
                  IPOS(4) = I4
C                                       Init output
      CALL COMOFF (CATBLK(KIDIM), CATBLK(KINAX), IPOS(4), BOTEMP, IERR)
      BOTEMP = BOTEMP + 1
      CALL MINIT ('WRIT', LUNO, INDO, WINO(3), WINO(4), WINO, BUFF2,
     *   JBUFSZ, BOTEMP, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'INIT OUTPUT I/O'
         GO TO 970
         END IF
      DO 300 I3 = 1,L3
C                                       Init a write
         CALL MDISK ('WRIT', LUNO, INDO, BUFF2, OBIND, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1000) IERR, 'WRITING OUTPUT FILE'
            GO TO 970
            END IF
         CALL RCOPY (NXO, ANSW(1,I3), BUFF2(OBIND))
 300     CONTINUE
C                                       Flush output plane
      CALL MDISK ('FINI', LUNO, INDO, BUFF2, OBIND, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'FINISHING OUTPUT I/O'
         GO TO 970
         END IF
 400              CONTINUE
 500           CONTINUE
 600        CONTINUE
 700     CONTINUE
      GO TO 980
C                                       Close down (error)
 970  CALL MSGWRT (8)
C                                       Close files
 980  CALL ZCLOSE (LUNO, INDO, JERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('PSCALE: ERROR',I5,' ON ',A)
      END
      SUBROUTINE SPIXHI (NCN, CLAOUT)
C-----------------------------------------------------------------------
C   SPIXHI copies and updates history file.
C   Inputs:
C      NCN      I     Index in catlgd files common
C      CLAOUT   C*6   Output map CLASS
C-----------------------------------------------------------------------
      CHARACTER CLAOUT*6
      INTEGER   NCN
C
      CHARACTER LABEL*8, DCOM(9)*14, HILINE*72, CCOM(3)*14
      INTEGER   LUN1, LUN2, IERR, I
      REAL      DMIN(9)
      LOGICAL   T
      INCLUDE 'TVSPX.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA LUN1, LUN2 /27,28/
      DATA T /.TRUE./
      DATA DMIN / 0.0, -1.E7, -1.E7, 0.0, 0.0, 0.0, 0.0, -1.E7, -1.E7/
      DATA DCOM /'Num pix < D(1)', 'Spix < D(2)', 'Spix > D(3)',
     *   'T/Tmin < D(4)', 'T/Tmax < D(5)', 'T < D(6)',
     *   'T > D(7)', 'Curv < D(8)', 'Curv > D(9)'/
      DATA CCOM /'Error T > C(1)', 'Error Sp> C(2)', 'Error C > C(3)'/
C-----------------------------------------------------------------------
C                                       Write History.
      CALL HIINIT (3)
C                                       Copy/open history file.
      CALL HISCOP (LUN1, LUN2, DISKIN, DISKO, OLDCNO, NEWCNO, CATBLK,
     *   SCRTCH(257), SCRTCH, IERR)
      IF (IERR.LE.2) GO TO 10
         WRITE (MSGTXT,1000) IERR
         CALL MSGWRT (6)
         GO TO 50
C                                       New history
 10   CALL HENCO1 (TSKNAM, NAMEIN, CLAIN, SEQIN, DISKIN, LUN2, SCRTCH,
     *   IERR)
      IF (IERR.NE.0) GO TO 50
      CALL HENCOO (TSKNAM, NAMOUT, CLAOUT, SEQOUT, DISKO, LUN2,
     *   SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 50
C                                       BLC
      WRITE (HILINE,2000) TSKNAM, BLC
      CALL HIADD (LUN2, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 50
C                                       TRC
      WRITE (HILINE,2001) TSKNAM, TRC
      CALL HIADD (LUN2, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 50
C                                       other Parms
      CALL H2CHR (8, 1, CATOH(KHBUN), LABEL)
      WRITE (HILINE,2002) TSKNAM, FCUT, LABEL
      CALL HIADD (LUN2, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 50
C                                       Old axis 1
      CALL H2CHR (8, 1, CATOH(KHCTP), LABEL)
      WRITE (HILINE,2020) TSKNAM, LABEL
      CALL HIADD (LUN2, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 50
      WRITE (HILINE,2021) TSKNAM, CATOLD(KINAX)
      CALL HIADD (LUN2, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 50
      WRITE (HILINE,2022) TSKNAM, CATOR(KRCRP)
      CALL HIADD (LUN2, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 50
      WRITE (HILINE,2023) TSKNAM, CATOR(KRCIC)
      CALL HIADD (LUN2, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 50
      WRITE (HILINE,2024) TSKNAM, CATOD(KDCRV)
      CALL HIADD (LUN2, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 50
C                                       ref freq
      WRITE (HILINE,2025) TSKNAM, REFREQ
      CALL HIADD (LUN2, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 50
C                                       Cutoffs
      DO 30 I = 1,9
         IF ((DPARM(I).GT.DMIN(I)) .AND. (DPARM(I).LT.1.E7)) THEN
            WRITE (HILINE,2030) TSKNAM, I, DPARM(I), DCOM(I)
            CALL HIADD (LUN2, HILINE, SCRTCH, IERR)
            IF (IERR.NE.0) GO TO 50
            END IF
 30      CONTINUE
      DO 35 I = 1,3
         IF (CPARM(I).LE.1.E7) THEN
            WRITE (HILINE,2031) TSKNAM, I, CPARM(I), CCOM(I)
            CALL HIADD (LUN2, HILINE, SCRTCH, IERR)
            IF (IERR.NE.0) GO TO 50
            END IF
 35      CONTINUE
C                                       blanked
      IF (DPARM(10).GT.0.0) THEN
         I = DPARM(10)
         WRITE (HILINE,2032) TSKNAM, I
         CALL HIADD (LUN2, HILINE, SCRTCH, IERR)
         IF (IERR.NE.0) GO TO 50
         MSGTXT = HILINE(9:)
         IF (NCN.EQ.NCFILE) CALL MSGWRT (4)
         END IF
C                                       good
      WRITE (HILINE,2033) TSKNAM, NGOOD
      CALL HIADD (LUN2, HILINE, SCRTCH, IERR)
      IF (IERR.NE.0) GO TO 50
      MSGTXT = HILINE(9:)
      IF (NCN.EQ.NCFILE) CALL MSGWRT (4)
C                                       Close HI file
 50   CALL HICLOS (LUN2, T, SCRTCH, IERR)
C                                        Update CATBLK and close
      CALL CATIO ('UPDT', DISKO, NEWCNO, CATBLK, 'CLWR', SCRTCH, IERR)
      FRW(NCN) = -1
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SPIXHI: ERROR',I3,' COPY/OPEN HISTORY FILE')
 2000 FORMAT (A6,'BLC =',6(F6.0,','),F6.0)
 2001 FORMAT (A6,'TRC =',6(F6.0,','),F6.0)
 2002 FORMAT (A6,'FLUX =',1PE12.4,14X,'/ Use only t > flux ',A8)
 2020 FORMAT (A6,'CTYPE1  = ''',A8,'''',12X,'/ Old axis 1')
 2021 FORMAT (A6,'NAXIS1  = ',I6,16X,'/ Old axis 1')
 2022 FORMAT (A6,'CRPIX1  = ',F9.3,13X,'/ Old axis 1')
 2023 FORMAT (A6,'CDELT1  = ',1PE13.5,9X,'/ Old axis 1')
 2024 FORMAT (A6,'CRVAL1  = ',1PE18.10,4X,'/ Old axis 1')
 2025 FORMAT (A6,'REFREQ = ',F9.4,4X,'/ reference frequency GHz')
 2030 FORMAT (A6,'DPARM(',I1,')= ',F12.3,4X,
     *   '/ Flag solution if ',A)
 2031 FORMAT (A6,'CPARM(',I1,')= ',F12.3,4X,
     *   '/ Flag solution if ',A)
 2032 FORMAT (A6,'/ Number possible solutions flagged=',I10)
 2033 FORMAT (A6,'/ Number good solutions=',I10)
      END
