C------------------------------------------------------------------------------
C       The following subroutines are part of the FITSIO subroutine library
C       and are specific to IBM main frame computers.
C------------------------------------------------------------------------------
C       IMPORTANT USAGE NOTES:
C          
C  1.  This library has been tested successfully under the IBM CMS operating 
C      system.
C
C  2.  When compiling the FITSIO file, one must specify a longer maximum
C      character string length as follows:
C
C      fortvs fitsio (charlen(28800))
C
C  3.  One must declare the maximum number of records in any newly created 
C      FITS files with a JCL line similar to the following:
C
C      FILEDEF FILENAME DISK FILENAME FITS A6 (XTENT 100 PERM)
C
C      where 'FILENAME' is the name of the FITS file to be created, and
C      the integer following 'XTENT' is the number of records in the file.
C------------------------------------------------------------------------------
C   This software was prepared by High Energy Astrophysic Science Archive
C   Research Center (HEASARC) at the NASA Goddard Space Flight Center. Users
C   shall not, without prior written permission of the U.S. Government,
C   establish a claim to statutory copyright.  The Government and others acting
C   on its behalf, shall have a royalty-free, non-exclusive, irrevocable,
C   worldwide license for Government purposes to publish, distribute,
C   translate, copy, exhibit, and perform such material.
C------------------------------------------------------------------------------
          subroutine ftopnx(funit,fname,oldnew,rwmode,block,status)

C       low-level, machine-dependent routine to create and open a new file 
C
C       funit   i  Fortran I/O unit number
C       fname   c  name of file to be opened
C       oldnew  i  file status: 0 = open old/existing file; else open new file
C       rwmode  i  file access mode: 0 = readonly; else = read/write
C       block   i  FITS record blocking factor 
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991

        integer funit,oldnew,rwmode,block,status
        integer i,ibuff,recln
        character*(*) fname
        character fstat*3
        logical found

C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 12)
        parameter (ne = 128)
        integer bufnum,bufpnt,reclen,recnum,bytnum
        integer chdu,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        logical wrmode,modify
        real compid
        common/ft0001/bufnum(199),bufpnt(nb),reclen(199),recnum(nb),
     &  bytnum(nb),wrmode(nb),modify(nb),chdu(nb),maxhdu(nb),
     &  hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),compid
C-------END OF COMMON BLOCK DEFINITIONS-----------------------------------

C       the following statement forces the BLOCK DATA FTBKDT module to be
C       loaded by the linker if it is not already loaded.
        external ftbkdt

        if (status .gt. 0)return

C       check for valid unit number
        if (funit .lt. 1 .or. funit .gt. 199)then
                status=101
                return
        end if

C       find available buffer slot for this file
        do 10 i=1,nb
                if (bufpnt(i) .eq. 0)then
                        ibuff=i
                        go to 20
                end if
10      continue

C       error: no vacant buffer slots left
        status=102
        return

20      continue
        if (oldnew .eq. 0)then
                fstat='OLD'
                inquire(file=fname,exist=found,recl=recln)
                if (.not. found)then
C                       error: file doesn't exist??
                        status=103
                        return
                end if

C               compute blocking factor (not accurate if not a multiple of 2880)
                block=recln/2880
                if (block*2880 .ne. recln)then
C                       record length is not an integer multiple of 2880
C                       so return actual record length in block
                        block=recln
                end if

C               store the record length
                reclen(funit)=recln
        else
                fstat='NEW'
                if (block .lt. 0 .or. block .gt. 28800)then
C                       illegal record blocking factor
                        status=109
                        return
C               set multiple of 2880-byte record length (= 720 4-byte words)
                else if (block .le. 1)then
                        reclen(funit)=2880
                else if (block .le. 10)then
C                       if 0 < block < 11, then this is logical blocking factor
                        reclen(funit)=2880*block
                else
C                       if block >10 then this is actual record length in bytes
                        reclen(funit)=block
                end if
        end if

C       support for larger blocking factors was removed in Oct 1992 in V3.22
        if (reclen(funit) .gt. 2880)then
                status=109
                return
        end if
        
        if (rwmode .eq. 0)then
C               open with read only access
                wrmode(ibuff)=.false.
                open(unit=funit,file=fname,status=fstat,err=900,
     &          recl=reclen(funit),form='UNFORMATTED',access='DIRECT')
        else
C               open file with read and write access
                wrmode(ibuff)=.true.
                open(unit=funit,file=fname,status=fstat,err=900,
     &          recl=reclen(funit),form='UNFORMATTED',access='DIRECT')
        end if

C       initialize various parameters about the CHDU
        recnum(ibuff)=0
        bytnum(ibuff)=0
        modify(ibuff)=.false.
        chdu(ibuff)=1
        maxhdu(ibuff)=1
        hdstrt(ibuff,1)=0
        hdend(ibuff)=0
        nxthdr(ibuff)=0
C       data start location is undefined
        dtstrt(ibuff)=-1000000000
C       store internal buffer number to use for this file
        bufnum(funit)=ibuff
C       store inverse pointer: tells which unit is attached to this buffer
        bufpnt(ibuff)=funit
        return

C       error opening file:
900     continue
        if (fstat .eq. 'OLD')then
                status=104
        else
                status=105
        end if
        end
C--------------------------------------------------------------------------
        subroutine ftclsx(iunit,status)

C       low level routine to close a file
C
C       iunit   i  Fortran I/O unit number
C       status  i  returned error status (0=ok)
C
C       written by Wm Pence, HEASARC/GSFC, Aug 1992

        integer iunit,status

C-------COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 12)
        parameter (ne = 128)
        integer bufnum,bufpnt,reclen,recnum,bytnum
        integer chdu,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        logical wrmode,modify
        real compid
        common/ft0001/bufnum(199),bufpnt(nb),reclen(199),recnum(nb),
     &  bytnum(nb),wrmode(nb),modify(nb),chdu(nb),maxhdu(nb),
     &  hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),compid
C       END OF COMMON BLOCK DEFINITIONS---------------------------------------

        integer ibuff

C       reset file pointers
        ibuff=bufnum(iunit)
        bufnum(iunit)=0
        bufpnt(ibuff)=0

        close(iunit,err=900)
        return

900     continue
C       set error code, if it has not previous been set
        if (status .le. 0)status=110
        end
C----------------------------------------------------------------------
        subroutine ftgsdt(dd,mm,yy,status)

C       get the current date from the system

C       dd      i  day of the month (1-31)
C       mm      i  month of the year (1-12)
C       yy      i  last 2 digits of the year (1992 = 92, 2001 = 01)

        integer dd,mm,yy,status
        integer iarray(8)

        if (status .gt. 0)return

C       the following is the IBM Fortran routine to get the system date:
        call datim(iarray)
        
        dd=iarray(6)
        mm=iarray(7)
        yy=iarray(8)-(iarray(8)/100)*100

        end
C----------------------------------------------------------------------
        subroutine ftpi2b(ounit,nvals,incre,i2vals,status)

C       Write an array of Integer*2 bytes to the output FITS file.
C       Does any required translation from internal machine format to FITS.

        integer nvals,incre,ounit,status,i,offset
        integer*2 i2vals(nvals)

C       ounit   i  fortran unit number
C       nvals   i  number of pixels in the i2vals array
C       incre   i  byte increment between values
C       i2vals  i*2 array of input integer*2 values
C       status  i  output error status

        if (incre .le. 2)then
                call ftpbyt(ounit,nvals*2,i2vals,status)
        else
C               offset is the number of bytes to move between each value
                offset=incre-2
                do 10 i=1,nvals
                        call ftpbyt(ounit,2,i2vals(i),status)
                        call ftmoff(ounit,offset,.true.,status)                
10              continue
        end if
        end
C----------------------------------------------------------------------
        subroutine ftpi4b(ounit,nvals,incre,i4vals,status)

C       Write an array of Integer*4 bytes to the output FITS file.
C       Does any required translation from internal machine format to FITS.

        integer nvals,incre,ounit,status,i,offset
        integer i4vals(nvals)

C       ounit   i  fortran unit number
C       nvals   i  number of pixels in the i4vals array
C       incre   i  byte increment between values
C       i4vals  i  array of input integer*4 values
C       status  i  output error status

        if (incre .le. 4)then
                call ftpbyt(ounit,nvals*4,i4vals,status)
        else
C               offset is the number of bytes to move between each value
                offset=incre-4
                do 10 i=1,nvals
                        call ftpbyt(ounit,4,i4vals(i),status)
                        call ftmoff(ounit,offset,.true.,status)                
10              continue
        end if
        end
C----------------------------------------------------------------------
        subroutine ftpr4b(ounit,nvals,incre,r4vals,status)

C       Write an array of Real*4 bytes to the output FITS file.
C       Does any required translation from internal machine format to FITS.

        integer nvals,incre,ounit,status,i,offset
        real r4vals(nvals)

C       ounit   i  fortran unit number
C       nvals   i  number of pixels in the r4vals array
C       incre   i  byte increment between values
C       r4vals  r  array of input real*4 values
C       status  i  output error status

        call ftibr4(r4vals,nvals)
        if (incre .le. 4)then
                call ftpbyt(ounit,nvals*4,r4vals,status)
        else
C               offset is the number of bytes to move between each value
                offset=incre-4
                do 10 i=1,nvals
                        call ftpbyt(ounit,4,r4vals(i),status)
                        call ftmoff(ounit,offset,.true.,status)                
10              continue
        end if
        end
C----------------------------------------------------------------------
        subroutine ftpr8b(ounit,nvals,incre,r8vals,status)

C       Write an array of Real*8 bytes to the output FITS file.
C       Does any required translation from internal machine format to FITS.

        integer nvals,incre,ounit,status,i,offset
        double precision r8vals(nvals)

C       r8vals  d  array of input real*8 values
C       nvals   i  number of pixels in the r4vals array
C       ounit   i  fortran unit number
C       incre   i  byte increment between values
C       status  i  output error status

        call ftibr8(r8vals,nvals)
        if (incre .le. 8)then
                call ftpbyt(ounit,nvals*8,r8vals,status)
        else
C               offset is the number of bytes to move between each value
                offset=incre-8
                do 10 i=1,nvals
                        call ftpbyt(ounit,8,r8vals(i),status)
                        call ftmoff(ounit,offset,.true.,status)                
10              continue
        end if
        end
C----------------------------------------------------------------------
        subroutine ftgi2b(iunit,nvals,incre,i2vals,status)

C       Read an array of Integer*2 bytes from the input FITS file.
C       Does any required translation from FITS to internal machine format 

        integer nvals,iunit,incre,status,i,offset
        integer*2 i2vals(nvals)

C       iunit   i  fortran unit number
C       nvals   i  number of pixels to read
C       incre   i  byte increment between values
C       i2vals  i*2 output array of integer*2 values
C       status  i  output error status

        if (incre .le. 2)then
                call ftgbyt(iunit,nvals*2,i2vals,status)
        else
C               offset is the number of bytes to move between each value
                offset=incre-2
                do 10 i=1,nvals
                        call ftgbyt(iunit,2,i2vals(i),status)
                        call ftmoff(iunit,offset,.false.,status)
10              continue
        end if
        end
C----------------------------------------------------------------------
        subroutine ftgi4b(iunit,nvals,incre,i4vals,status)

C       Read an array of Integer*4 bytes from the input FITS file.
C       Does any required translation from FITS to internal machine format 

        integer nvals,iunit,incre,status,i,offset
        integer i4vals(nvals)

C       iunit   i  fortran unit number
C       nvals   i  number of pixels to read
C       incre   i  byte increment between values
C       i4vals  i  output array of integer values
C       status  i  output error status

        if (incre .le. 4)then
                call ftgbyt(iunit,nvals*4,i4vals,status)
        else
C               offset is the number of bytes to move between each value
                offset=incre-4
                do 10 i=1,nvals
                        call ftgbyt(iunit,4,i4vals(i),status)
                        call ftmoff(iunit,offset,.false.,status)                
10              continue
        end if
        end
C----------------------------------------------------------------------
        subroutine ftgr4b(iunit,nvals,incre,r4vals,status)

C       Read an array of Real*4 bytes from the input FITS file.
C       Does any required translation from FITS to internal machine format.

        integer nvals,iunit,incre,status,i,offset
        real r4vals(nvals)

C       iunit   i  fortran unit number
C       nvals   i  number of pixels to read
C       incre   i  byte increment between values
C       r4vals  r  output array of real*4 values
C       status  i  output error status

        if (incre .le. 4)then
                call ftgbyt(iunit,nvals*4,r4vals,status)
        else
C               offset is the number of bytes to move between each value
                offset=incre-4
                do 10 i=1,nvals
                        call ftgbyt(iunit,4,r4vals(i),status)
                        call ftmoff(iunit,offset,.false.,status)                
10              continue
        end if
        call ftr4ib(r4vals,nvals)
        end
C----------------------------------------------------------------------
        subroutine ftgr8b(iunit,nvals,incre,r8vals,status)

C       Read an array of Real*8 bytes from the input FITS file.
C       Does any required translation from FITS to internal machine format.

        integer nvals,iunit,incre,status,i,offset
        double precision r8vals(nvals)

C       nvals   i  number of pixels to read
C       iunit   i  fortran unit number
C       incre   i  byte increment between values
C       r8vals  d  output array of real*8 values
C       status  i  output error status

        if (incre .le. 8)then
                call ftgbyt(iunit,nvals*8,r8vals,status)
        else
C               offset is the number of bytes to move between each value
                offset=incre-8
                do 10 i=1,nvals
                        call ftgbyt(iunit,8,r8vals(i),status)
                        call ftmoff(iunit,offset,.false.,status)                
10              continue
        end if
        call ftr8ib(r8vals,nvals)
        end
C--------------------------------------------------------------------------
        subroutine ftupch(string)
 
C       convert input string to upper case
C
C       NOTE!!!  this routine assumes EBCDIC coding, not ASCII codes
C
C       written by Wm Pence, HEASARC/GSFC, May 1991
 
        character*(*) string
        integer i,length
 
        length=len(string)
        do 10 i=1,length
                if   (string(i:i) .ge. 'a' 
     1          .and. string(i:i) .le. 'z')then
                        string(i:i)=char(ichar(string(i:i))+64)
                end if
10      continue
 
        end
C--------------------------------------------------------------------------
        subroutine ftas2c(array,nchar)

C       convert characters in the array from ASCII codes to
C       the machine's native character coding sequence
C       This is the IBM mainframe version.
 
C       array   c  array of characters to be converted (in place)
C       nchar   i  number of characters to convert

        character*(*) array
        integer nchar,i

        integer ebcd1(128),ebcd2(128),ebcdic(256)
        equivalence(ebcd1(1),ebcdic(1))
        equivalence(ebcd2(1),ebcdic(129))
 
C       The following look-up table gives the EBCDIC character code for
C       the corresponding ASCII code.  The conversion is not universally
C       established, so some sites may need to modify this table.
C       (The table has been broken into 2 arrays to reduce the number of
C       continuation lines in a single statement).
 
        data ebcd1/0,1,2,3,55,45,46,47,22,5,37,11,12,13,14,15,16,17,
     &  18,19,60,61,50,38,24,25,63,39,28,29,30,31,64,79,127,123,91,108,
     &  80,125,77,93,92,78,107,96,75,97,240,241,242,243,244,245,246,
     &  247,248,249,122,94,76,126,110,111,124,193,194,195,196,197,
     &  198,199,200,201,209,210,211,212,213,214,215,216,217,226,227,
     &  228,229,230,231,232,233,74,224,90,95,109,121,129,130,131,132,
     &  133,134,135,136,137,145,146,147,148,149,150,151,152,153,162,
     &  163,164,165,166,167,168,169,192,106,208,161,7/
 
        data ebcd2/32,33,34,35,36,21,
     &  6,23,40,41,42,43,44,9,10,27,48,49,26,51,52,53,54,8,56,57,58,59,
     &  4,20,62,225,65,66,67,68,69,70,71,72,73,81,82,83,84,85,86,87,88,
     &  89,98,99,100,101,102,103,104,105,112,113,114,115,116,117,118,
     &  119,120,128,138,139,140,141,142,143,144,154,155,156,157,158,159,
     &  160,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,
     &  185,186,187,188,189,190,191,202,203,204,205,206,207,218,219,220,
     &  221,222,223,234,235,236,237,238,239,250,251,252,253,254,255/
 
        do 10 i=1,nchar
C               find the internal equivalent of the character 
                array(i:i)=char(ebcdic(ichar(array(i:i))+1))
10      continue
        end

C--------------------------------------------------------------------------
        subroutine ftc2as(nbuff,fchar,lchar)

C       convert characters in the common block buffer from the machines
C       native character coding sequence in to ASCII codes

C       nbuff   i  number of the common block buffer to operate on
C       fchar   i  first character in the buffer to convert
C       lchar   i  last character in the buffer to convert

        integer nbuff,fchar,lchar,i

        character*2880 buff1,buff2,buff3,buff4,buff5,buff6
        character*2880 buff7,buff8,buff9,buff10,buff11,buff12
        common/ft00b1/buff1
        common/ft00b2/buff2
        common/ft00b3/buff3
        common/ft00b4/buff4
        common/ft00b5/buff5
        common/ft00b6/buff6
        common/ft00b7/buff7
        common/ft00b8/buff8
        common/ft00b9/buff9
        common/ft0b10/buff10
        common/ft0b11/buff11
        common/ft0b12/buff12

        integer asci1(128),asci2(128),ascii(256)
        equivalence (asci1(1),ascii(1))
        equivalence (asci2(1),ascii(129))

C       The following look-up table gives the ASCII character code for
C       the corresponding EBCDIC code.  The conversion is not universally
C       established, so some sites may need to modify this table.
C       (The table has been broken into 2 arrays to reduce the number of
C       continuation lines in a single statement).
 
      data asci1/0,1,2,3,156,9,134,127,151,141,142, 11, 12, 13, 14, 15,
     &  16, 17, 18, 19,157,133,  8,135, 24, 25,146,143, 28, 29, 30, 31,
     & 128,129,130,131,132, 10, 23, 27,136,137,138,139,140,  5,  6,  7,
     & 144,145, 22,147,148,149,150,  4,152,153,154,155, 20, 21,158, 26,
     &  32,160,161,162,163,164,165,166,167,168, 91, 46, 60, 40, 43, 33,
     &  38,169,170,171,172,173,174,175,176,177, 93, 36, 42, 41, 59, 94,
     &  45, 47,178,179,180,181,182,183,184,185,124, 44, 37, 95, 62, 63,
     & 186,187,188,189,190,191,192,193,194, 96, 58, 35, 64, 39, 61, 34/
 
      data asci2/
     & 195, 97, 98, 99,100,101,102,103,104,105,196,197,198,199,200,201,
     & 202,106,107,108,109,110,111,112,113,114,203,204,205,206,207,208,
     & 209,126,115,116,117,118,119,120,121,122,210,211,212,213,214,215,
     & 216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,
     & 123, 65, 66, 67, 68, 69, 70, 71, 72, 73,232,233,234,235,236,237,
     & 125, 74, 75, 76, 77, 78, 79, 80, 81, 82,238,239,240,241,242,243,
     &  92,159, 83, 84, 85, 86, 87, 88, 89, 90,244,245,246,247,248,249,
     &  48, 49, 50, 51, 52, 53, 54, 55, 56, 57,250,251,252,253,254,255/

C       find the ASCII equivalent of the character and add to buffer
        if (nbuff .eq. 1)then
            do 21 i=fchar,lchar
                buff1(i:i)=char(ascii(ichar(buff1(i:i))+1))
21          continue
        else if (nbuff .eq. 2)then
            do 22 i=fchar,lchar
                buff2(i:i)=char(ascii(ichar(buff2(i:i))+1))
22          continue
        else if (nbuff .eq. 3)then
            do 23 i=fchar,lchar
                buff3(i:i)=char(ascii(ichar(buff3(i:i))+1))
23          continue
        else if (nbuff .eq. 4)then
            do 24 i=fchar,lchar
                buff4(i:i)=char(ascii(ichar(buff4(i:i))+1))
24          continue
        else if (nbuff .eq. 5)then
            do 25 i=fchar,lchar
                buff5(i:i)=char(ascii(ichar(buff5(i:i))+1))
25          continue
        else if (nbuff .eq. 6)then
            do 26 i=fchar,lchar
                buff6(i:i)=char(ascii(ichar(buff6(i:i))+1))
26          continue
        else if (nbuff .eq. 7)then
            do 27 i=fchar,lchar
                buff7(i:i)=char(ascii(ichar(buff7(i:i))+1))
27          continue
        else if (nbuff .eq. 8)then
            do 28 i=fchar,lchar
                buff8(i:i)=char(ascii(ichar(buff8(i:i))+1))
28          continue
        else if (nbuff .eq. 9)then
            do 29 i=fchar,lchar
                buff9(i:i)=char(ascii(ichar(buff9(i:i))+1))
29          continue
        else if (nbuff .eq. 10)then
            do 30 i=fchar,lchar
                buff10(i:i)=char(ascii(ichar(buff10(i:i))+1))
30          continue
        else if (nbuff .eq. 11)then
            do 31 i=fchar,lchar
                buff11(i:i)=char(ascii(ichar(buff11(i:i))+1))
31          continue
        else if (nbuff .eq. 12)then
            do 32 i=fchar,lchar
                buff12(i:i)=char(ascii(ichar(buff12(i:i))+1))
32          continue
        end if
        end
C----------------------------------------------------------------------
        subroutine ftpbyt(ounit,nbytes,array,status)

C       write string of data bytes to output buffer.  If buffer fills up,
C       then dump it to the output disk file.

C       ounit   i  fortran unit number
C       nbytes  i  number of bytes
C       array   l  logical*1 array of bytes to be written (bytes)
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June 1991

        logical*1 array(*)
        integer nbytes,ounit,status

        integer nleft,nbyt,in1,nbuff,buflen,lastb,i

C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 12)
        parameter (ne = 128)
        integer bufnum,bufpnt,reclen,recnum,bytnum
        integer chdu,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        logical wrmode,modify
        real compid
        common/ft0001/bufnum(199),bufpnt(nb),reclen(199),recnum(nb),
     &  bytnum(nb),wrmode(nb),modify(nb),chdu(nb),maxhdu(nb),
     &  hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),compid

        logical*1 buff1,buff2,buff3,buff4,buff5,buff6
        logical*1 buff7,buff8,buff9,buff10,buff11,buff12
        common/ft00b1/buff1(2880)
        common/ft00b2/buff2(2880)
        common/ft00b3/buff3(2880)
        common/ft00b4/buff4(2880)
        common/ft00b5/buff5(2880)
        common/ft00b6/buff6(2880)
        common/ft00b7/buff7(2880)
        common/ft00b8/buff8(2880)
        common/ft00b9/buff9(2880)
        common/ft0b10/buff10(2880)
        common/ft0b11/buff11(2880)
        common/ft0b12/buff12(2880)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------

        if (status .gt. 0)return

        nbuff=bufnum(ounit)
        buflen=reclen(ounit)

        if (nbytes .lt. 0)then
C               error: negative number of bytes to write
                status=306
        else if (nbytes .eq. 0)then
C               simply dump the partially full buffer to disk, and reinitialize
                if (modify(nbuff))then
                  call ftpbyx(ounit,recnum(nbuff),buflen,nbuff,status)
                  modify(nbuff)=.false.
                end if
                recnum(nbuff)=0
                bytnum(nbuff)=0
        else

C       lastb   = position of last byte read from input buffer
C       nleft   = number of bytes left in the input buffer
C       in1     = position of first byte remaining in the input buffer
C       nbyt    = number of bytes to transfer from input to output

        lastb=bytnum(nbuff)
        nleft=nbytes
        in1=0

C       find the number of bytes that will fit in output buffer
20      nbyt=min(nleft,buflen-lastb)
        if (nbyt .gt. 0)then
C           append the input buffer to the output buffer
            if (nbuff .eq. 1)then
                do 30 i=1,nbyt
                        buff1(lastb+i)=array(in1+i)
30              continue
            else if (nbuff .eq. 2)then
                do 31 i=1,nbyt
                        buff2(lastb+i)=array(in1+i)
31              continue
            else if (nbuff .eq. 3)then
                do 32 i=1,nbyt
                        buff3(lastb+i)=array(in1+i)
32              continue
            else if (nbuff .eq. 4)then
                do 33 i=1,nbyt
                        buff4(lastb+i)=array(in1+i)
33              continue
            else if (nbuff .eq. 5)then
                do 34 i=1,nbyt
                        buff5(lastb+i)=array(in1+i)
34              continue
            else if (nbuff .eq. 6)then
                do 35 i=1,nbyt
                        buff6(lastb+i)=array(in1+i)
35              continue
            else if (nbuff .eq. 7)then
                do 36 i=1,nbyt
                        buff7(lastb+i)=array(in1+i)
36              continue
            else if (nbuff .eq. 8)then
                do 37 i=1,nbyt
                        buff8(lastb+i)=array(in1+i)
37              continue
            else if (nbuff .eq. 9)then
                do 38 i=1,nbyt
                        buff9(lastb+i)=array(in1+i)
38              continue
            else if (nbuff .eq. 10)then
                do 39 i=1,nbyt
                        buff10(lastb+i)=array(in1+i)
39              continue
            else if (nbuff .eq. 11)then
                do 40 i=1,nbyt
                        buff11(lastb+i)=array(in1+i)
40              continue
            else if (nbuff .eq. 12)then
                do 41 i=1,nbyt
                        buff12(lastb+i)=array(in1+i)
41              continue
            else
                status=102
                return
            end if

            modify(nbuff)=.true.
            bytnum(nbuff)=bytnum(nbuff)+nbyt
            lastb=lastb+nbyt
            in1=in1+nbyt
            nleft=nleft-nbyt
        end if

C       go back for more bytes, if any
        if (nleft .gt. 0)then
            if (lastb .eq. buflen)then
                if (modify(nbuff))then
C                   write out full buffer to disk, then reinitialize
                  call ftpbyx(ounit,recnum(nbuff),buflen,nbuff,status)
                    if (status .gt. 0)return
                    modify(nbuff)=.false.
                end if

C               attempt to read the next record into buffer (there may
C               not be a next record, so a read error is not serious)
                recnum(nbuff)=recnum(nbuff)+1
                call ftgbyx(ounit,recnum(nbuff),buflen,nbuff,status)
                if (status .gt. 0)then
                        status =0
                        modify(nbuff)=.true.
                end if
                lastb=0
                go to 20
            end if
        end if
C       store current buffer location
        bytnum(nbuff)=lastb

        end if
        end
C----------------------------------------------------------------------
        subroutine ftgbyt(iunit,nbytes,array,status)

C       read string of data bytes from input buffer.  If buffer becomes
C       empty, then read in another block from the disk file.

C       iunit   i  fortran unit number
C       nbytes  i  number of bytes
C       array   l  logical*1 array of bytes to be read
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, June, 1991

        integer nbytes,iunit,status
        logical*1 array(*)

        integer nleft,nbyt,lastb,in1,nbuff,buflen,i

C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 12)
        parameter (ne = 128)
        integer bufnum,bufpnt,reclen,recnum,bytnum
        integer chdu,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        logical wrmode,modify
        real compid
        common/ft0001/bufnum(199),bufpnt(nb),reclen(199),recnum(nb),
     &  bytnum(nb),wrmode(nb),modify(nb),chdu(nb),maxhdu(nb),
     &  hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),compid

        logical*1 buff1,buff2,buff3,buff4,buff5,buff6
        logical*1 buff7,buff8,buff9,buff10,buff11,buff12
        common/ft00b1/buff1(2880)
        common/ft00b2/buff2(2880)
        common/ft00b3/buff3(2880)
        common/ft00b4/buff4(2880)
        common/ft00b5/buff5(2880)
        common/ft00b6/buff6(2880)
        common/ft00b7/buff7(2880)
        common/ft00b8/buff8(2880)
        common/ft00b9/buff9(2880)
        common/ft0b10/buff10(2880)
        common/ft0b11/buff11(2880)
        common/ft0b12/buff12(2880)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------

        if (status .gt. 0)return

        if (nbytes .lt. 0)then
C               error: negative number of bytes to read
                status=306
                return
        end if

        nbuff=bufnum(iunit)
        buflen=reclen(iunit)

C       lastb   = position of last byte read from input buffer
C       nleft   = number of bytes left in the input buffer
C       in1     = position of first byte remaining in the input buffer
C       nbyt    = number of bytes to transfer from input to output

        lastb=bytnum(nbuff)
        nleft=nbytes
        in1=0

C       find the number of remaining bytes that can be read from buffer
10      nbyt=min(nleft,buflen-lastb)
C       append characters from the buffer to the output string
        if (nbyt .gt. 0)then
            if (nbuff .eq. 1)then
                        do 15 i=1,nbyt
                                array(in1+i)=buff1(lastb+i)
15                      continue
            else if (nbuff .eq. 2)then
                        do 16 i=1,nbyt
                                array(in1+i)=buff2(lastb+i)
16                      continue
            else if (nbuff .eq. 3)then
                        do 17 i=1,nbyt
                                array(in1+i)=buff3(lastb+i)
17                      continue
            else if (nbuff .eq. 4)then
                        do 18 i=1,nbyt
                                array(in1+i)=buff4(lastb+i)
18                      continue
            else if (nbuff .eq. 5)then
                        do 19 i=1,nbyt
                                array(in1+i)=buff5(lastb+i)
19                      continue
            else if (nbuff .eq. 6)then
                        do 20 i=1,nbyt
                                array(in1+i)=buff6(lastb+i)
20                      continue
            else if (nbuff .eq. 7)then
                        do 21 i=1,nbyt
                                array(in1+i)=buff7(lastb+i)
21                      continue
            else if (nbuff .eq. 8)then
                        do 22 i=1,nbyt
                                array(in1+i)=buff8(lastb+i)
22                      continue
            else if (nbuff .eq. 9)then
                        do 23 i=1,nbyt
                                array(in1+i)=buff9(lastb+i)
23                      continue
            else if (nbuff .eq. 10)then
                        do 24 i=1,nbyt
                                array(in1+i)=buff10(lastb+i)
24                      continue
            else if (nbuff .eq. 11)then
                        do 25 i=1,nbyt
                                array(in1+i)=buff11(lastb+i)
25                      continue
            else if (nbuff .eq. 12)then
                        do 26 i=1,nbyt
                                array(in1+i)=buff12(lastb+i)
26                      continue
            else
                        status=102
                        return
            end if
C           store the total number of bytes read:
            lastb=lastb+nbyt
            in1=in1+nbyt
            nleft=nleft-nbyt
        end if
        if (nleft .gt. 0)then
C               read in the next record, but first, check if the current
C               record has been modified.  If so, write it to disk.
                if (modify(nbuff))then
                 call ftpbyx(iunit,recnum(nbuff),buflen,nbuff,status)
                 if (status .gt. 0)return
                 modify(nbuff)=.false.
                end if

C               now read new record from disk
                recnum(nbuff)=recnum(nbuff)+1
                call ftgbyx(iunit,recnum(nbuff),buflen,nbuff,status)
                if (status .gt. 0)return

                lastb=0
C               go back for more bytes
                go to 10
        end if

C       save the current position in the read buffer
        bytnum(nbuff)=lastb
        end
C----------------------------------------------------------------------
        subroutine ftpbyx(ounit,recnum,nbytes,nbuff,status)

C       low-level routine to write bytes to an output file

C       ounit   i  fortran unit number
C       recnum  i  direct access file record number
C       nbytes  i  number of bytes to write
C       nbuff   i  number of the buffer to be written
C       status  i  output error status

        integer ounit,recnum,nbytes,nbuff,status
        character*2880 buff1,buff2,buff3,buff4,buff5,buff6
        character*2880 buff7,buff8,buff9,buff10,buff11,buff12
        common/ft00b1/buff1
        common/ft00b2/buff2
        common/ft00b3/buff3
        common/ft00b4/buff4
        common/ft00b5/buff5
        common/ft00b6/buff6
        common/ft00b7/buff7
        common/ft00b8/buff8
        common/ft00b9/buff9
        common/ft0b10/buff10
        common/ft0b11/buff11
        common/ft0b12/buff12
        
C       Note: we have to use separate buffers, rather than one big array
C       of buffers, because some compilers have a limit on the length of
C       a character array (e.g., 32K).

        if (status .gt. 0)return

        if (nbuff .eq. 1)then
                write(ounit,rec=recnum,err=900)buff1(1:nbytes)
        else if (nbuff .eq. 2)then
                write(ounit,rec=recnum,err=900)buff2(1:nbytes)
        else if (nbuff .eq. 3)then
                write(ounit,rec=recnum,err=900)buff3(1:nbytes)
        else if (nbuff .eq. 4)then
                write(ounit,rec=recnum,err=900)buff4(1:nbytes)
        else if (nbuff .eq. 5)then
                write(ounit,rec=recnum,err=900)buff5(1:nbytes)
        else if (nbuff .eq. 6)then
                write(ounit,rec=recnum,err=900)buff6(1:nbytes)
        else if (nbuff .eq. 7)then
                write(ounit,rec=recnum,err=900)buff7(1:nbytes)
        else if (nbuff .eq. 8)then
                write(ounit,rec=recnum,err=900)buff8(1:nbytes)
        else if (nbuff .eq. 9)then
                write(ounit,rec=recnum,err=900)buff9(1:nbytes)
        else if (nbuff .eq. 10)then
                write(ounit,rec=recnum,err=900)buff10(1:nbytes)
        else if (nbuff .eq. 11)then
                write(ounit,rec=recnum,err=900)buff11(1:nbytes)
        else if (nbuff .eq. 12)then
                write(ounit,rec=recnum,err=900)buff12(1:nbytes)
        else
                status=102
                return
        end if
        return

900     status=106
        end
C----------------------------------------------------------------------
        subroutine ftgbyx(iunit,recnum,nbytes,nbuff,status)

C       low-level routine to read bytes from a file

C       iunit   i  fortran unit number
C       recnum  i  direct access file record number
C       nbytes  i  number of bytes to read
C       nbuff   i  number of the buffer to read
C       status  i  output error status

        integer iunit,recnum,nbytes,nbuff,status,ios
        character*2880 buff1,buff2,buff3,buff4,buff5,buff6
        character*2880 buff7,buff8,buff9,buff10,buff11,buff12
        common/ft00b1/buff1
        common/ft00b2/buff2
        common/ft00b3/buff3
        common/ft00b4/buff4
        common/ft00b5/buff5
        common/ft00b6/buff6
        common/ft00b7/buff7
        common/ft00b8/buff8
        common/ft00b9/buff9
        common/ft0b10/buff10
        common/ft0b11/buff11
        common/ft0b12/buff12
        
C       Note: we have to use separate buffers, rather than one big array
C       of buffers, because some compilers have a limit on the length of
C       a character array (e.g., 32K).

        if (status .gt. 0)return

C       read the record; if the read fails then initialize the buffer with zeros
        if (nbuff .eq. 1)then
                read(iunit,rec=recnum,iostat=ios)buff1(1:nbytes)
        else if (nbuff .eq. 2)then
                read(iunit,rec=recnum,iostat=ios)buff2(1:nbytes)
        else if (nbuff .eq. 3)then
                read(iunit,rec=recnum,iostat=ios)buff3(1:nbytes)
        else if (nbuff .eq. 4)then
                read(iunit,rec=recnum,iostat=ios)buff4(1:nbytes)
        else if (nbuff .eq. 5)then
                read(iunit,rec=recnum,iostat=ios)buff5(1:nbytes)
        else if (nbuff .eq. 6)then
                read(iunit,rec=recnum,iostat=ios)buff6(1:nbytes)
        else if (nbuff .eq. 7)then
                read(iunit,rec=recnum,iostat=ios)buff7(1:nbytes)
        else if (nbuff .eq. 8)then
                read(iunit,rec=recnum,iostat=ios)buff8(1:nbytes)
        else if (nbuff .eq. 9)then
                read(iunit,rec=recnum,iostat=ios)buff9(1:nbytes)
        else if (nbuff .eq. 10)then
                read(iunit,rec=recnum,iostat=ios)buff10(1:nbytes)
        else if (nbuff .eq. 11)then
                read(iunit,rec=recnum,iostat=ios)buff11(1:nbytes)
        else if (nbuff .eq. 12)then
                read(iunit,rec=recnum,iostat=ios)buff12(1:nbytes)
        else
                status=102
                return
        end if

C       if we failed to read the record, then just fill the
C       read buffer with all zeros
        if (ios .ne. 0)then
                call ftzero(nbuff,(nbytes+3)/4)
C               assume that this error indicates an end of file condition:
                status=107
        end if
        end
C--------------------------------------------------------------------------
        subroutine ftpcbf(ounit,convrt,nchar,cbuff,status)

C       "Put Character BuFfer"
C       copy input buffer of characters to the output character buffer.
C       If output buffer fills up, then write it out to the disk file.
C       If nchar=0, then simply flush the current buffer to the disk file.
C
C       ounit   i  Fortran output unit number
C       convrt  i  whether (=1) or not (=0) to convert to ASCII
C               (this only applies to machines that do not use the
C                ASCII sequence for their native character representation)
C       nchar   i  number of characters in the string
C       cbuff   c  input character string
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991

        character cbuff*(*)
        integer convrt,ounit,nchar,status

        integer nleft,nbyt,in1,nbuff,buflen,lastb

C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 12)
        parameter (ne = 128)
        integer bufnum,bufpnt,reclen,recnum,bytnum
        integer chdu,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        logical wrmode,modify
        real compid
        common/ft0001/bufnum(199),bufpnt(nb),reclen(199),recnum(nb),
     &  bytnum(nb),wrmode(nb),modify(nb),chdu(nb),maxhdu(nb),
     &  hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),compid

        character*2880 buff1,buff2,buff3,buff4,buff5,buff6
        character*2880 buff7,buff8,buff9,buff10,buff11,buff12
        common/ft00b1/buff1
        common/ft00b2/buff2
        common/ft00b3/buff3
        common/ft00b4/buff4
        common/ft00b5/buff5
        common/ft00b6/buff6
        common/ft00b7/buff7
        common/ft00b8/buff8
        common/ft00b9/buff9
        common/ft0b10/buff10
        common/ft0b11/buff11
        common/ft0b12/buff12
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------

        if (status .gt. 0)return

        nbuff=bufnum(ounit)
        buflen=reclen(ounit)

        if (nchar .gt. 0)then

C       lastb   = position of last byte read from input buffer
C       nleft   = number of bytes left in the input buffer
C       in1     = position of first byte remaining in the input buffer
C       nbyt    = number of bytes to transfer from input to output

        lastb=bytnum(nbuff)
        nleft=nchar
        in1=1

C       find the number of bytes that will fit in output buffer
20      nbyt=min(nleft,buflen-lastb)
        if (nbyt .gt. 0)then
C           append the input buffer to the output buffer
            if (nbuff .eq. 1)then
                buff1(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
            else if (nbuff .eq. 2)then
                buff2(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
            else if (nbuff .eq. 3)then
                buff3(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
            else if (nbuff .eq. 4)then
                buff4(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
            else if (nbuff .eq. 5)then
                buff5(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
            else if (nbuff .eq. 6)then
                buff6(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
            else if (nbuff .eq. 7)then
                buff7(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
            else if (nbuff .eq. 8)then
                buff8(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
            else if (nbuff .eq. 9)then
                buff9(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
            else if (nbuff .eq. 10)then
                buff10(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
            else if (nbuff .eq. 11)then
                buff11(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
            else if (nbuff .eq. 12)then
                buff12(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1)
            else
                status=102
                return
            end if

C           convert the characters to ASCII, if necessary
            if (convrt .ne. 0)call ftc2as(nbuff,lastb+1,lastb+nbyt)

            modify(nbuff)=.true.
            bytnum(nbuff)=bytnum(nbuff)+nbyt
            lastb=lastb+nbyt
            in1=in1+nbyt
            nleft=nleft-nbyt
        end if

C       process more bytes, if any
        if (nleft .gt. 0)then
            if (lastb .eq. buflen)then
                if (modify(nbuff))then
C                   write out full buffer to disk, then reinitialize
                  call ftpbyx(ounit,recnum(nbuff),buflen,nbuff,status)
                    if (status .gt. 0)return
                    modify(nbuff)=.false.
                end if

C               attempt to read the next record into buffer (there may
C               not be a next record, so a read error is not serious)
                recnum(nbuff)=recnum(nbuff)+1
                call ftgbyx(ounit,recnum(nbuff),buflen,nbuff,status)
                if (status .gt. 0)then
                        status =0
                        modify(nbuff)=.true.
                end if
                lastb=0
                go to 20
            end if
        end if
C       store current buffer location
        bytnum(nbuff)=lastb

        else if (nchar .eq. 0)then
C               simply dump the partially full buffer to disk, and reinitialize
                if (modify(nbuff))then
                  call ftpbyx(ounit,recnum(nbuff),buflen,nbuff,status)
                  modify(nbuff)=.false.
                end if
                recnum(nbuff)=0
                bytnum(nbuff)=0
        else 
C               error: negative number of bytes to write
                status=306
        end if
        end
C--------------------------------------------------------------------------
        subroutine ftgcbf(iunit,convrt,nchar,array,status)

C       "Get Character BuFfer"
C       read NCHAR characters from the character buffer.
C       If buffer is empty, then read in another block of data from the
C       disk file.
C       If nchar=0, then simply flush out any remaining characters in the
C           the current block of data.
C
C       iunit   i  Fortran unit number for reading from disk
C       convrt  i  whether (=1) or not (=0) to convert from ASCII
C               (this only applies to machines that do not use the
C                ASCII sequence for their native character representation)
C       nchar   i  number of characters to read
C       array   c  output character string
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, June 1991

        integer iunit,convrt,nchar,status
        character*(*) array
        integer nleft,nbyt,lastb,in1,nbuff,buflen

C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nb,ne
        parameter (nb = 12)
        parameter (ne = 128)
        integer bufnum,bufpnt,reclen,recnum,bytnum
        integer chdu,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        logical wrmode,modify
        real compid
        common/ft0001/bufnum(199),bufpnt(nb),reclen(199),recnum(nb),
     &  bytnum(nb),wrmode(nb),modify(nb),chdu(nb),maxhdu(nb),
     &  hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),compid

        character*2880 buff1,buff2,buff3,buff4,buff5,buff6
        character*2880 buff7,buff8,buff9,buff10,buff11,buff12
        common/ft00b1/buff1
        common/ft00b2/buff2
        common/ft00b3/buff3
        common/ft00b4/buff4
        common/ft00b5/buff5
        common/ft00b6/buff6
        common/ft00b7/buff7
        common/ft00b8/buff8
        common/ft00b9/buff9
        common/ft0b10/buff10
        common/ft0b11/buff11
        common/ft0b12/buff12
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------

        if (status .gt. 0)return

        if (nchar .lt. 0)then
C               error: negative number of bytes to read
                status=306
                return
        end if

        nbuff=bufnum(iunit)
        buflen=reclen(iunit)

C       lastb   = position of last byte read from input buffer
C       nleft   = number of bytes left in the input buffer
C       in1     = position of first byte remaining in the input buffer
C       nbyt    = number of bytes to transfer from input to output

        lastb=bytnum(nbuff)
        nleft=nchar
        in1=1

C       find the number of remaining bytes that can be read from buffer
10      nbyt=min(nleft,buflen-lastb)
C       append characters from the buffer to the output string
        if (nbyt .gt. 0)then
            if (nbuff .eq. 1)then
                array(in1:in1+nbyt-1)=buff1(lastb+1:lastb+nbyt)
            else if (nbuff .eq. 2)then
                array(in1:in1+nbyt-1)=buff2(lastb+1:lastb+nbyt)
            else if (nbuff .eq. 3)then
                array(in1:in1+nbyt-1)=buff3(lastb+1:lastb+nbyt)
            else if (nbuff .eq. 4)then
                array(in1:in1+nbyt-1)=buff4(lastb+1:lastb+nbyt)
            else if (nbuff .eq. 5)then
                array(in1:in1+nbyt-1)=buff5(lastb+1:lastb+nbyt)
            else if (nbuff .eq. 6)then
                array(in1:in1+nbyt-1)=buff6(lastb+1:lastb+nbyt)
            else if (nbuff .eq. 7)then
                array(in1:in1+nbyt-1)=buff7(lastb+1:lastb+nbyt)
            else if (nbuff .eq. 8)then
                array(in1:in1+nbyt-1)=buff8(lastb+1:lastb+nbyt)
            else if (nbuff .eq. 9)then
                array(in1:in1+nbyt-1)=buff9(lastb+1:lastb+nbyt)
            else if (nbuff .eq. 10)then
                array(in1:in1+nbyt-1)=buff10(lastb+1:lastb+nbyt)
            else if (nbuff .eq. 11)then
                array(in1:in1+nbyt-1)=buff11(lastb+1:lastb+nbyt)
            else if (nbuff .eq. 12)then
                array(in1:in1+nbyt-1)=buff12(lastb+1:lastb+nbyt)
            else
                status=102
                return
            end if

C           store the total number of bytes read:
            lastb=lastb+nbyt
            in1=in1+nbyt
            nleft=nleft-nbyt
        end if
        if (nleft .gt. 0)then
C               read in the next record, but first, check if the current
C               record has been modified.  If so, write it to disk.
                if (modify(nbuff))then
                 call ftpbyx(iunit,recnum(nbuff),buflen,nbuff,status)
                 if (status .gt. 0)return
                 modify(nbuff)=.false.
                end if

C               now read new record from disk
                recnum(nbuff)=recnum(nbuff)+1
                call ftgbyx(iunit,recnum(nbuff),buflen,nbuff,status)
                if (status .gt. 0)return

                lastb=0
C               go back for more bytes
                go to 10
        end if

C       convert the array of characters to ASCII, if required
        if (convrt .ne. 0)call ftas2c(array,nchar)

C       save the current position in the read buffer
        bytnum(nbuff)=lastb
        end
C------------------------------------------------------------------------
        subroutine ftzero(nbuff,nwords)

C       fill the common block buffer with zeros, as efficiently as possible

        integer nbuff,nwords,i,nw2

        double precision buff1,buff2,buff3,buff4,buff5,buff6
        double precision buff7,buff8,buff9,buff10,buff11,buff12
        common /ft00b1/buff1(360)
        common /ft00b2/buff2(360)
        common /ft00b3/buff3(360)
        common /ft00b4/buff4(360)
        common /ft00b5/buff5(360)
        common /ft00b6/buff6(360)
        common /ft00b7/buff7(360)
        common /ft00b8/buff8(360)
        common /ft00b9/buff9(360)
        common /ft0b10/buff10(360)
        common /ft0b11/buff11(360)
        common /ft0b12/buff12(360)

        nw2=(nwords+1)/2
        if (nbuff .eq. 1)then
                do 10 i=1,nw2
10              buff1(i)=0
        else if (nbuff .eq. 2)then
                do 20 i=1,nw2
20              buff2(i)=0
        else if (nbuff .eq. 3)then
                do 30 i=1,nw2
30              buff3(i)=0
        else if (nbuff .eq. 4)then
                do 40 i=1,nw2
40              buff4(i)=0
        else if (nbuff .eq. 5)then
                do 50 i=1,nw2
50              buff5(i)=0
        else if (nbuff .eq. 6)then
                do 60 i=1,nw2
60              buff6(i)=0
        else if (nbuff .eq. 5)then
                do 70 i=1,nw2
70              buff7(i)=0
        else if (nbuff .eq. 6)then
                do 80 i=1,nw2
80              buff8(i)=0
        else if (nbuff .eq. 5)then
                do 90 i=1,nw2
90              buff9(i)=0
        else if (nbuff .eq. 6)then
                do 100 i=1,nw2
100              buff10(i)=0
        else if (nbuff .eq. 5)then
                do 110 i=1,nw2
110              buff11(i)=0
        else if (nbuff .eq. 6)then
                do 120 i=1,nw2
120              buff12(i)=0
        end if
        end
C----------------------------------------------------------------------
        subroutine ftibr4(array,npixel)
 
C       convert array of IBM R*4 data values to IEEE floating point format
 
C       array   r  array of data values to reformat
C       npixel  i  number of data values to be reformated
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        real array(*)
        integer npixel,i
 
        do 10 i=1,npixel
C               convert the number
                call lxdrbb(array(i),2,array(i),1)
10      continue
 
        end
C----------------------------------------------------------------------
        subroutine ftibr8(array,npixel)
 
C       convert array of R*8 data values to IEEE floating point format
 
C       array   d  array of data values to reformat
C       npixel  i  number of data values to be reformated
C
C       written by Wm Pence, HEASARC/GSFC, February 1991
 
        double precision array(*)
        integer npixel,i
 
        do 10 i=1,npixel
                call lxdrbb(array(i),18,array(i),17)
10      continue
        end
C----------------------------------------------------------------------
        subroutine ftr4ib(array,npixel)
 
C       convert array of IEEE floating point values to IBM R*4 format
 
C       array   r  array of data values to reformat
C       npixel  i  number of data values to be reformated
C
C       written by Wm Pence, HEASARC/GSFC, February 1991
 
        real array(*)
        integer npixel,i
        logical fttrnn

C       check to see if the value is equal to Not-a-Number. If not,
C       convert to IBM format. 
        do 10 i=1,npixel
            if (.not. fttrnn(array(i)))
     &                call lxdrbb(array(i),1,array(i),2)
10      continue
        end
C----------------------------------------------------------------------
        subroutine ftr8ib(array,npixel)
 
C       convert array of IEEE floating point values to R*8 format
 
C       array   d  array of data values to reformat
C       npixel  i  number of data values to be reformated
C
C       written by Wm Pence, HEASARC/GSFC, June 1991
 
        double precision array(*)
        integer npixel,i
        logical fttdnn
 
C       Only convert the value if not equal to NaN value.
        do 10 i=1,npixel
                if (.not. fttdnn(array(i)))
     &              call lxdrbb(array(i),17,array(i),18)
10      continue
        end
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION LXDRBB(IS,IA,ID,IB)
C
C   CONVERT FROM ONE FP FORMAT TO ANOTHER
C...THIS IS SETUP FOR 32 BIT INTEGERS
C
C
C   IS-SOURCE
C   IA-SOURCE TYPE
C   ID-DESTINATION
C   IB-DESTINATION TYPE
C
C   TYPE CODES
C    1   IEEE-32
C    2   370-32
C    3   DEC-32
C    5   CONVEX NATIVE-32
C   17   IEEE-64
C   18   370-64
C   19   DEC-64
C   20   CRAY-64
C   21   CONVEX NATIVE-64
C
C
C  This subroutine was kindly provided by:
C  Dan Whipple                       
C  NASA-Lewis Research Center        
C  Mail Stop 5-11                                                  
C  Cleveland, Ohio 44135                                           
C  (216) 433-5859   FTS 297-5859                                   
C  pswhip@avelon.lerc.nasa.gov       whipple@prandtl.nas.nasa.gov  

      DIMENSION IS(2),ID(2),IM(2)
C
C...SIGN MASKS
C
C...X'80000000' = -2147483648
      DATA MSA/Z80000000/
C
C...EXPONENT MASKS
C
C...X'7F000000' = 2130706432
C...X'7F800000' = 2139095040
C...X'7FF00000' = 2146435072
C...X'7FFF0000' = 2147418112
      DATA MEA/2130706432/,MEB/2139095040/,
     *     MEC/2146435072/,MED/2147418112/
C
C...FRACTION MASKS
C
C...X'00FFFFFF' = 16777215
C...X'007FFFFF' = 8388607
C...X'000FFFFF' = 1048575
C...X'0000FFFF' = 65535
      DATA MFA/16777215/,MFB/8388607/,
     *     MFC/1048575/,MFD/65535/
C
C...OTHER MASKS
C
C...X'00800000' = 8388608
C...X'00100000' = 1048576
      DATA MHA/8388608/,MHB/1048576/
C
C...BIAS VALUES
C
      DATA JBA/128/,JBB/127/,JBC/64/,JBD/1023/,JBE/16384/
C
C...EXPONENT SHIFT COUNTS
C
      DATA JESA/24/,JESB/23/,JESC/20/,JESD/16/
C
C
    5 CONTINUE
      LXDRBB=0
      IM(1)=0
      IM(2)=0
C...TEST FOR TRUE ZERO
      IF (IS(1).EQ.0) GO TO  203
      IF (IA.GT.15) IM(2)=IS(2)
C...GET SIGN
      ISIGN=IAND(IS(1),MSA)
C...GET EXPONENT AS A POWER OF 2 AND THE FRACTION IN
C   56 (24+32) BITS IN THE RANGE 0.5 TO 0.9999999.....
C
      IF (IA.EQ.2.OR.IA.EQ.18) THEN
C...370-32,370-64
        IEXP=IAND(IS(1),MEA)
        IEXP= ISHFT(IEXP,-JESA)-JBC
        IEXP=IEXP*4
        IM(1)=IAND(IS(1),MFA)
C...NORMALIZE
   11   CONTINUE
        IF (IAND(IM(1),MHA).NE.0) GO TO 15
        IEXP=IEXP-1
        CALL QVS64L(IM,1)
        GO TO 11
   15   CONTINUE
C
C
      ELSEIF (IA.EQ.1.OR.IA.EQ.3.OR.IA.EQ.19.OR.IA.EQ.5) THEN
C
C...IEEE-32,DEC-32,DEC-64,CONVEX NATIVE-32
        IEXP=IAND(IS(1),MEB)
        IEXP= ISHFT(IEXP,-JESB)-JBA
        IF (IA.EQ.1) IEXP=IEXP+2
        IM(1)=IAND(IS(1),MFB)+MHA
C
C
      ELSEIF (IA.EQ.17) THEN
C
C...IEEE-64
        IEXP=IAND(IS(1),MEC)
        IEXP= ISHFT(IEXP,-JESC)-JBD+1
        IM(1)=IAND(IS(1),MFC)+MHB
        CALL QVS64L(IM,3)
C
C
      ELSEIF (IA.EQ.20) THEN
C
C...CRAY-64
        IEXP=IAND(IS(1),MED)
        IEXP= ISHFT(IEXP,-JESD)-JBE
        IM(1)=IAND(IS(1),MFD)
        CALL QVS64L(IM,8)
C
C
      ELSEIF (IA.EQ.21) THEN
C
C...CONVEX NATIVE-64
        IEXP=IAND(IS(1),MEC)
        IEXP= ISHFT(IEXP,-JESC)-JBD-1
        IM(1)=IAND(IS(1),MFC)+MHB
        CALL QVS64L(IM,3)
C
C
      ELSE
C
        LXDRBB=-22
        GO TO 501
C
C
      ENDIF
C
C
C...NOW BUILD OUTPUT
C
      IF (IB.EQ.2.OR.IB.EQ.18) THEN
C...370-32,370-64
  101   CONTINUE
        IF (IAND(IEXP,3).EQ.0) GO TO 111
C...  IF (MOD(IEXP,4).EQ.0) GO TO 111
        IEXP=IEXP+1
        CALL QVS64R(IM,1)
        GO TO 101
  111   CONTINUE
        IEXP=(IEXP/4)+JBC
        IF (IEXP.LE.0) THEN
C...UNDERFLOW
          IEXP=1
          IM(1)=MHB
          IM(2)=0
        ELSEIF (IEXP.GT.127) THEN
C...OVERFLOW
          IEXP=127
          IM(1)=MFA
          IM(2)=-1
        ENDIF
        IEXP= ISHFT(IEXP,JESA)
C
C
      ELSEIF (IB.EQ.1.OR.IB.EQ.3.OR.IB.EQ.19.OR.IB.EQ.5) THEN
C
C...IEEE-32,DEC-32,DEC-64,CONVEX NATIVE-32
        IM(1)=IAND(IM(1),MFB)
        IF (IB.EQ.1) THEN
          IEXP=IEXP+JBB-1
        ELSE
          IEXP=IEXP+JBA
        ENDIF
        IF (IEXP.LE.0) THEN
C...UNDERFLOW
          IEXP=1
          IM(1)=0
          IM(2)=0
        ELSEIF (IEXP.GT.254) THEN
C...OVERFLOW
          IEXP=254
          IM(1)=MFB
          IM(2)=-1
        ENDIF
        IEXP= ISHFT(IEXP,JESB)
C
C
      ELSEIF (IB.EQ.17) THEN
C
C...IEEE-64
        IM(1)=IAND(IM(1),MFB)
        IEXP=IEXP+JBD-1
        IF (IEXP.LE.0) THEN
C...UNDERFLOW
          IEXP=1
          IM(1)=0
          IM(2)=0
        ELSEIF (IEXP.GT.2046) THEN
C...OVERFLOW
          IEXP=2046
          IM(1)=MFB
          IM(2)=-1
        ENDIF
        IEXP= ISHFT(IEXP,JESC)
        CALL QVS64R(IM,3)
C
C
      ELSEIF (IB.EQ.20) THEN
C
C...CRAY-64
        IEXP=IEXP+JBE
C...NO REAL NEED TO CHECK
        IF (IEXP.LE.0) THEN
C...UNDERFLOW
          IEXP=1
          IM(1)=MHA
          IM(2)=0
        ELSEIF (IEXP.GT.32766) THEN
C...OVERFLOW
          IEXP=32766
          IM(1)=MFA
          IM(2)=-1
        ENDIF
        IEXP= ISHFT(IEXP,JESD)
        CALL QVS64R(IM,8)
C
C
      ELSEIF (IB.EQ.21) THEN
C
C...CONVEX NATIVE-64
        IM(1)=IAND(IM(1),MFB)
        IEXP=IEXP+JBD+1
        IF (IEXP.LE.0) THEN
C...UNDERFLOW
          IEXP=1
          IM(1)=0
          IM(2)=0
        ELSEIF (IEXP.GT.2047) THEN
C...OVERFLOW
          IEXP=2047
          IM(1)=MFB
          IM(2)=-1
        ENDIF
        IEXP= ISHFT(IEXP,JESC)
        CALL QVS64R(IM,3)
C
C
      ELSE
C
        LXDRBB=-22
        GO TO 501
C
C
      ENDIF
C
C...BUILD RESULT
      IM(1)=ISIGN+IEXP+IM(1)
  203 CONTINUE
      ID(1)=IM(1)
      IF (IB.GT.15) ID(2)=IM(2)
  501 CONTINUE
      RETURN
      END
 
      SUBROUTINE QVS64L(I,N)
C
C...LEFT SHIFT 64 BIT WORD
C
      DIMENSION I(2)
C
      K=N
      IF (K.GT.31) RETURN
   11 CONTINUE
      IF (K.LE.0) RETURN
      K=K-1
      I(1)= ISHFT(I(1),1)
      J=0
      IF (I(2).LT.0) J=1
      I(2)= ISHFT(I(2),1)
      I(1)=I(1)+J
      GO TO 11
      END
C
C
C
C
      SUBROUTINE QVS64R(I,N)
C
C   RIGHT SHIFT 64 BIT WORD
C
      DIMENSION I(2)
C...X'7FFFFFFF' = 2147483647
C...X'80000000' = -2147483648
      DATA LA/2147483647/,LB/Z80000000/
C
      K=N
      IF (K.GT.31) RETURN
   11 CONTINUE
      IF(K.LE.0) RETURN
      K=K-1
      J=0
      IF (MOD(I(1),2).NE.0) J=LB
      I(1)= ISHFT(I(1),-1)
      I(2)= ISHFT(I(2),-1)
      I(2)=IAND(I(2),LA)+J
      GO TO 11
      END
