SUBROUTINE ldaped(itype, itval, nmtval, nmelt, icont, icenerg,
     &                  iconel, iconpt, iconsiz, ipseudo, ipenerg, 
     &                  ipsupt, ipsusiz, ilineE, ilineEm, ilineEl, 
     &                  ilinpt, ilinsiz, status)

      INTEGER itype, itval, nmtval, nmelt, icont, icenerg
      INTEGER iconEl, iconpt, iconsiz, ipseudo, ipenerg, ipsupt
      INTEGER ipsusiz, ilineE, ilineEm, ilineEl, ilinpt
      INTEGER ilinsiz, status

C Subroutine to read the APED style plasma model files.
C Arguments :
C     itype      I       i: type of plasma emission file
C     itval      I       r: pointer to array of tabulated temperatures
C     nmtval     I       r: number of tabulated temperatures
C     nmelt      I       r: number of tabulated elements
C     icont      I       r: Tabulated continua
C     icenerg    I       r: Energies for tabulated continua
C     iconl      I       r: Atomic numbers for tabulated elements
C     iconpt     I       r: Offsets in the cont array for each Z and kT
C     iconsiz    I       r: Sizes in the cont array for each Z and kT
C     ipseudo    I       r: Tabulated pseudo-continua
C     ipenerg    I       r: Energies for tabulated pseudo-continua
C     ipsupt     I       r: Offsets in the pseudo array for each Z and kT
C     ipsusiz    I       r: Sizes in the pseudo array for each Z and kT
C     ilineE     I       r: Tabulated line energies
C     ilineEm    I       r: Tabulated line emissivities
C     ilineEl    I       r: Tabulated line elements
C     ilinpt     I       r: Offsets in the line arrays for each kT
C     ilinsiz    I       r: Sizes in the line arrays for each kT

      INCLUDE '../../inc/xspec.inc'

      INTEGER ncont, npseudo, nlines, lenn, i, lentmp
      INTEGER iocont, ioline, index, ibuf, icol, hdutyp

      CHARACTER contfil*255, linefil*255, contxt*255, datdir*255
      CHARACTER comment*80, extnam*20, tmpstr*255
      CHARACTER pname*128, pvalue*128, ovalue*128

      LOGICAL qanyf, qexist

      INTEGER lenact
      CHARACTER fgdatd*128, fgmstr*128
      EXTERNAL lenact, fgdatd, fgmstr

      SAVE ovalue

      DATA ovalue /' '/

c Set the names of the input files and open them. Note that for APEC
c we check for the APECROOT string model parameter to allow the user
c to substitute different _coco and _line tables.

      datdir = fgdatd()
      lenn = lenact(datdir)
      pname = 'APECROOT'
      pvalue = fgmstr(pname)
      lentmp = lenact(pvalue)

      IF ( itype .EQ. 1 ) THEN
         contfil = datdir(:lenn)//'RS93_newx.fits'
         linefil = datdir(:lenn)//'RS93_line.fits'
      ELSEIF ( pvalue .EQ. ' ' ) THEN
         contfil = datdir(:lenn)//'apec_v1.3.1_coco.fits'
         linefil = datdir(:lenn)//'apec_v1.3.1_line.fits'
      ELSE

c if APECROOT has been set first test whether only a version number has
c changed. Then assume that only a root filename has been given. If neither
c these work then assume that an entire directory path was included.

         contfil = datdir(:lenn)//'apec_v'//
     &             pvalue(:lentmp)//'_coco.fits'
         linefil = datdir(:lenn)//'apec_v'//
     &             pvalue(:lentmp)//'_line.fits'
         inquire(file=contfil, exist=qexist)
         IF ( .NOT.qexist ) THEN
            contfil = datdir(:lenn)//pvalue(:lentmp)//'_coco.fits'
            linefil = datdir(:lenn)//pvalue(:lentmp)//'_line.fits'
            inquire(file=contfil, exist=qexist)
            IF ( .NOT.qexist ) THEN
               contfil = pvalue(:lentmp)//'_coco.fits'
               linefil = pvalue(:lentmp)//'_line.fits'
            ENDIF
         ENDIF
         IF ( ovalue .NE. pvalue ) THEN
            ovalue = pvalue
            contxt = 'Reading APEC data from '//pvalue(:lentmp)
            CALL xwrite(contxt,10)
         ENDIF
      ENDIF

      CALL getlun(iocont)
      CALL ftopen(iocont, contfil, 0, index, status)
      IF ( status .NE. 0 ) THEN
         contxt = 'Failed to open '//contfil(:lenact(contfil))
         CALL xwrite(contxt, 10)
         WRITE(contxt, '(a,i4)') 'Error in LDAPED : status = ', status
         CALL xwrite(contxt, 10)
         CALL frelun(iocont)
         RETURN
      ELSE
         contxt = 'Loading contents of '//contfil(:lenact(contfil))
         CALL xwrite(contxt, 15)
      ENDIF


      CALL getlun(ioline)
      CALL ftopen(ioline, linefil, 0, index, status)
      IF ( status .NE. 0 ) THEN
         contxt = 'Failed to open '//linefil(:lenact(linefil))
         CALL xwrite(contxt, 10)
         WRITE(contxt, '(a,i4)') 'Error in LDAPED : status = ', status
         CALL xwrite(contxt, 10)
         CALL frelun(ioline)
         RETURN
      ELSE
         contxt = 'Loading contents of '//linefil(:lenact(linefil))
         CALL xwrite(contxt, 15)
      ENDIF

C First scan the files to get the number of temperatures and elements
C and to find the sizes of arrays that will be required. First the
C continuum data

      ncont = 0
      npseudo = 0
      nmtval = 0

      CALL ftmrhd(iocont, 1, hdutyp, status)

      DO WHILE ( status .EQ. 0 )

         CALL ftgkys(iocont, 'EXTNAME', extnam, comment, status)
         WRITE(contxt, '(a,i6)') 
     &    'Failed to read EXTNAME for temperature #', nmtval
         IF ( status .NE. 0 ) GOTO 999

         IF ( extnam .EQ. 'EMISSIVITY' ) THEN

            nmtval = nmtval + 1

            CALL ftgkyj(iocont, 'NAXIS2', nmelt, comment, status)
            WRITE(contxt, '(a,i6)') 
     &       'Failed to read NAXIS2 for temperature #', nmtval
            IF ( status .NE. 0 ) GOTO 999

c Sum up the continuum elements required

            CALL ftgcno(iocont, .false., 'N_Cont', icol, status)
            WRITE(contxt, '(a,i6)') 
     &       'Failed to find N_Cont column for temperature #', nmtval
            IF ( status .NE. 0 ) GOTO 999
         
            DO i = 1, nmelt
               CALL ftgcvj(iocont, icol, i, 1, 1, 0, ibuf, qanyf, 
     &                     status)
               WRITE(contxt, '(a,i6,i6)') 
     &          'Failed to read N_Cont : ', nmtval, i
               IF ( status .NE. 0 ) GOTO 999
               ncont = ncont + ibuf
            ENDDO

c Sum up the pseudo-continuum elements required

            CALL ftgcno(iocont, .false., 'N_Pseudo', icol, status)
            WRITE(contxt, '(a,i6)') 
     &    'Failed to find N_Pseudo column for temperature #', nmtval
            IF ( status .NE. 0 ) GOTO 999
         
            DO i = 1, nmelt
               CALL ftgcvj(iocont, icol, i, 1, 1, 0, ibuf, qanyf, 
     &                     status)
               WRITE(contxt, '(a,i6,i6)') 
     &          'Failed to read N_Pseudo : ', nmtval, i
               IF ( status .NE. 0 ) GOTO 999
               npseudo = npseudo + ibuf
            ENDDO

         ENDIF

c Move on to the next extension

         CALL ftmrhd(iocont, 1, hdutyp, status)

      ENDDO
      status = 0

C Now the line data - this is easier since we only need the NAXIS2 for
C each extension

      nlines = 0

      CALL ftmrhd(ioline, 1, hdutyp, status)

      DO WHILE ( status .EQ. 0 )

         CALL ftgkys(iocont, 'EXTNAME', extnam, comment, status)
         WRITE(contxt, '(a,i6)') 
     &    'Failed to read EXTNAME for temperature #', nmtval
         IF ( status .NE. 0 ) GOTO 999

         IF ( extnam .EQ. 'EMISSIVITY' ) THEN

            CALL ftgkyj(ioline, 'NAXIS2', ibuf, comment, status)
            WRITE(contxt, '(a,i6)')
     &       'Failed to read NAXIS2 for temperature #', i
            IF ( status .NE. 0 ) GOTO 999

            nlines = nlines + ibuf

         ENDIF

         CALL ftmrhd(ioline, 1, hdutyp, status)

      ENDDO
      status = 0

C Reset both files to the primary HDU

      CALL ftmahd(iocont, 1, hdutyp, status)
      contxt = 'Failed to move back to continuum file primary header'
      IF ( status .NE. 0 ) GOTO 999

      CALL ftmahd(ioline, 1, hdutyp, status)
      contxt = 'Failed to move back to line file primary header'
      IF ( status .NE. 0 ) GOTO 999

C Grab the memory that will be needed

      CALL udmget(nmtval, 6, itval, status)
      contxt = 'Failed to get memory for tval array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(ncont, 6, icont, status)
      contxt = 'Failed to get memory for cont array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(ncont, 6, icenerg, status)
      contxt = 'Failed to get memory for cenerg array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nmelt, 4, iconEl, status)
      contxt = 'Failed to get memory for conEl array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nmtval*nmelt, 4, iconpt, status)
      contxt = 'Failed to get memory for conpt array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nmtval*nmelt, 4, iconsiz, status)
      contxt = 'Failed to get memory for consiz array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(npseudo, 6, ipseudo, status)
      contxt = 'Failed to get memory for pseudo array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(npseudo, 6, ipenerg, status)
      contxt = 'Failed to get memory for penerg array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nmtval*nmelt, 4, ipsupt, status)
      contxt = 'Failed to get memory for psupt array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nmtval*nmelt, 4, ipsusiz, status)
      contxt = 'Failed to get memory for psusiz array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nlines, 6, ilineE, status)
      contxt = 'Failed to get memory for lineE array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nlines, 6, ilineEm, status)
      contxt = 'Failed to get memory for lineEm array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nlines, 4, ilineEl, status)
      contxt = 'Failed to get memory for lineEl array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nmtval, 4, ilinpt, status)
      contxt = 'Failed to get memory for linpt array'
      IF ( status .NE. 0 ) GOTO 999

      CALL udmget(nmtval, 4, ilinsiz, status)
      contxt = 'Failed to get memory for linsiz array'
      IF ( status .NE. 0 ) GOTO 999

C Read the files and load the arrays

      CALL rdaped(iocont, ioline, nmtval, nmelt, ncont, npseudo,
     &            nlines, MEMR(itval), MEMR(icont), MEMR(icenerg),
     &            MEMI(iconEl), MEMI(iconpt), MEMI(iconsiz), 
     &            MEMR(ipseudo), MEMR(ipenerg), MEMI(ipsupt), 
     &            MEMI(ipsusiz), MEMR(ilineE), MEMR(ilineEm),
     &            MEMI(ilineEl), MEMI(ilinpt), MEMI(ilinsiz), status)
      contxt = 'Failure in RDAPED'
      IF ( status .NE. 0 ) GOTO 999

 999  CONTINUE

C Close the files and release the unit numbers. This is after the break-out
c point from errors to ensure that everything gets shut down correctly.

      CALL ftclos(iocont, status)
      CALL frelun(iocont)

      CALL ftclos(ioline, status)
      CALL frelun(ioline)

      IF ( status .NE. 0 ) THEN
         CALL xwrite(contxt, 10)
         WRITE(contxt, '(a,i4)') 'Error in LDAPED : status = ', status
         CALL xwrite(contxt, 10)
      ENDIF

      RETURN
      END