LOCAL INCLUDE 'RIFRM.INC'
C                                       Local include for RIFRM
      INCLUDE 'INCS:ZPBUFSZ.INC'
      INCLUDE 'INCS:PUVD.INC'
      INTEGER   NTMAX, NSMAX
      PARAMETER (NTMAX=10000)
      PARAMETER (NSMAX=100)
C
      HOLLERITH XNAMEI(3), XCLAIN(2), XXSOUR(4,30), XINFIL(16,2)
      REAL      XSIN, XDISIN, GAININ, GAINOU, XANT(50)
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XXSOUR, GAININ,
     *   GAINOU, XINFIL, XANT
C
      CHARACTER NAMEIN*12, CLAIN*6, SRCS(30)*16, INFILE*128,
     *   SRCNAM(NSMAX)*16
      INTEGER   SEQIN, DISKIN, CNOIN, CLVIN, CLVOUT, SNUMS(NSMAX),
     *   SCRTCH(512), NTIMES, NFAIL(4), TEVER, SRCBRK(2,NSMAX), NSRCS,
     *   NSORC, NANT, IANT(50)
      LOGICAL   TENEW
      REAL      TIMES(NTMAX), DAZ(NTMAX), DEL(NTMAX), STEC(NTMAX),
     *   VTEC(NTMAX), RMS(NTMAX), SUMRUN, TOTRUN
      COMMON /COPPRM/ SEQIN, DISKIN, CNOIN, CLVIN, CLVOUT, NSORC, SNUMS,
     *   NTIMES, NFAIL, SCRTCH, TIMES, RMS, DAZ, DEL, STEC, VTEC,
     *   TEVER, TENEW, NSRCS, SRCBRK, SUMRUN, TOTRUN, NANT, IANT
      COMMON /CHPARM/ NAMEIN, CLAIN, SRCS, SRCNAM, INFILE
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
LOCAL END
      PROGRAM RIFRM
C-----------------------------------------------------------------------
C! RIFRM reads text file(s) from ALBUS to put IFR, DDelay in CL & TE
C# Spectral UV-util CALIBRATION
C-----------------------------------------------------------------------
C;  Copyright (C) 2024
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   RIFRM reads ALBUS report files and updates a CL and TE table with
C   IFR and Dispersive delay
C   Inputs:
C     AIPS adverb    Prg. name.          Description.
C       INNAME         NAMEIN        Name of input uv data.
C       INCLASS        CLAIN         Class of input uv data.
C       INSEQ          SEQIN         Seq. of input uv data.
C       INDISK         DISKIN        Disk number of input uv data.
C       SOURCES        SRCS          Source names
C       GAINVER        GAININ        Input CL version
C       GAINUSE        GAINOU        Output Cl version
C       ASDMFILE       INFILE        text file name
C-----------------------------------------------------------------------
      CHARACTER PRGM*6, CANT*3
      INTEGER IRET, THEANT, IA, J, I, JTRIM, K
C
      INCLUDE 'RIFRM.INC'
      INCLUDE 'INCS:DFIL.INC'
      DATA PRGM /'RIFRM'/
C-----------------------------------------------------------------------
C                                       Get input parameters
      CALL RIFRMI (PRGM, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Loop over antennas
      J = JTRIM (INFILE)
      DO 50 IA = 1,NANT
         THEANT = IANT(IA)
         CANT = ' '
         IF (THEANT.GT.0) WRITE (CANT,1010) THEANT
C                                       get the data
         NTIMES = 0
         NSRCS = 0
         CALL FILL (2*NSMAX, 0, SRCBRK)
C                                       one input file
         IF (INFILE(J:J).NE.'_') THEN
            INFILE(J+1:) = CANT
            CALL DATGET (INFILE, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READING 1 ALBUS DATA FILE'
               IF (NANT.EQ.1) GO TO 980
               CALL MSGWRT (7)
               GO TO 50
               END IF
            IF ((NTIMES.GT.0) .AND. (NSORC.EQ.1) .AND. (NSRCS.EQ.0))
     *         THEN
               NSRCS = 1
               SRCBRK(1,1) = 1
               SRCBRK(2,1) = SNUMS(1)
               MSGTXT = 'Assuming that these data are for ' //
     *            SRCNAM(1)
               CALL MSGWRT (3)
               END IF
C                                       multiple sources
         ELSE
            DO 40 I = 1,NSORC
               NSRCS = NSRCS + 1
               SRCBRK(1,NSRCS) = NTIMES + 1
               SRCBRK(2,NSRCS) = SNUMS(I)
               INFILE(J+1:) = SRCNAM(I)
               K = JTRIM (INFILE)
               INFILE (K+1:) = CANT
               CALL DATGET (INFILE, IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1000) IRET, 'READING DATA FOR ' //
     *               SRCS(I) // CANT
                  CALL MSGWRT (7)
                  END IF
 40            CONTINUE
            END IF
C                                       now rewrite CL, TE tables
         INFILE(J+1:) = ' '
         IF (TENEW) THEN
            CALL RIFRMA (THEANT, IRET)
            TENEW = .FALSE.
         ELSE
            CALL RIFRMO (THEANT, IRET)
            END IF
         IF (IRET.NE.0) GO TO 990
 50      CONTINUE
C
      CALL RIFRMH
      GO TO 990
C                                       Close down files, etc.
 980  CALL MSGWRT (8)
 990  CALL DIE (IRET, SCRTCH)
C
 999  STOP
C-----------------------------------------------------------------------
 1000 FORMAT ('MAIN ERROR',I4,' ON ',A)
 1010 FORMAT ('_',I2.2)
      END
      SUBROUTINE RIFRMI (PRGN, JERR)
C-----------------------------------------------------------------------
C   RIFRMI gets input parameters, sets the parameters which are used to
C   select data.
C   Inputs:  PRGN    C*6       Program name
C   Output:  JERR    I         Error code: 0 => ok
C                                5 => catalog troubles
C                                6 => too much data to select ch.
C                                8 => can't start
C----------------------------------------------------------------------
      CHARACTER PRGN*6
      INTEGER   JERR
C
      INCLUDE 'RIFRM.INC'
      INTEGER   I, IROUND, NPARM, IERR, J, JTRIM
      CHARACTER STRING*64
      LOGICAL   ISVLBA
      INCLUDE  'RIFRM.INC'
      CHARACTER STAT*4, UTYPE*2
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      JERR = 0
      SUMRUN = 0.0
      TOTRUN = 0.0
C                                       Get input parameters.
      NPARM = 211
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         RQUICK = .TRUE.
         JERR = 8
         IF (IERR.EQ.1) GO TO 999
            WRITE (MSGTXT,1000) IERR, 'GETTING ADVERB VALUES'
            CALL MSGWRT (8)
         END IF
C                                       Restart AIPS
      IF (RQUICK) CALL RELPOP (JERR, SCRTCH, IERR)
      IF (JERR.NE.0) GO TO 999
      JERR = 5
C                                       Hollerith -> char
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      DO 20 I = 1,30
         CALL H2CHR (16, 1, XXSOUR(1,I), SRCS(I))
 20      CONTINUE
      CALL H2CHR (64, 1, XINFIL(1,1), INFILE)
      CALL H2CHR (64, 1, XINFIL(1,2), STRING)
      J = JTRIM (INFILE)
      INFILE(J+1:) = STRING
      J = JTRIM (INFILE)
C                                       Crunch input parameters
      SEQIN = IROUND (XSIN)
      DISKIN = IROUND (XDISIN)
C                                       Get CATBLK from old file.
      CNOIN = 1
      UTYPE = 'UV'
      CALL CATDIR ('SRCH', DISKIN, CNOIN, NAMEIN, CLAIN, SEQIN, UTYPE,
     *   NLUSER, STAT, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1030) IERR, NAMEIN, CLAIN, SEQIN, DISKIN,
     *      NLUSER
         GO TO 990
         END IF
      CALL CATIO ('READ', DISKIN, CNOIN, CATBLK, 'WRIT', SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1000) IERR, 'READING DATA SET HEADER'
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = CNOIN
      FRW(NCFILE) = 1
      CALL H2CHR (8, 1, CATH(KHTEL), STRING)
      ISVLBA = STRING(:4).EQ.'VLBA'
C                                       CL table versions
      CALL FNDEXT ('CL', CATBLK, I)
      CLVIN = GAININ + 0.1
      IF (CLVIN.LE.0) CLVIN = I
      CLVIN = MIN (I, CLVIN)
      CLVOUT = GAINOU + 0.1
      IF ((CLVOUT.LE.I) .AND. (CLVOUT.NE.CLVIN)) CLVOUT = I + 1
      IF (CLVIN.LE.0) THEN
         JERR = 10
         MSGTXT = 'NO CL TABLES FOUND'
         GO TO 990
         END IF
      CALL FNDEXT ('TE', CATBLK, I)
      IF (CLVOUT.EQ.CLVIN) THEN
         TEVER = MAX (1, I)
      ELSE
         TEVER = I + 1
         END IF
      TENEW = TEVER.GT.I
C                                       Source list
      CALL SRCGET (JERR)
      IF (JERR.NE.0) THEN
         WRITE (MSGTXT,1000) JERR, 'FINDING SOURCE NUMBERS'
         GO TO 990
         END IF
      CALL FILL (50, 0, IANT)
      IF (.NOT.ISVLBA) THEN
         NANT = 1
      ELSE
         NANT = 0
         DO 30 I = 1,50
            IANT(I) = XANT(I) + 0.1
            IF (IANT(I).LE.0) GO TO 40
            NANT = NANT + 1
 30         CONTINUE
 40      IF (NANT.EQ.0) THEN
            NANT = 10
            DO 45 I = 1,10
               IANT(I) = I
 45            CONTINUE
            END IF
         END IF
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('RIFRMI: ERROR',I3,' ON ',A)
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',I3,
     *   ' USID=',I5)
      END
      SUBROUTINE SRCGET (IRET)
C-----------------------------------------------------------------------
C   Determines source list
C   Output
C      IRET   I   Error code
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'RIFRM.INC'
      INTEGER   I, J, NS, TABUFF(512), VER, LUN, LUNTMP, NUMIF, ISURNO,
     *   SUKOLS(MAXSUC), SUNUMV(MAXSUC), FREQID, NREC, IDSOU, QUAL, K,
     *   JTRIM
      CHARACTER VELTYP*8, VELDEF*8, SOUNAM*16, CALCOD*8
      REAL      FLUX(4,MAXIF)
      DOUBLE PRECISION FREQO(MAXIF), BANDW, RAEPO, DECEPO, EPOCH, RAAPP,
     *   DECAPP, RAOBS, DECOBS, LSRVEL(MAXIF), LRESTF(MAXIF), PMRA,
     *   PMDEC
C-----------------------------------------------------------------------
C                                       how many sources specified
      NS = 0
      DO 10 I = 1,30
         IF (SRCS(I).EQ.' ') GO TO 20
         NS = NS + 1
 10      CONTINUE
C                                       open source table
 20   LUN = LUNTMP (1)
      VER = 1
      CALL SOUINI ('READ', TABUFF, DISKIN, CNOIN, VER, CATBLK, LUN,
     *   NUMIF, VELTYP, VELDEF, FREQID, ISURNO, SUKOLS, SUNUMV, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING SOURCE TABLE'
         GO TO 990
         END IF
C                                       read source table
      NREC = TABUFF(5)
      NSORC = 0
      DO 50 I = 1,NREC
         ISURNO = I
         CALL TABSOU ('READ', TABUFF, ISURNO, SUKOLS, SUNUMV, IDSOU,
     *      SOUNAM, QUAL, CALCOD, FLUX, FREQO, BANDW, RAEPO, DECEPO,
     *      EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL, LRESTF, PMRA,
     *      PMDEC, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READING SOURCE TABLE'
            GO TO 990
            END IF
C                                       in list?
         IF (NS.GT.0) THEN
            DO 30 J = 1,NS
               IF (SOUNAM.EQ.SRCS(J)) GO TO 40
 30            CONTINUE
            GO TO 50
            END IF
 40      IF (NSORC.GE.NSMAX) THEN
            WRITE (MSGTXT,1040) NSMAX
            CALL MSGWRT (8)
            GO TO 55
            END IF
         NSORC = NSORC + 1
         SNUMS(NSORC) = IDSOU
         K = JTRIM (SOUNAM)
         DO 45 J = 1,K
            IF (SOUNAM(J:J).EQ.' ') SOUNAM(J:J) = '_'
 45         CONTINUE
         SRCNAM(NSORC) = SOUNAM
 50      CONTINUE
C                                       close source table
 55   CALL TABSOU ('CLOS', TABUFF, ISURNO, SUKOLS, SUNUMV, IDSOU,
     *   SOUNAM, QUAL, CALCOD, FLUX, FREQO, BANDW, RAEPO, DECEPO,
     *   EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL, LRESTF, PMRA,
     *   PMDEC, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CLOSING SOURCE TABLE'
         GO TO 990
         END IF
      IF (NSORC.LE.0) THEN
         IRET = 10
         MSGTXT = 'NO SOURCES FOUND'
         GO TO 990
         END IF
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('SRCGET ERROR',I4,' ON ',A)
 1040 FORMAT ('SRCGET SOURCE LIST TERMINATED AFTER',I4,' SOURCES')
      END
      SUBROUTINE DATGET (THEFIL, IRET)
C-----------------------------------------------------------------------
C   Read the ALBUS report file
C   Input
C      THEFIL   C*(*)   ALBUS text file
C   Output
C      IRET     I       Error code
C-----------------------------------------------------------------------
      INTEGER   IRET
      CHARACTER THEFIL*(*)
C
      INTEGER   LUN, FIND, I, J, JTRIM, KBPLIM, KBP, NBAD, IY, IM, ID,
     *   LD(3)
      DOUBLE PRECISION XX, T0
      CHARACTER INLINE*256, DOB*8, STRING*16
      INCLUDE 'RIFRM.INC'
      INCLUDE 'INCS:DHDR.INC'
      DATA LUN /3/
C-----------------------------------------------------------------------
C                                       Open first file
      I = 1
      CALL ZTXOPN ('READ', LUN, FIND, THEFIL, .FALSE., IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPEN ALBUS OUTPUT TEXT FILE'
         GO TO 990
         END IF
C                                       skip head except ref time
 10   CALL ZTXIO ('READ', LUN, FIND, INLINE, IRET)
      IF (IRET.EQ.0) THEN
         KBPLIM = JTRIM (INLINE)
         IF ((KBPLIM.LE.0) .OR. (INLINE(:1).EQ.'#')) GO TO 10
         IF (INLINE(:9).EQ.'reference') THEN
            J = INDEX (INLINE, ',sec')
            IF (J.GT.0) THEN
               KBP = J + 4
               CALL GETNUM (INLINE, KBPLIM, KBP, XX)
               IF (XX.EQ.DBLANK) GO TO 10
               IY = XX + 0.01D0
               CALL GETNUM (INLINE, KBPLIM, KBP, XX)
               IF (XX.EQ.DBLANK) GO TO 10
               IM = XX + 0.01D0
               CALL GETNUM (INLINE, KBPLIM, KBP, XX)
               IF (XX.EQ.DBLANK) GO TO 10
               ID = XX + 0.01D0
               CALL GETNUM (INLINE, KBPLIM, KBP, XX)
               IF (XX.EQ.DBLANK) GO TO 10
               T0 = XX
               CALL GETNUM (INLINE, KBPLIM, KBP, XX)
               IF (XX.EQ.DBLANK) GO TO 10
               T0 = T0 + XX/60.0D0
               CALL GETNUM (INLINE, KBPLIM, KBP, XX)
               IF (XX.EQ.DBLANK) GO TO 10
               T0 = T0 + XX/3600.0D0
               T0 = T0 / 24.0
               END IF
            END IF
         IF (INLINE(:12).EQ.'observation:') THEN
            CALL LASTRN (INLINE, STRING)
            DO 15 I = 1,NSORC
               IF (STRING.EQ.SRCNAM(I)) THEN
                  IF (NSRCS.EQ.NSMAX) THEN
                     WRITE (MSGTXT,1012) NSMAX
                     IRET = 10
                     GO TO 990
                     END IF
                  NSRCS = NSRCS + 1
                  SRCBRK(1,NSRCS) = NTIMES + 1
                  SRCBRK(2,NSRCS) = SNUMS(I)
                  GO TO 10
                  END IF
 15            CONTINUE
            WRITE (MSGTXT,1015) STRING
            CALL MSGWRT (8)
            END IF
         IF (INLINE(:18).EQ.'process_ionosphere') GO TO 25
         IF (INLINE(:3).NE.'seq') GO TO 10
      ELSE
         WRITE (MSGTXT,1000) IRET, 'READING START OF ALBUS OUTPUT FILE'
         IF ((IRET.NE.2) .OR. (NTIMES.LE.0)) GO TO 990
         IRET = 0
         GO TO 30
         END IF
C                                       right day??
      CALL H2CHR (8, 1, CATH(KHDOB), DOB)
      CALL DATEST (DOB, LD)
      IF ((LD(1).NE.IY) .OR. (LD(2).NE.IM) .OR. (LD(3).NE.ID)) THEN
         WRITE (MSGTXT,1010) IY, IM, ID, LD
         IRET = 10
         GO TO 990
         END IF
C                                       read loop
 20   CALL ZTXIO ('READ', LUN, FIND, INLINE, IRET)
      IF (IRET.EQ.0) THEN
         KBPLIM = JTRIM (INLINE)
         IF ((KBPLIM.LE.0) .OR. (INLINE(:1).EQ.'#')) GO TO 10
         NBAD = NBAD + 1
         IF (INLINE(:18).EQ.'process_ionosphere') THEN
            NBAD = NBAD - 1
            GO TO 25
            END IF
         J = INDEX (INLINE,':')
         IF (J.LT.3) GO TO 20
         KBP = J + 1
         CALL GETNUM (INLINE, KBPLIM, KBP, XX)
         IF (XX.EQ.DBLANK) GO TO 20
         CALL GETNUM (INLINE, KBPLIM, KBP, XX)
         IF (XX.EQ.DBLANK) GO TO 20
         TIMES(NTIMES+1) = XX / 86400.0D0 + T0
         CALL GETNUM (INLINE, KBPLIM, KBP, XX)
         IF (XX.EQ.DBLANK) GO TO 20
         CALL GETNUM (INLINE, KBPLIM, KBP, XX)
         IF (XX.EQ.DBLANK) GO TO 20
         DEL(NTIMES+1) = XX
         CALL GETNUM (INLINE, KBPLIM, KBP, XX)
         IF (XX.EQ.DBLANK) GO TO 20
         DAZ(NTIMES+1) = XX
         CALL GETNUM (INLINE, KBPLIM, KBP, XX)
         IF (XX.EQ.DBLANK) GO TO 20
         STEC(NTIMES+1) = XX
         CALL GETNUM (INLINE, KBPLIM, KBP, XX)
         IF (XX.EQ.DBLANK) GO TO 20
         RMS(NTIMES+1) = XX
         CALL GETNUM (INLINE, KBPLIM, KBP, XX)
         IF (XX.EQ.DBLANK) GO TO 20
         VTEC(NTIMES+1) = XX * STEC(NTIMES+1)
         NTIMES = NTIMES + 1
         IF (NTIMES.GT.NTMAX) THEN
            WRITE (MSGTXT,1020) NTMAX
            IRET = 10
            GO TO 990
            END IF
         NBAD = NBAD - 1
         GO TO 20
      ELSE IF (IRET.NE.2) THEN
         WRITE (MSGTXT,1000) IRET, 'READING ALBUS OUTPUT TEXT FILE'
         GO TO 990
         END IF
      GO TO 30
C                                       last text line
 25   J = INDEX (INLINE,'time:')
      KBP = J + 5
      KBPLIM = JTRIM (INLINE)
      CALL GETNUM (INLINE, KBPLIM, KBP, XX)
      IF (XX.NE.DBLANK) THEN
         TOTRUN = XX
         SUMRUN = SUMRUN + XX
         WRITE (MSGTXT,1025) TOTRUN
         CALL MSGWRT (3)
         END IF
C                                       shut down
 30   CALL ZTXCLS (LUN, FIND, I)
      IRET = 0
      WRITE (MSGTXT,1030) NTIMES
      CALL MSGWRT (3)
      WRITE (MSGTXT,1031) NSRCS
      CALL MSGWRT (3)
      WRITE (MSGTXT,1032) NBAD
      CALL MSGWRT (3)
      GO TO 999
C
  990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('GETDAT: ERROR',I4,' ON ',A)
 1010 FORMAT ('TEXT FILE FOR',I5,2I3,'  DATA FROM',I5,2I3,' STOPPING')
 1012 FORMAT ('MAXIMUM NUMBER OF SOURCES',I5,' EXCEEDED')
 1015 FORMAT ('SOURCE ''',A,''' NOT FOUND!')
 1020 FORMAT ('MAXIMUM NUMBER OF SOURCE TIMES',I7,' EXCEEDED')
 1025 FORMAT ('ALBUS total run time',F7.2,' minutes')
 1030 FORMAT ('GETDAT read',I4,' times')
 1031 FORMAT ('GETDAT in  ',I4,' sources')
 1032 FORMAT ('GETDAT',I6,' bad values lines')
      END
      SUBROUTINE LASTRN (INLINE, STRING)
C-----------------------------------------------------------------------
C   returns the last string in an input line (drops ' marks if any)
C   Input:
C      INLINE   C*(*)   Text line to parse
C   Output
C      STRING   C*(*)   last string
C-----------------------------------------------------------------------
      CHARACTER   INLINE*(*), STRING*(*)
C
      INTEGER   I, J, JTRIM, I1, I2
C-----------------------------------------------------------------------
      STRING = ' '
      J = JTRIM (INLINE)
      DO 10 I = J,1,-1
         IF ((INLINE(I:I).EQ.' ') .OR. (I.EQ.1)) THEN
            I1 = I + 1
            IF (I.EQ.1) I1 = 1
            IF (INLINE(I1:I1).EQ.'''') THEN
               I1 = I1 + 1
            ELSE IF (INLINE(I1:I1).EQ.'"') THEN
               I1 = I1 + 1
               END IF
            I2 = J
            IF (INLINE(I2:I2).EQ.'''') THEN
               I2 = I2 - 1
            ELSE IF (INLINE(I2:I2).EQ.'"') THEN
               I2 = I2 - 1
               END IF
            STRING = INLINE(I1:I2)
            GO TO 999
            END IF
 10      CONTINUE
C
 999  RETURN
      END
      SUBROUTINE RIFRMA (THEANT, IRET)
C-----------------------------------------------------------------------
C   Reads the input text file(s), copies the CL & TE table
C   Inputs:
C      THEANT   I       Data set antenna number, 0 -> all
C   Inputs (common)
C      DISKIN   I       Data set disk
C      CNOIN    I       Data set catalog number
C      THESRC   I       Data set source number
C      TEVOUT   I       Data set TE version number
C      CLVIN    I       Data set CL input version number
C      CLVOUT   I       Data set CL output version number
C      INFILE   C*(*)   ALBUS output data file
C   Output:
C      IRET   I         Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   THEANT, IRET
C
      INCLUDE 'RIFRM.INC'
      INTEGER   INBUFF(512), OUBUFF(512), LUNI, LUNO, ICLRNO, NUMANT,
     *   CLKOLS(MAXCLC), CLNUMV(MAXCLC), NUMPOL, NUMIF, NTERM, SOURID,
     *   ANTNO, SUBA, FREQID, REFA(2,MAXIF), NREC, I, ITERNO, TUNO,
     *   TEKOLS(16), TENUMV(16), OUTUFF(512)
      REAL      GMMOD, TIMEI, IFR, DOPOFF(MAXIF), ATMOS, DATMOS,
     *   MBDELY(2), CLOCK(2), DCLOCK(2), DISP(2), DDISP(2),
     *   CREAL(2,MAXIF), CIMAG(2,MAXIF), DELAY(2,MAXIF), RATE(2,MAXIF),
     *   WEIGHT(2,MAXIF), TEDATA(16)
      DOUBLE PRECISION TIME, GEODLY(MAXIF)
      CHARACTER  RDATE*8, TECTYP*8
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DMSG.INC'
      DATA LUNI, LUNO, TUNO /16, 17, 19/
C-----------------------------------------------------------------------
      TECTYP = 'ALBUS'
      CALL H2CHR (8, 1, CATH(KHDOB), RDATE)
C                                       Output new TE table
      CALL TEINI ('WRIT', OUTUFF, DISKIN, CNOIN, TEVER, CATBLK, TUNO,
     *   ITERNO, TEKOLS, TENUMV, RDATE, TECTYP, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING NEW OUTPUT TE TABLE'
         GO TO 990
         END IF
C                                       input CL table
      CALL CALINI ('READ', INBUFF, DISKIN, CNOIN, CLVIN, CATBLK, LUNI,
     *   ICLRNO, CLKOLS, CLNUMV, NUMANT, NUMPOL, NUMIF, NTERM, GMMOD,
     *   IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING INPUT CL TABLE'
         GO TO 990
         END IF
C                                       Output CL table
      CALL CALINI ('WRIT', OUBUFF, DISKIN, CNOIN, CLVOUT, CATBLK, LUNO,
     *   ICLRNO, CLKOLS, CLNUMV, NUMANT, NUMPOL, NUMIF, NTERM, GMMOD,
     *   IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING OUTPUT CL TABLE'
         GO TO 990
         END IF
      WRITE (MSGTXT,1010) 'Reading CL', CLVIN
      CALL MSGWRT (3)
      WRITE (MSGTXT,1010) 'Writing CL', CLVOUT
      CALL MSGWRT (3)
      WRITE (MSGTXT,1010) 'Creating TE', TEVER
      CALL MSGWRT (3)
C                                       read loop
      NREC = INBUFF(5)
      DO 20 I = 1,NREC
         ICLRNO = I
         CALL TABCAL ('READ', INBUFF, ICLRNO, CLKOLS, CLNUMV, NUMPOL,
     *      NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR,
     *      GEODLY, DOPOFF, ATMOS, DATMOS, MBDELY, CLOCK, DCLOCK, DISP,
     *      DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READING INPUT CL TABLE'
            GO TO 990
            END IF
C                                      get new IFR
         IF ((THEANT.EQ.0) .OR. (ANTNO.EQ.THEANT)) CALL IFRGET (TIME,
     *      SOURID, IFR, DISP, TEDATA)
         ICLRNO = I
         CALL TABCAL ('WRIT', OUBUFF, ICLRNO, CLKOLS, CLNUMV, NUMPOL,
     *      NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR,
     *      GEODLY, DOPOFF, ATMOS, DATMOS, MBDELY, CLOCK, DCLOCK, DISP,
     *      DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING OUTPUT CL TABLE'
            GO TO 990
            END IF
         ITERNO = I
         CALL TABTE ('WRIT', OUTUFF, ITERNO, TEKOLS, TENUMV, TIME,
     *      SOURID, ANTNO, TEDATA(1), TEDATA(2), TEDATA(3), TEDATA(4),
     *      TEDATA(5), TEDATA(6), TEDATA(7), TEDATA(8), TEDATA(11),
     *      TEDATA(12), TEDATA(13), TEDATA(14), TEDATA(15), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING OUTPUT TE TABLE'
            GO TO 990
            END IF
 20      CONTINUE
C                                       close
      ICLRNO = NREC
      CALL TABCAL ('CLOS', OUBUFF, ICLRNO, CLKOLS, CLNUMV, NUMPOL,
     *   NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR,
     *   GEODLY, DOPOFF, ATMOS, DATMOS, MBDELY, CLOCK, DCLOCK, DISP,
     *   DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CLOSING OUTPUT CL TABLE'
         GO TO 990
         END IF
      ICLRNO = NREC
      CALL TABCAL ('CLOS', INBUFF, ICLRNO, CLKOLS, CLNUMV, NUMPOL,
     *   NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR,
     *   GEODLY, DOPOFF, ATMOS, DATMOS, MBDELY, CLOCK, DCLOCK, DISP,
     *   DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CLOSING INPUT CL TABLE'
         GO TO 990
         END IF
      CALL TABTE ('CLOS', OUTUFF, ITERNO, TEKOLS, TENUMV, TIME,
     *   SOURID, ANTNO, TEDATA(1), TEDATA(2), TEDATA(3), TEDATA(4),
     *   TEDATA(5), TEDATA(6), TEDATA(7), TEDATA(8), TEDATA(11),
     *   TEDATA(12), TEDATA(13), TEDATA(14), TEDATA(15), IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CLOSING OUTPUT TE TABLE'
         GO TO 990
         END IF
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('RIFMRA: ERROR',I4,' ON ',A)
 1010 FORMAT ('RIFRMA: ',A,' table version',I4)
      END
      SUBROUTINE RIFRMO (THEANT, IRET)
C-----------------------------------------------------------------------
C   Reads the input text file(s), copies the CL & TE table
C   TE file exists, CL version in same as out
C      THEANT   I       Data set antenna number, 0 -> all
C   Inputs (common)
C      DISKIN   I       Data set disk
C      CNOIN    I       Data set catalog number
C      TEVER    I       Data set TE version number
C      CLVOUT   I       Data set CL output version number
C   Output:
C      IRET   I    Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   THEANT, IRET
C
      INCLUDE 'RIFRM.INC'
      INTEGER   INBUFF(512), OUBUFF(512), LUNI, LUNO, ICLRNO, NUMANT,
     *   CLKOLS(MAXCLC), CLNUMV(MAXCLC), NUMPOL, NUMIF, NTERM, SOURID,
     *   ANTNO, SUBA, FREQID, REFA(2,MAXIF), NREC, I, ITERNO, TUNO,
     *   TEKOLS(16), TENUMV(16), OUTUFF(512), TUNI, INTUFF(512)
      REAL      GMMOD, TIMEI, IFR, DOPOFF(MAXIF), ATMOS, DATMOS,
     *   MBDELY(2), CLOCK(2), DCLOCK(2), DISP(2), DDISP(2),
     *   CREAL(2,MAXIF), CIMAG(2,MAXIF), DELAY(2,MAXIF), RATE(2,MAXIF),
     *   WEIGHT(2,MAXIF), TEDATA(16)
      DOUBLE PRECISION TIME, GEODLY(MAXIF)
      CHARACTER  RDATE*8, TECTYP*8
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DMSG.INC'
      DATA LUNI, LUNO, TUNI, TUNO /16, 17, 18, 19/
C-----------------------------------------------------------------------
C                                       input CL table
      CALL CALINI ('READ', INBUFF, DISKIN, CNOIN, CLVOUT, CATBLK, LUNI,
     *   ICLRNO, CLKOLS, CLNUMV, NUMANT, NUMPOL, NUMIF, NTERM, GMMOD,
     *   IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING CL TABLE AS INPUT'
         GO TO 990
         END IF
C                                       Output CL table
      CALL CALINI ('WRIT', OUBUFF, DISKIN, CNOIN, CLVOUT, CATBLK, LUNO,
     *   ICLRNO, CLKOLS, CLNUMV, NUMANT, NUMPOL, NUMIF, NTERM, GMMOD,
     *   IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING CL TABLE AS OUTPUT'
         GO TO 990
         END IF
      WRITE (MSGTXT,1010) 'Modifying CL', CLVOUT
      CALL MSGWRT (3)
C                                       read loop
      NREC = INBUFF(5)
      DO 20 I = 1,NREC
         ICLRNO = I
         CALL TABCAL ('READ', INBUFF, ICLRNO, CLKOLS, CLNUMV, NUMPOL,
     *      NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR,
     *      GEODLY, DOPOFF, ATMOS, DATMOS, MBDELY, CLOCK, DCLOCK, DISP,
     *      DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READING INPUT CL TABLE'
            GO TO 990
            END IF
C                                       get new IFR
         IF ((THEANT.EQ.0) .OR. (ANTNO.EQ.THEANT)) CALL IFRGET (TIME,
     *      SOURID, IFR, DISP, TEDATA)
         ICLRNO = I
         CALL TABCAL ('WRIT', OUBUFF, ICLRNO, CLKOLS, CLNUMV, NUMPOL,
     *      NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR,
     *      GEODLY, DOPOFF, ATMOS, DATMOS, MBDELY, CLOCK, DCLOCK, DISP,
     *      DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING OUTPUT CL TABLE'
            GO TO 990
            END IF
 20      CONTINUE
C                                       close
      ICLRNO = NREC
      CALL TABCAL ('CLOS', OUBUFF, ICLRNO, CLKOLS, CLNUMV, NUMPOL,
     *   NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR,
     *   GEODLY, DOPOFF, ATMOS, DATMOS, MBDELY, CLOCK, DCLOCK, DISP,
     *   DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CLOSING OUTPUT CL TABLE'
         GO TO 990
         END IF
      ICLRNO = NREC
      CALL TABCAL ('CLOS', INBUFF, ICLRNO, CLKOLS, CLNUMV, NUMPOL,
     *   NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR,
     *   GEODLY, DOPOFF, ATMOS, DATMOS, MBDELY, CLOCK, DCLOCK, DISP,
     *   DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CLOSING INPUT CL TABLE'
         GO TO 990
         END IF
C                                       Input TE table
      CALL TEINI ('READ', INTUFF, DISKIN, CNOIN, TEVER, CATBLK, TUNI,
     *   ITERNO, TEKOLS, TENUMV, RDATE, TECTYP, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING TE TABLE AS INPUT'
         GO TO 990
         END IF
C                                       Output same TE table
      TECTYP = 'ALBUS'
      CALL TEINI ('WRIT', OUTUFF, DISKIN, CNOIN, TEVER, CATBLK, TUNO,
     *   ITERNO, TEKOLS, TENUMV, RDATE, TECTYP, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING TE TABLE AS OUTPUT'
         GO TO 990
         END IF
      NREC = INTUFF(5)
      WRITE (MSGTXT,1010) 'Modifying TE', TEVER
      CALL MSGWRT (3)
      DO 120 I = 1,NREC
         ITERNO = I
         CALL TABTE ('READ', INTUFF, ITERNO, TEKOLS, TENUMV, TIME,
     *      SOURID, ANTNO, TEDATA(1), TEDATA(2), TEDATA(3), TEDATA(4),
     *      TEDATA(5), TEDATA(6), TEDATA(7), TEDATA(8), TEDATA(11),
     *      TEDATA(12), TEDATA(13), TEDATA(14), TEDATA(15), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'READING TE TABLE'
            GO TO 990
            END IF
C                                       get new IFR
         IF ((THEANT.EQ.0) .OR. (ANTNO.EQ.THEANT)) CALL IFRGET (TIME,
     *      SOURID, IFR, DISP, TEDATA)
         ITERNO = I
         CALL TABTE ('WRIT', OUTUFF, ITERNO, TEKOLS, TENUMV, TIME,
     *      SOURID, ANTNO, TEDATA(1), TEDATA(2), TEDATA(3), TEDATA(4),
     *      TEDATA(5), TEDATA(6), TEDATA(7), TEDATA(8), TEDATA(11),
     *      TEDATA(12), TEDATA(13), TEDATA(14), TEDATA(15), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING TE TABLE'
            GO TO 990
            END IF
 120     CONTINUE
      CALL TABTE ('CLOS', INTUFF, ITERNO, TEKOLS, TENUMV, TIME,
     *   SOURID, ANTNO, TEDATA(1), TEDATA(2), TEDATA(3), TEDATA(4),
     *   TEDATA(5), TEDATA(6), TEDATA(7), TEDATA(8), TEDATA(11),
     *   TEDATA(12), TEDATA(13), TEDATA(14), TEDATA(15), IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CLOSING INPUT TE TABLE'
         GO TO 990
         END IF
      CALL TABTE ('CLOS', OUTUFF, ITERNO, TEKOLS, TENUMV, TIME,
     *   SOURID, ANTNO, TEDATA(1), TEDATA(2), TEDATA(3), TEDATA(4),
     *   TEDATA(5), TEDATA(6), TEDATA(7), TEDATA(8), TEDATA(11),
     *   TEDATA(12), TEDATA(13), TEDATA(14), TEDATA(15), IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CLOSING OUTPUT TE TABLE'
         GO TO 990
         END IF
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('RIFMRO: ERROR',I4,' ON ',A)
 1010 FORMAT ('RIFRMO: ',A,' table version',I4)
      END
      SUBROUTINE IFRGET (TIME, SOURID, IFR, DISP, TEDATA)
C-----------------------------------------------------------------------
C   IFRGET gets the IFR, DISP, TE values from the tables
C   Inputs
C      SOURID   I      The current source
C      TIME     D      time (days)
C   In/out
C      IFR      R      Ionospheric Faraday rotation radians/m/m
C                      from table or unchanged if fail to find
C      DISP     R(2)   Dispersive delay
C      TEDATA   R(16)  HA, AZ, ZA, AZION, ZAION, DLON, DLAT, B(3),
C                      TEPATH, MAG, TEC, IFR, DISP(2)
C   Common
C-----------------------------------------------------------------------
      DOUBLE PRECISION TIME
      INTEGER   SOURID
      REAL      IFR, DISP(2), TEDATA(16)
C
      INCLUDE 'RIFRM.INC'
      INTEGER   I, LT, LS, LT1, LT2
      REAL      PT, TSC
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:PSTD.INC'
      SAVE LT, PT, LS, LT1, LT2
      DATA LT, PT, LS, LT1, LT2 /1, 0.0, 3*0/
C------------------------------------------------------------------------
      IF (TENEW) CALL RFILL (16, FBLANK, TEDATA)
      IF (SOURID.NE.LS) THEN
         DO 10 I = 1,NSRCS
            IF (SOURID.EQ.SRCBRK(2,I)) THEN
               LT1 = SRCBRK(1,I)
               IF (I.LT.NSRCS) THEN
                  LT2 = SRCBRK(1,I+1)
               ELSE
                  LT2 = NTIMES
                  END IF
               LT = 1
               PT = 0.0
               LS = SOURID
               GO TO 30
               END IF
 10         CONTINUE
         GO TO 999
         END IF
C                                       Find time
 30   IF (TIME.LT.PT) LT = LT1
      DO 40 I = LT1,LT2-1
         IF ((TIME.GE.TIMES(I)) .AND. (TIME.LE.TIMES(I+1))) THEN
            LT = I
            PT = TIMES(I)
            GO TO 50
            END IF
 40      CONTINUE
      PT = 0.0
      LT = LT1
      GO TO 999
C                                       interpolate
 50   IF ((RMS(I).EQ.FBLANK) .OR. (RMS(I+1).EQ.FBLANK)) THEN
         IFR = FBLANK
      ELSE
         TSC = (TIME-TIMES(I)) / (TIMES(I+1)-TIMES(I))
         IFR = TSC * (RMS(I+1) - RMS(I)) + RMS(I)
         TEDATA(2) = TSC * (DAZ(I+1)-DAZ(I)) + DAZ(I)
         TEDATA(3) = TSC * (DEL(I+1)-DEL(I)) + DEL(I)
         TEDATA(3) = 90.0 - TEDATA(3)
         TEDATA(11) = TSC * (STEC(I+1)-STEC(I)) + STEC(I)
         TEDATA(13) = TSC * (VTEC(I+1)-VTEC(I)) + VTEC(I)
         TEDATA(14) = IFR
         TEDATA(15) = 40.28 * TEDATA(11) / (VELITE ** 3) * 1.E16
         TEDATA(16) = TEDATA(15)
         END IF
C
 999  RETURN
      END
      SUBROUTINE RIFRMH
C-----------------------------------------------------------------------
C   RIFRMH adds history to the data set
C-----------------------------------------------------------------------
      INCLUDE 'RIFRM.INC'
      INTEGER   IRET, LUN, TIME(3), DATE(3), I, I1, I2, J, JTRIM
      CHARACTER HILINE*72, CTIME(2)*12, CDUM*10
      DATA LUN /27/
C-----------------------------------------------------------------------
      CALL HIINIT (3)
      CALL HIOPEN (LUN, DISKIN, CNOIN, SCRTCH, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CREATE HI FILE'
         GO TO 990
         END IF
C                                       Task message
      CALL ZDATE (DATE)
      CALL ZTIME (TIME)
      CALL TIMDAT (TIME, DATE, CTIME(2), CTIME)
      WRITE (HILINE,2000) TSKNAM, RLSNAM, CTIME
      CALL HIADD (LUN, HILINE, SCRTCH, IRET)
      IF (IRET.NE.0) GO TO 900
C                                       sources
      CDUM = 'SOURCES ='
      I2 = 0
 10   I1 = I2 + 1
      I2 = MIN (NSORC,I1+2)
      IF (I1.LE.NSORC) THEN
         WRITE (HILINE,2010) TSKNAM, CDUM, (SRCNAM(I), I = I1,I2)
         IF ((I2.EQ.NSORC) .AND. (I2-I1.LT.2)) THEN
            I = JTRIM (HILINE)
            HILINE(I:) = ' '
            END IF
         CALL HIADD (LUN, HILINE, SCRTCH, IRET)
         IF (IRET.NE.0) GO TO 900
         CDUM = ' '
         GO TO 10
         END IF
C                                       CL/TE versions
      WRITE (HILINE,2025) TSKNAM, 'GAINVER', CLVIN, 'input CL'
      CALL HIADD (LUN, HILINE, SCRTCH, IRET)
      IF (IRET.NE.0) GO TO 900
      WRITE (HILINE,2025) TSKNAM, 'GAINUSE', CLVOUT, 'output CL'
      CALL HIADD (LUN, HILINE, SCRTCH, IRET)
      IF (IRET.NE.0) GO TO 900
      WRITE (HILINE,2025) TSKNAM, 'TEVER', TEVER, 'output TE'
      CALL HIADD (LUN, HILINE, SCRTCH, IRET)
      IF (IRET.NE.0) GO TO 900
C                                       input file
      J = JTRIM (INFILE)
      IF (INFILE(J:J).EQ.'_') THEN
         HILINE = TSKNAM // '/ multiple source reports read'
      ELSE
         HILINE = TSKNAM // '/ all sources use the same report'
         END IF
      CALL HIADD (LUN, HILINE, SCRTCH, IRET)
      IF (IRET.NE.0) GO TO 900
      I = MIN (J, 54)
      HILINE = TSKNAM // '/ ASDMFILE=''' // INFILE(:I)
      IF (I.LT.54) THEN
         I = I + J
         HILINE(I+1:) = ''''
         CALL HIADD (LUN, HILINE, SCRTCH, IRET)
         IF (IRET.NE.0) GO TO 900
      ELSE
         CALL HIADD (LUN, HILINE, SCRTCH, IRET)
         IF (IRET.NE.0) GO TO 900
         I1 = MIN (118, J)
         HILINE = TSKNAM // '/ ' // INFILE(I+1:I1)
         I1 = JTRIM (HILINE)
         IF (I1.LT.72) THEN
            HILINE (I1+1:) = ''''
            CALL HIADD (LUN, HILINE, SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 900
         ELSE
            CALL HIADD (LUN, HILINE, SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 900
            HILINE = TSKNAM // '/ ' // INFILE(I1+1:J) // ''''
            CALL HIADD (LUN, HILINE, SCRTCH, IRET)
            IF (IRET.NE.0) GO TO 900
            END IF
         END IF
      WRITE (HILINE,2050) TSKNAM, SUMRUN
      CALL HIADD (LUN, HILINE, SCRTCH, IRET)
      IF (IRET.NE.0) GO TO 900
C
      CALL HICLOS (LUN, .TRUE., SCRTCH, I)
      GO TO 999
C
 900  CALL HICLOS (LUN, .TRUE., SCRTCH, I)
      WRITE (MSGTXT,1000) IRET, 'WRITING HISTORY FILE'
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('RIFRMH ERROR',I4,' ON ',A)
 2000 FORMAT (A6,'RELEASE   =''',A7,' ''  /******* Start ',A12,2X,A8)
 2010 FORMAT (A6,A9,3(' ''',A,''''))
 2025 FORMAT (A6,A,' =',I4,5X,'/ ',A,' table version')
 2050 FORMAT (A6,'/ ALBUS reported sum run time',F8.2,' minutes')
      END
