      program RDHIS
c               M A SWEENEY 24 JULY 1986
c            RAShafer 22 Oct 1986
c       PROGRAM TO READ COMPLETE INFORMATION FROM 
c       A SF HISTORY FILE.

      IMPLICIT NONE

      INCLUDE '../inc/writebuf.inc'

      INTEGER iparse,nret,iflag,ierr
      INTEGER infoar(4),nsubs,ierrsf,iunit,ounit
      INTEGER i,j,k,m,n,ij,ik,jk,itri,ntri
      INTEGER index,lenbuf,nhist,lenact,nstrd
      INTEGER len,nspar

      CHARACTER*80 header,tmplte,string
      CHARACTER*12 pkgtyp
      CHARACTER*30 hisfile,outfile

      LOGICAL qdone

c For processing the main structures

      INTEGER MAXSIZE, MAXSZE4, MAXSZE8
      PARAMETER (MAXSIZE=256, MAXSZE4=64)
      CHARACTER cbuf*(MAXSIZE)
      REAL rbuf(MAXSZE4)
      INTEGER ibuf(MAXSZE4)
      EQUIVALENCE (ibuf,rbuf,cbuf)

c and the sub-structures

      INTEGER NSBUF, NSBUF4
      PARAMETER (NSBUF=200, NSBUF4=50)
      CHARACTER csbuf*(NSBUF)
      INTEGER isbuf(NSBUF4)
      REAL rsbuf(NSBUF4)
      LOGICAL qsbuf(NSBUF4)
      EQUIVALENCE (isbuf, rsbuf, qsbuf, csbuf)

      INTEGER NSBF2, NSBF24
      PARAMETER (NSBF2=200, NSBF24=50)
      CHARACTER csbf2*(NSBF2)
      REAL rsbf2(NSBF24)
      EQUIVALENCE (rsbf2, csbf2)

c Get the history filename to be read and any output filename

      CALL xinird('<history file> [<output file>]:',string,iparse)
      if(iparse.ne.0)goto 9000
      CALL xgtstr(string,iparse,1,'history file',1,hisfile,
     &                nret,iflag,-1)
      outfile='none'
      CALL xgtstr(string,iparse,1,'output file',1,outfile,
     &                nret,iflag,-1)

c Open the history file and if an output file has been specified
c then open it as a logfile.

      CALL xtend(hisfile,'xhs')
      CALL getlun(iunit)
      ierrsf=0
      CALL opnrsf(hisfile,iunit,'XSPEC histry',header,tmplte,nhist,
     &            ierrsf)
      IF (ierrsf.ne.0)goto 9000
      IF(outfile.ne.'none')then
         CALL xtend(outfile,'log')
         CALL getlun(ounit)
         CALL xopnlg(outfile,.false.,' RDHIS ',.true.,ounit,ierr)
         IF(ierr.ne.0)goto 9000
      ENDIF
      call xchaty(25, 25)

c Write out the header

      write(wrtstr,*)'History file header:',header(27:47)
     &        //' '//header(49:57)
      CALL xwrite(wrtstr,5)

c Write out the history file history records

      IF (nhist .NE. 0) THEN
         WRITE(wrtstr,*)'   File history:'
         CALL xwrite(wrtstr,5)
         lenbuf=maxsize
         CALL ptxtsf(iunit,nhist,cbuf,lenbuf)
      ENDIF

c Read the first package in the history file

      ierrsf=0
      lenbuf=maxsize
      pkgtyp=' '
      index=0
      nsubs=0
      CALL nxpksf(iunit,pkgtyp,index,nsubs,infoar,cbuf,lenbuf,
     &            .false.,ierrsf)
      qdone=ierrsf.eq.7

c Loop round the packages in the history file till done

      DO WHILE( .NOT.qdone )

	wrtstr=' '
	call xwrite(wrtstr,5)
	write(wrtstr,'(3a)')' ***** Package "',pkgtyp,
     &	 '" *****'
	call xwrite(wrtstr,5)

c If package is data file info

         IF(pkgtyp.eq.'data files  ')then

            DO i=1,nsubs
               nstrd=1
               CALL rstrsf(iunit,csbuf,1,nstrd,ierrsf)
               WRITE(wrtstr,'(a,i4,a,i4)')
     &           ' Group number',isbuf(1),
     &           '   Total no. of PHA chans.',isbuf(2)
               CALL xwrite(wrtstr,5)
               WRITE(wrtstr,'(a,i4)')
     &           ' Total no. of Bins',isbuf(3)
               CALL xwrite(wrtstr,5)
               WRITE(wrtstr,'(2a)')
     &          ' Data file name: ',
     &          csbuf(17:lenact(csbuf))
               CALL xwrite(wrtstr,5)
            ENDDO

c If package is associated file info

         ELSEIF(pkgtyp.eq.'assoc files ')then

            DO j=1,nsubs
               nstrd=1
               CALL rstrsf(iunit,csbuf,1,nstrd,ierrsf)
               WRITE(wrtstr,'(a,i4,a,a1)')
     &           ' Data file index',isbuf(1),
     &           ' File type ',csbuf(5:5)
               CALL xwrite(wrtstr,5)
               WRITE(wrtstr,'(a,a)')' Assoc. file name: ',
     &           csbuf(6:lenact(csbuf))
               CALL xwrite(wrtstr,5)
            ENDDO

c If package is channel info

         ELSEIF(pkgtyp.eq.'channels    ')then

            WRITE(wrtstr,'(a,i5)')
     &          ' Number of bins before ignore commands: ', ibuf(1)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a)')
     & ' Number of bins, channels per bin, startchannel, start file bin'
            CALL xwrite(wrtstr,5)
            len=16
            DO WHILE (len .NE. 0)
               CALL rsubsf(iunit,csbuf,len,ierrsf)
               IF(len.gt.0)then
                  WRITE(wrtstr,'(5x,i6,3(9x,i6))')
     &               isbuf(1),isbuf(2),
     &               isbuf(3),isbuf(4)
                  CALL xwrite(wrtstr,5)
               ENDIF
            ENDDO

c If package is grouping info

         ELSEIF(pkgtyp.eq.'grouping    ')then

            WRITE(wrtstr,'(a,1x,5(2x,5a1,1x,5a1))')
     &           '  Channel grouping =',
     &           (cbuf(i:i),i=1,lenbuf)
            CALL xwrite(wrtstr,5)

c If package is model info

         ELSEIF(pkgtyp.eq.'model       ')then

            len=28
            DO k=1,nsubs
               CALL rsubsf(iunit,csbuf,len,ierrsf)
               WRITE(wrtstr,'(a,i4,2a)')' Data group no. ',
     &               isbuf(1),' Model name: ',csbuf(21:28)
               CALL xwrite(wrtstr,5)
               WRITE(wrtstr,'(a,i4)')
     &               ' Model group no.',isbuf(2)
               CALL xwrite(wrtstr,5)
               WRITE(wrtstr,'(a,i4)')
     &                ' Component no.  ',isbuf(3)
               CALL xwrite(wrtstr,5)
            ENDDO

c If package is parameter definition

         ELSEIF(pkgtyp.eq.'param def   ')then

            len=28
            DO m=1,nsubs
               CALL rsubsf(iunit,csbuf,len,ierrsf)
               WRITE(wrtstr,'(a,i3,a,a8)')
     &           ' Fit parameter no',isbuf(3),' : ',
     &           csbuf(21:28)
               CALL xwrite(wrtstr,5)
               WRITE(wrtstr,'(10x,a,i4,a,i4)')
     &           ' Model parameter no.',isbuf(2),
     &           ' Model Index',isbuf(1)
               CALL xwrite(wrtstr,5)
            ENDDO

c If package is parameter ranges

         ELSEIF(pkgtyp.eq.'param range ')then

            len=28
            DO n=1,nsubs
               CALL rsubsf(iunit,csbuf,len,ierrsf)
               WRITE(wrtstr,'(a,i4,a,g15.5)')
     &           ' Fit parameter index',isbuf(1),
     &           ' Initial value',rsbuf(2)
               CALL xwrite(wrtstr,5)
               WRITE(wrtstr,'(a,g15.5)')
     &           ' Step size',rsbuf(3)
               CALL xwrite(wrtstr,5)
               WRITE(wrtstr,'(a,2(2x,g15.5))')
     &            ' Hard and Soft lower limits',
     &            rsbuf(4),rsbuf(5)
               CALL xwrite(wrtstr,5)
               WRITE(wrtstr,'(a,2(2x,g15.5))')
     &            ' Soft and Hard upper limits',
     &            rsbuf(6),rsbuf(7)
               CALL xwrite(wrtstr,5)
            ENDDO

c If package is fit info

         ELSEIF(pkgtyp.eq.'fit         ')then

            WRITE(wrtstr,'(a,i4)')
     &         ' Error flag value at conclusion of fit', ibuf(1)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,g14.6)')
     &         ' Final chi-squared value', rbuf(2)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,g14.6)')
     &         ' Function value', rbuf(3)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,g14.6)')
     &         ' Function value', rbuf(4)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,g14.6)')
     &         ' Function value', rbuf(5)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,i4)')
     &         ' Number of fit parameters', ibuf(6)
            CALL xwrite(wrtstr,5)
            len=4*ibuf(6)
            CALL rsubsf(iunit,csbuf,len,ierrsf)
            CALL rsubsf(iunit,csbf2,len,ierrsf)
            DO ij=1,ibuf(6)
               WRITE(wrtstr,'(a,i3,a,g14.6,a,g14.6)')
     &           ' Parameter',ij,' = ',rsbuf(ij),' +- ',
     &           rsbf2(ij)
               CALL xwrite(wrtstr,5)
            ENDDO

c If package is observed spectrum

         ELSEIF(pkgtyp.eq.'spectrum    ')then

            WRITE(wrtstr,'(a,i4)')' Total number of bins =', ibuf(1)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(14x,2a)') cbuf(5:28), cbuf(29:52)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(34x,a)')'observed     error        model'
            CALL xwrite(wrtstr,5)
            len=20
            DO ij=1,ibuf(1)
               CALL rsubsf(iunit,csbuf,len,ierrsf)
               WRITE(wrtstr,'(i5,1x,2(g10.4,a),3g13.4)')ij,
     &              rsbuf(1),' - ',rsbuf(2),': ',rsbuf(3),
     &              rsbuf(4),rsbuf(5)
               CALL xwrite(wrtstr,5)
            ENDDO

c If package is unfolded spectrum

         ELSEIF(pkgtyp.eq.'ufspec    ')then

            WRITE(wrtstr,'(a,i4)')' Total number of bins =', ibuf(1)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(14x,2a)') cbuf(5:28), cbuf(29:52)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(34x,a)')'unfolded     error'
            CALL xwrite(wrtstr,5)
            len=16
            DO ij=1,ibuf(1)
               CALL rsubsf(iunit,csbuf,len,ierrsf)
               WRITE(wrtstr,'(i5,1x,2(g10.4,a),2g13.4)')ij,
     &              rsbuf(1),' - ',rsbuf(2),': ',rsbuf(3),
     &              rsbuf(4)
               CALL xwrite(wrtstr,5)
            ENDDO

c If package is model spectrum

         ELSEIF(pkgtyp.eq.'photon    ')then

            WRITE(wrtstr,'(a,i6)')
     &         ' Total number of energy ranges =', ibuf(1)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(14x,2a)') cbuf(5:28), cbuf(29:68)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(34x,a)')'Photon model spectrum'
            CALL xwrite(wrtstr,5)
            len=12
            DO ij=1,ibuf(1)
               CALL rsubsf(iunit,csbuf,len,ierrsf)
               WRITE(wrtstr,'(i5,1x,2(g10.4,a),g13.4)')ij,
     &             rsbuf(1),' - ',rsbuf(2),':  ',rsbuf(3)
               CALL xwrite(wrtstr,5)
            ENDDO

c If package is steppar output

         ELSEIF(pkgtyp.eq.'steppar     ')then

            WRITE(wrtstr,'(a,i4)')
     &           ' The number of stepped parameters:', ibuf(1)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,g15.5)')
     &           ' Current minimum chisquare:', rbuf(2)
            CALL xwrite(wrtstr,5)
            nspar=ibuf(1)
            DO ik=1,nspar
               len=20
               CALL rsubsf(iunit,csbuf,len,ierrsf)
               WRITE(wrtstr,'(3(a,i4))')
     &              ' Step parameter no.',ik,
     &              ' Fit index number',isbuf(1),
     &              ' The number of steps',isbuf(2)
               CALL xwrite(wrtstr,5)
               WRITE(wrtstr,'(a,2(1x,f8.3))')
     &              ' The lower and upper stepping limits',
     &              rsbuf(3),rsbuf(4)
               CALL xwrite(wrtstr,5)
               WRITE(wrtstr,'(a,L1)')
     &              ' Log flag:',qsbuf(5)
               CALL xwrite(wrtstr,5)
            ENDDO
            ntri=nsubs-nspar
            WRITE(wrtstr,'(4a)')
     &           ' Error flag, Chisquared, Par values:'
            CALL xwrite(wrtstr,5)
            DO itri=1,ntri
               len=20+4*nspar
               CALL rsubsf(iunit,csbuf,len,ierrsf)
               WRITE(wrtstr,'(i4,f8.3,(1x,1p4g16.5))')
     &              isbuf(1),rsbuf(2),
     &              (rsbuf(i+5),i=1,nspar)
               CALL xwrite(wrtstr,5)
            ENDDO

c If package is output from error command

         ELSEIF(pkgtyp.eq.'error       ')then

            WRITE(wrtstr,'(a,i4)')' Fit par. no.',ibuf(4)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,i4)')' Error indication',ibuf(1)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,g12.5)')
     &            ' Minimum chi-squared',rbuf(2)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,g12.5)')
     &            ' Delta chi-sqr defining confidence range',
     &            rbuf(3)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,3g12.5)')
     &            ' The "lower" "best" and "higher" fit value',
     &            rbuf(6),rbuf(5),rbuf(7)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,2g12.5)')
     &        ' The actual lower and upper limit delta chi squared ',
     &            rbuf(8),rbuf(9)
            CALL xwrite(wrtstr,5)
            IF ( cbuf(73:73) .EQ. 'T' ) THEN
               WRITE(wrtstr,'(a)')' The lower value was pegged'
               CALL xwrite(wrtstr,5)
            ENDIF
            IF ( cbuf(74:74) .EQ. 'T' ) THEN
               WRITE(wrtstr,'(a)')' The higher value was pegged'
               CALL xwrite(wrtstr,5)
            ENDIF
            DO ij=1,3
               WRITE(wrtstr,'(a,3g10.3)')
     &            ' The "lower" "best" and "higher" function value',
     &            rbuf(ij+12),rbuf(ij+9),rbuf(ij+15)
               CALL xwrite(wrtstr,5)
            ENDDO

c If package is output from equivalent width command

         ELSEIF(pkgtyp.eq.'equiv width ')then

            WRITE(wrtstr,'(a,i4)')
     &         ' Model index whose equiv width is being estimated',
     &         ibuf(1)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,g14.6)')
     &         ' Energy at which continuum is evaluated',
     &         rbuf(2)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,g14.6)')
     &         ' Continuum photon flux at this energy',
     &         rbuf(3)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,2(1x,g14.6))')
     &         ' Lower and upper limit of the continuum integration',
     &         rbuf(4), rbuf(5)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,g14.6)')
     &         ' Model component photon flux',rbuf(6)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,2(1x,g14.6))')
     &         ' Lower and upper limit of the model integration',
     &         rbuf(7),rbuf(8)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,g14.6)')
     &         ' Equiv width using photon nos',rbuf(9)
            CALL xwrite(wrtstr,5)

c If package is output from flux command

         ELSEIF(pkgtyp.eq.'flux        ')then

            WRITE(wrtstr,'(a,2(1x,g14.6))')
     &         ' The lower and upper limits of integration ',
     &         rbuf(1),rbuf(2)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,g14.6)')
     &          ' Integrated photon flux ',rbuf(3)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,g14.6)')
     &          ' Integrated energy flux ',rbuf(4)
            CALL xwrite(wrtstr,5)

c If package is time info

         ELSEIF(pkgtyp.eq.'time        ')then

            WRITE(wrtstr,'(3a,f8.2)')
     &           ' Date and time',cbuf(1:20),
     &           ' Elapsed clock time',rbuf(6)
            CALL xwrite(wrtstr,5)
            WRITE(wrtstr,'(a,1x,5(1x,i8))')
     &           ' Performance values',(ibuf(jk+6),jk=1,5)
            CALL xwrite(wrtstr,5)

c Else if package is unknown

         ELSE

            WRITE(wrtstr,*)' Unidentified package of type:',pkgtyp 
            CALL xwrite(wrtstr,5)

         ENDIF

c Read the next package

         ierrsf=0
         lenbuf=maxsize
         pkgtyp=' '
         index=0
         nsubs=0
         CALL nxpksf(iunit,pkgtyp,index,nsubs,infoar,cbuf,lenbuf,
     &               .false.,ierrsf)
         qdone=ierrsf.eq.7

      ENDDO

9000  CONTINUE

      close(unit=iunit)
      CALL frelun(iunit)

      IF(outfile.ne.'none')then
         close(unit=ounit)
         CALL frelun(ounit)
      ENDIF

      END
