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 'LISPX.INC'
      INTEGER   MAXFQ, MAXSP
      PARAMETER (MAXSP=100)
      PARAMETER (MAXFQ=32768)
C
      INCLUDE 'XMBUFRS'
      CHARACTER INFILE*48, OUFILE*48, OPTYPE*4, FUNCTY(7)*2,
     *   CUNITS(7)*8, SPCHAR(MAXSP)*128
      HOLLERITH XINFIL(12), XOUFIL(12), XOPTYP(1)
      REAL      FCUT, REFREQ, DPARM(10), CPARM(10)
      DOUBLE PRECISION XFREQ(MAXFQ)
      REAL      XDATA(MAXFQ), XRMS(MAXFQ), SPIX(7,MAXSP)
      INTEGER   NSPEC, FVALU(MAXSP)
      COMMON /INPARM/ XINFIL, XOUFIL, FCUT, REFREQ, XOPTYP, DPARM, CPARM
      COMMON /CHPARM/ INFILE, OUFILE, SPCHAR, OPTYPE, FUNCTY, CUNITS
      COMMON /PARMS/ XFREQ, XDATA, XRMS, FVALU, NSPEC, SPIX
LOCAL END
LOCAL INCLUDE 'LISPX.TV'
      INTEGER   IGR1, IGR2, IGR3, IGR4, IGR5, IGR7, IPL(2)
      INCLUDE 'INCS:DTVC.INC'
      COMMON /TVLISP/ IGR1, IGR2, IGR3, IGR4, IGR5, IGR7, IPL
LOCAL END
      PROGRAM LISPX
C-----------------------------------------------------------------------
C! LISPX fits 1-D spectral indexes from a text file
C# Map-util Spectral
C-----------------------------------------------------------------------
C;  Copyright (C) 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   LISPX fits 1-dimensional spectral inices to spectra from a text file
C   It fits and then allows TV interaction to blank bad values
C   Inputs:
C      AIPS adverb  Prg. name.          Description.
C      INFILE         INFILE        Text file with data
C      OUTFILE        OUFILE        Optional output text file
C      FLUX           FCUT          Flux cutoff: use only data >
C                                   FLUX.
C      OPTYPE         XOPTY         'CURV' to do curvature
C      DPARM          DPARM         Blanking on values
C      CPARM          CPARM         blanking on uncertainties
C   Programmer Eric W. Greisen  2025
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET, ITYP
      INCLUDE 'LISPX.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA PRGM /'LISPX'/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL LISPIN (PRGM, ITYP, IRET)
C                                       Call routine that sends data
C                                       to the user routine.
      IF (IRET.EQ.0) CALL LISPDO (ITYP, IRET)
      IF (IRET.EQ.0) CALL LISPTV (ITYP, IRET)
      IF (IRET.EQ.0) CALL LISPOU (ITYP, IRET)
C                                       Close down files, etc.
      CALL DIE (IRET, SCRTCH)
C
 999  STOP
      END
      SUBROUTINE LISPIN (PRGN, ITYP, IRET)
C-----------------------------------------------------------------------
C   LISPIN gets input parameters for LISPX.
C   Inputs:
C      PRGN     C*6    Program name (2 chars/word)
C   Output:
C      ITYP     I      # output parameters
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)
      INTEGER   ITYP, IRET
C
      INTEGER   IERR, NPARM
      INCLUDE 'LISPX.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DFIL.INC'
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      IRET = 0
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
C                                       Get input parameters.
      NPARM = 47
      CALL GTPARM (PRGN, NPARM, RQUICK, XINFIL, 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 (48, 1, XINFIL, INFILE)
      CALL H2CHR (48, 1, XOUFIL, OUFILE)
      CALL H2CHR (12, 1, XOPTYP, OPTYPE)
      ITYP = 5
      IF (OPTYPE.EQ.'CURV') ITYP = 7
C                                       reference freq
      IF (REFREQ.LE.0.0) REFREQ = 1.0
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
C                                       Read data
      CALL READIT (IRET)
      IF (IRET.NE.0) GO TO 990
      IF (NSPEC.LE.0) THEN
         MSGTXT = 'YOU MUST DEFINE SOME SPECTRA'
         IF (IRET.EQ.0) CALL MSGWRT (8)
         IRET = 10
         END IF
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('LISPIN: ERROR',I3,' ON ',A)
      END
      SUBROUTINE READIT (IRET)
C-----------------------------------------------------------------------
C   Read the input text file, find the spectra
C   Output
C      IRET   I   Error code
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'LISPX.INC'
      CHARACTER LINE*128
      INTEGER   TLUN, TIND, J, JTRIM, M, N, LUNTMP, I1, I2, LLIM, LP
      DOUBLE PRECISION X
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
      IF (INFILE.EQ.' ') THEN
         IRET = 10
         MSGTXT = 'YOU MUST SPECIFY INFILE'
         GO TO 999
      END IF
      TLUN = LUNTMP (2)
C                                       open the text file
      CALL ZTXOPN ('READ', TLUN, TIND, INFILE, .FALSE., IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPEN INPUT TEXT FILE'
         GO TO 999
         END IF
      N = 0
      M = 0
 10   CALL ZTXIO ('READ', TLUN, TIND, LINE, IRET)
      IF (IRET.EQ.2) THEN
         IRET = 0
         NSPEC = N
         FVALU(N+1) = M+1
         CALL ZTXCLS (TLUN, TIND, J)
      ELSE IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'READING INPUT TEXT FILE'
      ELSE
         LLIM = JTRIM (LINE)
         IF ((LLIM.LE.0) .OR. (LINE(1:).EQ.'#')) GO TO 10
         IF (LINE(:4).EQ.'SPEC') THEN
            N = N + 1
            FVALU(N) = M + 1
            SPCHAR(N) = ' '
            I1 = INDEX (LINE, '''')
            IF (I1.GT.0) THEN
               I2 = INDEX (LINE(I1+1:), '''')
               IF (I2.LE.0) I2 = LLIM - I1 + 1
               I2 = I2 + I1 - 1
               I1 = I1 + 1
               SPCHAR(N) = LINE(I1:I2)
               END IF
         ELSE
            M = M + 1
            LP = 1
            CALL GETNUM (LINE, LLIM, LP, X)
            IF ((X.EQ.DBLANK) .OR. (X.LE.0.0))THEN
               M = M - 1
               GO TO 10
            ELSE
               XFREQ(M) = X
               END IF
            CALL GETNUM (LINE, LLIM, LP, X)
            IF (X.EQ.DBLANK) THEN
               M = M - 1
               GO TO 10
            ELSE
               XDATA(M) = X
               END IF
            CALL GETNUM (LINE, LLIM, LP, X)
            IF (X.EQ.DBLANK) THEN
               XRMS(M) = FBLANK
            ELSE
               XRMS(M) = X
               END IF
            END IF
         GO TO 10
         END IF
C                                       go to log space
      DO 100 J = 1,M
         XFREQ(J) = LOG10 (XFREQ(J)/REFREQ)
 100     CONTINUE
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('READIT: ERROR',I4,' ON ',A)
      END
      SUBROUTINE LISPDO (ITYP, IRET)
C-----------------------------------------------------------------------
C   LISPDO sends image one row at a time to the moment fitting
C   routine and then saves the answers
C   Inputs
C      ITYP     I      # answers (5 or 7)
C   Output:
C      IRET     I      Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   ITYP, IRET
C
      INTEGER   I, I1, N
      INCLUDE 'LISPX.INC'
      REAL      ANSWER(7)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
C-----------------------------------------------------------------------
      DO 100 I = 1,NSPEC
         N = FVALU(I+1) - FVALU(I)
         I1 = FVALU(I)
C                                       Call DO1SPX
         IF (OPTYPE.NE.'CURV') THEN
            CALL DO1SPX (N, XFREQ(I1), XDATA(I1), ANSWER)
         ELSE
            CALL DO2SPX (N, XFREQ(I1), XDATA(I1), ANSWER)
            END IF
C                                       Save answer
         DO 20 I1 = 1,ITYP
            SPIX(I1,I) = ANSWER(I1)
 20         CONTINUE
 100     CONTINUE
      IRET = 0
C
 999  RETURN
      END
      SUBROUTINE DO1SPX (N, XF, XD, RESULT)
C-----------------------------------------------------------------------
C   DO1SPX fits spectral index to a row of an image and returns the
C   answers in RESULT.
C   Inputs:
C      N        I      Number samples in spectrm
C      XF       D(*)   Frequencies
C      XD       R(*)   Data
C   Values from commons:
C      FCUT     R      Flux cutoff
C   Output:
C      RESULT   R      (count, br, br err, spix sp err,...)
C-----------------------------------------------------------------------
      INTEGER   N
      DOUBLE PRECISION XF(*)
      REAL      XD(*), 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 'LISPX.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DDCH.INC'
C-----------------------------------------------------------------------
C                                       Not last call
      CALL RFILL (5, FBLANK, RESULT)
      IF (N.GT.0) THEN
         LFCUT = FCUT
         LFCUT = MAX (1.E-10, LFCUT)
         INPTS = N
         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 = XD(I)
            IF ((V.GT.LFCUT) .AND. (V.NE.FBLANK)) THEN
               TMIN = MIN (TMIN, V)
               TMAX = MAX (TMAX, V)
               Y = LOG10 (V)
               X = XF(I)
               SX = SX + X
               SY = SY + Y
               SXX = SXX + X * X
               SXY = SXY + X * Y
               SN = SN + 1.0
               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 = XD(I)
               IF ((Y.GT.LFCUT) .AND. (Y.NE.FBLANK)) THEN
                  Y = LOG10 (Y)
                  X = XF(I)
                  SDD = SDD + (VM * X + VB - Y)**2
                  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
         END IF
C
 999  RETURN
      END
      SUBROUTINE DO2SPX (N, XF, XD, RESULT)
C-----------------------------------------------------------------------
C   DO2SPX fits spectral index plus curvature to a spectrum and
C   returns the answers in RESULT.
C   Inputs:
C      N        I      Number samples in spectrm
C      XF       D(*)   Frequencies
C      XD       R(*)   Data
C   Values from commons:
C      FCUT     R      Flux cutoff
C   Output:
C      RESULT   R      (count, br, br err, spix sp err,...)
C-----------------------------------------------------------------------
      INTEGER   N
      DOUBLE PRECISION XF(*)
      REAL      XD(*), 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 'LISPX.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DDCH.INC'
C-----------------------------------------------------------------------
      CALL RFILL (7, FBLANK, RESULT)
C                                       Not last call
      IF (N.GT.0) THEN
         LFCUT = FCUT
         LFCUT = MAX (1.E-10, LFCUT)
         INPTS = N
         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 = XD(I)
            IF ((V.GT.LFCUT) .AND. (V.NE.FBLANK)) THEN
               TMIN = MIN (TMIN, V)
               TMAX = MAX (TMAX, V)
               Y = LOG10 (V)
               X = XF(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
 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 = XD(I)
               IF ((Y.GT.LFCUT) .AND. (Y.NE.FBLANK)) THEN
                  Y = LOG10 (Y)
                  X = XF(I)
                  SDD = SDD + (VC * X * X + VM * X + VB - Y)**2
                  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
         END IF
C
 999  RETURN
      END
      SUBROUTINE LISPTV (ITYP, IRET)
C-----------------------------------------------------------------------
C   LISPTV interacts with user and answers
C   Inputs
C      ITYP     I      # answers (5 or 7)
C   In/output in COMMON
C      SPIX     R(*)   Answer images
C   Output:
C      IRET     I      Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   ITYP, IRET
C
      INTEGER   I, J, MTYPE, MCOL, MROWS(2), GRCHS(2), TIMLIM, CHS,
     *   TVBUT, TOPSEP, SIDSEP, NTITL
      CHARACTER CHOIC1(4)*16, CHOICS(10)*16, ROUTIN*6, ISHELP*6,
     *   TITLE*128
      LOGICAL   LEAVE(10)
      INCLUDE 'LISPX.INC'
      INCLUDE 'LISPX.TV'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DTVC.INC'
      DATA CHOIC1 /'EXIT', 'ABORT', ' ', 'REDO ALL'/
      DATA LEAVE /.FALSE., 9*.TRUE./
C-----------------------------------------------------------------------
      TITLE = ' '
      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
C                                       prepare menu
      J = 4
      DO 10 I = 1,4
         CHOICS(I) = CHOIC1(I)
 10      CONTINUE
      MROWS(1) = J
      MTYPE = 0
      MCOL = 1
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
      GRCHS(1) = 2
      GRCHS(2) = 1
      TOPSEP = 3
      SIDSEP = 10
      ISHELP = TSKNAM
      TIMLIM = 0
      NTITL = 0
C                                       title lines
 50   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 skip output text'
         CALL MSGWRT (2)
         IRET = 10
         GO TO 990
C                                       blank
      ELSE IF (CHOICS(CHS).EQ.' ') THEN
C                                       redo all
      ELSE IF (CHOICS(CHS).EQ.'REDO ALL') THEN
         CALL YZERO (IGR5, IRET)
         CALL YZERO (1, IRET)
         CALL UPDALL (ITYP, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'RE-DOING ALL'
            GO TO 990
            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)
      CALL TVCLOS (SCRTCH, J)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('LISPTV ERROR',I4,' ON A',A)
      END
      SUBROUTINE UPDALL (ITYP, IRET)
C-----------------------------------------------------------------------
C   UPDALL re-does fitting on all spectra
C   Inputs:
C      ITYP   I      # parameters (5, 7)
C   In/out in COMMON
C      SPIX   R(*)   Answers
C   Output:
C      IRET   I      Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   ITYP, IRET
C
      INCLUDE 'LISPX.INC'
      INTEGER   I, N, I1
      REAL      ANSWER(7)
      INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
      DO 100 I = 1,NSPEC
         N = FVALU(I+1) - FVALU(I)
         I1 = FVALU(I)
         CALL RCOPY (ITYP, SPIX(1,I), ANSWER)
         CALL SPREDO (I, N, ITYP, XFREQ(I1), XDATA(I1), ANSWER, IRET)
         IF (IRET.EQ.99) THEN
            WRITE (MSGTXT,1000) I-1, NSPEC
            CALL MSGWRT (6)
            IRET = 0
            GO TO 999
            END IF
         IF (IRET.NE.0) GO TO 999
         CALL RCOPY (ITYP, ANSWER, SPIX(1,I))
 100     CONTINUE
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('Only',i3,' spectra of',I3,' processed before QUIT',
     *   'requested')
      END
      SUBROUTINE SPREDO (ISP, NZ, ITYP, XF, XD, RESULT, IRET)
C-----------------------------------------------------------------------
C   SPREDO displays a spectrum, allows interaction to fit, flag data
C   returns new values to the answer
C   Inputs
C      ISP     I      Spectrum number
C      NZ      I      # spectral points
C      ITYP    I      # answers (5 or 7)
C      XF      D(*)   Frequencies
C      XD      R(*)   spectrum
C   In/Output:
C     RESULT  R(*)   Initial/New fit parms (or blanked)
C     Output
C      IRET    I      =99 -> QUIT, else TV error
C-----------------------------------------------------------------------
      INTEGER   ISP, NZ, ITYP, IRET
      REAL      XD(*), RESULT(*)
      DOUBLE PRECISION XF(*)
C
      INCLUDE 'LISPX.INC'
      INCLUDE 'LISPX.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), 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
      CALL RCOPY (NZ, XD, 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) ISP
            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**XF(I)
         FMIN = MIN (FF, FMIN)
         FMAX = MAX (FF, FMAX)
 10      CONTINUE
      DX = 0.05 * (FMAX - FMIN)
      FMIN = (FMIN - DX) * REFREQ
      FMAX = (FMAX + DX) * REFREQ
      FFMN = FMIN
      FFMX = FMAX
      CALL RFILL (7, 1.0, XBLC)
      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)*XF(I) + LRES(6)*(XF(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(1),1035) (LRES(I), I=2,5)
      ELSE
         WRITE (TEXT(1),1036) (LRES(I), I=2,7)
         END IF
      NTEXT = 1
      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 spectrum number
      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) ISP
      CALL IMCHAR (IGR, IDX, IDY, 0, 0, MSGBUF(:7), SCRTCH, IRET)
      IF (IRET.NE.0) GO TO 970
C                                       add ID string
      DX = PBLC(1)*SCALEX + RX0
      DY = PTRC(2)*SCALEY + RY0 + 0.5 * CSIZTV(2)
      IDX = DX + 0.5
      IDY = DY + 0.5
      MSGBUF = SPCHAR(ISP)(:80)
      CALL IMCHAR (IGR, IDX, IDY, 0, 0, MSGBUF, SCRTCH, IRET)
      IF (IRET.NE.0) GO TO 970
C                                       add data points
      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**XF(I)) * REFREQ
         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**XF(I)) * REFREQ
         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 = 99
         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, XD, LDATA)
         CALL RCOPY (ITYP, RESULT, LRES)
         GO TO 20
      ELSE IF (CHOICS(CHS).EQ.'NEW FIT') THEN
         IF (ITYP.LT.7) THEN
            CALL DO1SPX (NZ, XF, LDATA, LRES)
         ELSE
            CALL DO2SPX (NZ, XF, 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, XD, 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
            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**XF(IP)) * REFREQ
                  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: SPECTRUM',I4,' ALREADY FAILED')
 1035 FORMAT ('T0=',F8.3,' (',F7.3,') SP=',F7.3,' (',F6.3,')')
 1036 FORMAT ('T0=',F8.3,' (',F7.3,') SP=',F7.3,' (',F6.3,') CU=',F7.3,
     *   ' (',F6.3,')')
 1060 FORMAT ('S=',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,' ?Hz')
      END
      SUBROUTINE LISPOU (ITYP, IRET)
C-----------------------------------------------------------------------
C   LISPOU prints the answers and optionally writes a text file
C   Inputs
C      ITYP     I      # answers (5 or 7)
C   Output:
c      IRET    I      0 => ok,  4 => real trouble.
C------------------------------------------------------------------------
      INTEGER   ITYP, IRET
C
      REAL      TFREQ, TMOD, TDIF
      INTEGER   TLUN, TIND, LUNTMP, ISP, J, JTRIM, K, I, I1, I2
      LOGICAL   DOTEXT
      CHARACTER STRING*128
      INCLUDE 'LISPX.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
C-----------------------------------------------------------------------
      IRET = 0
      DO 20 ISP = 1,NSPEC
         J = JTRIM (SPCHAR(ISP))
         J = MIN (45, MAX (1,J))
         IF (SPIX(1,ISP).EQ.FBLANK) THEN
            WRITE (MSGTXT,1005) ISP, SPCHAR(ISP)(:J)
            CALL MSGWRT (5)
         ELSE
            K = SPIX(1,ISP) + 0.1
            WRITE (MSGTXT,1010) ISP, K, SPCHAR(ISP)(:J)
            CALL MSGWRT (5)
            WRITE (MSGTXT,1020) ' ', SPIX(2,ISP), SPIX(3,ISP)
            CALL MSGWRT (5)
            WRITE (MSGTXT,1021) ' ', SPIX(4,ISP), SPIX(5,ISP)
            CALL MSGWRT (5)
            IF (ITYP.EQ.7) THEN
               WRITE (MSGTXT,1022) ' ', SPIX(6,ISP), SPIX(7,ISP)
               CALL MSGWRT (5)
               END IF
            END IF
 20      CONTINUE
C                                       text file
      DOTEXT = OUFILE.NE.' '
      IF (DOTEXT) THEN
         TLUN = LUNTMP (2)
         CALL ZTXOPN ('WRIT', TLUN, TIND, OUFILE, .TRUE., IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'OPENING OUTPUT TEXT FILE'
            CALL MSGWRT (8)
            GO TO 999
            END IF
         DO 50 ISP = 1,NSPEC
            I1 = FVALU(ISP)
            I2 = FVALU(ISP+1) - 1
            J = JTRIM (SPCHAR(ISP))
            J = MIN (92, MAX (1,J))
            IF (SPIX(1,ISP).EQ.FBLANK) THEN
               WRITE (STRING,1005) ISP, SPCHAR(ISP)(:J)
               J = JTRIM (STRING)
               CALL ZTXIO ('WRIT', TLUN, TIND, STRING(:J), IRET)
               IF (IRET.NE.0) THEN
                  WRITE (STRING,1000) IRET, 'WRITING OUTPUT TEXT FILE'
                  CALL MSGWRT (8)
                  DOTEXT = .FALSE.
                  END IF
            ELSE
               K = SPIX(1,ISP) + 0.1
               WRITE (STRING,1011) ISP, K, SPCHAR(ISP)(:J)
               J = JTRIM (STRING)
               CALL ZTXIO ('WRIT', TLUN, TIND, STRING(:J), IRET)
               IF (IRET.NE.0) GO TO 900
               WRITE (STRING,1020) '#', SPIX(2,ISP), SPIX(3,ISP)
               J = JTRIM (STRING)
               CALL ZTXIO ('WRIT', TLUN, TIND, STRING(:J), IRET)
               IF (IRET.NE.0) GO TO 900
               WRITE (STRING,1021) '#', SPIX(4,ISP), SPIX(5,ISP)
               J = JTRIM (STRING)
               CALL ZTXIO ('WRIT', TLUN, TIND, STRING(:J), IRET)
               IF (IRET.NE.0) GO TO 900
               IF (ITYP.EQ.7) THEN
                  WRITE (STRING,1022) '#', SPIX(6,ISP), SPIX(7,ISP)
                  J = JTRIM (STRING)
                  CALL ZTXIO ('WRIT', TLUN, TIND, STRING(:J), IRET)
                  IF (IRET.NE.0) GO TO 900
                  DO 30 I = I1,I2
                     TFREQ = (10.0 ** (XFREQ(I))) * REFREQ
                     TMOD = LOG10 (SPIX(2,ISP)) + SPIX(4,ISP) * XFREQ(I)
     *                  + SPIX(6,ISP) * (XFREQ(I)**2)
                     TMOD = 10.0 ** TMOD
                     TDIF = XDATA(I) - TMOD
                     IF (XRMS(I).EQ.FBLANK) THEN
                        WRITE (STRING,1030) TFREQ, XDATA(I), TMOD, TDIF
                     ELSE
                        WRITE (STRING,1030) TFREQ, XDATA(I), XRMS(I),
     *                     TMOD, TDIF
                        END IF
                     J = JTRIM (STRING)
                     CALL ZTXIO ('WRIT', TLUN, TIND, STRING(:J), IRET)
                     IF (IRET.NE.0) GO TO 900
 30                  CONTINUE
               ELSE
                  DO 40 I = I1,I2
                     TFREQ = (10.0 ** (XFREQ(I))) * REFREQ
                     TMOD = LOG10 (SPIX(2,ISP)) + SPIX(4,ISP) * XFREQ(I)
                     TMOD = 10.0 ** TMOD
                     TDIF = XDATA(I) - TMOD
                     IF (XRMS(I).EQ.FBLANK) THEN
                        WRITE (STRING,1030) TFREQ, XDATA(I), TMOD, TDIF
                     ELSE
                        WRITE (STRING,1030) TFREQ, XDATA(I), XRMS(I),
     *                     TMOD, TDIF
                        END IF
                     J = JTRIM (STRING)
                     CALL ZTXIO ('WRIT', TLUN, TIND, STRING(:J), IRET)
                     IF (IRET.NE.0) GO TO 900
 40                  CONTINUE
                  END IF
               END IF
 50         CONTINUE
         END IF
      IF ((OUFILE.NE.' ') .AND. (TIND.NE.0)) CALL ZTXCLS (TLUN, TIND, J)
      GO TO 999
C
 900  WRITE (MSGTXT,1000) IRET, 'WRITING OUTPUT TEXT FILE'
      CALL MSGWRT (8)
      CALL ZTXCLS (TLUN, TIND, J)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('LISPOU ERROR',I5,' ON ',A)
 1005 FORMAT ('Spectrum',I3,'  FLAGGED BAD   label=''',A,'''')
 1010 FORMAT ('Spectrum',I3,'  N data=',I6,' label=''',A,'''')
 1011 FORMAT ('SPECTRUM',I3,'  N data=',I6,' label=''',A,'''')
 1020 FORMAT (A1,4X,'Flux at ref fr',F10.3,'  (',F8.3,')')
 1021 FORMAT (A1,4X,'Spectral index',F10.3,'  (',F8.3,')')
 1022 FORMAT (A1,4X,'Spectral curv.',F10.3,'  (',F8.3,')')
 1030 FORMAT (F15.10,4F12.6)
      END
