LOCAL INCLUDE 'TX2IM.INC'
      INCLUDE 'INCS:PMAD.INC'
      INTEGER   SEQOU, DISKOU, NEWCNO, JBUFSZ, ICODE, NVAL, SCRTCH(512)
      HOLLERITH XNAMEO(3), XCLAOU(2), XINFIL(12), XAXTYP(2), XSORC(4),
     *   XDATE(2)
      CHARACTER NAMEOU*12, CLAOU*6, INFILE*48, AXTYPE*8, BUNIT*8,
     *   SRCNAM*16, OBSDAT*8
      REAL      XSEQOU, XDISKO, COORD(6), REFREQ, BUFF1(MABFSS)
      DOUBLE PRECISION XX(16384), XV(16384), FREQ0
      COMMON /INPARM/ XNAMEO, XCLAOU, XSEQOU, XDISKO, XINFIL, XAXTYP,
     *   COORD, REFREQ, XSORC, XDATE
      COMMON /CHPARM/ NAMEOU, CLAOU, INFILE, AXTYPE, BUNIT, OBSDAT,
     *   SRCNAM
      COMMON /PARMS/ SEQOU, DISKOU, NEWCNO, JBUFSZ, ICODE, NVAL
      COMMON /BUFRS/ XX, XV, FREQ0, BUFF1, SCRTCH
LOCAL END
      PROGRAM TX2IM
C-----------------------------------------------------------------------
C! Convert 1-D text file to 1-D cataloged image
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   TX2IM converts 1-D text file to 1-D image
C   Inputs:
C      AIPS adverb  Prg. name.          Description.
C      INNAME         NAMEOU        Name of input image.
C      INCLASS        CLAOU         Class of input image.
C      INSEQ          SEQOU         Seq. of input image.
C      INDISK         DISKOU        Disk number of input image.
C      INFILE         INFILE        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 'TX2IM.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA PRGM /'TX2IM '/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL TX2IMI (PRGM, IRET)
C                                       Call routine that sends data
C                                       to the user routine.
      IF (IRET.EQ.0) CALL TX2IMR (IRET)
C                                       History
      IF (IRET.EQ.0) CALL TX2IMH
C                                       Close down files, etc.
      CALL DIE (IRET, BUFF1)
C
 999  STOP
      END
      SUBROUTINE TX2IMI (PRGN, IRET)
C-----------------------------------------------------------------------
C   TX2IMI gets input parameters for TX2IM 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
      INTEGER   IERR, NPARM, IROUND
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'TX2IM.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DLOC.INC'
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, XNAMEO, BUFF1, IERR)
      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, BUFF1, IERR)
      IF (IRET.NE.0) GO TO 999
      IRET = 5
C                                       Hollerith -> char.
      CALL H2CHR (12, 1, XNAMEO, NAMEOU)
      CALL H2CHR (6, 1, XCLAOU, CLAOU)
      CALL H2CHR (8, 1, XAXTYP, AXTYPE)
      CALL H2CHR (48, 1, XINFIL, INFILE)
      CALL H2CHR (16, 1, XSORC, SRCNAM)
      CALL H2CHR (16, 1, XDATE, OBSDAT)
C                                       Crunch input parameters.
      SEQOU = IROUND (XSEQOU)
      DISKOU = IROUND (XDISKO)
      IF (INFILE.EQ.' ') THEN
         MSGTXT = 'INFILE MUST BE SPECIFIED'
         GO TO 990
         END IF
C                                       Get the data
      CALL READIT (IERR)
      IF (IERR.NE.0) GO TO 999
      IF (NAMEOU.EQ.' ') NAMEOU = 'NO NAME'
      IF (CLAOU.EQ.' ') CLAOU = TSKNAM
      CALL CHR2H (12, NAMEOU, KHIMNO, CATH(KHIMN))
      CALL CHR2H (6, CLAOU, KHIMCO, CATH(KHIMC))
      CATBLK(KIIMS) = SEQOU
C                                       Create output file.
      NEWCNO = 1
      CALL MCREAT (DISKOU, NEWCNO, SCRTCH, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CREATING OUTPUT IMAGE'
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKOU
      FCNO(NCFILE) = NEWCNO
      FRW(NCFILE) = 2
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('TX2IMI: ERROR',I3,' ON ',A)
      END
      SUBROUTINE READIT (IRET)
C-----------------------------------------------------------------------
C     READIT reads the spectrum and any header data
C     Output
C     IRET  i   error code
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'TX2IM.INC'
      INTEGER   I, J, K, JTRIM, TLUN, TIND, LPLIM, LP, M, HM(2), JF,
     *   JR, JD, JS, ALTCOD
      CHARACTER INLINE*128, CTYPE(7)*8, CHM*1
      REAL      SEC, ALTPIX
      DOUBLE PRECISION CRVAL(2,7), X, CDELT(7), RA, DEC, RESTFR, ALTVAL,
     *   CRPIX(7)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHDR.INC'
C-----------------------------------------------------------------------
      DO 5 I = 1,7
         CRVAL(1,I) = 0.0D0
         CRVAL(2,I) = 0.0D0
         CTYPE(I) = ' '
         CDELT(I) = 0.0D0
 5       CONTINUE
      BUNIT = ' '
      RESTFR = 0.0D0
      ALTVAL = 0.0D0
      ALTPIX = 0.0
      ALTCOD = 0
      NVAL = 0
      TLUN = 3
      CALL ZTXOPN ('READ', TLUN, TIND, INFILE, .FALSE., IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING INPUT TEXT FILE'
         GO TO 990
         END IF
 10   CALL ZTXIO ('READ', TLUN, TIND, INLINE, IRET)
      IF (IRET.EQ.2) THEN
         CALL ZTXCLS (TLUN, TIND, IRET)
         GO TO 100
      ELSE IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'READING INPUT TEXT FILE'
         GO TO 990
      ELSE IF (INLINE(:1).EQ.'#') THEN
         LPLIM = JTRIM (INLINE)
         IF (INLINE(2:5).EQ.'Data') THEN
            I = INDEX (INLINE, '''')
            K = INDEX (INLINE(I+1:), '''')
            IF (K.EQ.0) THEN
               K = I + 9
            ELSE
               K = K + I
               K = MIN (K, LPLIM)
               END IF
            AXTYPE = INLINE(I+1:K-1)
         ELSE IF (INLINE(2:5).EQ.'INFO') THEN
            LP = INDEX (INLINE, 'BUNIT')
            IF (LP.GT.0) THEN
               I = INDEX (INLINE(LP:), '''')
               I = LP + I
               K = INDEX (INLINE(I:), '''')
               K = K + I - 1
               BUNIT = INLINE(I:K)
               END IF
            LP = INDEX (INLINE, 'OBSDATE')
            IF (LP.GT.0) THEN
               I = INDEX (INLINE(LP:), '''')
               I = LP + I
               K = INDEX (INLINE(I:), '''')
               K = K + I - 1
               OBSDAT = INLINE(I:K)
               END IF
            LP = INDEX (INLINE, 'SRCNAME')
            IF (LP.GT.0) THEN
               I = INDEX (INLINE(LP:), '''')
               I = LP + I
               K = INDEX (INLINE(I:), '''')
               K = K + I - 1
               SRCNAM = INLINE(I:K)
               END IF
            LP = INDEX (INLINE, 'ALTCODE')
            IF (LP.GT.0) THEN
               LP = LP + 7
               CALL GETNUM (INLINE, LPLIM, LP, X)
               IF (X.NE.DBLANK) ALTCOD = X + 0.01
               END IF
            LP = INDEX (INLINE, 'RESTFREQ')
            IF (LP.GT.0) THEN
               LP = LP + 8
               CALL GETNUM (INLINE, LPLIM, LP, X)
               IF (X.NE.DBLANK) RESTFR = X
               END IF
            LP = INDEX (INLINE, 'ALTVAL')
            IF (LP.GT.0) THEN
               LP = LP + 6
               CALL GETNUM (INLINE, LPLIM, LP, X)
               IF (X.NE.DBLANK) ALTVAL = X
               END IF
            LP = INDEX (INLINE, 'ALTPIX')
            IF (LP.GT.0) THEN
               LP = LP + 6
               CALL GETNUM (INLINE, LPLIM, LP, X)
               IF (X.NE.DBLANK) ALTPIX = X
               END IF
         ELSE IF (INLINE(2:5).EQ.'HEAD') THEN
            LP = INDEX(INLINE, ' ')
            CALL GETNUM (INLINE, LPLIM, LP, X)
            IF (X.EQ.DBLANK) GO TO 10
            M = X + 0.1
            IF ((M.LT.1) .OR. (M.GT.7)) THEN
               WRITE (MSGTXT,1010) M
               CALL MSGWRT (6)
               GO TO 10
               END IF
            I = INDEX (INLINE, '''')
            IF (I.GT.0) THEN
               K = INDEX (INLINE(I+1:), '''')
               IF (K.EQ.0) THEN
                  K = I + 9
               ELSE
                  K = K + I
                  K = MIN (K, LPLIM)
                  END IF
               CTYPE(M) = INLINE(I+1:K-1)
               END IF
            I = INDEX (INLINE, 'Refval')
            IF (I.GT.0) THEN
               LP = I + 6
               CALL GETNUM (INLINE, LPLIM, LP, X)
               IF (X.EQ.DBLANK) GO TO 10
               CRVAL(1,M) = X
               END IF
            I = INDEX (INLINE, 'Cdelt')
            IF (I.GT.0) THEN
               LP = I + 5
               CALL GETNUM (INLINE, LPLIM, LP, X)
               IF (X.EQ.DBLANK) GO TO 10
               CDELT(M) = X
               END IF
            I = INDEX (INLINE, 'Refpix')
            IF (I.GT.0) THEN
               LP = I + 6
               CALL GETNUM (INLINE, LPLIM, LP, X)
               IF (X.EQ.DBLANK) GO TO 10
               CRPIX(M) = X
               END IF
            I = INDEX (INLINE, 'AvgValue')
            IF (I.GT.0) THEN
               LP = I + 8
               CALL GETNUM (INLINE, LPLIM, LP, X)
               IF (X.EQ.DBLANK) GO TO 10
               CRVAL(2,M) = X
               END IF
            END IF
      ELSE
         LPLIM = JTRIM (INLINE)
         LP = 1
         CALL GETNUM (INLINE, LPLIM, LP, X)
         IF (X.EQ.DBLANK) GO TO 10
         XX(NVAL+1) = X
         CALL GETNUM (INLINE, LPLIM, LP, X)
         IF (X.EQ.DBLANK) GO TO 10
         XV(NVAL+1) = X
         NVAL = NVAL + 1
         END IF
      GO TO 10
C                                       build header
 100  CALL CATINI (CATBLK)
C                                       check header
      JF = 0
      JR = 0
      JD = 0
      JS = 0
      LP = 0
      IF (AXTYPE(:4).EQ.'FREQ') JF = -1
      IF (AXTYPE(:2).EQ.'RA') JR = -1
      IF (AXTYPE(:3).EQ.'DEC') JD = -1
      IF (AXTYPE(:4).EQ.'STOK') JS = -1
      DO 110 I = 1,7
         IF (CTYPE(I).NE.' ') LP = LP + 1
         IF (CTYPE(I)(:4).EQ.'FREQ') JF = I
         IF (CTYPE(I)(:2).EQ.'RA') JR = I
         IF (CTYPE(I)(:3).EQ.'DEC') JD = I
         IF (CTYPE(I)(:4).EQ.'STOK') JS = I
 110     CONTINUE
      IF ((JR.EQ.0) .AND. (LP.LE.6)) THEN
         LP = LP + 1
         CTYPE(LP) = 'RA'
         END IF
      IF ((JD.EQ.0) .AND. (LP.LE.6)) THEN
         LP = LP + 1
         CTYPE(LP) = 'DEC'
         END IF
      IF ((JF.EQ.0) .AND. (LP.LE.6)) THEN
         LP = LP + 1
         CTYPE(LP) = 'FREQ'
         END IF
      IF ((JS.EQ.0) .AND. (LP.LE.6)) THEN
         LP = LP + 1
         CTYPE(LP) = 'STOKES'
         CRVAL(1,LP) = 1.0D0
         END IF
      IF (BUNIT.EQ.' ') BUNIT = 'JY/BEAM'
      IF (SRCNAM.EQ.' ') SRCNAM = 'Source ?'
C                                       build header
      CALL CHR2H (8, BUNIT, 1, CATH(KHBUN))
      CALL CHR2H (8, SRCNAM, 1, CATH(KHOBJ))
      CALL CHR2H (8, OBSDAT, 1, CATH(KHDOB))
      CATD(KDRST) = RESTFR
      CATD(KDARV) = ALTVAL
      CATR(KRARP) = ALTPIX
      CATBLK(KIALT) = ALTCOD
      CATBLK(KIDIM) = 1
      CALL CHR2H (8, AXTYPE, 1, CATH(KHCTP))
      CATBLK(KINAX) = NVAL
      J = 0
      DO 150 I = 1,7
         IF (CTYPE(I).EQ.AXTYPE) THEN
            CATD(KDCRV) = CRVAL(1,I)
            CATR(KRCIC) = CDELT(I)
            CATR(KRCRP) = CRPIX(I)
         ELSE IF (CTYPE(I).NE.' ') THEN
            IF (CRVAL(2,I).NE.0.0D0) CRVAL(1,I) = CRVAL(2,I)
            J = J + 1
            IF (J.LE.6) THEN
               CATBLK(KIDIM) = CATBLK(KIDIM) + 1
               CALL CHR2H (8, CTYPE(I), 1, CATH(KHCTP+2*J))
               IF (CRVAL(1,I).EQ.0.0D0) THEN
                  IF (CTYPE(I).EQ.'FREQ') CRVAL(1,I) = REFREQ*1.D9
                  IF (CTYPE(I)(:2).EQ.'RA') CRVAL(1,I) = 15.0D0 *
     *               (COORD(1) + COORD(2)/60.0D0 + COORD(3)/3600.D0)
                  IF (CTYPE(I)(:3).EQ.'DEC') THEN
                     CRVAL(1,I) = ABS(COORD(4)) + ABS(COORD(2))/6.D1 +
     *                  ABS(COORD(3))/3.6D3
                     IF ((COORD(4).LT.0.) .OR. (COORD(5).LT.0.) .OR.
     *                  (COORD(6).LT.0.)) CRVAL(1,I) = -CRVAL(1,I)
                     END IF
                  END IF
               IF (CTYPE(I).EQ.'FREQ') FREQ0 = CRVAL(1,I)
               IF (CTYPE(I).EQ.'FQID') CRVAL(1,I) = 1.0D0
               IF (CTYPE(I)(:2).EQ.'RA') RA = CRVAL(1,I)
               IF (CTYPE(I)(:3).EQ.'DEC') DEC = CRVAL(1,I)
               CATD(KDCRV+J) = CRVAL(1,I)
               CATR(KRCIC+J) = CDELT(I)
               END IF
            END IF
 150     CONTINUE
      REFREQ = FREQ0 / 1.D9
      CALL COORDD (1, RA, CHM, HM, SEC)
      COORD(1) = HM(1)
      COORD(2) = HM(2)
      COORD(3) = SEC
      CALL COORDD (2, DEC, CHM, HM, SEC)
      COORD(4) = HM(1)
      COORD(5) = HM(2)
      COORD(6) = SEC
      IF (CHM.EQ.'-') THEN
         COORD(4) = -COORD(4)
         IF (COORD(4).EQ.0.) COORD(5) = -COORD(5)
         IF ((COORD(4).EQ.0.) .AND. (COORD(5).EQ.0.)) COORD(6) =
     *      -COORD(6)
         END IF
C
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('READIT ERROR',I4,' ON ',A)
 1010 FORMAT ('READIT BAD AXIS NUMBER',I5)
      END
      SUBROUTINE TX2IMR (IRET)
C-----------------------------------------------------------------------
C   TX2IMR copies data to image file, fixes header for the axis,
C   writes an FQ table if needed
C   Output
c      IRET   I   error code
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   I, LUNO, INDO, NX, NY, WIN(4), BOI, VER, LUN, IFQRNO,
     *   FQKOLS(MAXFQC), FQNUMV(MAXFQC), NUMIF, FQID, IFSIDE, IBIND
      REAL      OUTMAX, OUTMIN, IFCHW, IFTBW
      CHARACTER IFILE*48, BNDCOD*8, CTYPE*8
      LOGICAL   T, F
      DOUBLE PRECISION S, SS, IFFREQ

      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'TX2IM.INC'
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
      CALL ZPHFIL ('MA', DISKOU, NEWCNO, 1, IFILE, IRET)
      LUNO = 18
      CALL ZOPEN (LUNO, INDO, DISKOU, IFILE, T, T, T, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPEN OUPUT IMAGE'
         GO TO 990
      END IF
      NX = NVAL
      NY = 1
      WIN(1) = 1
      WIN(2) = 1
      WIN(3) = NX
      WIN(4) = NY
      OUTMAX = -1.0E30
      OUTMIN = 1.0E30
      BOI = 1
      CALL MINIT ('WRIT', LUNO, INDO, NX, NY, WIN, BUFF1, JBUFSZ, BOI,
     *   IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'INIT I/O TO IMAGE FILE'
         GO TO 990
         END IF
      CALL MDISK ('WRIT', LUNO, INDO, BUFF1, IBIND, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'WRITE TO IMAGE FILE'
         GO TO 990
         END IF
      DO 20 I = 1,NVAL
         IF (XV(I).LT.OUTMIN) OUTMIN = XV(I)
         IF (XV(I).GT.OUTMAX) OUTMAX = XV(I)
         BUFF1(IBIND+I-1) = XV(I)
 20      CONTINUE
      CALL MDISK ('FINI', LUNO, INDO, BUFF1, IBIND, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'FINISH IMAGE FILE'
         GO TO 990
         END IF
      CATR(KRDMN) = OUTMIN
      CATR(KRDMX) = OUTMAX
C                                       study increments
      CALL H2CHR (8, 1, CATH(KHCTP), CTYPE)
      IF (CTYPE.NE.'FQID') THEN
         S = 0.0D0
         SS = 0.0D0
         DO 30 I = 2,NVAL
            S = S + XX(I) - XX(I-1)
            SS = SS + (XX(I)-XX(I-1)) ** 2
 30         CONTINUE
         S = S / (NVAL-1)
         SS = SS / (NVAL-1) - S * S
         SS = SQRT (MAX(0.0D0,SS))
         IF (ABS(SS/S).GT.0.05) THEN
            WRITE (MSGTXT,1030) S, SS
            CALL MSGWRT (5)
            END IF
         CATR(KRCIC) = S
      ELSE
         CATD(KDCRV) = 1.0D0
         VER = 1
         LUN = 20
         NUMIF = 1
         CALL FQINI ('WRIT', SCRTCH, DISKOU, NEWCNO, VER, CATBLK, LUN,
     *      IFQRNO, FQKOLS, FQNUMV, NUMIF, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'CREATE FQ TABLE'
            GO TO 990
         END IF
         IFSIDE = 1
         IFCHW = 0.0
         IFTBW = 0.0
         BNDCOD = ' '
         DO 50 I = 1,NVAL
            IFQRNO = I
            IFFREQ = XX(I) - FREQ0
            FQID = I
            CALL TABFQ ('WRIT', SCRTCH, IFQRNO, FQKOLS, FQNUMV, NUMIF,
     *         FQID, IFFREQ, IFCHW, IFTBW, IFSIDE, BNDCOD, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'WRITING FQ TABLE'
               GO TO 990
               END IF
 50         CONTINUE
C                                       close
         CALL TABFQ ('CLOS', SCRTCH, IFQRNO, FQKOLS, FQNUMV, NUMIF,
     *      FQID, IFFREQ, IFCHW, IFTBW, IFSIDE, BNDCOD, VER)
         END IF
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('TX2IMR ERROR',I4,' ON ',A)
 1030 FORMAT ('AVERAGE INCREMENT',1PE12.4,' RMS LARGE',1PE12.4)
      END
      SUBROUTINE TX2IMH
C-----------------------------------------------------------------------
C     Creates and fills history file
C-----------------------------------------------------------------------
C
      INCLUDE 'TX2IM.INC'
      INTEGER   HLUN, TLUN, TIND, IRET, HBUFF(256), J, JTRIM
      CHARACTER INLINE*128, HILINE*72
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DCAT.INC'
C-----------------------------------------------------------------------
      CALL HIINIT (1)
      HLUN = 27
      CALL HICREA (HLUN, DISKOU, NEWCNO, CATBLK, HBUFF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CREATE HISTORY FILE'
         GO TO 990
      END IF
      J = JTRIM (INFILE)
      HILINE = TSKNAM // 'INFILE=''' // INFILE(:J) // ''''
      CALL HIADD (HLUN, HILINE, HBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      HILINE = TSKNAM // 'AXTYPE=''' // AXTYPE // ''''
      CALL HIADD (HLUN, HILINE, HBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      WRITE (HILINE,1010) TSKNAM, COORD
      CALL HIADD (HLUN, HILINE, HBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      WRITE (HILINE,1015) TSKNAM, REFREQ
      CALL HIADD (HLUN, HILINE, HBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      J = JTRIM (SRCNAM)
      WRITE (HILINE,1020) TSKNAM, SRCNAM(:J)
      CALL HIADD (HLUN, HILINE, HBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      WRITE (HILINE,1025) TSKNAM, OBSDAT
      CALL HIADD (HLUN, HILINE, HBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
C                                       input file info
      HILINE = TSKNAM // '/ Comments found in INFILE'
      CALL HIADD (HLUN, HILINE, HBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      TLUN = 3
      CALL ZTXOPN ('READ', TLUN, TIND, INFILE, .FALSE., IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING INPUT TEXT FILE'
         GO TO 990
         END IF
 10   CALL ZTXIO ('READ', TLUN, TIND, INLINE, IRET)
      IF (IRET.EQ.2) THEN
         CALL ZTXCLS (TLUN, TIND, IRET)
         GO TO 100
      ELSE IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'READING INPUT TEXT FILE'
         GO TO 990
      ELSE IF (INLINE(:1).EQ.'#') THEN
         J = JTRIM (INLINE)
         J = MIN (J, 64)
         HILINE = TSKNAM // '/ ' // INLINE(:J)
         CALL HIADD (HLUN, HILINE, HBUFF, IRET)
         IF (IRET.NE.0) GO TO 980
      END IF
      GO TO 10
C
 100  CALL HICLOS (HLUN, .TRUE., HBUFF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CLOSING HISTORY FILE'
         GO TO 990
      END IF
      GO TO 999
C
 980  WRITE (MSGTXT,1000) IRET, 'WRITING HISTORY FILE'
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('TX2IMH ERROR',I4,' ON ',A)
 1010 FORMAT (A,'COORDINA=',2F4.0,F6.2,2F4.0,F6.2)
 1015 FORMAT (A,'REFREQ=',F10.5,' GHz')
 1020 FORMAT (A,'SRCNAME=''',A,'''')
 1025 FORMAT (A,'REFDATE=''',A,'''')
      END
