C***************************************************************************
C SELECTOR TASK
C      hxtarf
C
C FILE:
C      hxtarf.f
C
C DESCRIPTION:      
C     create a .arf file for a given HEXTE observation
C      
C AUTHOR:
C      James Lochner  5/95
C     with Tod Strohmeyer (PCA) and Ian George (HEASARC)
C     modified for HEXTE by Philip Blanco (HEXTE/UCSD)      
C      
C MODIFICATION HISTORY:
C     Dec. 1, 1995 - Convert jitter parameter to minutes of arc rather
C              than quaternion units
C     Feb 12, 1996 - Use seconds of arc for jitter parameter

C     Nov 26, 1996 - modified from XPCAARF to deal with HEXTE data
C as well. Significant changes include:
C  - the task has been renamed from XPCAARF to hxtarf
C  - The detector ID is now specified as a string parameter, detnam
C since HEXTE detectors are identified by a number AND a letter for
C cluster A or B.
C - the input file is now a detector-axis ARF, not RMF.
C - various additional keyword checking and writing, to ensure that
C the collimator response is not applied twice.
C - Version numbers are now generated by RCS.      
C - Dec 16, 1996 - Bug fix in dohxtarf for reading times from GTI, to
C keep in step with similar fix to doxpcaarf in XPCAARF
C - Feb 28, 1997 - added dynamic arrays GTIstarts and GTIstops to hold
C all the times in the PHA files GTI extension, and modified
C rd_quaterns to average only those quaternions within the GTIs.
C - Mar 20, 1997 - changes to subroutine RD_QUATRNS to average
C spacecraft coordinates instead of the quaternions themselves.      
C - Aug 20, 1997 - changes to code which reads on the on-axis ARF,
C including support for CALDB access.      
C - Oct 20, 1998 - changes to code to read the collimator cube, 
C including support for CALDB access. 
C User must now specify either "CALDB", or filename[extension no.], for
C these files (i.e. "extension searching" is no longer supported). 
C - Dec 10 1998 - Two changes made by FTOOLS team reintroduced:
C 1) obs_date and obs_time changed to character*68 to accomodate Y2K
C 2) fixed two writes containing "i" format specifiers without field 
C    width parameter (non-ANSI Fortran; chokes recent versions of g77)
C M Tripicco (03 Aug 15) fixed bugs in CK_ARF subroutine which
C            caused bus error on Mac OS X (rmap1d.f bug fix checked in
C            yesterday as well)
C NOTES:
C
C ARGUMENTS:
C      none
C
C PRIMARY LOCAL VARIABLES:
C      phafil	 - name of input HEXTE .pha file
C      inarf	 - name of input HEXTE .arf file
C      outarf    - name of output .arf file
C      xtefilt   - name of XTE filter file or quaternion file.
C      collcube  - name for HEXTE collimator cube file
C      jitter    - acceptable jitter in spacecraft pointing
C      detnam    - alternate detector name      
C      ra        - alternate source ra
C      dec       - alternate source dec
C      start     - alternate start time for observation
C      stop      - alternate stop time for observation
C      arfversn  - version number of the ARF file to be written
C      chatter   - how much to tell user
C
C CALLED ROUTINES:
C     subroutine ghxtarf  - gets parameters from environment
c     subroutine dohxtarf - constructs and outputs the .arf file
C ************************************************************************** 

      Subroutine hxtarf

      IMPLICIT NONE

c start with initial declarations
      CHARACTER*160 phafil, inarf, outarf, xtefilt
      CHARACTER*160 collcube

      CHARACTER*5 arfversn
      CHARACTER*12 detnam, ra, dec
      REAL jitter
      DOUBLE PRECISION start, stop
      INTEGER chatter
      
      LOGICAL abort
      LOGICAL clobber
        
      CHARACTER*40 taskname
      COMMON /task/ taskname

C First set up the software version strings  
      CHARACTER*40 rcsname
      INTEGER i

      rcsname = ' $Revision: 1.12 $ '
      READ(rcsname, 5) taskname
    5 FORMAT(12X, (A))
      i = INDEX(taskname, '$')
      taskname = 'HXTARF v'// taskname(1:i-2)

      abort = .false.
      
c get the parameters from the par file
        CALL ghxtarf(phafil, inarf, outarf, xtefilt, collcube,
     &    jitter, detnam, ra, dec, start, stop, arfversn,
     &    chatter, clobber)

        IF (chatter .GE. 5) CALL fcecho('             '//taskname)

c Perform the Algorithm:   
        CALL dohxtarf(phafil, inarf, outarf, xtefilt, collcube,
     &     jitter, detnam, ra, dec, start, stop, arfversn,
     &     chatter, clobber)

c  Exit subroutine

	RETURN
	END
C*****************************************************************
C SUBROUTINE:
C      ghxtarf
C
C DESCRIPTION:      
C      Gets parameters from parameter file
C      
C AUTHOR:
C      James Lochner  5/95
C
C MODIFICATION HISTORY:
C      
C NOTES:
C      ghxtarf uses F77/VOS like CALLs to read parameters from .par file
C
C USEAGE:      
C      CALL ghxtarf(phafil, inarf, outarf, xtefilt, collcube,
C                     jitter, ra, dec, start, stop, arfversn,
C                     chatter)
C      
C ARGUMENTS:
C     phafil	 - name of input PCA/HEXTE pha file
C     inarf     - name of input PCA/HEXTE arf file
C     outarf	 - name of output .arf file
C     xtefilt    - name of XTE filter file
C     collcube   - name of PCA/HEXTE collimator cube file
C     jitter     - acceptable jitter in the spacecraft pointing
C     detnam     - (alternate) desired detector        
C     ra         - alternate source ra
C     dec        - alternate source dec
c     start      - alternate start time for observation
c     stop       - alternate stop time for observation
C     chatter    - how much to tell user (for CALLIB routines)
C     arfversn   - version number of the ARF file to be written
C
C PRIMARY LOCAL VARIABLES:
C      context  - error message
C      status   - error number
C
C CALLED ROUTINES:
C      subroutine fcerr  - echo message to terminal
C      subroutine fcerrm - echo fitsio error message to terminal 
C      subroutine uclgsd - get real*8 parameter
C      subroutine uclgsi - get INTEGER parameter
C      subroutine uclgsr - get real*4 parameter
C      subroutine uclgst - get string parameter
C      
C *******************************************************************************

      SUBROUTINE ghxtarf(phafil, inarf, outarf, xtefilt, collcube,
     &     jitter, detnam, ra, dec, start, stop, arfversn,
     &     chatter, clobber)

      IMPLICIT NONE

c start with the declarations
      CHARACTER*(*) phafil, inarf, outarf, xtefilt
      CHARACTER*(*) collcube, arfversn, detnam, ra, dec
      REAL jitter
      DOUBLE PRECISION start, stop
      INTEGER chatter
      LOGICAL clobber
      
      CHARACTER*80 context
      INTEGER  status
      REAL rstart, rstop
      
      status = 0

c get the name of the input pha file
	CALL uclgst('phafil',phafil,status)
	IF (status .NE. 0) THEN
          context = 'could not get PHAFIL parameter'
          CALL fcerr(context)
          GOTO 999
	ENDIF

c get the name of the input arf file
	CALL uclgst('inarf',inarf,status)
	IF (status .NE. 0) THEN
          context = 'could not get inarf parameter'
          CALL fcerr(context)
          GOTO 999
	ENDIF

c get the name of the output arf file
	CALL uclgst('outarf',outarf,status)
	IF (status .NE. 0) THEN
	    context = 'could not get outarf parameter'
	    CALL fcerr(context)
	    GOTO 999
	ENDIF
        
c get the name of the XTE filter file
	CALL uclgst('xtefilt',xtefilt,status)
	IF (status .NE. 0) THEN
	    context = 'could not get XTEFILT parameter'
	    CALL fcerr(context)
	    GOTO 999
	ENDIF
        
c get the name of the collimator cube file
	CALL uclgst('collcube',collcube,status)
	IF (status .NE. 0) THEN
	    context = 'could not get COLLCUBE parameter'
	    CALL fcerr(context)
	    GOTO 999
	ENDIF
        
C get the value of the acceptable s/c pointing jitter (hidden)
        CALL uclgsr('jitter',jitter,status)
        IF (status .NE. 0) THEN
           context = 'could not get JITTER parameter'
           CALL fcerr(context)
           GOTO 999
        ENDIF

C get the desired detector
        CALL uclgst('detnam',detnam, status)
        IF (status .NE. 0) THEN
           context = 'could not get Alternate detnam parameter'
           CALL fcerr(context)
        ENDIF
                
c get desired source position (hidden parameter)
c     (need routine to accept/decode either hh mm ss or decimal degrees)
        CALL uclgst('ra',ra,status)
	IF (status .NE. 0) THEN
	    context = 'could not get Alternate RA parameter'
	    CALL fcerr(context)
	    GOTO 999
	ENDIF
        CALL uclgst('dec',dec,status)
	IF (status .NE. 0) THEN
	    context = 'could not get Alternate DEC parameter'
	    CALL fcerr(context)
	    GOTO 999
	ENDIF

C get the value of the alternate start and stop times (hidden)
        CALL uclgsr('start',rstart,status)
        IF (status .NE. 0) THEN
           context = 'could not get START parameter'
           CALL fcerr(context)
           GOTO 999
        ENDIF
        CALL uclgsr('stop',rstop,status)
        IF (status .NE. 0) THEN
           context = 'could not get STOP parameter'
           CALL fcerr(context)
           GOTO 999
        ENDIF
        start = rstart
        stop = rstop

c get the arfversn to be used
        CALL uclgst('arfversn',arfversn,status)
	IF (status .NE. 0) THEN
	    context = 'could not get ARFVERSN parameter'
	    CALL fcerr(context)
	    GOTO 999
	ENDIF

C get the chattiness flag
        CALL uclgsi('chatter',chatter,status)
        IF (status .NE. 0) THEN
           context = 'could not get CHATTER parameter'
           CALL fcerr(context)
           status = 0
           context = 'setting CHATTER = 10'
           CALL fcerr(context)
           chatter = 10
	ENDIF

C get the clobber flag
        CALL uclgsb('clobber',clobber,status)
        IF (status .NE. 0) THEN
           context = 'could not get CLOBBER parameter'
           CALL fcerr(context)
           status = 0
           context = 'setting CLOBBER FALSE'
           CALL fcerr(context)
           clobber = .FALSE.
	ENDIF

C Exit subroutine
999	CONTINUE 
	IF (status .NE. 0) CALL fcerrm(status)

	RETURN
	END
C*****************************************************************
C SUBROUTINE:
C     dohxtarf
C
C DESCRIPTION:      
C      
C      
C AUTHOR:
C      James Lochner  5/95
C     with Tod Strohmayer (PCA) & Ian George (HEASARC)
C      
C MODIFICATION HISTORY:
C     Dec. 1, 1995 - Use .pha GTI times rather than TSTART/TSTOP for
C                  deciding times in the quaternion file
C     Mar. 8, 1996 - allow value of 'none' for name of xtefilter/quaternion
C                  file.  Source position in s/c coord THEN defaults to
C                  (0.0,0.0).  Also incresed maxe2 from 256 to 2048.
C     Mar. 22, 1996 - Read boresight values from parameter file.  (Use 0.0
C                  IF not found in parameter file)
C      Oct 20, 1998 - changes to code to read the collimator cube, 
C and the ARF, including support for CALDB access. 
C User must now specify either "CALDB", or filename[extension no.], for
C these files (i.e. "extension searching" is no longer supported). 

C NOTES:
C
C USEAGE:      
C      CALL dohxtarf(phafil, inarf, outarf, xtefilt, collcube,
C     &     jitter, detnam, ra_str, dec_str, tstart_pha,
C     &     tstop_pha, arfversn, chat)
C      
C ARGUMENTS:
C     phafil	 - name of input HEXTE pha file
C     inarf     - name of input HEXTE arf file
C     outarf	 - name of output .arf file
C     xtefilt    - name of XTE filter file
C     collcube   - name of HEXTE collimator cube file
C     jitter     - acceptable jitter in the spacecraft pointing
C     detnam     - alternate detector name
C     ra_str     - alternate source ra
C     dec_str    - alternate source dec
C     start_pha  - alternate start time for observation
C     stop_pha   - alternate stop time for observation
C     chat       - how much to tell user (for CALLIB routines)
C     arfversn   - version number of the ARF file to be written
C
C     PRIMARY LOCAL VARIABLES (selected):
C     N.B. e = energy, c1 = coord. 1 (i.e. x), c2 = coord. 2 (i.e. y)
C     quat      - average quaternions for the observation
C     colfil    - file name extracted from input string collcube
C     x_lo,x_hi - limits on the spatial grid in coll. cube
C     y_lo,y_hi -      "                  "
C     c1lo, c1hi, c2lo, c2hi
C               - subcube to extract from the coll. cube
C     cresp3d   - coll. cube in energy, x, and y position
C     tmpimg    - 2 x 2 subset of cresp3d
C     cresp1d   - 1-d coll. resp. on coll cube's energy grid
C     cresp_out - 1-d coll. resp. on input ARF's energy grid
C     context   - error message
C     status    - error number
C
C CALLED ROUTINES:
C     subroutine fcerr  - echo message to terminal
C     subroutine fcerrm - echo fitsio error message to terminal
C     subroutine gtcalf - CALLib        
c     subroutine gcsynm - CALLib
C     subroutine gcrefs - CALLib
c     subroutine gcsylt - CALLib
c     subroutine xtcol1 - CALLib
c     subroutine rmap1d - CALLib
C     INTEGER FUNCTION CLENACT - CALLib        
C *******************************************************************************

      SUBROUTINE dohxtarf(phafil, inarf, outarf, xtefilt, collcube,
     &     jitter, detnam, ra_str, dec_str, tstart_pha,
     &     tstop_pha, arfversn, chat, clobber)

      IMPLICIT NONE
C start with the declarations
      CHARACTER*(*) phafil, inarf, outarf, xtefilt
      CHARACTER*(*) collcube, detnam, ra_str, dec_str, arfversn
      REAL jitter
      INTEGER chat
      LOGICAL clobber
      
      DOUBLE PRECISION tstart_pha, tstop_pha
      
      INTEGER ounit, iunit1, iunit2
      CHARACTER*80 context, msg
      CHARACTER*160 arfhist, colhist
      INTEGER lenarf, lencol
      CHARACTER*80 comment(10), hist(10)
      CHARACTER*68 obs_date, obs_time
      CHARACTER*8 pha_telescop, pha_instrume, pha_detnam, pha_filter
      CHARACTER*8 inarf_telescop,inarf_instrume,inarf_detnam,
     &  inarf_filter
      CHARACTER*40 arfclas2
      CHARACTER*8 hduclas(9), hduvers(9,2), crspvers, csys
      CHARACTER*6 online(1)
      REAL coor(3), sccoor(3)
      REAL pi, acc
      DOUBLE PRECISION ra, dec, mjdref_pha
      DOUBLE PRECISION nullval
      INTEGER inarf_nen, inarf_lo_energy, inarf_hi_energy, inarf_resp
      INTEGER GTIstarts, GTIstops
      INTEGER o_vector, equinox
      INTEGER nsearch, block, ftstatus, htype, ierr
      INTEGER ngti, frow, felem
      INTEGER extno(1), nfound, nret, ireadwrite
      INTEGER nk_hist, nk_comm
      INTEGER ien, icx, icy
      INTEGER i, j, m, n
      LOGICAL anyf

      INTEGER maxextn, maxdim, maxe, maxc1, maxc2, maxe2
      PARAMETER (maxextn=10, maxdim=3, maxe=10, maxe2=2048, 
     &     maxc1=30, maxc2=30)
      INTEGER status, icol
      CHARACTER*20 ftype
      CHARACTER*30 wrnstr, errstr2
      CHARACTER*160 colfil(1), arffil(1)
      INTEGER ndim
      CHARACTER*20 coordtyp(maxdim), coordnam(2,maxdim)
      INTEGER coordnpts(maxdim), coordcol(2,maxdim)
      LOGICAL qok, quiet
      REAL e_lo, e_hi, x_lo, x_hi, y_lo, y_hi
      INTEGER edim, c1dim, c2dim
      INTEGER incol(2)
      CHARACTER*20 x_units, y_units
      REAL c1lo, c1hi, c2lo, c2hi
      CHARACTER*20 c1unt, c2unt, enunt
      REAL egrd(2,maxe), c1grd(2,maxc1), c2grd(2,maxc2)
      REAL egrd_lo(maxe2), egrd_hi(maxe2)
      REAL cresp3d(maxe,maxc1,maxc2)
      REAL cresp1d(maxe)
      REAL cresp_out(maxe2)
      REAL work1d(maxe*maxc1*maxc2)
      REAL tmpimg(2,2)
      REAL x(2), y(2)
      REAL temp
      
c     REAL energ_lo(256), energ_hi(256)
      INTEGER mode
C Function returning the active length of a string      
      INTEGER CLENACT
      
C******************************************************************************
C   the following MEM COMMON block definition is in the system iraf77.inc file
C   and is used for dynamic memory allocation 
      LOGICAL          MEMB(1)
      INTEGER*2        MEMS(1)
      INTEGER*4        MEMI(1)
      INTEGER*4        MEML(1)
      REAL             MEMR(1)
      DOUBLE PRECISION MEMD(1)
      COMPLEX          MEMX(1)
      EQUIVALENCE (MEMB, MEMS, MEMI, MEML, MEMR, MEMD, MEMX)
      COMMON /MEM/ MEMD
      
C     note:
C      datatype      value
C      LOGICAL        1
C      INTEGER*2      3
C      INTEGER        4
C      Long INTEGER   5
C      REAL           6
C      Double         7
C      Complex        8
C******************************************************************************      
      CHARACTER*40 taskname
      COMMON /task/ taskname

c Initalization
      wrnstr = '** WARNING from dohxtarf:'
      errstr2 = '** ERROR in dohxtarf:'

      ierr = 0
      ftstatus = 0
      status = 0
c next two are to shut up compiler warnings
      c1dim = 0
      c2dim = 0
      
      pi = 3.14159
      frow = 1
      felem = 1
      nullval = -99.0

C Open and check the pha file
      ireadwrite = 0
      CALL CK_XTEPHA(chat, phafil, iunit1, ireadwrite,
     &  pha_telescop, pha_instrume,
     &  pha_detnam, pha_filter, obs_date, obs_time, ierr)
      IF (ierr .NE. 0) THEN
        context = errstr2//'Could not get pha file information.'
        GOTO 999
      ENDIF
      
C Obtain the detector name from the PHA file if it is not specified.
      IF (detnam .eq. 'INDEF') THEN
        detnam = pha_detnam
      ENDIF
                
C From the pha file, obtain the source position
C  N.B. parsedec & parsera are in ftools/develop/xanlib/coords         
        IF (ra_str .eq. 'INDEF') THEN
         CALL ftgkyd(iunit1,'RA_OBJ',ra,comment,ftstatus)
         IF (ftstatus .NE. 0) THEN
            context = 'unable to obtain object RA'
            CALL fcerr(context)
            GOTO 999
         ENDIF
      ELSE
         CALL parsera(ra_str,equinox,ra,ierr)
      ENDIF
      
      IF (dec_str .eq. 'INDEF') THEN
         CALL ftgkyd(iunit1,'DEC_OBJ',dec,comment,ftstatus)
         IF (ftstatus .NE. 0) THEN
            context = 'unable to obtain object Dec'
            CALL fcerr(context)
            GOTO 999
         ENDIF
      ELSE
         CALL parsedec(dec_str,equinox,dec,ierr)
      ENDIF

C Chatter the source position to the screen
      IF (chat .GE. 10) THEN
         WRITE(msg,'(a,2(f8.4,2x))') 'Source R.A. & Dec.: ',
     &        ra,dec
         CALL fcecho(msg)
      ENDIF

      
C Get TSTART and TSTOP times from the GTI extension of the pha file,
C     or override with inputs
C Dec 16, 1996 - bug fix for GTI's with many rows: read just row 1 for start,
C                read just row = ngti for stop
C      
      IF (tstart_pha .eq. -1.) THEN
         CALL ftmrhd(iunit1,1,htype,ftstatus)
         IF (ftstatus .NE. 0) THEN
            context = 'unable to move to GTI extension'
            CALL fcerr(context)
            GOTO 999
         ENDIF
         CALL ftgkyj(iunit1,'NAXIS2',ngti,context,ftstatus)
         IF (ftstatus .NE. 0) THEN
            context = 'unable to get number of GTI time values'
            CALL fcerr(context)
            GOTO 999
          ENDIF

C         Allocate memory for the GTIs: 
          GTIstarts = 0
          GTIstops = 0
          CALL udmget(ngti,7,GTIstarts,ftstatus)
          CALL udmget(ngti,7,GTIstops,ftstatus)

         CALL ftgcvd(iunit1,1,1,felem,ngti,nullval,MEMD(GTIstarts),anyf,
     &        ftstatus)
         CALL ftgcvd(iunit1,2,1,felem,ngti,nullval,MEMD(GTIstops),anyf,
     &     ftstatus)
         
         IF (ftstatus .NE. 0) THEN
            context = 'unable to obtain GTI time values'
            CALL fcerr(context)
            GOTO 999
         ENDIF
      ENDIF
      
C N.B.  For convenience, we set the value of mjdref_pha.  This variable
c      is included in the CALL to rd_quatrns, but rd_quatrns doesn't
c      actually do anything with it.  At a future date, you may eliminate
c     mjdref_pha entirely, IF you wish.
      
      mjdref_pha = 49352.000696574074
         
C close the input pha file
      CALL ftclos(iunit1,ftstatus)
      CALL ftfiou(iunit1,ftstatus)

C Convert source RA & Dec into unit vector in inertial coord.
      coor(1) = cos(pi*dec/180.) * cos(pi*ra/180.)
      coor(2) = cos(pi*dec/180.) * sin(pi*ra/180.)
      coor(3) = sin(pi*dec/180.)

C Check whether the user has specified "CALDB"
      
      IF (inarf(1:5) .eq. 'CALDB' .or. inarf .eq. 'caldb') THEN
C
C ... From the detector name, determine the appropriate effective area
        CALL gtcalf(chat, pha_telescop, pha_instrume, detnam, 
     &    '-', 'EFF_AREA', obs_date, obs_time, obs_date, obs_time,
     &    '-', 1, arffil(1), extno, online, nret, nfound, ierr)

        IF (ierr.NE.0. OR. nret .EQ. 0)THEN 
            msg = errstr2//'unable to get input ARF file from CALDB.'
            CALL fcecho(msg)
            GOTO 999
          ENDIF          
                               
c ... Otherwise, Translate the name of the input file (taking off any 
c     extension specified by the user).

      ELSE
         CALL fcpars(inarf, arffil(1), extno(1),status)
         if(status.NE.0) THEN
            msg = wrnstr // 
     &           ' Problem parsing "inarf" parameter: '//inarf
            CALL fcecho(msg)
            msg = ' ... will search all extensions'
            CALL fcecho(msg)
            extno(1) = -99
         ENDIF	
      ENDIF

      
c ... Now
c 	arffil(1) - name of file to be opened 
c	extno(1)  - extension no. of dataset (or -99 indicating search reqd)

C Chatter the name of the ARF file to the screen

      lenarf = CLENACT(arffil(1))
      WRITE(arfhist, '(1X, (A), 1A, I3, 1A)')
     &  'Input ARF: '//arffil(1)(1:lenarf), '[',extno(1),']'
      IF (chat .GE. 10) THEN
        CALL fcecho(arfhist)
      ENDIF
            
C Check out the ARF file and move to the SPECRESP
C extension
      CALL CK_ARF(chat, arffil, iunit1, extno(1), inarf_telescop,
     &  inarf_instrume,
     &  inarf_detnam, inarf_filter, inarf_nen, arfclas2, csys, ierr)
      
C Compare ARF keywords with pha keywords
        CALL compkey(chat, inarf, inarf_telescop, inarf_instrume,
     &    inarf_detnam, inarf_filter, 'PHA', pha_telescop,
     &    pha_instrume, detnam, pha_filter, ierr)
C  IF telescope information doesn't match (ierr = 1) THEN quit
        IF (ierr .NE. 0) GOTO 999

C Make sure that the input is an on-axis detector response, otherwise
C warn the user, but do nothing even IF it looks like the collimator
C response has been applied to the input ARF (based on the values
C of the CSYSNAME keyword).        
        
        IF (INDEX(csys, 'RAW_DET') .EQ. 0) THEN
          msg = 'WARNING! Input ARF does not have CSYSNAME=RAW_DET.'
          CALL fcecho(msg)
          IF (INDEX(csys, 'XMA_CART') .NE. 0) THEN
            msg = 'CSYSNAME=XMA_CART: Collimator response may ' //
     &        'have been applied to the input ARF already.'
            CALL fcecho(msg)
          ENDIF
        ENDIF
      
C allocate inarf_lo_energy, inarf_hi_energy and inarf_resp arrays
C      m = max(inarf_nen,100)
      m = inarf_nen  
      inarf_lo_energy = 0
      inarf_hi_energy = 0
      inarf_resp = 0
      o_vector = 0
      CALL udmget(m,6,inarf_lo_energy,ftstatus)
      CALL udmget(m,6,inarf_hi_energy,ftstatus)
      CALL udmget(m,6,inarf_resp,ftstatus)
      
C Get the energy grids and spectral response from INARF
      CALL RDARF1(iunit1, chat, inarf_telescop, inarf_instrume,
     &  inarf_detnam, inarf_filter, inarf_nen, MEMR(inarf_lo_energy),
     &  MEMR(inarf_hi_energy), MEMR(inarf_resp), arfversn, ierr)
      IF (ierr .NE. 0) GOTO 999
      
      CALL ftfiou(iunit1,ftstatus)

C allocate the rest of the arrays
      m = inarf_nen
      CALL udmget(m,6,o_vector,ftstatus)

C Open the xtefilter file or quaternion file (rd_quatrns)
c     and get the pointing info
      
      IF (xtefilt .NE. 'none' .AND. xtefilt .NE. 'NONE'
     &  .AND. xtefilt .NE. 'None') THEN
        IF (tstart_pha .eq. -1) THEN
          CALL rd_quatrns(ngti, MEMD(GTIstarts), MEMD(GTIstops),
     &      mjdref_pha, xtefilt, coor, jitter, sccoor, chat, ierr)
        ELSE  
          CALL rd_quatrns(1, tstart_pha, tstop_pha, mjdref_pha,
     &      xtefilt, coor, jitter, sccoor, chat, ierr)
        ENDIF
        IF (ierr .NE. 0) GOTO 999
      ELSE
C      IF there is no filter/quaternion file (xtefilt='none') THEN
C      set the source position to the value read from the par file)
        CALL uclgsr('y_source', sccoor(2),ftstatus)
        CALL uclgsr('z_source',sccoor(3),ftstatus)
        IF (ftstatus .NE. 0) THEN
          msg = 'Spacecraft (y, z) source coordinates not found, '
     &      // 'in par file - using (0.0, 0.0).'
          CALL fcecho(msg)
          sccoor(2) = 0.0
          sccoor(3) = 0.0
          ftstatus = 0
        ENDIF
      ENDIF

C Chatter the source position in SPACECRAFT coordinates to the screen
      IF (chat .GE. 20) THEN
        WRITE(msg,'(a,2(f8.4,2x))')
     &    'Spacecraft Y, Z: ', sccoor(2), sccoor(3)
        CALL fcecho(msg)
      ENDIF
      
c %%% Start of IMG Addition -------------
c ----------------- Start of COLLIMATOR RESPONSE stuff -----------------
c ... Check whether i/p string contains special CHARACTERs denoting 
c     COLLIMATOR RESPONSE filename to be determined from the local CALDB, 
c     and IF so CALL caldb access software 

      IF (collcube(1:5) .eq. 'CALDB' .or. collcube .eq. 'caldb') THEN
C
C ... From the detector name, determine the appropriate collimator cube
         quiet = .false.
         CALL gtcalf(chat, pha_telescop, pha_instrume, detnam , 
     &     '-', 'COLLRESP', obs_date, obs_time, obs_date, obs_time,
     &     '-', 1, colfil(1), extno, online, nret, nfound, ierr)

         IF (ierr.NE.0. .OR. nret .EQ. 0)THEN 
            msg = errstr2//'Unable to get collimator cube from caldb.'
            CALL fcecho(msg)
            GOTO 999
         ENDIF
                     
c ... Otherwise, Translate the name of the input file (taking off any 
c     extension specified by the user).

       ELSE
         CALL fcpars(collcube,colfil(1),extno(1),status)
         if(status.NE.0) THEN
            msg = wrnstr // 
     &           ' Problem parsing collcube parameter: '//collcube
            CALL fcecho(msg)
            msg = ' ... will search all extensions'
            CALL fcecho(msg)
            extno(1) = -99
         ENDIF	
      ENDIF

C Chatter the name of the collimator cube to the screen
      lencol = CLENACT(colfil(1))
      WRITE(colhist, '(1X, (A), 1A, I3, 1A)')
     &  'Coll. cube: '//colfil(1)(1:lencol),'[',extno(1),']'
      IF (chat .GE. 10) THEN
        CALL fcecho(colhist)
      ENDIF
      
c ... Now
c 	colfil(1) - name of file to be opened 
c	extno(1)  - extension no. of dataset (or -99 indicating search reqd)

c Open i/p file
        status = 0
      	CALL cgetlun(iunit2)
      	CALL ftopen(iunit2,colfil(1),0,block,status)
      	IF (status.NE.0) THEN
      		msg = errstr2//' opening file: '//colfil(1)
      		CALL wt_ferrmsg(status,msg)
		ierr = 1        
		GOTO 999
      	ENDIF

c GO FIND THE EXTENSION
	if(extno(1).GE.0) THEN
c  	   - Extension number IS already known
	   CALL ftmahd(iunit2,extno(1)+1,htype,status)
	   msg = wrnstr // ' Problem moving to specified extension'
           CALL wt_ferrmsg(status, msg)
	ELSE
c  	   - Extension SEARCHING required 
c 	   .... Search for COLLRESP 
          nsearch = maxextn
	   CALL fndcol(chat, iunit2, nsearch,
     &          crspvers, hduclas, hduvers,
     &          ierr)
	   if(ierr.EQ.0) THEN
	    ftype = hduclas(2)
	   ELSE 
	    msg = errstr2//' Unable to locate acceptable extension'
	    CALL fcecho(msg)
	    GOTO 999
	   ENDIF
	ENDIF

c ... Now
c	Assuming everything's OK, we should be at the desired extension

c Find the column number of the coll.cube dataset
c ... (a good check that we're at the right place in the file)
	CALL ftgcno(iunit2, .false., 'COLLRESP', icol, status)
      	IF (status.NE.0) THEN
      		msg = errstr2//' Locating COLLRESP column'
      		CALL wt_ferrmsg(status,msg)
		ierr = 1        
		GOTO 999
      	ENDIF

c Get all the info regarding the storage of the coll.cube dataset
	CALL gcrefs(iunit2, chat, icol, maxdim, ndim,
     &		coordtyp, coordnam, coordcol, coordnpts, ierr)
      	IF(ierr.NE.0) THEN
		GOTO 999
	ENDIF

c ... Now
c	Assuming everything's OK, we know a whole bunch of stuff regarding 
c       the column number & ordering of the COLLRESP dataset, plus 
c       the column number, number of elements etc of the corresponding 
c	energy & spatial "grids"

c Cycle through the dimensions found, assigning pointers to the relevant dims
	DO i = 1, ndim
	   if(coordtyp(i).EQ.'ENERGY') THEN
		edim = i
	   ELSE IF(coordtyp(i).EQ.'COORD-1') THEN
		c1dim = i
	   ELSE IF(coordtyp(i).EQ.'COORD-2') THEN
		c2dim = i
	   ENDIF
	ENDDO

c Go and get the limits on the spatial coord grids (for later checks)
c ... First coordinate
	incol(1) = coordcol(1,c1dim)
	incol(2) = coordcol(2,c1dim)
      	CALL gcsylt(iunit2, chat, incol, x_lo, x_hi, x_units, ierr)
      	IF(ierr.NE.0) THEN
		GOTO 999
	ENDIF
c ... Second coordinate
	incol(1) = coordcol(1,c2dim)
	incol(2) = coordcol(2,c2dim)
      	CALL gcsylt(iunit2, chat, incol, y_lo, y_hi, y_units, ierr)
      	IF(ierr.NE.0) THEN
		GOTO 999
	ENDIF

c -------------------------------------------------------------------
c -------- Start Checking & Preparation of Spatial Grid -------------

c ... Perform checks
c     (For now, simple/crude checks & similar error messages; later messages
c      should be improved, and perhaps coordinate transformations
c      might even be performed here IF necessary instead of erroring out)
	qok = .true.
	if(coordnam(1,c1dim).NE.coordnam(2,c1dim)) THEN
	   qok = .false.
	   msg = errstr2//' Coord-1 across 2 columns'
	ENDIF
	if(coordnam(1,c2dim).NE.coordnam(2,c2dim)) THEN
	   qok = .false.
	   msg = errstr2//' Coord-2 across 2 columns'
	ENDIF
	if((coordnam(1,c1dim).NE.'ALPHA').OR.
     &		coordnam(1,c2dim).NE.'BETA') THEN
	   qok = .false.
	   msg = errstr2//' Mixed coord system'
	ENDIF
	if((sccoor(2).LT.x_lo).OR.(sccoor(2).GT.x_hi)) THEN
	   qok = .false.
	   msg = errstr2//' Coord-1 out-of-range'
	ELSE IF((sccoor(3).LT.y_lo).OR.(sccoor(3).GT.y_hi)) THEN
	   qok = .false.
	   msg = errstr2//' Coord-2 out-of-range'
	ENDIF	   
	if(.NOT.qok) THEN
	  CALL fcecho(msg)
	  GOTO 999
	ENDIF
c ... Now
c	Assuming everything's OK, we believe that the position for which the 
c       the COLLRESP is required IS indeed included within the spatial 
c       coordinate grid of the calibration dataset.

c -------- END Checking & Preparation of Spatial Grid -------------
c -------------------------------------------------------------------


c -------------------------------------------------------------------
c ------------- Extract nearest Spatial elements from Cube ----------
c Extract appropriate elements from the collimator cube
c ... to do this, we set up the limits for the 3-dimensional sub-cube we 
c     want extracted. In our case we want a sub-cube which represents the
c     four nearest points in the spatial dimensions, and all the points in
c     the energy dimension. 
c ... This is achieved by setting 
c     c1lo=c1hi=sccoor(2), 
c     c2lo=c2hi=sccoor(3)
c     e_lo>e_hi (actual values dont matter)

c ... Set up "dummy" Energy i/ps (to return ALL values in energy dimension)
	e_lo = 1
	e_hi = 0
	enunt = 'keV' 
c ... Set up coordsystem
	csys = 'XMA_CART'
c ... Set up Coord-1 (ALPHA) values
	c1lo = sccoor(2)
	c1hi = sccoor(2)
	c1unt = x_units
c ... Set up Coord-2 (BETA) values
	c2lo = sccoor(3)
	c2hi = sccoor(3)
	c2unt = y_units
c ... Just do it
      	CALL xtcol1(iunit2, chat, maxe, maxc1, maxc2, 
     &    e_lo, e_hi, enunt,
     & 		csys, c1lo, c1hi, c1unt, c2lo, c2hi, c2unt,
     &		ien, egrd, icx, c1grd, icy, c2grd, 
     &		cresp3d, work1d, ierr)
      	IF(ierr.NE.0) GOTO 999
        IF (chat .GE. 20) THEN
          msg = 'xtcol1 completed'
          CALL fcecho(msg)
        ENDIF
             
c OK, so now it is believed that we have the sub-cube in the cresp3d
c array, along with the relevant grid-point arrays in engrd, cxgrd, cygrd
	if(icx.NE.2) THEN
	   WRITE(msg,'(a,a,i12)') errstr2,' icx =', icx
	   CALL fcecho(msg)
	   ierr = 1
	   GOTO 998
	ELSE IF(icy.NE.2) THEN
	   WRITE(msg,'(a,a,i12)') errstr2,' icy =', icy
	   CALL fcecho(msg)
	   ierr = 1
	   GOTO 998
	ENDIF

c -------------------------------------------------------------------
c ------------- Perform Bi-linear interpolation ---------------------
C We do this for each energy-slice of the sub-cube
c ... fill in the grid points
	x(1) = c1grd(1,1)
	x(2) = c1grd(1,2)
	y(1) = c2grd(1,1)
	y(2) = c2grd(1,2)

c ... Loop over the energies, putting the result in tmpimg
      	DO n = 1,ien
          DO j = 1, icy
            DO i = 1, icx
              tmpimg(i,j) = cresp3d(n,i,j)
            ENDDO
           ENDDO
c          ... interpolate to the source position (not allowing extrapolation)
	   CALL bilint(chat, sccoor(2), sccoor(3), 2, 2, 
     &		2, 2, x, y, tmpimg, .false., temp, ierr) 
	cresp1d(n) = temp 
      	   IF(ierr.NE.0) THEN
		GOTO 999
	   ENDIF
	ENDDO
 
c So now we have a 1-dimension array cresp1d, with ien elements, and 
c energies specified by the 2-dimensional egrd array.

        
c -------------------------------------------------------------------
c ------------- Perform Remapping onto ARF energy grid --------------

c Optional dump ...
        IF (chat .GE. 5) THEN
           CALL fcecho('Interpolated collimator response:')
           msg = '   E_lo       E_hi     Response'
           CALL fcecho(msg)
        ENDIF
        
	DO i = 1, ien
	   egrd_lo(i) = egrd(1,i)
	   egrd_hi(i) = egrd(2,i)
           IF (chat .GE. 5) THEN
             WRITE(msg,'(1Xf8.4,3x,f8.4,3x,f8.6)')
     &             egrd_lo(i), egrd_hi(i), cresp1d(i)
              CALL fcecho(msg)
           ENDIF
	ENDDO
	acc = 999
        mode = 3

C remap the collimator energy grid onto the ARF's:
	CALL rmap1d(chat, ien, egrd_lo, egrd_hi,  cresp1d,
     &	  inarf_nen, MEMR(inarf_lo_energy), MEMR(inarf_hi_energy), 
     &	  cresp_out, mode, acc, ierr)
      	IF(ierr.NE.0) THEN
		GOTO 999
	ENDIF
C Multiply the extraction from the coll. cube by the effective area.
        CALL multarr(inarf_nen,MEMR(inarf_resp),cresp_out,
     &    MEMR(O_vector))

C This should multiply the collimator cube by the INPUT ARF.
	
        IF (chat .GE. 20) THEN
           msg = 'done with multiplication'
           CALL fcecho(msg)
        ENDIF
        
C Output the .arf file (inherited from ROSAT tool PCARF)
C     Output a null primary header

      if(arfversn(1:1).EQ.'1')THEN
C             ... Open the FITS file and write a null primary header

c %%% Start of IMG Addition -------------
        CALL opnPA(outarf, chat, ounit, clobber, ierr)
c %%% END of IMG Addition -------------

            if(ierr.NE.0) THEN
                  ierr = 5
                  GOTO 998
            ENDIF
C             ... Add additional keywords to Primary Header
              CALL FTPKYS(ounit,'CREATOR', taskname,
     &             's/w task which wrote this dataset', ierr)

              CALL FTPKYS(ounit,'CONTENT','ANCILLARY RESP',
     &             'SPECRESP extension', ierr)
        ELSE
              msg = errstr2 // 'Unknown format: '// arfversn
              CALL fcecho(msg)
              ierr = 1
              GOTO 998
        ENDIF

C  Now do SPECRESP Extension

      if(arfversn(1:1).EQ.'1')THEN
C     ... Write the SPECRESP extension within ARF file
        hist(1) = 'Produced by ' // taskname // '.'
        hist(2) = colhist(1:80)
        hist(3) = arfhist(1:80)
        WRITE(hist(4), '((A), SP,F8.4, (A), SP,F8.4)')
     &    'Input spacecraft coords: Y=', sccoor(2), ' Z=', sccoor(3)
        hist(5) = 'XTE attitude/filter file: ' // xtefilt // ','
        WRITE(hist(6), '((A), F9.5, (A), SP,F9.5)')
     &     'Input source position: RA=', ra, ' Dec=', dec
        nk_hist = 6
        
        nk_comm = 0        
        CALL wtarf1(ounit, chat,
     &    nk_hist, hist,
     &    nk_comm, comment,arfversn,phafil,
     &    inarf_telescop, inarf_instrume, inarf_detnam,
     &    inarf_filter, inarf_nen, inarf_nen, MEMR(inarf_lo_energy),
     &    MEMR(inarf_hi_energy), MEMR(o_vector), ierr)
         if(ierr.NE.0) GOTO 876

C (Note that HDUCLAS2=SPECRESP was already written to the output file
C by wtarf1.f. IF this is not appropriate, override the keyword here).
         
         CALL FTPKYS(ounit,'CREATOR', taskname,
     &     's/w task which wrote this dataset',ierr)

C Write the spacecraft coordinates actually used into the ARF as keywords:

         CALL FTPKYS(ounit, 'CSYSNAME', 'XMA_CART',
     &     'Coordinate system', status)
         CALL FTPKYF(ounit, 'ALPHA', sccoor(2), 5,
     &     'RXTE spacecraft Y coordinate', status)
         CALL FTPKYF(ounit, 'BETA', sccoor(3),  5,
     &     'RXTE spacecraft Z coordinate', status)

         msg = 'Energ_lo  Energ_hi   Collimator Response'
         CALL FTPCOM(ounit, msg, ftstatus)
         DO i = 1, ien
           WRITE(msg,'(1X, F8.4, 2X, F8.4, 4X, F9.6)')
     &       egrd_lo(i), egrd_hi(i), cresp1d(i)
           CALL FTPCOM(ounit, msg, ftstatus)
         ENDDO
         
         CALL ftpcks(ounit,ftstatus)

      ELSE
         msg = errstr2  //  'Unknown format: ' //  arfversn
         CALL fcecho(msg)
         ierr = 1
         GOTO 998
      ENDIF

C ----------------- finished SPECRESP EXTENSION ----------------------------

876            CONTINUE

C Close the FITS file
        CALL ftclos(ounit, ierr) 
      if(ierr.NE.0) THEN
            ierr = 6
            GOTO 998
      ENDIF

        
C Exit subroutine
998   CONTINUE
999   CONTINUE 
      IF (ierr .NE. 0) CALL fcerrm(ftstatus)
      IF (ftstatus .NE. 0) CALL fcerrm(ftstatus) 
	RETURN
	END
C ***********************************************************
C SUBROUTINE:
C	compkey
C
C DESCRIPTION:
C	compare the values for the telescop, instume and detector
C         keywords extracted from two FITS files
C
C AUTHOR:
C	James Lochner  5/95
C
C MODIFICATION HISTORY:
C     Aug 17, 1995 - allow b_detnam to have value ALL which matches
C                    any a_detnam value
C      
C NOTES:
C 
C USEAGE:
C 	CALL compkey (chatter, infil, a_telescop, a_instrume, a_detnam,
C             a_filter, b_name,b_telescop, b_instrume, b_detnam, b_filter,
C             ierr)
C
C ARGUMENTS:
C       chatter         - amount of chatter
C	infile		- name of file from which a_values extracted
C 	b_name		- type of file from which b_values extracted
C	a_,b_telescop	- value of TELESCOP keyword
C	a_,b_instrume	- value of INSTRUME keyword
C	a_,b_detnam	- value of DETNAM keyword
C	a_,b_filter	- value of FITLER keyword
C	ierr		- error status
C
C PRIMARY LOCAL VARIABLES:
C
C CALLED ROUTINES:
C	subroutine grab_name
C
C **************************************************************

      subroutine compkey(chatter, infil, a_telescop, a_instrume,
     &     a_detnam,a_filter,b_name,b_telescop,b_instrume,b_detnam,
     &     b_filter, ierr)

      IMPLICIT NONE
      CHARACTER*(*) infil, b_name
      CHARACTER*(*) a_telescop, a_instrume, a_detnam, a_filter
      CHARACTER*(*) b_telescop, b_instrume, b_detnam, b_filter
      INTEGER chatter, ierr
      INTEGER ifs, ife
      CHARACTER*160 message
      CHARACTER*12 errstr, wrnstr
      
      errstr = '** ERROR: '
      wrnstr = '** WARNING: '

      CALL grab_name(infil,ifs,ife)

      if(a_telescop .NE. b_telescop)THEN
         ierr = 1
         message=errstr // infil(ifs:ife) // ' telescope: '
         CALL fcecho(message)
c     CALL fcerr(message)
         message= a_telescop // 
     &        'doesn''t match' // b_name // 'telescope: ' // b_telescop
         CALL fcecho(message)
c     CALL fcerr(message)
      ENDIF

      if(a_instrume .NE. b_instrume)THEN
         ierr = 1
         message=errstr // infil(ifs:ife) // ' instrument ('
     &         // a_instrume // ') doesn''t match ' // b_name
     &         // ' instrument (' // b_instrume // ')'
c         CALL fcerr(message)
         CALL fcecho(message)
      ENDIF
      
      if(a_detnam .NE. b_detnam .AND. b_detnam .NE. 'ALL')THEN
c         ierr = 1
         message=wrnstr//infil(ifs:ife)//' detector ('//a_detnam//
     &        ') doesn''t match '//b_name//' detector ('
     &        //b_detnam//')'
c         CALL fcerr(message)
         CALL fcecho(message)
      ENDIF

998   IF (ierr .NE. 0) THEN
         message = errstr // 'Fatal'
         CALL fcecho(message)
      ENDIF

      RETURN
      END

C ***********************************************************
C SUBROUTINE:
C	grab_name
C
C DESCRIPTION:
C	extracts the meaningful name from a CHARACTER string (i.e. strips
C        out blanks)
C
C AUTHOR:
C	from "grab_meaningful_name" in pcarf.f 
C
C MODIFICATION HISTORY:
C
C NOTES:
C 
C USEAGE:
C      CALL grab_name(filfil,ifs,ife)
C
C ARGUMENTS:
C	infile	- name of file from which a_values extracted
C       ifs     - location of initial CHARACTER
C       ife     - location of final non-blank CHARACTER
C
C PRIMARY LOCAL VARIABLES:
C
C CALLED ROUTINES:
C
C **************************************************************

      subroutine grab_name(filfil,ifs,ife)

      IMPLICIT NONE
      CHARACTER*(*) filfil
      INTEGER ifs,ife,i
      DO i=160,1,-1
         if(filfil(i:i).NE.' ') GOTO 10
      ENDDO
 10   ife=i
      DO i=ife,1,-1
         if(filfil(i:i).eq.'/') GOTO 20
      ENDDO
      ifs=1
      RETURN
 20   ifs=i+1
      RETURN
      END
C *******************************************************************
C SUBROUTINE: 
C     multarr
C
C DESCRIPTION:      
C     multiplies 2 arrays and returns the product
C
C AUTHOR:
C     James Lochner 5/95
C
C MODIFICATION HISTORY:
C
C NOTES:
C     actual size of output array is the size of the first array
C
C USEAGE:
C     CALL multarr(n1, array1, array2, prodct)
C
C ARGUMENTS:
C     n1        - size of input arrays
C     array1	- first array       
C     array2     - array to be multiplied
C     prodct    - array1 * array2
C
C PRIMARY LOCAL VARIABLES:
C
C CALLED SUBROUTINES:
C
C ********************************************************************

      SUBROUTINE multarr(n1, array1, array2, prodct)

      IMPLICIT NONE

      INTEGER n1
      REAL array1(n1), array2(n1), prodct(n1)

      INTEGER i
      
      DO i = 1, n1
        prodct(i) = array1(i) * array2(i)
      ENDDO

      RETURN
      END

C -------------------------------------------------------------------------
*+ CK_ARF
      subroutine CK_ARF(chatter, arffil, iunit, extno, telescop,
     &  instrume, detnam, filter,
     &            ienerg, arfclas2, csys, ierr)

C Locates an effective area extension in an ARF and reads various keywords
      
      IMPLICIT NONE
      INTEGER chatter, ierr, iunit, ienerg
      CHARACTER*(*) arffil, instrume, telescop
      CHARACTER*(*) detnam, filter
      CHARACTER*(*) arfclas2
      CHARACTER*(*) csys

C Description
C   Subroutine to perform an initial check out the inputarf file presented 
C to hxtarf, determine whether there is a arf extension present. IF an 
C acceptable extension is found a bunch of instrument-related keywords are 
C read from its header.
C   The file is left open and scrolled to the extension ifan acceptable
C extension is found, otherwise the file is CLOSED
C
C Passed Parameters
C  CHATTER          i   : Chattiness flag (<5 quiet, >15 noisey)
C  ARFFIL           i   : PHA filename (optionally incl extension #)
C  IUNIT              o : The Unit number of the ARF file
C  TELESCOP           o : Value of the TELESCOP keyword from located extn
C  INSTRUME           o : Value of the INSTRUME keyword from located extn
C  DETNAM             o : Value of the DETNAM keyword (or 'NONE')
C  FILTER             o : Value of the FILTER keyword (or 'NONE')
C  IENERG             o : Number of incident energy bins in the matrix
C  arfclas2           o : CHARACTER string giving type of response
C  IERR               o : Subroutine error flag (zero = OK)
C
C CALLed Routines
C
C Author/Modification History
C  Philip R. Blanco (1.0.0:96 Nov 11), adapted from CK_RMF 2.0.0      
C  M Tripicco (1.0.1:03 Aug 15) fixed errflg vs status bug 

      CHARACTER*7 version
      PARAMETER (version='1.0.1')
*-
C Max arrays
      INTEGER maxextn
      PARAMETER (maxextn=99)
C Internals
      INTEGER  status
      INTEGER ninstr, nsearch
      INTEGER next(maxextn)
      CHARACTER*20 instr(9)
      CHARACTER*20 outhdu(9,maxextn), outver(9,maxextn)
      CHARACTER*20 extnam(maxextn)
      CHARACTER*30 errstr, wrnstr, comm
      CHARACTER*80 message
      INTEGER errflg
      INTEGER extno, block
C Initialize
      ierr = 0 
             errstr = '** CK_ARF '//version//' ERROR:'
             wrnstr = '** CK_ARF '//version//' WARNING:'
C Start 

C ... give user info IF requested
        if(chatter.GT.40) THEN
           message = ' ... using CK_ARF '// version
           CALL fcecho(message)
        ENDIF

C -------------------------- SPECRESP extension --------------------
C Find the HDUCLAS=RESPONSE/EFF_AREA, or EXTNAME=SPECRESP extension

        ninstr = 2
        instr(1) = 'RESPONSE'
        instr(2) = 'EFF_AREA'
        nsearch = maxextn

        status = 0
        errflg = 0
        call cgetlun(iunit)
        call ftopen(iunit,arffil,0,block,status)
        IF (status.NE.0) THEN
          message =errstr // 'error opening infile '//arffil
          call fcecho(message)
          ierr=status
          RETURN
        ENDIF

C Move to the specified extension (if extnum > 0), or to
C a suitable extension with the right HDUCLAS and EXTNAME keywords.
        
        CALL mver(iunit,extno,ninstr,instr,
     &    nsearch,next,outhdu,extnam,outver,
     &    'SPECRESP',errflg,chatter)
        if(errflg.NE.0) THEN
          message = errstr // ' Unable to recover'
          CALL fcecho(message)
          CALL ftclos(iunit, status) 
          ierr=errflg
          RETURN
        ENDIF

C Set the ARF Class to the value of the relevant HDUCLASn keyword.
      arfclas2 = outhdu(2,1)

C --------- Read the necessary keywords -----------------
C NAXIS2:      
      status = 0
      CALL ftcmsg()
      CALL ftgkyj(iunit,'NAXIS2',ienerg,comm,status)
      message = errstr//' reading NAXIS2 value '
      IF (status.NE.0) THEN
        ierr = 4
        CALL fcecho(message)
      GOTO 483
      ENDIF

C TELESCOP ...
      status = 0
      CALL ftcmsg()
      telescop = 'UNKNOWN'
      CALL ftgkys(iunit,'TELESCOP',telescop,comm,status)
      IF (status.EQ.202) THEN
         telescop = 'UNKNOWN'
         status=0
         CALL ftcmsg()
      ELSE IF (status.NE.0) THEN
         message = errstr//' reading TELESCOP'
         CALL fcerr(message)
         CALL fcerrm(status)
      ENDIF

C INSTRUME ...
      status = 0
      CALL ftcmsg()
      instrume = 'UNKNOWN'
      CALL ftgkys(iunit,'INSTRUME',instrume,comm,status)
      IF (status.EQ.202) THEN
         instrume = 'UNKNOWN'
         status=0
         CALL ftcmsg()
      ELSE IF (status.NE.0) THEN
         message = errstr//' reading INSTRUME'
         CALL fcerr(message)
         CALL fcerrm(status)
      ENDIF

C DETNAM ...
      status = 0
      CALL ftcmsg()
      CALL ftgkys(iunit,'DETNAM',detnam,comm,status)
      IF (status.EQ.202) THEN
         detnam = 'UNKNOWN'
         status=0
         CALL ftcmsg()
      ELSE IF (status.NE.0) THEN
         message = errstr//' reading DETNAM'
         CALL fcerr(message)
         CALL fcerrm(status)
      ENDIF

C FILTER ...
      status = 0
      CALL ftcmsg()
      CALL ftgkys(iunit,'FILTER',filter,comm,status)
      IF (status.EQ.202) THEN
         filter = 'UNKNOWN'
         status=0
         CALL ftcmsg()
      ELSE IF (status.NE.0) THEN
         message = errstr//' reading FILTER'
         CALL fcerr(message)
         CALL fcerrm(status)
       ENDIF

C Check that the input file is given in on-axis detector coordinates
       CALL FTGKYS(iunit, 'CSYSNAME', csys, comm, status)
       IF (status .EQ. 202) THEN
         csys = 'UNKNOWN'
         status = 0
         CALL FTCMSG()
       ENDIF

C Check for errors
483     IF (ierr.NE.0) THEN
          message = errstr // ' Unable to recover.'
          CALL fcecho(message)
          CALL ftclos(iunit, status) 
          RETURN
        ENDIF

      RETURN
      END
