SUBROUTINE cphdeb(iunit, inrmfl, ounit, nhist, hist, 
     &                  contxt, status)

      IMPLICIT none
      CHARACTER*(*) inrmfl, contxt, hist(*)
      INTEGER iunit, ounit, nhist, status

c Copy the header and energy bound extensions from the first RMF file
c into the output file.

*  Modifications
*       Peter D Wilson 02/20/98
*             . Preserve history keywords of RSP extension of
*               first RMF file
*

c Arguments :
c     iunit        i      i: I/O unit for input RMF file
c     inrmfl       c      i: Name of input RMF file
c     ounit        i      i: I/O unit for output RMF file (already opened)
c     nhist        i      i: Number of history keywords
c     hist         c      i: History keywords
c     contxt       c      r: error message
c     status       i      r: Status   0 = OK, !0 = !OK

      INTEGER rmfsiz, nfound, htype, i, j
      INTEGER next(10)

      character(20) instr(2)
      character(20) outhdu(9,10), extnam(10), outver(9,10)

      status = 0

c Open the input RMF file

      rmfsiz=2880 
      CALL ftopen(iunit, inrmfl, 0, rmfsiz, status)
      contxt = 'CPHDEB : Failed to open first RMF'
      IF ( status .NE. 0 ) RETURN

c Copy the header from the input RMF to the output RMF

      CALL ftcopy(iunit, ounit, nhist, status)
      contxt = 'CPHDEB : Failed to copy header'
      IF ( status .NE. 0 ) RETURN

c Add the history keywords

      DO i = 1, nhist
         CALL ftphis(ounit, hist(i), status)
         contxt = 'CPHDEB : Failed to write history keyword'
         IF ( status .NE. 0 ) RETURN
      ENDDO

c Append a new empty HDU to the output RMF

      CALL ftcrhd(ounit, status)
      contxt = 'CPHDEB : Failed to append new HDU to the output RMF'
      IF ( status .NE. 0 ) RETURN

c Find the EBOUNDS extension in the input RMF and go to it

      instr(1) = 'RESPONSE'
      instr(2) = 'EBOUNDS'
      CALL fndhdu(5, iunit, 2, instr, 10, nfound, next, outhdu,
     &            outver, extnam, status)
      contxt = 'CPHDEB : Failed to find EBOUNDS extension in first RMF'
      IF ( nfound .EQ. 0 ) status = 1
      IF ( status .NE. 0 ) RETURN

      CALL ftmrhd(iunit, next(1), htype, status)
      contxt = 'CPHDEB : Failed to go to EBOUNDS extension in first RMF'
      IF ( status .NE. 0 ) RETURN

c Copy the EBOUNDS extension from the input RMF to the output RMF

      CALL ftcopy(iunit, ounit, 0, status)
      contxt = 'CPHDEB : Failed to copy EBOUNDS extension'
      IF ( status .NE. 0 ) RETURN

c Close then reopen input RMF to reset HDU position... PDW 02/20/98

      CALL ftclos(iunit, status)
      contxt = 'CPHDEB : Failed to close EBOUNDS extension'

      IF ( status .NE. 0 ) RETURN
      CALL ftopen(iunit, inrmfl, 0, rmfsiz, status)
      contxt = 'CPHDEB : Failed to reopen first RMF'
      IF ( status .NE. 0 ) RETURN
      
c Find the extension with the redistribution matrix.

      instr(1) = 'RESPONSE'
      instr(2) = 'RSP_MATRIX'
      do j=1,10
         next(j)= 0
      enddo
      CALL fndhdu(5, iunit, 2, instr, 10, nfound, next, outhdu,
     &     outver, extnam, status)
      
      contxt = 'CPHDEB : Failed to find RSP extension in first RMF'
      IF ( nfound .EQ. 0 ) status = 1
      IF ( status .NE. 0 ) RETURN
      
c Go to the extension and read in history keywords
      
      CALL ftmrhd(iunit, next(1), htype, status)
      contxt = 'CPHDEB : Failed to go to matrix extension in first RMF'
      IF ( status .NE. 0 ) RETURN
      
      IF ( nhist.lt.99 ) then
         nhist = nhist+1
         hist(nhist) = '*** History of I/p RMF file: '//inrmfl
         CALL fcrhky(iunit,100,nhist,hist,status)
      ENDIF

c Close input RMF

      CALL ftclos(iunit, status)
      contxt = 'CPHDEB : Failed to close matrix extension'

      RETURN
      END