LOCAL INCLUDE 'IM2TX.INC'
      INCLUDE 'INCS:PMAD.INC'
      INTEGER   SEQIN, DISKIN, OLDCNO, JBUFSZ, ICODE
      HOLLERITH XNAMEI(3), XCLAIN(2), XOPCOD(1), XOUFIL(12)
      CHARACTER NAMEIN*12, CLAIN*6, OPCODE*4, OUTFIL*48
      REAL      XSEQIN, XDISKI, BLC(7), TRC(7), BUFF1(MABFSS)
      LOGICAL   ISFREQ
      DOUBLE PRECISION XFREQ(16384)
      COMMON /INPARM/ XNAMEI, XCLAIN, XSEQIN, XDISKI, BLC, TRC, XOPCOD,
     *   XOUFIL
      COMMON /CHPARM/ NAMEIN, CLAIN, OUTFIL, OPCODE
      COMMON /PARMS/ SEQIN, DISKIN, OLDCNO, JBUFSZ, ICODE, ISFREQ
      COMMON /BUFRS/ XFREQ, BUFF1
LOCAL END
      PROGRAM IM2TX
C-----------------------------------------------------------------------
C! Sum or average a region in N-1 axes, write text spectrum in the other
C# Map-util Analysis
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   IM2TX sums or averages a BLC-TRC region in all axes but one and
C   writes a text file "spectrum" in that axis.
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      BLC(7)         BLC           Bottom left corner of subimage
C                                   of input image.
C      TRC(7)         TRC           Top right corner of subimage.
C      OPCODE         OPCODE        User specified opcode.
C      OUTFILE        OUTFIL        Text file
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER  IRET
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'IM2TX.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA PRGM /'IM2TX '/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL IM2TXI (PRGM, IRET)
C                                       Call routine that sends data
C                                       to the user routine.
      IF (IRET.EQ.0) CALL IM2TXR (IRET)
C                                       Close down files, etc.
      CALL DIE (IRET, BUFF1)
C
 999  STOP
      END
      SUBROUTINE IM2TXI (PRGN, IRET)
C-----------------------------------------------------------------------
C   IM2TXI gets input parameters for IM2TX and creates an output text
C   file.
C   Inputs:
C      PRGN    C*6  Program name
C   Output:
C      IRET    I    Error code: 0 => ok
C                               4 => user routine detected error.
C                               5 => catalog troubles
C                               8 => can't start
C-----------------------------------------------------------------------
      INTEGER   IRET
      CHARACTER PRGN*6
C
      CHARACTER  STAT*4, MTYPE*2, NUMCH(7)*1
      INTEGER   IERR, NPARM, IROUND, I
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'IM2TX.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DLOC.INC'
      DATA NUMCH /'1', '2', '3', '4', '5', '6', '7'/
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      JBUFSZ = 2 * MABFSS
      IRET = 0
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      locnum = 1
C                                       Get input parameters.
      NPARM = 34
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         RQUICK = .TRUE.
         IRET = 8
         IF (IERR.EQ.1) GO TO 999
            WRITE (MSGTXT,1000) IERR
            CALL MSGWRT (8)
         END IF
C                                       Restart AIPS
      IF (RQUICK) CALL RELPOP (IRET, BUFF1, IERR)
      IF (IRET.NE.0) GO TO 999
      IRET = 5
C                                       Hollerith -> char.
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      CALL H2CHR (4, 1, XOPCOD, OPCODE)
      CALL H2CHR (48, 1, XOUFIL, OUTFIL)
C                                       Crunch input parameters.
      SEQIN = IROUND (XSEQIN)
      DISKIN = IROUND (XDISKI)
      IF (OUTFIL.EQ.' ') THEN
         MSGTXT = 'OUTFILE MUST BE SPECIFIED'
         GO TO 990
         END IF
C                                       Create new file.
C                                       Get CATBLK from old file.
      OLDCNO = 1
      MTYPE = 'MA'
      CALL CATDIR ('SRCH', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN, MTYPE,
     *   NLUSER, STAT, BUFF1, 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, CATBLK, 'READ', BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1040) IERR
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = OLDCNO
      FRW(NCFILE) = 0
C                                       Set defaults on BLC,TRC
      CALL WINDOW (CATBLK(KIDIM), CATBLK(KINAX), BLC, TRC, IERR)
      IF (IERR.NE.0) GO TO 999
      ICODE = 0
      DO 20 I = 1,CATBLK(KIDIM)
         IF (OPCODE(:1).EQ.NUMCH(I)) ICODE = I
 20      CONTINUE
      IF (ICODE.EQ.0) THEN
         MSGTXT = 'OPCODE DOES NOT SAY WHICH AXIS'
         GO TO 990
         END IF
      IF (TRC(ICODE)-BLC(ICODE).LT.1.0) THEN
         MSGTXT = 'TRC AND BLC SPECIFY A NULL 1-D IMAGE'
         GO TO 990
         END IF
      IRET = 0
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('IM2TXI: ERROR',I3,' OBTAINING INPUT PARAMETERS')
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I3,' DISK=',
     *   I3,' USID=',I5)
 1040 FORMAT ('ERROR',I3,' COPYING CATBLK ')
      END
      SUBROUTINE IM2TXR (IRET)
C-----------------------------------------------------------------------
C   IM2TXR opens the input image, creates the text file, writes the text
C   file header, and then invokes various routines to fine and create
C   the output data.
C   Output:
C      IRET   I  Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      CHARACTER IFILE*48, CTYPE*8, OUTLIN*128, BUNIT*8, AXTYPE*8
      INTEGER   I, NPTS, LUNI, LUNT, COUNT(16384), INDI, FINDT, J, NAX,
     *   JTRIM, K, L, DEPTH(7), I1, I2
      REAL      FI, FR, C1CRP, C1CIC, XPIX, YPIX
      DOUBLE PRECISION FV, C1CRV, X(7), ANSW(16384), ANSS(16384)
      LOGICAL   T, F
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'IM2TX.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA LUNI, LUNT /16, 3/
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
      ISFREQ = F
      CALL AXEFND (8, 'SEQ.NUM.', CATBLK(KIDIM), CATH(KHCTP), L, IRET)
      IF (IRET.NE.0) L = -1
      CALL AXEFND (4, 'FQID', CATBLK(KIDIM), CATH(KHCTP), K, IRET)
      IF (IRET.NE.0) K = -1
      CALL AXEFND (4, 'FREQ', CATBLK(KIDIM), CATH(KHCTP), J, IRET)
      IF (K.EQ.-1) K = L
      IF (K.EQ.-1) K = J
      IF (IRET.EQ.0) THEN
         ISFREQ = K.EQ.ICODE-1
         NAX = CATBLK(KINAX+K)
         FV = CATD(KDCRV+J)
         FI = CATR(KRCIC+J)
         FR = CATR(KRCRP+J)
         CALL H2CHR (8, 1, CATH(KHCTP+2*K), AXTYPE)
         IF (AXTYPE.EQ.'FREQ') THEN
            DO 10 I = 1,NAX
               XFREQ(I) = FV + FI * (I - FR)
 10            CONTINUE
         ELSE IF (AXTYPE.EQ.'SEQ.NUM.') THEN
            CALL HIGET (DISKIN, OLDCNO, NAX, XFREQ, IRET)
         ELSE IF (AXTYPE.EQ.'FQID') THEN
            C1CRV = CATD(KDCRV+K)
            C1CRP = CATR(KRCRP+K)
            C1CIC = CATR(KRCIC+K)
            CALL FQGET (DISKIN, OLDCNO, NAX, FV, C1CRV, C1CRP, C1CIC,
     *         CATBLK, XFREQ, IRET)
            END IF
         FV = 0.0D0
         I1 = BLC(K+1) + 0.1
         I2 = TRC(K+1) + 0.1
         DO 15 I = I1,I2
            FV = FV + XFREQ(I)
 15         CONTINUE
         FV = FV / (I2 - I1 + 1)
      END IF
      DO 20 I = 1,7
         DEPTH(I) = (TRC(I) + BLC(I)) / 2.0 + 0.5
 20   CONTINUE
      CALL SETLOC (DEPTH(3), .FALSE.)
      XPIX = DEPTH(1)
      YPIX = DEPTH(2)
      CALL DFILL (7, 0.0D0, X)
      CALL XYVAL (XPIX, YPIX, X(1), X(2), X(3), IRET)
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 FILE'
         GO TO 990
         END IF
      CALL ZTXOPN ('WRIT', LUNT, FINDT, OUTFIL, T, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CREATING OUTPUT TEXT FILE'
         GO TO 990
         END IF
C                                       text file header
      CALL H2CHR (8, 1, CATH(KHCTP+2*ICODE-2), AXTYPE)
      WRITE (OUTLIN,2000) ICODE, AXTYPE, OPCODE(2:4)
      J = JTRIM (OUTLIN)
      CALL ZTXIO ('WRIT', LUNT, FINDT, OUTLIN(:J), IRET)
      IF (IRET.NE.0) GO TO 980
      CALL H2CHR (8, 1, CATH(KHBUN), BUNIT)
      CALL H2CHR (8, 1, CATH(KHDOB), CTYPE)
      WRITE (OUTLIN,2005) BUNIT, CTYPE
      J = JTRIM (OUTLIN)
      CALL ZTXIO ('WRIT', LUNT, FINDT, OUTLIN(:J), IRET)
      IF (IRET.NE.0) GO TO 980
      CALL H2CHR (8, 1, CATH(KHOBJ), CTYPE)
      WRITE (OUTLIN,2006) CTYPE
      J = JTRIM (OUTLIN)
      CALL ZTXIO ('WRIT', LUNT, FINDT, OUTLIN(:J), IRET)
      IF (IRET.NE.0) GO TO 980
      IF ((AXTYPE.EQ.'FREQ') .OR. (AXTYPE(:4).EQ.'VELO') .OR.
     *   (AXTYPE(:4).EQ.'FELO')) THEN
         IF (CATBLK(KIALT).NE.0) THEN
            WRITE (OUTLIN,2007) CATBLK(KIALT)
            J = JTRIM (OUTLIN)
            CALL ZTXIO ('WRIT', LUNT, FINDT, OUTLIN(:J), IRET)
            IF (IRET.NE.0) GO TO 980
            WRITE (OUTLIN,2008) CATD(KDARV), CATR(KRARP)
            J = JTRIM (OUTLIN)
            CALL ZTXIO ('WRIT', LUNT, FINDT, OUTLIN(:J), IRET)
            IF (IRET.NE.0) GO TO 980
            END IF
         IF (CATD(KDRST).NE.0.0D0) THEN
            WRITE (OUTLIN,2009) CATD(KDRST)
            J = JTRIM (OUTLIN)
            CALL ZTXIO ('WRIT', LUNT, FINDT, OUTLIN(:J), IRET)
            IF (IRET.NE.0) GO TO 980
            END IF
         END IF
      DO 40 I = 1,CATBLK(KIDIM)
         CALL H2CHR (8, 1, CATH(KHCTP+2*I-2), CTYPE)
         IF ((CTYPE.EQ.'FREQ') .OR. (CTYPE.EQ.'FQID') .OR.
     *      (CTYPE.EQ.'SEQ.NUM.')) X(I) = FV
         WRITE (OUTLIN,2010) I, CTYPE, CATBLK(KINAX+I-1), BLC(I), TRC(I)
         J = JTRIM (OUTLIN)
         CALL ZTXIO ('WRIT', LUNT, FINDT, OUTLIN(:J), IRET)
         IF (IRET.NE.0) GO TO 980
         WRITE (OUTLIN,2011) I, CATD(KDCRV+I-1), CATR(KRCIC+I-1)
         J = JTRIM (OUTLIN)
         CALL ZTXIO ('WRIT', LUNT, FINDT, OUTLIN(:J), IRET)
         IF (IRET.NE.0) GO TO 980
         WRITE (OUTLIN,2012) I, CATR(KRCRP+I-1)
         J = JTRIM (OUTLIN)
         CALL ZTXIO ('WRIT', LUNT, FINDT, OUTLIN(:J), IRET)
         IF (IRET.NE.0) GO TO 980
         WRITE (OUTLIN,2013) I, X(I)
         J = JTRIM (OUTLIN)
         IF (X(I).NE.0.0D0) CALL ZTXIO ('WRIT', LUNT, FINDT, OUTLIN(:J),
     *      IRET)
         IF (IRET.NE.0) GO TO 980
 40      CONTINUE
C                                       now do it
      NPTS = TRC(ICODE) - BLC(ICODE) + 1.1
      CALL RFILL (NPTS, 0.0, ANSW)
      CALL RFILL (NPTS, 0.0, ANSS)
      CALL FILL (NPTS, 0, COUNT)
      IF (ICODE.EQ.1) THEN
         CALL DOIT1 (NPTS, LUNI, INDI, LUNT, FINDT, ANSW, COUNT, ANSS,
     *      IRET)
      ELSE IF (ICODE.EQ.2) THEN
         CALL DOIT2 (NPTS, LUNI, INDI, LUNT, FINDT, ANSW, COUNT, ANSS,
     *      IRET)
      ELSE
         CALL DOIT3 (NPTS, LUNI, INDI, LUNT, FINDT, ANSW, COUNT, ANSS,
     *      IRET)
         END IF
      IF (IRET.NE.0) GO TO 999
C                                       close text file
      CALL ZTXCLS (LUNT, FINDT, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CLOSING OUTOUT TEXT FILE'
         GO TO 990
         END IF
      GO TO 999
C
 980  WRITE (MSGTXT,1000) IRET, 'WRITING TEXT FILE'
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('IM2TXR ERROR',I5,' ON ',A)
 2000 FORMAT ('#Data type',I2,' ''',A,'''  value is ',A)
 2005 FORMAT ('#INFO BUNIT ''',A,'''  OBSDATE ''',A,'''')
 2006 FORMAT ('#INFO SRCNAME ''',A,'''')
 2007 FORMAT ('#INFO ALTCODE',I7)
 2008 FORMAT ('#INFO ALTVAL',1PE14.6,' ALTPIX',0PF7.1)
 2009 FORMAT ('#INFO RESTFREQ',1PE14.6)
 2010 FORMAT ('#HEADa',I2,'  ''',A,''' Npts',I6,' BLC/TRC',2F7.0)
 2011 FORMAT ('#HEADb',I2,'  Refval',1PE15.7,'  Cdelt',1PE14.6)
 2012 FORMAT ('#HEADc',I2,'  Refpix',F8.1)
 2013 FORMAT ('#HEADd',I2,'  AvgValue',1PE17.9)
      END
      SUBROUTINE DOIT1 (NPTS, LUNI, INDI, LUNT, FINDT, ANSW, COUNT,
     *   ANSS, IRET)
C-----------------------------------------------------------------------
C   DOIT1 sums aver the BLC-TRC window in axes 2-N.
C   Inputs
C      NPTS    I      Number points in spectrum
C      LUNI    I      LUN of open data file
C      INDI    I      FTAB pointer of open data file
C      LUNT    I      LUN of open text file
C      FINDT   I      FTAB pointer of open data file
C   Outputs
C      ANSW    D(*)   Answer
C      COUNT   I(*)   Number samples in ANSW
C      ANSS    D(*)   RMS
C      IRET    I      > 0 => error
C-----------------------------------------------------------------------
      INTEGER   NPTS, LUNI, INDI, LUNT, FINDT, COUNT(*), IRET
      DOUBLE PRECISION ANSW(*), ANSS(*)
C
      INTEGER   IROUND, NYI, NXI, WINI(4), BOI, LIM1, LIM2, LIM3, LIM4,
     *   LIM5, LIM6, LIM7, I1, I2, I3, I4, I5, I6, I7, IPOS(7),
     *   DEPTH(5), IBIND, J, JTRIM
      LOGICAL   T, F
      CHARACTER OUTLIN*128
      REAL      XPIX, YPIX
      DOUBLE PRECISION X(3), XV
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'IM2TX.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
C                                       Setup for I/O
      NXI = CATBLK(KINAX)
      NYI = CATBLK(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
C                                       Loop
      DO 700 I7 = 1,LIM7
         IPOS(7) = BLC(7) + I7 - 0.9
         DO 600 I6 = 1,LIM6
            IPOS(6) = BLC(6) + I6 - 0.9
            DO 500 I5 = 1,LIM5
               IPOS(5) = BLC(5) + I5 - 0.9
               DO 400 I4 = 1,LIM4
                  IPOS(4) = BLC(4) + I4 - 0.9
                  DO 300 I3 = 1,LIM3
                     IPOS(3) = BLC(3) + I3 - 0.9
C                                       Init. files, first input.
         CALL COMOFF (CATBLK(KIDIM), CATBLK(KINAX), IPOS(3), BOI, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'FIND OFFSET FOR I/O'
            GO TO 990
            END IF
         BOI = BOI + 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 DATA'
            GO TO 990
            END IF
         DO 200 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, 'read IMAGE DATA'
               GO TO 990
               END IF
            DO 100 I1 = 1,LIM1
               IF (BUFF1(IBIND+I1-1).NE.FBLANK) THEN
                  ANSW(I1) = ANSW(I1) + BUFF1(IBIND+I1-1)
                  ANSS(I1) = ANSS(I1) + BUFF1(IBIND+I1-1)**2
                  COUNT(I1) = COUNT(I1) + 1
                  END IF
 100              CONTINUE
 200           CONTINUE
 300                 CONTINUE
 400              CONTINUE
 500           CONTINUE
 600        CONTINUE
 700     CONTINUE
C                                       average
      IF ((OPCODE(2:4).EQ.'AVG') .OR. (OPCODE(2:4).EQ.'RMS')) THEN
         DO 710 I1 = 1,LIM1
            IF (COUNT(I1).GT.0) THEN
               ANSW(I1) = ANSW(I1) / COUNT(I1)
               ANSS(I1) = ANSS(I1) / COUNT(I1) - ANSW(I1)**2
               ANSS(I1) = SQRT (MAX (0.0D0, ANSS(I1)))
               END IF
 710        CONTINUE
         END IF
      DEPTH(1) = (TRC(3) + BLC(3)) / 2.0 + 0.5
      DEPTH(2) = (TRC(4) + BLC(4)) / 2.0 + 0.5
      DEPTH(3) = (TRC(5) + BLC(5)) / 2.0 + 0.5
      DEPTH(4) = (TRC(6) + BLC(6)) / 2.0 + 0.5
      DEPTH(5) = (TRC(7) + BLC(7)) / 2.0 + 0.5
      CALL SETLOC (DEPTH, T)
      YPIX = (TRC(2) + BLC(2)) / 2.0
      DO 720 I1 = 1,LIM1
         J = BLC(1) + I1 - 0.9
         IF (ISFREQ) THEN
            XV = XFREQ(J)
         ELSE
            XPIX = BLC(1) + I1 - 1.0
            CALL XYVAL (XPIX, YPIX, X(1), X(2), X(3), IRET)
            XV = X(1)
         END IF
         IF (OPCODE(2:4).EQ.'RMS') THEN
            WRITE (OUTLIN,1710) XV, ANSS(I1)
         ELSE IF (OPCODE(2:4).EQ.'AVG') THEN
            WRITE (OUTLIN,1710) XV, ANSW(I1), ANSS(I1)
         ELSE
            WRITE (OUTLIN,1710) XV, ANSW(I1)
            END IF
         J = JTRIM (OUTLIN)
         CALL ZTXIO ('WRIT', LUNT, FINDT, OUTLIN(:J), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING OUTPUT TEXT FILE'
            GO TO 990
            END IF
 720     CONTINUE
C
      IRET = 0
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('DOIT1: ERROR',I3,' ON ',A)
 1710 FORMAT (1PE17.9,2X,2(1PE14.6))
      END
      SUBROUTINE DOIT2 (NPTS, LUNI, INDI, LUNT, FINDT, ANSW, COUNT,
     *   ANSS, IRET)
C-----------------------------------------------------------------------
C   DOIT1 sums aver the BLC-TRC window in axes 2-N.
C   Inputs
C      NPTS    I      Number points in spectrum
C      LUNI    I      LUN of open data file
C      INDI    I      FTAB pointer of open data file
C      LUNT    I      LUN of open text file
C      FINDT   I      FTAB pointer of open data file
C   Outputs
C      ANSW    D(*)   Answer
C      COUNT   I(*)   Number samples in ANSW
C      ANSS    D(*)   RMS
C      IRET    I      > 0 => error
C-----------------------------------------------------------------------
      INTEGER   NPTS, LUNI, INDI, LUNT, FINDT, COUNT(*), IRET
      DOUBLE PRECISION ANSW(*), ANSS(*)
C
      INTEGER   IROUND, NYI, NXI, WINI(4), BOI, LIM1, LIM2, LIM3, LIM4,
     *   LIM5, LIM6, LIM7, I1, I2, I3, I4, I5, I6, I7, IPOS(7), CORN(7),
     *   IBIND, J, JTRIM, DEPTH(5)
      LOGICAL   T, F
      CHARACTER OUTLIN*128
      REAL      XPIX, YPIX
      DOUBLE PRECISION X(3), XV
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'IM2TX.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
C                                       Setup for I/O
      NXI = CATBLK(KINAX)
      NYI = CATBLK(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
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 (CATBLK(KIDIM), CATBLK(KINAX), IPOS(3), BOI, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'FIND OFFSET FOR I/O'
            GO TO 990
            END IF
         BOI = BOI + 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 DATA'
            GO TO 990
            END IF
         DO 200 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, 'read IMAGE DATA'
               GO TO 990
               END IF
            DO 100 I1 = 1,LIM1
               IF (BUFF1(IBIND+I1-1).NE.FBLANK) THEN
                  ANSW(I2) = ANSW(I2) + BUFF1(IBIND+I1-1)
                  ANSS(I2) = ANSS(I2) + BUFF1(IBIND+I1-1)**2
                  COUNT(I2) = COUNT(I2) + 1
                  END IF
 100              CONTINUE
 200           CONTINUE
 300                 CONTINUE
 400              CONTINUE
 500           CONTINUE
 600        CONTINUE
 700     CONTINUE
C                                       average
      IF ((OPCODE(2:4).EQ.'AVG') .OR. (OPCODE(2:4).EQ.'RMS')) THEN
         DO 710 I1 = 1,LIM1
            IF (COUNT(I1).GT.0) THEN
               ANSW(I1) = ANSW(I1) / COUNT(I1)
               ANSS(I1) = ANSS(I1) / COUNT(I1) - ANSW(I1)**2
               ANSS(I1) = SQRT (MAX (0.0D0, ANSS(I1)))
               END IF
 710        CONTINUE
         END IF
      DEPTH(1) = (TRC(3) + BLC(3)) / 2.0 + 0.5
      DEPTH(2) = (TRC(4) + BLC(4)) / 2.0 + 0.5
      DEPTH(3) = (TRC(5) + BLC(5)) / 2.0 + 0.5
      DEPTH(4) = (TRC(6) + BLC(6)) / 2.0 + 0.5
      DEPTH(5) = (TRC(7) + BLC(7)) / 2.0 + 0.5
      CALL SETLOC (DEPTH, T)
      XPIX = (TRC(1) + BLC(1)) / 2.0
      DO 720 I2 = 1,LIM2
         J = BLC(2) + I2 - 0.9
         IF (ISFREQ) THEN
            XV = XFREQ(J)
         ELSE
            YPIX = BLC(2) + I2 - 1.0
            CALL XYVAL (XPIX, YPIX, X(1), X(2), X(3), IRET)
            XV = X(2)
            END IF
         IF (OPCODE(2:4).EQ.'RMS') THEN
            WRITE (OUTLIN,1710) XV, ANSS(I2)
         ELSE IF (OPCODE(2:4).EQ.'AVG') THEN
            WRITE (OUTLIN,1710) XV, ANSW(I2), ANSS(I2)
         ELSE
            WRITE (OUTLIN,1710) XV, ANSW(I2)
            END IF
         J = JTRIM (OUTLIN)
         CALL ZTXIO ('WRIT', LUNT, FINDT, OUTLIN(:J), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING OUTPUT TEXT FILE'
            GO TO 990
            END IF
 720     CONTINUE
C
      IRET = 0
      GO TO 999
      IRET = 0
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('DOIT2: ERROR',I3,' ON ',A)
 1710 FORMAT (1PE17.9,2X,2(1PE14.6))
      END
      SUBROUTINE DOIT3 (NPTS, LUNI, INDI, LUNT, FINDT, ANSW, COUNT,
     *   ANSS, IRET)
C-----------------------------------------------------------------------
C   DOIT3 sums aver the BLC-TRC window in axes 1-2, 4-N.
C   Inputs
C      NPTS    I      Number points in spectrum
C      LUNI    I      LUN of open data file
C      INDI    I      FTAB pointer of open data file
C      LUNT    I      LUN of open text file
C      FINDT   I      FTAB pointer of open data file
C   Outputs
C      ANSW    D(*)   Answer
C      COUNT   I(*)   Number samples in ANSW
C      ANSS    D(*)   RMS
C      IRET    I      > 0 => error
C-----------------------------------------------------------------------
      INTEGER   NPTS, LUNI, INDI, LUNT, FINDT, COUNT(*), IRET
      DOUBLE PRECISION ANSW(*), ANSS(*)
C
      INTEGER   IROUND, NYI, NXI, WINI(4), BOI, LIM1, LIM2, LIM3, LIM4,
     *   LIM5, LIM6, LIM7, I1, I2, I3, I4, I5, I6, I7, IPOS(7), CORN(7),
     *   IBIND, J, JTRIM, DEPTH(5)
      LOGICAL   T, F
      CHARACTER OUTLIN*128
      REAL      XPIX, YPIX
      DOUBLE PRECISION X(3), XV
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'IM2TX.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DLOC.INC'
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
C                                       Setup for I/O
      NXI = CATBLK(KINAX)
      NYI = CATBLK(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
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 (CATBLK(KIDIM), CATBLK(KINAX), IPOS(3), BOI, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'FIND OFFSET FOR I/O'
            GO TO 990
            END IF
         BOI = BOI + 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 DATA'
            GO TO 990
            END IF
         DO 200 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, 'read IMAGE DATA'
               GO TO 990
               END IF
            DO 100 I1 = 1,LIM1
               IF (BUFF1(IBIND+I1-1).NE.FBLANK) THEN
                  ANSW(I3) = ANSW(I3) + BUFF1(IBIND+I1-1)
                  ANSS(I3) = ANSS(I3) + BUFF1(IBIND+I1-1)**2
                  COUNT(I3) = COUNT(I3) + 1
                  END IF
 100              CONTINUE
 200           CONTINUE
 300                 CONTINUE
 400              CONTINUE
 500           CONTINUE
 600        CONTINUE
 700     CONTINUE
C                                       average
      IF ((OPCODE(2:4).EQ.'AVG') .OR. (OPCODE(2:4).EQ.'RMS')) THEN
         DO 710 I1 = 1,LIM1
            IF (COUNT(I1).GT.0) THEN
               ANSW(I1) = ANSW(I1) / COUNT(I1)
               ANSS(I1) = ANSS(I1) / COUNT(I1) - ANSW(I1)**2
               ANSS(I1) = SQRT (MAX (0.0D0, ANSS(I1)))
               END IF
 710        CONTINUE
         END IF
      DEPTH(2) = (TRC(4) + BLC(4)) / 2.0 + 0.5
      DEPTH(3) = (TRC(5) + BLC(5)) / 2.0 + 0.5
      DEPTH(4) = (TRC(6) + BLC(6)) / 2.0 + 0.5
      DEPTH(5) = (TRC(7) + BLC(7)) / 2.0 + 0.5
      XPIX = (TRC(1) + BLC(1)) / 2.0
      YPIX = (TRC(2) + BLC(2)) / 2.0
      DO 720 I3 = 1,LIM3
         DEPTH(1) = BLC(3) + I3 - 1
         CALL SETLOC (DEPTH, T)
         J = BLC(3) + I3 - 0.9
         IF (ISFREQ) THEN
            XV = XFREQ(J)
         ELSE
            CALL XYVAL (XPIX, YPIX, X(1), X(2), X(3), IRET)
            XV = X(3)
            END IF
         IF (OPCODE(2:4).EQ.'RMS') THEN
            WRITE (OUTLIN,1710) XV, ANSS(I3)
         ELSE IF (OPCODE(2:4).EQ.'AVG') THEN
            WRITE (OUTLIN,1710) XV, ANSW(I3), ANSS(I3)
         ELSE
            WRITE (OUTLIN,1710) XV, ANSW(I3)
            END IF
         J = JTRIM (OUTLIN)
         CALL ZTXIO ('WRIT', LUNT, FINDT, OUTLIN(:J), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING OUTPUT TEXT FILE'
            GO TO 990
            END IF
 720     CONTINUE
C
      IRET = 0
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('DOIT3: ERROR',I3,' ON ',A)
 1710 FORMAT (1PE17.9,2X,2(1PE14.6))
      END
      SUBROUTINE HIGET (DISK, CNO, NF, 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 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) MF = MF - 1
 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 FQGET (DISK, CNO, NF, FV, CV, CP, CI, CATBLK, 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   Outputs:
C      XFREQ    D(*)     LOG10(freq/FV)
C      IRET     I        Error code
C-----------------------------------------------------------------------
      INTEGER   DISK, CNO, NF, CATBLK(*), IRET
      DOUBLE PRECISION FV, CV, 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) MF = MF - 1
 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
