
      SUBROUTINE flx2xp

c A program to take an ASCII file of fluxes with errors on particular
c energy ranges and turn it into FITS spectral and response files for
c XSPEC.

c kaa 3/31/95 - 11/2/98
c kaa 10/11/06   modified to allow multiple input spectra which are
c                written to a typeII file

      INTEGER nenrgy, nspec, status

      CHARACTER*255 infile, phafil, rspfil, contxt
      CHARACTER*255 bckfil, corfil, ancfil
      CHARACTER*70 cjunk
      CHARACTER*16 telescop, instrume, detnam, filter, hduclas2

      LOGICAL qclobber

c Pointers for dynamic arrays

      INTEGER enlow, enhigh, flux, error, matrix
      INTEGER channel, ngrp, nchan, fchan

* Dynamic memory allocation stuff

      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     datatype gives a symbolic code for the data type, e.g.,  4 = Integer*4
C     1 is boolean
C     3 is short integer
C     4 is integer
C     5 is long integer
C     6 is single precision real
C     7 is double precision real
C     8 complex

      CHARACTER*40 taskname
      COMMON / task / taskname

      DATA telescop, instrume, detnam, filter/4*'none'/

      CALL fcecho('FLX2XSP  vers 1.10 11 Oct 2006.')

      taskname = 'flx2xsp v1.10'

c get the parameters from the "flx2xsp.par" file 

      status = 0
      CALL gpf2xs(infile, phafil, rspfil, nspec, qclobber, status)
      contxt = 'Error in getting parameters'
      IF ( status .NE. 0 ) GOTO 999

c Read the input ASCII file to get the number of channels/energy bins

      CALL gtnen(infile, nenrgy, contxt, status)
      IF ( status .NE. 0 ) GOTO 999

      WRITE(contxt, '(i8, a)') nenrgy, ' rows read from ASCII file'
      CALL fcecho(contxt)

c Grab the memory for the arrays required

      enlow = 0
      enhigh = 0
      flux = 0
      error = 0
      matrix = 0
      channel = 0
      ngrp = 0
      nchan = 0
      fchan = 0

      CALL udmget(nenrgy, 6, enlow, status)
      contxt = 'Insufficient memory for enlow array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nenrgy, 6, enhigh, status)
      contxt = 'Insufficient memory for enhigh array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nenrgy*nspec, 6, flux, status)
      contxt = 'Insufficient memory for flux array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nenrgy*nspec, 6, error, status)
      contxt = 'Insufficient memory for error array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nenrgy, 6, matrix, status)
      contxt = 'Insufficient memory for matrix array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nenrgy*nspec, 4, channel, status)
      contxt = 'Insufficient memory for channel array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nenrgy, 4, ngrp, status)
      contxt = 'Insufficient memory for ngrp array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nenrgy, 4, nchan, status)
      contxt = 'Insufficient memory for nchan array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nenrgy, 4, fchan, status)
      contxt = 'Insufficient memory for fchan array'
      IF ( status .NE. 0 ) GOTO 999

c Read the input ASCII file and set the various array values

      CALL rdasci(infile, nenrgy, nspec, MEMR(enlow), MEMR(enhigh), 
     &            MEMR(flux), MEMR(error), MEMR(matrix), MEMI(channel),
     &            MEMI(ngrp), MEMI(nchan), MEMI(fchan), contxt, status)
      IF ( status .NE. 0 ) GOTO 999

c open the spectrum file and initialize the primary header

      IF ( qclobber ) CALL clobber(phafil, status)
      CALL ftinit(1, phafil, 1, status)
      contxt = ' Failed to open output PHA file'
      IF ( status .NE. 0 ) GOTO 999

      CALL ftpdef(1, 8, 0, 0, 0, 1, status)
      CALL ftphpr(1, .TRUE., 8, 0, 0, 0, 1, .TRUE., status)
      contxt = ' Failed to initialize output PHA file'
      IF ( status .NE. 0 ) GOTO 999

c write out the spectrum extension to the PHA file

      hduclas2 = 'NET'
      bckfil = 'none'
      corfil = 'none'
      ancfil = 'none'
      CALL wtpha3(1, 10, nspec, 0, cjunk, 0, cjunk, telescop, instrume, 
     &            detnam, filter, '1.1.0', hduclas2, 1, 1., .FALSE.,
     &            1., .FALSE., bckfil, .FALSE., 1., .FALSE., corfil, 
     &            1., .FALSE., rspfil, .FALSE., ancfil, nenrgy, 'PI', 
     &            MEMI(channel), MEMR(flux), 2, .TRUE., MEMR(error), 
     &            .FALSE., MEMR(error), .FALSE., MEMI(channel),
     &            .FALSE., MEMI(channel), nenrgy, status)
      contxt = ' Failed to write spectrum extension to output PHA file'
      IF ( status .NE. 0 ) GOTO 999

      CALL ftclos(1, status)
      contxt = ' Failed to close output PHA file'
      IF ( status .NE. 0 ) GOTO 999

c open the the response file and initialize the primary header

      IF ( qclobber ) CALL clobber(rspfil, status)
      CALL ftinit(1, rspfil, 1, status)
      contxt = ' Failed to open output RSP file'
      IF ( status .NE. 0 ) GOTO 999

      CALL ftpdef(1, 8, 0, 0, 0, 1, status)
      CALL ftphpr(1, .TRUE., 8, 0, 0, 0, 1, .TRUE., status)
      contxt = ' Failed to initialize output RSP file'
      IF ( status .NE. 0 ) GOTO 999

c write out the "energy bounds" extension for the response file

      CALL wtebd3(1, 10, 0, cjunk, 0, cjunk, '1.2.0', telescop, 
     &            instrume, detnam, filter, 1., 'PI', 1, nenrgy, 
     &            MEMR(enlow), MEMR(enhigh), status)
      contxt = 
     & ' Failed to write energy bounds extension to output RSP file'
      IF ( status .NE. 0 ) GOTO 999

c write out the "matrix" extension for the response file

      CALL wtrmf4(1, 10, 0, cjunk, 0, cjunk, '1.3.0', 
     &            'SPECRESP MATRIX', telescop,
     &            instrume, detnam, filter, 1., 'PI', 1, nenrgy, 
     &            nenrgy, nenrgy, nenrgy, MEMR(enlow), MEMR(enhigh), 
     &            MEMI(ngrp), MEMI(fchan), MEMI(nchan), 
     &            .FALSE., 1, MEMR(matrix), 1.e-6, status)
      contxt = 
     & ' Failed to write matrix extension to output RSP file'
      IF ( status .NE. 0 ) GOTO 999

      CALL ftclos(1, status)
      contxt = ' Failed to close output RSP file'
      IF ( status .NE. 0 ) GOTO 999

c if necessary write out the error message

 999  CONTINUE

      IF ( status .NE. 0 ) THEN
         CALL fcerr(contxt)
         CALL fcerrm(status)
      ENDIF

      RETURN

      END

